~ubuntu-branches/ubuntu/jaunty/libdata-structure-util-perl/jaunty

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define dsDEBUG 0
#if dsDEBUG
#  define dsWARN(msg)  warn(msg)
#else
#  define dsWARN(msg)
#endif
#define PTRLEN 40

/*
   Generate a string containing the address,
   the flags and the Sv type
*/

SV *
_get_infos( SV * sv ) {
    return newSVpvf( "%p-%x-%x", sv, SvFLAGS( sv ) & ~SVf_OOK,
                     SvTYPE( sv ) );
}

/*

Upgrade strings to utf8

*/
bool
_utf8_set( SV * sv, HV * seen, int onoff ) {
    I32 len, i;
    HV *myHash;
    HE *HEntry;
    SV **AValue;

    /* if this is a plain reference then simply
       move down to what the reference points at */

  redo_utf8:
    if ( SvROK( sv ) ) {
        if ( has_seen( sv, seen ) )
            return TRUE;
        sv = SvRV( sv );
        goto redo_utf8;
    }

    switch ( SvTYPE( sv ) ) {

        /* recursivly look inside a hash and arrays */

    case SVt_PVAV:{
            dsWARN( "Found array\n" );
            len = av_len( ( AV * ) sv );
            for ( i = 0; i <= len; i++ ) {
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue )
                    _utf8_set( *AValue, seen, onoff );
            }
            break;
        }
    case SVt_PVHV:{
            dsWARN( "Found hash\n" );
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
                _utf8_set( HeVAL( HEntry ), seen, onoff );
            }
            break;
        }

        /* non recursive case, check if it's got a string
           value or not. */

    default:{
            if ( SvPOK( sv ) ) {
                /* it's a string! do the transformation if we need to */

                dsWARN( "string (PV)\n" );
                dsWARN( SvUTF8( sv ) ? "UTF8 is on\n" : "UTF8 is off\n" );
                if ( onoff && !SvUTF8( sv ) ) {
                    sv_utf8_upgrade( sv );
                }
                else if ( !onoff && SvUTF8( sv ) ) {
                    sv_utf8_downgrade( sv, 0 );
                }
            }
            else {
                /* unknown type.  Could be a SvIV or SvNV, but they don't
                   have magic so that's okay.  Could also be one of the
                   types we don't deal with (a coderef, a typeglob) */

                dsWARN( "unknown type\n" );
            }
        }
    }
    return TRUE;
}

/*

Change utf8 flag

*/
bool
_utf8_flag_set( SV * sv, HV * seen, int onoff ) {
    I32 i, len;
    HV *myHash;
    HE *HEntry;
    SV **AValue;

    /* if this is a plain reference then simply
       move down to what the reference points at */

  redo_flag_utf8:
    if ( SvROK( sv ) ) {
        if ( has_seen( sv, seen ) )
            return TRUE;
        sv = SvRV( sv );
        goto redo_flag_utf8;
    }

    switch ( SvTYPE( sv ) ) {

        /* recursivly look inside a hash and arrays */

    case SVt_PVAV:{
            dsWARN( "Found array\n" );
            len = av_len( ( AV * ) sv );
            for ( i = 0; i <= len; i++ ) {
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue )
                    _utf8_flag_set( *AValue, seen, onoff );
            }
            break;
        }
    case SVt_PVHV:{
            dsWARN( "Found hash\n" );
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
                _utf8_flag_set( HeVAL( HEntry ), seen, onoff );
            }
            break;
        }

        /* non recursive case, check if it's got a string
           value or not. */

    default:{

            /* it's a string! do the transformation if we need to */

            if ( SvPOK( sv ) ) {
                dsWARN( "string (PV)\n" );
                dsWARN( SvUTF8( sv ) ? "UTF8 is on\n" : "UTF8 is off\n" );
                if ( onoff && !SvUTF8( sv ) ) {
                    SvUTF8_on( sv );
                }
                else if ( !onoff && SvUTF8( sv ) ) {
                    SvUTF8_off( sv );
                }
            }
            else {

                /* unknown type.  Could be a SvIV or SvNV, but they don't
                   have magic so that's okay.  Could also be one of the
                   types we don't deal with (a codref, a typeglob) */

                dsWARN( "unknown type\n" );
            }
        }
    }
    return TRUE;
}

/*

Returns true if sv contains a utf8 string

*/
bool
_has_utf8( SV * sv, HV * seen ) {
    I32 i, len;
    SV **AValue;
    HV *myHash;
    HE *HEntry;

  redo_has_utf8:
    if ( SvROK( sv ) ) {
        if ( has_seen( sv, seen ) )
            return FALSE;
        sv = SvRV( sv );
        goto redo_has_utf8;
    }

    switch ( SvTYPE( sv ) ) {

    case SVt_PV:
    case SVt_PVNV:{
            dsWARN( "string (PV)\n" );
            dsWARN( SvUTF8( sv ) ? "UTF8 is on\n" : "UTF8 is off\n" );
            if ( SvUTF8( sv ) ) {
                dsWARN( "Has UTF8\n" );
                return TRUE;
            }
            break;
        }
    case SVt_PVAV:{
            dsWARN( "Found array\n" );
            len = av_len( ( AV * ) sv );
            for ( i = 0; i <= len; i++ ) {
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue && _has_utf8( *AValue, seen ) )
                    return TRUE;
            }
            break;
        }
    case SVt_PVHV:{
            dsWARN( "Found hash\n" );
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
                if ( _has_utf8( HeVAL( HEntry ), seen ) )
                    return TRUE;
            }
            break;
        }
    }
    return FALSE;
}

/*

unbless any object within the data structure

*/
SV *
_unbless( SV * sv, HV * seen ) {
    I32 i, len;
    SV **AValue;
    HV *myHash;
    HE *HEntry;

  redo_unbless:
    if ( SvROK( sv ) ) {

        if ( has_seen( sv, seen ) )
            return sv;

        if ( sv_isobject( sv ) ) {
            sv = ( SV * ) SvRV( sv );
            SvOBJECT_off( sv );
        }
        else {
            sv = ( SV * ) SvRV( sv );
        }
        goto redo_unbless;
    }

    switch ( SvTYPE( sv ) ) {

    case SVt_PVAV:{
            dsWARN( "an array\n" );
            len = av_len( ( AV * ) sv );
            for ( i = 0; i <= len; i++ ) {
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue )
                    _unbless( *AValue, seen );
            }
            break;
        }
    case SVt_PVHV:{
            dsWARN( "a hash (PVHV)\n" );
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
                _unbless( HeVAL( HEntry ), seen );
            }
            break;
        }
    }
    return sv;
}

/*

Returns objects within a data structure, deep first

*/
AV *
_get_blessed( SV * sv, HV * seen, AV * objects ) {
    I32 i;
    SV **AValue;
    HV *myHash;
    HE *HEntry;

    if ( SvROK( sv ) ) {

        if ( has_seen( sv, seen ) )
            return objects;
        _get_blessed( SvRV( sv ), seen, objects );
        if ( sv_isobject( sv ) ) {
            SvREFCNT_inc( sv );
            av_push( objects, sv );
        }

    }
    else {

        switch ( SvTYPE( sv ) ) {
        case SVt_PVAV:{
                for ( i = 0; i <= av_len( ( AV * ) sv ); i++ ) {
                    AValue = av_fetch( ( AV * ) sv, i, 0 );
                    if ( AValue )
                        _get_blessed( *AValue, seen, objects );
                }
                break;
            }
        case SVt_PVHV:{
                myHash = ( HV * ) sv;
                hv_iterinit( myHash );
                while ( HEntry = hv_iternext( myHash ) ) {
                    _get_blessed( HeVAL( HEntry ), seen, objects );
                }
                break;
            }
        }
    }

    return objects;
}

/*

Returns references within a data structure, deep first

*/
AV *
_get_refs( SV * sv, HV * seen, AV * objects ) {
    I32 i;
    SV **AValue;
    HV *myHash;
    HE *HEntry;
    if ( SvROK( sv ) ) {

        if ( has_seen( sv, seen ) )
            return objects;
        _get_refs( SvRV( sv ), seen, objects );
        SvREFCNT_inc( sv );
        av_push( objects, sv );

    }
    else {

        switch ( SvTYPE( sv ) ) {
        case SVt_PVAV:{
                for ( i = 0; i <= av_len( ( AV * ) sv ); i++ ) {
                    AValue = av_fetch( ( AV * ) sv, i, 0 );
                    if ( AValue )
                        _get_refs( *AValue, seen, objects );
                }
                break;
            }
        case SVt_PVHV:{
                myHash = ( HV * ) sv;
                hv_iterinit( myHash );
                while ( HEntry = hv_iternext( myHash ) ) {
                    _get_refs( HeVAL( HEntry ), seen, objects );
                }
                break;
            }
        }
    }
    return objects;
}

/*

Returns a signature of the structure

*/
AV *
_signature( SV * sv, HV * seen, AV * infos ) {
    I32 i;
    U32 len;
    SV **AValue;
    HV *myHash;
    HE *HEntry;
    char *HKey;

  testvar1:

    if ( SvROK( sv ) ) {
        if ( has_seen( sv, seen ) )
            return infos;

        av_push( infos, _get_infos( sv ) );
        sv = SvRV( sv );
        goto testvar1;

    }
    else {

        av_push( infos, _get_infos( sv ) );
        switch ( SvTYPE( sv ) ) {
        case SVt_PVAV:
            for ( i = 0; i <= av_len( ( AV * ) sv ); i++ ) {
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue )
                    _signature( *AValue, seen, infos );
            }
            break;

        case SVt_PVHV:
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
                STRLEN len;
                HKey = HePV( HEntry, len );
                _signature( HeVAL( HEntry ), seen, infos );
            }
            break;

        }
    }
    return infos;
}

/*

Detects if there is a circular reference

*/
SV *
_has_circular_ref( SV * sv, HV * parents, HV * seen ) {

    SV *ret;
    SV *found;
    U32 len;
    I32 i;
    SV **AValue;
    HV *myHash;
    HE *HEntry;
    SV **HValue;
#if dsDEBUG
    char errmsg[100];
#endif

    if ( SvROK( sv ) ) {        /* Reference */

        char addr[PTRLEN];
        sprintf( addr, "%p", SvRV( sv ) );
        len = strlen( addr );

        if ( hv_exists( parents, addr, len ) ) {
#ifdef SvWEAKREF
            if ( SvWEAKREF( sv ) ) {
                dsWARN( "found a weak reference" );
                return &PL_sv_undef;
            }
            else {
#endif
                dsWARN( "found a circular reference!!!" );
                SvREFCNT_inc( sv );
                return sv;
#ifdef SvWEAKREF
            }
#endif
        }
        if ( hv_exists( seen, addr, len ) ) {
            dsWARN( "circular reference on weak ref" );
            return &PL_sv_undef;
        }

        hv_store( parents, addr, len, NULL, 0 );
        hv_store( seen, addr, len, NULL, 0 );
#ifdef SvWEAKREF
        if ( SvWEAKREF( sv ) ) {
            dsWARN( "found a weak reference 2" );
            ret = _has_circular_ref( SvRV( sv ), newHV(  ), seen );
        }
        else {
#endif
            ret = _has_circular_ref( SvRV( sv ), parents, seen );
#ifdef SvWEAKREF
        }
#endif
        hv_delete( seen, addr, ( U32 ) len, 0 );
        hv_delete( parents, addr, ( U32 ) len, 0 );
        return ret;
    }

    /* Not a reference */
    switch ( SvTYPE( sv ) ) {

    case SVt_PVAV:{            /* Array */
            dsWARN( "Array" );
            for ( i = 0; i <= av_len( ( AV * ) sv ); i++ ) {
#if dsDEBUG
                sprintf( errmsg, "next elem %i\n", i );
                warn( errmsg );
#endif
                AValue = av_fetch( ( AV * ) sv, i, 0 );
                if ( AValue ) {
                    found = _has_circular_ref( *AValue, parents, seen );
                    if ( SvOK( found ) )
                        return found;
                }
            }
            break;
        }
    case SVt_PVHV:{            /* Hash */
            dsWARN( "Hash" );
            myHash = ( HV * ) sv;
            hv_iterinit( myHash );
            while ( HEntry = hv_iternext( myHash ) ) {
#if dsDEBUG
                STRLEN len2;
                char *HKey = HePV( HEntry, len2 );
                sprintf( errmsg, "NEXT KEY is %s\n", HKey );
                warn( errmsg );
#endif
                found =
                    _has_circular_ref( HeVAL( HEntry ), parents, seen );
                if ( SvOK( found ) )
                    return found;
            }
            break;
        }
    }
    return &PL_sv_undef;
}

/*

Weaken any circular reference found

*/
SV *
_circular_off( SV * sv, HV * parents, HV * seen, SV * counter ) {

    U32 len;
    I32 i;
    SV **AValue;
    HV *myHash;
    HE *HEntry;
    char addr[PTRLEN];
#if dsDEBUG
    char errmsg[100];
#endif

    if ( SvROK( sv ) ) {        /* Reference */

        sprintf( addr, "%p", SvRV( sv ) );
        len = strlen( addr );

        if ( hv_exists( parents, addr, len ) ) {
            if ( SvWEAKREF( sv ) ) {
                dsWARN( "found a weak reference" );
            }
            else {
                dsWARN( "found a circular reference!!!" );
                sv_rvweaken( sv );
                sv_inc( counter );
            }
        }
        else {

            if ( hv_exists( seen, addr, len ) ) {
                dsWARN( "circular reference on weak ref" );
                return &PL_sv_undef;
            }

            hv_store( parents, addr, len, NULL, 0 );
            hv_store( seen, addr, len, NULL, 0 );
#ifdef SvWEAKREF
            if ( SvWEAKREF( sv ) ) {
                dsWARN( "found a weak reference 2" );
                _circular_off( SvRV( sv ), newHV(  ), seen, counter );
            }
            else {
#endif
                _circular_off( SvRV( sv ), parents, seen, counter );
#ifdef SvWEAKREF
            }
#endif
            hv_delete( seen, addr, ( U32 ) len, 0 );
            hv_delete( parents, addr, ( U32 ) len, 0 );
        }

    }
    else {

        /* Not a reference */
        switch ( SvTYPE( sv ) ) {

        case SVt_PVAV:{        /* Array */
                dsWARN( "Array" );
                for ( i = 0; i <= av_len( ( AV * ) sv ); i++ ) {
#if dsDEBUG
                    sprintf( errmsg, "next elem %i\n", i );
                    warn( errmsg );
#endif
                    AValue = av_fetch( ( AV * ) sv, i, 0 );
                    if ( AValue ) {
                        _circular_off( *AValue, parents, seen, counter );
                        if ( SvTYPE( sv ) != SVt_PVAV ) {
                            /* In some circumstances, weakening a reference screw things up */
                            croak
                                ( "Array that we were weakening suddenly turned into a scalar of type type %d",
                                  SvTYPE( sv ) );
                        }
                    }
                }
                break;
            }
        case SVt_PVHV:{        /* Hash */
                dsWARN( "Hash" );
                myHash = ( HV * ) sv;
                hv_iterinit( myHash );
                while ( HEntry = hv_iternext( myHash ) ) {
#if dsDEBUG
                    STRLEN len2;
                    char *HKey = HePV( HEntry, len2 );
                    sprintf( errmsg, "NEXT KEY is %s\n", HKey );
                    warn( errmsg );
#endif
                    _circular_off( HeVAL( HEntry ), parents, seen,
                                   counter );
                    if ( SvTYPE( sv ) != SVt_PVHV ) {
                        /* In some circumstances, weakening a reference screw things up */
                        croak
                            ( "Hash that we were weakening suddenly turned into a scalar of type type %d",
                              SvTYPE( sv ) );
                    }
                }
                break;
            }
        }
    }
    return counter;
}

#if dsDEBUG
/*

Dump any data structure

*/

SV *
_dump_any( SV * re, HV * seen, int depth ) {

  testvar:

    if ( SvROK( re ) ) {
        if ( has_seen( re, seen ) )
            return re;
        printf( "a reference " );

        if ( sv_isobject( re ) )
            printf( " blessed " );

        printf( "to " );
        re = SvRV( re );
        goto testvar;

    }
    else {

        switch ( SvTYPE( re ) ) {
        case SVt_NULL:
            printf( "an undef value\n" );
            break;
        case SVt_IV:
            printf( "an integer (IV): %d\n", SvIV( re ) );
            break;
        case SVt_NV:
            printf( "a double (NV): %f\n", SvNV( re ) );
            break;
        case SVt_RV:
            printf( "a RV\n" );
            break;
        case SVt_PV:
            printf( "a string (PV): %s\n", SvPV_nolen( re ) );
            printf( "UTF8 %s\n", SvUTF8( re ) ? "on" : "off" );
            break;
        case SVt_PVIV:
            printf( "an integer (PVIV): %d\n", SvIV( re ) );
            break;
        case SVt_PVNV:
            printf( "a string (PVNV): %s\n", SvPV_nolen( re ) );
            printf( "UTF8 %s\n", SvUTF8( re ) ? "on" : "off" );
            break;
        case SVt_PVMG:
            printf( "a PVMG\n" );
            break;
        case SVt_PVLV:
            printf( "a PVLV\n" );
            break;
        case SVt_PVAV:
            {
                I32 i;

                printf( "an array of %u elems (PVAV)\n",
                        av_len( ( AV * ) re ) + 1 );
                for ( i = 0; i <= av_len( ( AV * ) re ); i++ ) {
                    SV **AValue = av_fetch( ( AV * ) re, i, 0 );
                    if ( AValue ) {
                        printf( "NEXT ELEM is " );
                        _dump_any( *AValue, seen, depth );
                    }
                    else {
                        printf( "NEXT ELEM was undef" );
                    }
                }
                break;
            }

        case SVt_PVHV:
            {
                HV *myHash = ( HV * ) re;
                HE *HEntry;
                int count = 0;

                printf( "a hash (PVHV)\n" );
                hv_iterinit( myHash );
                while ( HEntry = hv_iternext( myHash ) ) {
                    STRLEN len;
                    char *HKey = HePV( HEntry, len );
                    int i;

                    count++;
                    for ( i = 0; i < depth; i++ )
                        printf( "\t" );
                    printf( "NEXT KEY is %s, value is ", HKey );
                    _dump_any( HeVAL( HEntry ), seen, depth + 1 );
                }
                if ( !count )
                    printf( "Empty\n" );
                break;
            }

        case SVt_PVCV:
            printf( "a code (PVCV)\n" );
            return;
        case SVt_PVGV:
            printf( "a glob (PVGV)\n" );
            break;
        case SVt_PVBM:
            printf( "a PVBM\n" );
            break;
        case SVt_PVFM:
            printf( "a PVFM\n" );
            break;
        case SVt_PVIO:
            printf( "a PVIO\n" );
            break;
        default:
            if ( SvOK( re ) ) {
                printf( "Don't know what it is\n" );
                return;
            }
            else {
                croak( "Not a Sv" );
                return;
            }
        }
    }
    return re;
}
#endif

/*
 has_seen
 Returns true if ref already seen
*/
int
has_seen( SV * sv, HV * seen ) {
    char addr[PTRLEN];
    sprintf( addr, "%p", SvRV( sv ) );
    if ( hv_exists( seen, addr, ( U32 ) strlen( addr ) ) ) {
        dsWARN( "already seen" );
        return TRUE;
    }
    else {
        hv_store( seen, addr, ( U32 ) strlen( addr ), NULL, 0 );
        return FALSE;
    }
}

/* *INDENT-OFF* */

MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

bool
utf8_off_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    _utf8_set(sv, (HV*) sv_2mortal((SV*) newHV()), 0);


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

bool
utf8_on_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _utf8_set(sv, (HV*) sv_2mortal((SV*) newHV()), 1);
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

bool
_utf8_off_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    _utf8_flag_set(sv, (HV*) sv_2mortal((SV*) newHV()), 0);


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

bool
_utf8_on_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _utf8_flag_set(sv, (HV*) sv_2mortal((SV*) newHV()), 1);
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

bool
has_utf8_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _has_utf8(sv, (HV*) sv_2mortal((SV*) newHV()));
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

SV*
unbless_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    _unbless(sv, (HV*) sv_2mortal((SV*) newHV()));


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

SV*
has_circular_ref_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _has_circular_ref(sv, (HV*) sv_2mortal((SV*) newHV()), (HV*) sv_2mortal((SV*) newHV()));
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

SV*
circular_off_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
#ifdef SvWEAKREF
#else
    croak("This version of perl doesn't support weak references");
#endif
    RETVAL = _circular_off(sv, (HV*) sv_2mortal((SV*) newHV()), (HV*) sv_2mortal((SV*) newHV()), newSViv(0));
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

AV*
get_blessed_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _get_blessed(sv, (HV*) sv_2mortal((SV*) newHV()), (AV*) sv_2mortal((SV*) newAV()));
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

AV*
get_refs_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _get_refs(sv, (HV*) sv_2mortal((SV*) newHV()), (AV*) sv_2mortal((SV*) newAV()));
OUTPUT:
    RETVAL


MODULE = Data::Structure::Util     PACKAGE = Data::Structure::Util

AV*
signature_xs(sv)
    SV* sv
PROTOTYPE: $
CODE:
    RETVAL = _signature(sv, (HV*) sv_2mortal((SV*) newHV()), (AV*) sv_2mortal((SV*) newAV()));
OUTPUT:
    RETVAL