Data-Structure-Util-0.15/0000755000076500000240000000000010765036245014047 5ustar andystaffData-Structure-Util-0.15/CHANGES0000644000076500000240000000710710765036231015042 0ustar andystaffRevision history for Perl module Data::Structure::Util 0.15 2008-03-09 - Fixed Makefile patching on platforms that use double quotes. 0.14 2008-03-09 - Use Storable::freeze instead of Data::Dumper for signature generation - Remove Clone dependency. 0.13 2008-03-06 - Fixed signature to ignore SVf_OOK - Fixed t/04utf8.t failure by adding use bytes. The default behaviour of unpack changed for 5.10 and that was causing breakage. 0.12 Wed Jun 21 15:37:40 2006 - Check return value of av_fetch in the debug code - Need to check the return value of av_fetch() in circular_off - Avoid the "unknown error" (which was actually the hash or array we were traversing suddenly being deleted from underneath us) by holding an additional reference to the passed in structure. - Make the "Unknown error" message a lot more helpful - _circular_ref should check the return value of av_fetch - Substitute a sane way of chosing the test plan - Convert t/02circular to Test::More - _signature should check the return value of av_fetch - _get_refs should check the return value of av_fetch - Convert t/05refs.t to Test::More - Check the return value from av_fetch in _utf8_flag and _utf8_flag_set - _has_utf8 should check the return value of av_fetch - convert 04utf8.t to Test::More - Check return value from av_fetch in _unbless - Check the return value from av_fetch is not NULL before deferencing it in _get_blessed - Use Test::More rather than Test::Simple in t/03bless.t - Use Test::More's eq/ne functiosn rather than comparisons inside the arguments to ok() - Have to use a hash ref rather than a hash and keep taking references for the signature test, as temporary refs are in the signature, and their address can - differ each time round the loop - Remove C99-isms from the debugging code - Use the SvFLAGS() macro rather than a direct structure access 0.11 Fri Sep 10 11:00:00 2004 - Fixed t/00pod.t for those who don't have Test::POD installed - Thanks Jeremy - Major doc updates - fixed some utf8 bugs with magic scalars (length caching for utf8) - Thanks Mark 0.10 Sat Jun 26 19:25:00 2004 - Updated tests to be compatible vith perl 5.6 - Thanks Jeremy - Added _utf8_on() and _utf8_off() 0.09 Fri Mar 26 15:10:00 2004 - Updated tests to pass on perls without unicode - Tom - Updated doc 0.08 Mon Jan 20 12:00:00 2004 - Fixed memory leaks (very embarassing I must admit) - Thanks Richard Clamp 0.07 Mon Jan 19 09:50:00 2004 - Added get_refs() and signature() - Updated doc 0.06 Tue Dec 30 10:27:00 2003 - Changed C++ style comments to C style comments - Thanks Leon - Fixed bug in has_circular_ref() and circular_off() where there was a weak ref: in some cases, a circular ref could be wrongly reported. 0.05 - Added circular_off() to weaken references when a circular ref is found - Added 02circular_off.t - Added bin/packages.pl to scan all global variables for circular refs - Cleaned 02circular.t - Thanks autarch - Updated doc 0.04 - Circular reference detection is smarter in presence of weak references - Removed warnings from tests 0.03 Tue Nov 05 23:25:00 2003 - Added support for weaken references in has_circular_ref() - Added prototyping of XS functions - Updated documentation 0.02 Tue Nov 04 22:05:00 2003 - Fixed compilations issues with old versions of gcc - Thanks Leon - has_utf8(), utf8_on() and utf8_off() now return the first parameter - skip utf8 tests if perl version < 5.8.0 - Removed SIGNATURE from MANIFEST 0.01 Fri Oct 31 14:00:00 2003 - original version Data-Structure-Util-0.15/MANIFEST0000644000076500000240000000063110765036242015175 0ustar andystaffbin/packages.pl CHANGES inc/Devel/CheckLib.pm inc/IO/CaptureOutput.pm lib/Data/Structure/Util.pm Makefile.PL MANIFEST NINJA README t/00pod.t t/01compile.t t/02circular.t t/02circular_off.t t/03bless.t t/04utf8.t t/05refs.t t/06signature.t Util.xs META.yml Module meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) Data-Structure-Util-0.15/META.yml0000644000076500000240000000126110765036242015315 0ustar andystaff--- #YAML:1.0 name: Data-Structure-Util version: 0.15 abstract: Change nature of data within a structure license: perl author: - Andy Armstrong generated_by: ExtUtils::MakeMaker version 6.44 distribution_type: module requires: Digest::MD5: 0 Scalar::Util: 1.01 Test::More: 0 Test::Pod: 0 Test::Simple: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 no_index: package: - Devel::CheckLib - IO::CaptureOutput Data-Structure-Util-0.15/Makefile.PL0000644000076500000240000000265710765032406016026 0ustar andystaffuse 5.008; use strict; use lib qw(inc); use Config; use Devel::CheckLib; use ExtUtils::MakeMaker; # Check that we have a C compiler check_lib_or_exit(); my %mm_args = ( ( MM->can( 'signature_target' ) ? ( SIGN => 1 ) : () ), NAME => 'Data::Structure::Util', AUTHOR => 'Andy Armstrong ', VERSION_FROM => 'lib/Data/Structure/Util.pm', ABSTRACT_FROM => 'lib/Data/Structure/Util.pm', PL_FILES => {}, PREREQ_PM => { 'Digest::MD5' => 0, 'Scalar::Util' => '1.01', 'Test::More' => 0, 'Test::Pod' => 0, 'Test::Simple' => 0, }, LIBS => [''], DEFINE => '', INC => '', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Data-Structure-Util-*' }, ); { local $^W = 0; # Silence warning about non-numeric version if ( $ExtUtils::MakeMaker::VERSION >= '6.31' ) { $mm_args{LICENSE} = 'perl'; } } WriteMakefile( %mm_args ); package MY; sub metafile { my @lines = split /\n/, shift->SUPER::metafile_target( @_ ); my @exclude = qw( Devel::CheckLib IO::CaptureOutput ); my $pad = ' ' x 4; die "Can't parse Makefile fragment" unless $lines[-2] =~ /^([^"']*(["'])).*?(\2[^"']*)$/; splice @lines, -1, 0, map { "$1$_$3" } ( 'no_index:', "${pad}package:", map { "${pad}${pad}- $_" } @exclude ); return join "\n", @lines; } Data-Structure-Util-0.15/NINJA0000644000076500000240000000020710446256061014624 0ustar andystaff--- #YAML:1.0 attributes: charisma: 0.73 constitution: 0.87 dexterity: 0.07 intelligence: 0.60 strength: 0.60 wisdom: 0.93 Data-Structure-Util-0.15/README0000644000076500000240000000037210446256061014725 0ustar andystaffThis module provides useful method to modify the nature of data within a structure Here are the basic install instructions. perl Build.PL ./Build ./Build test ./Build install If you are on a windows box you should use 'nmake' rather than 'make'. Data-Structure-Util-0.15/SIGNATURE0000644000076500000240000000347210765036245015341 0ustar andystaffThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 4c6366b8d612cf8c5b95f092dff60be5f160ebd7 CHANGES SHA1 1e8553ad871c1246cbaed931e4b338877cdbb881 MANIFEST SHA1 339faeaa69ff2414c8ed07b44eaab65e25e1dd35 META.yml SHA1 0c4b407514e89b09df2981ca25e2f13683e9abc7 Makefile.PL SHA1 c012e531a57bae33bd51bd54cf471c0d2ede456d NINJA SHA1 0637effa677b3380caea210ddde0e16ba47c57aa README SHA1 c5475702524c3bf536a0301ed4926a34cbe35190 Util.xs SHA1 150fa4f28e960bd5fecb41e718e69fcf0c650991 bin/packages.pl SHA1 632a566b4f388c3c12350ed830aa87c6fd410d24 inc/Devel/CheckLib.pm SHA1 f7e235a7e912d3a8394dfb0d7822bef213bbda16 inc/IO/CaptureOutput.pm SHA1 e526b1eede8ce447a110bc681b8f34741020ae71 lib/Data/Structure/Util.pm SHA1 0aecef19b41df53deec039d4989a8e4f2a3b2b8e t/00pod.t SHA1 0ca7413e5c4abb499671fa3e6be90396295d805f t/01compile.t SHA1 6ffcdf17aa60124010b621e90baa68ffc78c43bc t/02circular.t SHA1 4f19d45862189ee54f1f120425fdcfd377b58657 t/02circular_off.t SHA1 9190cb14d996aff3f0ec591faa468d5c11efc847 t/03bless.t SHA1 7e5306d8da76de7212e3e265617029ff884ecaa1 t/04utf8.t SHA1 e1ecd132e83af395b7c2433a718fb8a165471880 t/05refs.t SHA1 56097683516f7d3b7c3ebb61a7f00f776da6516d t/06signature.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.7 (Darwin) iD8DBQFH1DyjwoknRJZQnCERAnwAAKCYopUaUbMUtAQs/ciHQLQs6mskLQCgmDSS 8wLZ7XPFU2Ub9nv+Kz+LjxE= =37Hy -----END PGP SIGNATURE----- Data-Structure-Util-0.15/Util.xs0000644000076500000240000005366110764753037015357 0ustar andystaff#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 Data-Structure-Util-0.15/bin/0000755000076500000240000000000010765036241014613 5ustar andystaffData-Structure-Util-0.15/bin/packages.pl0000644000076500000240000000215110764754146016737 0ustar andystaffuse strict; use warnings; use blib; use TEST; use Data::Dumper; use Data::Structure::Util qw( has_circular_ref ); sub check_globals { my $package = shift || 'main'; next_package($package); } sub next_package { my $pkg = shift; no strict 'refs'; for my $key (%{"$pkg".'::'}) { next if ($key =~ /^\*/); if ($key =~ /(.+)\:\:$/) { if ($1 ne $pkg) { next_package($pkg . '::' . $1); } } my $scalar = ${"$pkg\::$key"}; if (ref $scalar) { if (my $ref = has_circular_ref($scalar)) { warn "###### CIRCULAR REF DETECTED IN \$$pkg\::$key\n"; } } my $hash = \%{"$pkg\::$key"}; if (%$hash) { if (my $ref = has_circular_ref($hash)) { warn "###### CIRCULAR REF DETECTED IN \%$pkg\::$key\n"; } } my $array = \@{"$pkg\::$key"}; if (@$array) { if (my $ref = has_circular_ref($array)) { warn "###### CIRCULAR REF DETECTED IN \@$pkg\::$key\n"; } } } } =head1 NAME packages.pl =head1 DESCRIPTION Search through all the global variables in all packagse for any circular reference. =cut Data-Structure-Util-0.15/inc/0000755000076500000240000000000010765036241014614 5ustar andystaffData-Structure-Util-0.15/inc/Devel/0000755000076500000240000000000010765036241015653 5ustar andystaffData-Structure-Util-0.15/inc/Devel/CheckLib.pm0000644000076500000240000002045310764754146017673 0ustar andystaff# $Id: CheckLib.pm,v 1.10 2007/10/30 15:12:17 drhyde Exp $ package Devel::CheckLib; use strict; use vars qw($VERSION @ISA @EXPORT); $VERSION = '0.3'; use Config; use File::Spec; use File::Temp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(assert_lib check_lib_or_exit); # localising prevents the warningness leaking out of this module local $^W = 1; # use warnings is a 5.6-ism _findcc(); # bomb out early if there's no compiler =head1 NAME Devel::CheckLib - check that a library is available =head1 DESCRIPTION Devel::CheckLib is a perl module that checks whether a particular C library is available, and dies if it is not. =head1 SYNOPSIS # in a Makefile.PL or Build.PL use lib qw(inc); use Devel::CheckLib; check_lib_or_exit( lib => 'jpeg' ); check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] ); # or prompt for path to library and then do this: check_lib_or_exit( lib => 'jpeg', libpath => $additional_path ); =head1 HOW IT WORKS You pass named parameters to a function describing how to build and link to the library. Currently the only parameter supported is 'lib', which can be a string or an arrayref of several libraries. In the future, expect us to add something for checking that header files are available as well. It works by trying to compile this: int main(void) { return 0; } and linking it to the specified libraries. If something pops out the end which looks executable, then we know that it worked. =head1 FUNCTIONS All of these take the same named parameters and are exported by default. To avoid exporting them, C. =head2 assert_lib Takes several named parameters. The value of C must be either a string with the name of a single library or a reference to an array of strings of library names. Depending on the compiler found, library names will be fed to the compiler either as C<-l> arguments or as C<.lib> file names. (E.g. C<-ljpeg> or C) Likewise, C must if provided either be a string or an array of strings representing additional paths to search for libraries. C must be a C-style space-seperated list of libraries (each preceded by '-l') and directories (preceded by '-L'). This will die with an error message if any of the libraries listed can not be found. B: dying in a Makefile.PL or Build.PL may provoke a 'FAIL' report from CPAN Testers' automated smoke testers. Use C instead. =head2 check_lib_or_exit This behaves exactly the same as C except that instead of dieing, it warns (with exactly the same error message) and exits. This is intended for use in Makefile.PL / Build.PL when you might want to prompt the user for various paths and things before checking that what they've told you is sane. If a library isn't found, it exits with an exit value of 0 to avoid causing a CPAN Testers 'FAIL' report. CPAN Testers should ignore this result -- which is what you want if an external library dependency is not available. =cut sub check_lib_or_exit { eval 'assert_lib(@_)'; if ( $@ ) { warn $@; exit; } } sub assert_lib { my %args = @_; my ( @libs, @libpaths ); @libs = ( ref( $args{lib} ) ? @{ $args{lib} } : $args{lib} ) if $args{lib}; @libpaths = ( ref( $args{libpath} ) ? @{ $args{libpath} } : $args{libpath} ) if $args{libpath}; # work-a-like for Makefile.PL's "LIBS" argument if ( defined( $args{LIBS} ) ) { for my $arg ( split( /\s+/, $args{LIBS} ) ) { die( "LIBS argument badly-formed: $arg\n" ) unless ( $arg =~ /^-l/i ); push @{ $arg =~ /^-l/ ? \@libs : \@libpaths }, substr( $arg, 2 ); } } my @cc = _findcc(); my ( $ch, $cfile ) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c', UNLINK => 1 ); print $ch "int main(void) { return 0; }\n"; close( $ch ); my @missing; for my $lib ( @libs ) { my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe}; my @sys_cmd; if ( $Config{cc} eq 'cl' ) { # Microsoft compiler require Win32; my @libpath = map { q{/libpath:} . Win32::GetShortPathName( $_ ) } @libpaths; @sys_cmd = ( @cc, $cfile, "${lib}.lib", "/Fe$exefile", "/link", @libpath ); } elsif ( $Config{cc} =~ /bcc32(\.exe)?/ ) { # Borland my @libpath = map { "-L$_" } @libpaths; @sys_cmd = ( @cc, "-o$exefile", "-l$lib", @libpath, $cfile ); } else { # Unix-ish # gcc, Sun, AIX (gcc, cc) my @libpath = map { "-L$_" } @libpaths; @sys_cmd = ( @cc, $cfile, "-o", "$exefile", "-l$lib", @libpath ); } warn "# @sys_cmd\n" if $args{debug}; my $rv = $args{debug} ? system( @sys_cmd ) : _quiet_system( @sys_cmd ); push @missing, $lib if $rv != 0 || !-x $exefile; _cleanup_exe( $exefile ); } unlink $cfile; my $miss_string = join( q{, }, map { qq{'$_'} } @missing ); die( "Can't build and link to $miss_string\n" ) if @missing; } sub _cleanup_exe { my ( $exefile ) = @_; my $ofile = $exefile; $ofile =~ s/$Config{_exe}$/$Config{_o}/; unlink $exefile if -f $exefile; unlink $ofile if -f $ofile; unlink "$exefile\.manifest" if -f "$exefile\.manifest"; return; } sub _findcc { my @paths = split( /$Config{path_sep}/, $ENV{PATH} ); my @cc = split( /\s+/, $Config{cc} ); return @cc if -x $cc[0]; for my $path ( @paths ) { my $compiler = File::Spec->catfile( $path, $cc[0] ) . $Config{_exe}; return ( $compiler, @cc[ 1 .. $#cc ] ) if -x $compiler; } die( "Couldn't find your C compiler\n" ); } # code substantially borrowed from IPC::Run3 sub _quiet_system { my ( @cmd ) = @_; # save handles local *STDOUT_SAVE; local *STDERR_SAVE; open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT"; open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR"; # redirect to nowhere local *DEV_NULL; open DEV_NULL, ">" . File::Spec->devnull or die "CheckLib: $! opening handle to null device"; open STDOUT, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDOUT to null handle"; open STDERR, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDERR to null handle"; # run system command my $rv = system( @cmd ); # restore handles open STDOUT, ">&" . fileno STDOUT_SAVE or die "CheckLib: $! restoring STDOUT handle"; open STDERR, ">&" . fileno STDERR_SAVE or die "CheckLib: $! restoring STDERR handle"; return $rv; } =head1 PLATFORMS SUPPORTED You must have a C compiler installed. We check for C<$Config{cc}>, both literally as it is in Config.pm and also in the $PATH. It has been tested with varying degrees on rigourousness on: =over =item gcc (on Linux, *BSD, Solaris, Cygwin) =item Sun's compiler tools on Solaris =item IBM's tools on AIX =item Microsoft's tools on Windows =item MinGW on Windows (with Strawberry Perl) =item Borland's tools on Windows =back =head1 WARNINGS, BUGS and FEEDBACK This is a very early release intended primarily for feedback from people who have discussed it. The interface may change and it has not been adequately tested. Feedback is most welcome, including constructive criticism. Bug reports should be made using L or by email. When submitting a bug report, please include the output from running: perl -V perl -MDevel::CheckLib =head1 SEE ALSO L =head1 AUTHORS David Cantrell Edavid@cantrell.org.ukE David Golden Edagolden@cpan.orgE Thanks to the cpan-testers-discuss mailing list for prompting us to write it in the first place; to Chris Williams for help with Borland support. =head1 COPYRIGHT and LICENCE Copyright 2007 David Cantrell. Portions copyright 2007 David Golden. This module is free-as-in-speech software, and may be used, distributed, and modified under the same conditions as perl itself. =head1 CONSPIRACY This module is also free-as-in-mason software. =cut 1; Data-Structure-Util-0.15/inc/IO/0000755000076500000240000000000010765036241015123 5ustar andystaffData-Structure-Util-0.15/inc/IO/CaptureOutput.pm0000644000076500000240000002247210764754211020317 0ustar andystaff# $Id: CaptureOutput.pm,v 1.3 2005/03/25 12:44:14 simonflack Exp $ package IO::CaptureOutput; use strict; use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS/; use Exporter; @ISA = 'Exporter'; @EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/; %EXPORT_TAGS = ( all => \@EXPORT_OK ); $VERSION = '1.0801'; sub capture (&@) { ## no critic my ( $code, $output, $error, $output_file, $error_file ) = @_; for ( $output, $error ) { $_ = \do { my $s; $s = '' } unless ref $_; $$_ = '' if $_ != \undef && !defined( $$_ ); } # don't merge if both undef -- someone might still want to capture # them separately in temp files my $should_merge = defined $error && defined $output && $output == $error; my ( $capture_out, $capture_err ); if ( $output != \undef ) { $capture_out = IO::CaptureOutput::_proxy->new( 'STDOUT', $output, undef, $output_file ); } if ( $error != \undef ) { my $capture_err = IO::CaptureOutput::_proxy->new( 'STDERR', $error, ( $should_merge ? 'STDOUT' : undef ), $error_file ); } &$code(); } sub capture_exec { my @args = @_; my ( $output, $error ); capture sub { system _shell_quote( @args ) }, \$output, \$error; return wantarray ? ( $output, $error ) : $output; } *qxx = \&capture_exec; sub capture_exec_combined { my @args = @_; my $output; capture sub { system _shell_quote( @args ) }, \$output, \$output; return $output; } *qxy = \&capture_exec_combined; # extra quoting required on Win32 systems *_shell_quote = ( $^O =~ /MSWin32/ ) ? \&_shell_quote_win32 : sub { @_ }; sub _shell_quote_win32 { my @args; for ( @_ ) { if ( /[ \"]/ ) { # TODO: check if ^ requires escaping ( my $escaped = $_ ) =~ s/([\"])/\\$1/g; push @args, '"' . $escaped . '"'; next; } push @args, $_; } return @args; } # Captures everything printed to a filehandle for the lifetime of the object # and then transfers it to a scalar reference package IO::CaptureOutput::_proxy; use File::Temp 'tempfile'; use File::Basename qw/basename/; use Symbol qw/gensym qualify qualify_to_ref/; use Carp; sub _is_wperl { $^O eq 'MSWin32' && basename( $^X ) eq 'wperl.exe' } sub new { my $class = shift; my ( $fh, $capture, $merge_fh, $capture_file ) = @_; $fh = qualify( $fh ); # e.g. main::STDOUT my $fhref = qualify_to_ref( $fh ); # e.g. \*STDOUT # Duplicate the filehandle my $saved; { no strict 'refs'; ## no critic - needed for 5.005 if ( defined fileno( $fh ) && !_is_wperl() ) { $saved = gensym; open $saved, ">&$fh" or croak "Can't redirect <$fh> - $!"; } } # Create replacement filehandle if not merging my ( $newio, $newio_file ); if ( !$merge_fh ) { $newio = gensym; if ( $capture_file ) { $newio_file = $capture_file; } else { ( undef, $newio_file ) = tempfile; } open $newio, "+>$newio_file" or croak "Can't write temp file for $fh - $!"; } else { $newio = qualify( $merge_fh ); } # Redirect (or merge) { no strict 'refs'; ## no critic -- needed for 5.005 open $fhref, ">&" . fileno( $newio ) or croak "Can't redirect $fh - $!"; } bless [ $$, $fh, $saved, $capture, $newio, $newio_file, $capture_file ], $class; } sub DESTROY { my $self = shift; my ( $pid, $fh, $saved ) = @{$self}[ 0 .. 2 ]; return unless $pid eq $$; # only cleanup in the process that is capturing # restore the original filehandle my $fh_ref = Symbol::qualify_to_ref( $fh ); select( ( select( $fh_ref ), $| = 1 )[0] ); if ( defined $saved ) { open $fh_ref, ">&" . fileno( $saved ) or croak "Can't restore $fh - $!"; } else { close $fh_ref; } # transfer captured data to the scalar reference if we didn't merge my ( $capture, $newio, $newio_file ) = @{$self}[ 3 .. 5 ]; if ( $newio_file ) { # some versions of perl complain about reading from fd 1 or 2 # which could happen if STDOUT and STDERR were closed when $newio # was opened, so we just squelch warnings here and continue local $^W; seek $newio, 0, 0; $$capture = do { local $/; <$newio> }; close $newio; } # Cleanup return unless defined $newio_file && -e $newio_file; return if $self->[6]; # the "temp" file was explicitly named unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!"; } 1; __END__ =pod =begin wikidoc = NAME IO::CaptureOutput - capture STDOUT and STDERR from Perl code, subprocesses or XS = VERSION This documentation describes version %%VERSION%%. = SYNOPSIS use IO::CaptureOutput qw(capture capture_exec); my ($stdout, $stderr); sub noisy { warn "this sub prints to stdout and stderr!"; print "arguments: @_"; } capture { noisy(@args) } \$stdout, \$stderr; ($stdout, $stderr) = capture_exec( 'perl', '-e', 'print "Hello"; print STDERR "World!"'); = DESCRIPTION This module provides routines for capturing STDOUT and STDERR from perl subroutines, forked system calls (e.g. {system()}, {fork()}) and from XS or C modules. = FUNCTIONS The following functions will be exported on demand. == capture() capture \&subroutine, \$stdout, \$stderr; Captures everything printed to {STDOUT} and {STDERR} for the duration of {&subroutine}. {$stdout} and {$stderr} are optional scalars that will contain {STDOUT} and {STDERR} respectively. {capture()} uses a code prototype so the first argument can be specified directly within brackets if desired. # shorthand with prototype capture { print __PACKAGE__ } \$stdout, \$stderr; Returns the return value(s) of {&subroutine}. The sub is called in the same context as {capture()} was called e.g.: @rv = capture { wantarray } ; # returns true $rv = capture { wantarray } ; # returns defined, but not true capture { wantarray }; # void, returns undef {capture()} is able to capture output from subprocesses and C code, which traditional {tie()} methods of output capture are unable to do. *Note:* {capture()} will only capture output that has been written or flushed to the filehandle. If the two scalar references refer to the same scalar, then {STDERR} will be merged to {STDOUT} before capturing and the scalar will hold the combined output of both. capture \&subroutine, \$combined, \$combined; Normally, {capture()} uses anonymous, temporary files for capturing output. If desired, specific file names may be provided instead as additional options. capture \&subroutine, \$stdout, \$stderr, $out_file, $err_file; Files provided will be clobbered, overwriting any previous data, but will persist after the call to {capture()} for inspection or other manipulation. By default, when no references are provided to hold STDOUT or STDERR, output is captured and silently discarded. # Capture STDOUT, discard STDERR capture \&subroutine, \$stdout; # Discard STDOUT, capture STDERR capture \&subroutine, undef, \$stderr; If either STDOUT or STDERR should be passed through to the terminal instead of captured, provide a reference to undef -- {\undef} -- instead of a capture variable. # Capture STDOUT, display STDERR capture \&subroutine, \$stdout, \undef; # Display STDOUT, capture STDERR capture \&subroutine, \undef, \$stderr; == capture_exec() ($stdout, $stderr) = capture_exec(@args); Captures and returns the output from {system(@args)}. In scalar context, {capture_exec()} will return what was printed to {STDOUT}. In list context, it returns what was printed to {STDOUT} and {STDERR} $stdout = capture_exec('perl', '-e', 'print "hello world"'); ($stdout, $stderr) = capture_exec('perl', '-e', 'warn "Test"'); {capture_exec} passes its arguments to {system()} and on MSWin32 will protect arguments with shell quotes if necessary. This makes it a handy and slightly more portable alternative to backticks, piped {open()} and {IPC::Open3}. You can check the exit status of the {system()} call with the {$?} variable. See [perlvar] for more information. == capture_exec_combined() $combined = capture_exec_combined( 'perl', '-e', 'print "hello\n"', 'warn "Test\n" ); This is just like {capture_exec()}, except that it merges {STDERR} with {STDOUT} before capturing output and returns a single scalar. *Note:* there is no guarantee that text printed to {STDOUT} and {STDERR} in the subprocess will be appear in order. The actual order will depend on how IO buffering is handled in the subprocess. == qxx() This is an alias for {capture_exec()}. == qxy() This is an alias for {capture_exec_combined()}. = SEE ALSO * [IPC::Open3] * [IO::Capture] * [IO::Utils] = AUTHORS * Simon Flack (original author) * David Golden (co-maintainer since version 1.04) = COPYRIGHT AND LICENSE Portions copyright 2004, 2005 Simon Flack. Portions copyright 2007 David Golden. All rights reserved. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =end wikidoc =cut Data-Structure-Util-0.15/lib/0000755000076500000240000000000010765036241014611 5ustar andystaffData-Structure-Util-0.15/lib/Data/0000755000076500000240000000000010765036241015462 5ustar andystaffData-Structure-Util-0.15/lib/Data/Structure/0000755000076500000240000000000010765036241017462 5ustar andystaffData-Structure-Util-0.15/lib/Data/Structure/Util.pm0000644000076500000240000003445110764754727020763 0ustar andystaffpackage Data::Structure::Util; use 5.008; use strict; use warnings::register; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Storable qw( freeze ); use Digest::MD5 qw( md5_hex ); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw( Exporter DynaLoader ); $VERSION = '0.15'; @EXPORT_OK = qw( unbless get_blessed get_refs has_circular_ref circular_off signature ); if ( $] >= 5.008 ) { push @EXPORT_OK, qw( has_utf8 utf8_off utf8_on _utf8_on _utf8_off ); } bootstrap Data::Structure::Util $VERSION; sub has_utf8 { has_utf8_xs( $_[0] ) ? $_[0] : undef; } sub utf8_off { utf8_off_xs( $_[0] ) ? $_[0] : undef; } sub utf8_on { utf8_on_xs( $_[0] ) ? $_[0] : undef; } sub _utf8_off { _utf8_off_xs( $_[0] ) ? $_[0] : undef; } sub _utf8_on { _utf8_on_xs( $_[0] ) ? $_[0] : undef; } sub unbless { unbless_xs( $_[0] ); } sub get_blessed { $_[0] or return []; get_blessed_xs( $_[0] ); } sub get_refs { $_[0] or return []; get_refs_xs( $_[0] ); } sub has_circular_ref { $_[0] or return $_[0]; has_circular_ref_xs( $_[0] ); } # Need to hold another reference to the passed in value to avoid this # pathological case throwing an error # my $obj8 = []; # $obj8->[0] = \$obj8; # circular_off($obj8); # Used to throw an error sub circular_off { my $r = $_[0]; $r or return $r; circular_off_xs( $r ); } sub signature { return @_ ? md5_hex( freeze( [ $_[0], signature_xs( $_[0] ) ] ) ) : '0' x 32; } 1; __END__ =head1 NAME Data::Structure::Util - Change nature of data within a structure =head1 SYNOPSIS use Data::Structure::Util qw( has_utf8 utf8_off utf8_on unbless get_blessed get_refs has_circular_ref circular_off signature ); # get the objects in the data structure my $objects_arrayref = get_blessed( $data ); # unbless all objects unbless( $data ); if ( has_circular_ref( $data ) ) { print "Removing circular ref!\n"; circular_off( $data ); } # convert back to latin1 if needed and possible utf8_off( $data ) if defined has_utf8( $data ); =head1 DESCRIPTION C is a toolbox to manipulate the data inside a data structure. It can process an entire tree and perform the operation requested on each appropriate element. For example: It can transform all strings within a data structure to utf8 or transform any utf8 string back to the default encoding. It can remove the blessing on any reference. It can collect all the objects or detect if there is a circular reference. It is written in C for decent speed. =head1 FUNCTIONS All Data::Structure::Util functions operate on a whole tree. If you pass them a simple scalar then they will operate on that one scalar. However, if you pass them a reference to a hash, array, or scalar then they will iterate though that structure and apply the manipulation to all elements, and in turn if they are references to hashes, arrays or scalars to all their elements and so on, recursively. For speed reasons all manipulations that alter the data structure do in- place manipulation meaning that rather than returning an altered copy of the data structure the passed data structure which has been altered. =head2 Manipulating Data Structures =over 4 =item has_circular_ref($ref) This function detects if the passed data structure has a circular reference, that is to say if it is possible by following references contained in the structure to return to a part of the data structure you have already visited. Data structures that have circular references will not be automatically reclaimed by Perl's garbage collector. If a circular reference is detected the function returns a reference to an element within circuit, otherwise the function will return a false value. If the version of perl that you are using supports weak references then any weak references found within the data structure will not be traversed, meaning that circular references that have had links successfully weakened will not be returned by this function. =item circular_off($ref) Detects circular references in $ref (as above) and weakens a link in each so that they can be properly garbage collected when no external references to the data structure are left. This means that one (or more) of the references in the data structure will be told that the should not count towards reference counting. You should be aware that if you later modify the data structure and leave parts of it only 'accessible' via weakened references that those parts of the data structure will be immediately garbage collected as the weakened references will not be strong enough to maintain the connection on their own. The number of references weakened is returned. =item get_refs($ref) Examine the data structure and return a reference to flat array that contains one copy of every reference in the data structure you passed. For example: my $foo = { first => [ "inner", "array", { inmost => "hash" } ], second => \"refed scalar", }; use Data::Dumper; # tell Data::Dumper to show nodes multiple times $Data::Dumper::Deepcopy = 1; print Dumper get_refs( $foo ); $VAR1 = [ { 'inmost' => 'hash' }, [ 'inner', 'array', { 'inmost' => 'hash' } ], \'refed scalar', { 'first' => [ 'inner', { 'inmost' => 'hash' }, 'array' ], 'second' => \'refed scalar' } ]; As you can see, the data structure is traversed depth first, so the top most references should be the last elements of the array. See L below for a similar function for blessed objects. =item signature($ref) Returns a md5 of the passed data structure. Any change at all to the data structure will cause a different md5 to be returned. The function examines the structure, addresses, value types and flags to generate the signature, meaning that even data structures that would look identical when dumped with Data::Dumper produce different signatures: $ref1 = { key1 => [] }; $ref2 = $ref1; $ref2->{key1} = []; # this produces the same result, as they look the same # even though they are different data structures use Data::Dumper; use Digest::MD5 qw(md5_hex); print md5_hex( Dumper( $ref1 ) ), " ", md5_hex( Dumper( $ref2 ) ), "\n"; # cb55d41da284a5869a0401bb65ab74c1 cb55d41da284a5869a0401bb65ab74c1 # this produces differing results use Data::Structure::Util qw(signature); print signature( $ref1 ), " ", signature( $ref2 ), "\n"; # 5d20c5e81a53b2be90521167aefed9db 8b4cba2cbae0fec4bab263e9866d3911 =back =head2 Object Blessing =over 4 =item unbless($ref) Remove the blessing from any objects found within the passed data structure. For example: my $foo = { 'a' => bless( { 'b' => bless( {}, "c" ), }, "d" ), 'e' => [ bless( [], "f" ), bless( [], "g" ), ] }; use Data::Dumper; use Data::Structure::Util qw(unbless); print Dumper( unbless( $foo ) ); $VAR1 = { 'a' => { 'b' => {} }, 'e' => [ [], [] ] }; Note that the structure looks inside blessed objects for other objects to unbless. =item get_blessed($ref) Examine the data structure and return a reference to flat array that contains every object in the data structure you passed. For example: my $foo = { 'a' => bless( { 'b' => bless( {}, "c" ), }, "d" ), 'e' => [ bless( [], "f" ), bless( [], "g" ), ] }; use Data::Dumper; # tell Data::Dumper to show nodes multiple times $Data::Dumper::Deepcopy = 1; use Data::Structure::Util qw(get_blessed); print Dumper( get_blessed( $foo ) ); $VAR1 = [ bless( {}, 'c' ), bless( { 'b' => bless( {}, 'c' ) }, 'd' ), bless( [], 'f' ), bless( [], 'g' ) ]; This function is essentially the same as C but only returns blessed objects rather than all objects. As with that function the data structure is traversed depth first, so the top most objects should be the last elements of the array. Note also (as shown in the above example shows) that objects within objects are returned. =back =head2 utf8 Manipulation Functions These functions allow you to manipulate the state of the utf8 flags in the scalars contained in the data structure. Information on the utf8 flag and it's significance can be found in L. =over 4 =item has_utf8($var) Returns C<$var> if the utf8 flag is enabled for C<$var> or any scalar that a data structure passed in C<$var> contains. print "this will be printed" if defined has_utf8( "\x{1234}" ); print "this won't be printed" if defined has_utf8( "foo bar" ); Note that you should not check the truth of the return value of this function when calling it with a single scalar as it is possible to have a string "0" or "" for which the utf8 flag set; Since C can never have the utf8 flag set the function will never return a defined value if the data structure does not contain a utf8 flagged scalar. =item _utf8_off($var) Recursively disables the utf8 flag on all scalars within $var. This is the same the C<_utf8_off> function of L but applies to any string within C<$var>. The data structure is converted in-place, and as a convenience the passed variable is returned from the function. This function makes no attempt to do any character set conversion to the strings stored in any of the scalars in the passed data structure. This means that if perl was internally storing any character as sequence of bytes in the utf8 encoding each byte in that sequence will then be henceforth treated as a character in it's own right. For example: my $emoticons = { smile => "\x{236a}" }; use Data::Structure::Util qw(_utf8_on); print length( $emoticons->{smile} ), "\n"; # prints 1 _utf8_off( $emoticons ); print length( $emoticons->{smile} ), "\n"; # prints 3 =item _utf8_on($var) Recursively enables the utf8 flag on all scalars within $var. This is the same the C<_utf8_on> function of L but applies to any string within C<$var>. The data structure is converted in-place and as a convenience the passed variable is returned from the function. As above, this makes no attempt to do any character set conversion meaning that unless your string contains the valid utf8 byte sequences for the characters you want you are in trouble. B. In particular, the regular expression engine has significant problems with invalid utf8 that has been incorrectly marked as utf8. You should know what you are doing if you are using this function; Consider using the Encode module as an alternative. Contrary example to the above: my $emoticons = { smile => "\342\230\272" }; use Data::Structure::Util qw(_utf8_on); print length( $emoticons->{smile} ), "\n"; # prints 3 _utf8_on( $emoticons ); print length( $emoticons->{smile} ), "\n"; # prints 1 =item utf8_on($var) This routine performs a C on each scalar string in the passed data structure that does not have the utf8 flag turned on. This will cause the perl to change the method it uses internally to store the string from the native encoding (normally Latin-1 unless locales come into effect) into a utf8 encoding and set the utf8 flag for that scalar. This means that single byte letters will now be represented by multi-byte sequences. However, as long as the C pragma is not in effect the string will be the same length as because as far as perl is concerned the string still contains the same number of characters (but not bytes). This routine is significantly different from C<_utf8_on>; That routine assumes that your string is encoded in utf8 but was marked (wrongly) in the native encoding. This routine assumes that your string is encoded in the native encoding and is marked that way, but you'd rather it be encoded and marked as utf8. =item utf8_off($var) This routine performs a C on each scalar string in the passed data structure that has the utf8 flag turned on. This will cause the perl to change the method it uses internally to store the string from the utf8 encoding into a the native encoding (normally Latin-1 unless locales are used) and disable the utf8 flag for that scalar. This means that multiple byte sequences that represent a single character will be replaced by one byte per character. However, as long as the C pragma is not in effect the string will be the same length as because as far as perl is concerned the string still contains the same number of characters (but not bytes). Please note that not all strings can be converted from utf8 to the native encoding; In the case that the utf8 character has no corresponding character in the native encoding Perl will die with "Wide character in subroutine entry" exception. This routine is significantly different from C<_utf8_off>; That routine assumes that your string is encoded in utf8 and that you want to simply mark it as being in the native encoding so that perl will treat every byte that makes up the character sequences as a character in it's own right in the native encoding. This routine assumes that your string is encoded in utf8, but you want it each character that is currently represented by multi-byte strings to be replaced by the single byte representation of the same character. =back =head1 SEE ALSO L, L, L, L See the excellent article http://www.perl.com/pub/a/2002/08/07/proxyobject.html from Matt Sergeant for more info on circular references. The development version of this module and others can be found at http://opensource.fotango.com/svn/trunk/Data-Structure-Util/ =head1 BUGS C is sensitive to the hash randomisation algorithm This module only recurses through basic hashes, lists and scalar references. It doesn't attempt anything more complicated. =head1 THANKS TO James Duncan and Arthur Bergman who helped me and found a name for this module. Leon Brocard and Richard Clamp have provided invaluable help to debug this module. Mark Fowler rewrote large chunks of the documentation and patched a few bugs. =head1 AUTHOR This release by Andy Armstrong Originally by Pierre Denis http://opensource.fotango.com/ =head1 COPYRIGHT Copyright 2003, 2004 Fotango - All Rights Reserved. This module is released under the same license as Perl itself. =cut Data-Structure-Util-0.15/t/0000755000076500000240000000000010765036241014306 5ustar andystaffData-Structure-Util-0.15/t/00pod.t0000644000076500000240000000112410764754146015425 0ustar andystaff#!/usr/bin/perl -w ## Make sure we can "use" every module use strict; use vars qw(@classes); use lib 'lib'; BEGIN { eval "use Test::Pod"; if ( $@ ) { print "1..0 # Skipped - do not have Test::Pod installed\n"; exit; } eval "use File::Find::Rule"; if ( $@ ) { print "1..0 # Skipped - do not have File::Find::Rule installed\n"; exit; } } BEGIN { @classes = File::Find::Rule->file()->name( '*.pm' )->in( 'blib/lib' ); } use Test::Pod tests => scalar @classes; for my $class ( @classes ) { pod_file_ok( $class ); } Data-Structure-Util-0.15/t/01compile.t0000644000076500000240000000013210764737250016267 0ustar andystaffuse strict; use warnings; use Test::More tests => 1; use_ok( 'Data::Structure::Util' ); Data-Structure-Util-0.15/t/02circular.t0000644000076500000240000000615210764754146016457 0ustar andystaff#!/usr/bin/perl use strict; use warnings; use blib; use Data::Structure::Util qw(unbless get_blessed has_circular_ref); use Data::Dumper; my $WEAKEN; eval q{ use Scalar::Util qw(weaken isweak) }; if ( !$@ and defined &Scalar::Util::weaken ) { $WEAKEN = 1; } use Test::More; plan tests => 14 + 6 * $WEAKEN; ok( 1, "we loaded fine..." ); my $obj = bless { key1 => [ 1, 2, 3, bless {} => 'Tagada' ], key2 => undef, key3 => { key31 => {}, key32 => bless { bla => [] } => 'Tagada', }, key5 => bless [] => 'Ponie', } => 'Scoobidoo'; $obj->{key4} = \$obj; $obj->{key3}->{key33} = $obj->{key3}->{key31}; my $thing = { var1 => {} }; $thing->{var2} = [ $thing->{var1}->{hello} ]; $thing->{var1}->{hello} = $thing->{var2}; my $obj2 = { key1 => [ sub { [] } ] }; $obj2->{key2} = $obj2->{key1}; my $obj3; $obj3 = \$obj3; my $obj4 = { key1 => $obj3 }; my @V1 = ( 1, 2, sub { } ); my $obj5 = { key1 => undef, key2 => sub { }, key3 => \@V1, key4 => $obj2, key5 => { key51 => sub { }, key52 => \*STDERR, key53 => [ 0, \"hello" ], }, }; $obj5->{key5}->{key53}->[2] = $obj5->{key5}; $obj5->{key5}->{key54} = $obj5->{key5}->{key53}->[2]; $obj5->{key6} = $obj5->{key5}->{key53}->[2]; $obj5->{key5}->{key55} = $obj5->{key5}->{key53}->[2]; my $obj6 = { key1 => undef }; $obj = $obj6; my $V2 = [ 1, undef, \5, sub { } ]; for ( 1 .. 50 ) { $obj->{key2} = {}; $obj->{key1} = $V2; $obj = $obj->{key2}; } $obj->{key3} = \$obj6; ok( !has_circular_ref( $thing ), "Not a circular ref" ); my $ref = has_circular_ref( $obj ); ok( $ref, "Got a circular reference" ); is( $ref, $obj, "reference is correct" ); ok( !has_circular_ref( $obj2 ), "No circular reference" ); ok( has_circular_ref( $obj3 ), "Got a circular reference" ); ok( has_circular_ref( $obj4 ), "Got a circular reference" ); ok( has_circular_ref( $obj5 ), "Got a circular reference" ); ok( has_circular_ref( $obj6 ), "Got a circular reference" ); is( $obj6, has_circular_ref( $obj6 ), "Match reference" ); ok( !has_circular_ref(), "No circular reference" ); ok( !has_circular_ref( [] ), "No circular reference" ); ok( has_circular_ref( [ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\$ref ] ), "Has circular reference" ); if ( $WEAKEN ) { my $obj7 = { key1 => {} }; $obj7->{key1}->{key11} = $obj7->{key1}; ok( has_circular_ref( $obj7 ), "Got a circular reference" ); weaken( $obj7->{key1}->{key11} ); ok( isweak( $obj7->{key1}->{key11} ), "has weaken reference" ); ok( !has_circular_ref( $obj7 ), "No more circular reference" ); my $obj8 = bless { key1 => bless { parent => undef, } => 'Bar', } => 'Foo'; $obj8->{key1}->{parent} = $obj8; ok( has_circular_ref( $obj8 ), "Got circular" ); my $obj81 = $obj8->{key1}; weaken( $obj8->{key1} ); ok( isweak( $obj8->{key1} ), "is weak" ); ok( !has_circular_ref( $obj8 ), "Got no circular" ); } else { warn "Scalar::Util XS version not installed, some tests skipped\n"; } my $a; my $r; $a->[1] = \$r; ok( !has_circular_ref( $a ), "circular ref where av_fetch() returns 0 should not SEGV" ); Data-Structure-Util-0.15/t/02circular_off.t0000644000076500000240000001035010764754146017304 0ustar andystaff#!/usr/bin/perl use strict; use warnings; use blib; use Data::Structure::Util qw(has_circular_ref circular_off); use Data::Dumper; BEGIN { eval q{ use Scalar::Util qw(weaken isweak) }; if ( $@ ) { my $reason = "A recent version of Scalar::Util must be installed"; eval qq{ use Test::More skip_all => "$reason" }; exit; } else { eval q{ use Test::More tests => 35 }; } } ok( 1, "we loaded fine..." ); my $obj = bless { key1 => [ 1, 2, 3, bless {} => 'Tagada' ], key2 => undef, key3 => { key31 => {}, key32 => bless { bla => [] } => 'Tagada', }, key5 => bless [] => 'Ponie', } => 'Scoobidoo'; $obj->{key4} = \$obj; $obj->{key3}->{key33} = $obj->{key3}->{key31}; my $thing = { var1 => {} }; $thing->{var2} = [ $thing->{var1}->{hello} ]; $thing->{var1}->{hello} = $thing->{var2}; my $obj2 = { key1 => [ sub { [] } ] }; $obj2->{key2} = $obj2->{key1}; my $obj3; $obj3 = \$obj3; my $obj4 = { key1 => $obj3 }; my @V1 = ( 1, 2, sub { } ); my $obj5 = { key1 => undef, key2 => sub { }, key3 => \@V1, key4 => $obj2, key5 => { key51 => sub { }, key52 => \*STDERR, key53 => [ 0, \"hello" ], }, key6 => qr/adsa[sdf]+/, }; $obj5->{key5}->{key53}->[2] = $obj5->{key5}; $obj5->{key5}->{key54} = $obj5->{key5}->{key53}->[2]; $obj5->{key6} = $obj5->{key5}->{key53}->[2]; $obj5->{key5}->{key55} = $obj5->{key5}->{key53}->[2]; my $obj6 = { key1 => undef }; my $obj6b = $obj6; my $V2 = [ 1, undef, \5, sub { } ]; for ( 1 .. 50 ) { $obj6b->{key2} = bless {} => 'Test'; $obj6b->{key1} = $V2; $obj6b = $obj6b->{key2}; $obj6b->{key3} = [$obj6]; # \$obj6 fails } ok( !has_circular_ref( $thing ), "Not a circular ref" ); { is( circular_off( $thing ), 0, "No circular ref broken" ); } my $ref = has_circular_ref( $obj ); ok( $ref, "Got a circular reference" ); is( circular_off( $obj ), 1, "Weaken circular references" ); is( circular_off( $obj ), 0, "No more weaken circular references" ); ok( !has_circular_ref( $obj ), "No more circular ref" ); ok( !has_circular_ref( $obj2 ), "No circular reference" ); is( circular_off( $obj2 ), 0, "No circular ref broken" ); ok( has_circular_ref( [ $obj3, $obj4, $obj5 ] ), "Got a circular reference" ); is( circular_off( [ $obj3, $obj4, $obj5 ] ), 4, "Weaken circular references" ); ok( !has_circular_ref( [ $obj3, $obj4, $obj5 ] ), "No more circular ref" ); ok( has_circular_ref( $obj6 ), "Got a circular reference" ); ok( $obj6 == has_circular_ref( $obj6 ), "Match reference" ); is( circular_off( $obj6 ), 50, "Weaken 50 circular refs" ); ok( !has_circular_ref( $obj6 ), "Got a circular reference" ); ok( !has_circular_ref(), "No circular reference" ); ok( !has_circular_ref( [] ), "No circular reference" ); ok( !has_circular_ref( [ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\$ref ] ), "Has circular reference" ); my $spy; { my $obj7 = { key1 => {} }; $obj7->{key1}->{key11} = $obj7->{key1}; $spy = $obj7->{key1}; weaken( $spy ); ok( isweak( $spy ), "got a spy" ); ok( has_circular_ref( $obj7 ), "Got a circular reference" ); is( circular_off( $obj7 ), 1, "Removed circular refs" ); } ok( !$spy, "No memory leak" ); my $obj8 = bless { key1 => bless { parent => undef, } => 'Bar', } => 'Foo'; $obj8->{key1}->{parent} = $obj8; ok( has_circular_ref( $obj8 ), "Got circular" ); is( circular_off( $obj8 ), 1, "removed circular" ); ok( isweak( $obj8->{key1}->{parent} ), "is weak" ); ok( !has_circular_ref( $obj8 ), "no circular" ); ok( !circular_off( $obj8 ), "removed circular" ); my $obj9 = bless { key1 => bless { parent => undef, } => 'Bar', } => 'Foo'; $obj9->{key1}->{parent} = $obj9; ok( has_circular_ref( $obj9 ), "got circular" ); my $obj91 = $obj9->{key1}; weaken( $obj9->{key1} ); ok( isweak( $obj9->{key1} ), "is weak" ); ok( !has_circular_ref( $obj9 ), "no circular" ); ok( !circular_off( $obj9 ), "no circular" ); $obj8 = {}; $obj8->{a} = \$obj8; is( circular_off( $obj8 ), 1, "Removed circular refs" ); $obj8 = []; $obj8->[0] = \$obj8; is( circular_off( $obj8 ), 1, "Removed circular refs" ); $obj8 = []; $obj8->[1] = \$obj8; is( circular_off( $obj8 ), 1, "Removed circular refs" ); Data-Structure-Util-0.15/t/03bless.t0000644000076500000240000000303610764023676015757 0ustar andystaff#!/usr/bin/perl use blib; use strict; use warnings; use Data::Structure::Util qw(unbless get_blessed has_circular_ref); use Data::Dumper; use Test::More tests => 17; ok( 1, "we loaded fine..." ); my $obj = bless { key1 => [ 1, 2, 3, bless {} => 'Tagada' ], key2 => undef, key3 => { key31 => {}, key32 => bless { bla => [undef] } => 'Tagada', }, key5 => bless [] => 'Ponie', } => 'Scoobidoo'; $obj->{key4} = \$obj; $obj->{key3}->{key33} = $obj->{key3}->{key31}; ok( my $objects = get_blessed( $obj ), "Got objects" ); ok( $objects->[1] == $obj->{key3}->{key32} || $objects->[1] == $obj->{key1}->[3] || $objects->[1] == $obj->{key5}, "Got object 1" ); ok( $objects->[2] == $obj->{key1}->[3] || $objects->[2] == $obj->{key3}->{key32} || $objects->[2] == $obj->{key5}, "Got object 2" ); is( $objects->[3], $obj, "Got top object" ); is( @{ get_blessed( undef ) }, 0, "undef" ); is( @{ get_blessed( 'hello' ) }, 0, "hello" ); is( @{ get_blessed() }, 0, "empty list" ); is( $obj, unbless( $obj ), "Have unblessed obj" ); is( ref $obj, 'HASH', "Not blessed anymore" ); is( ref $obj->{key1}->[3], 'HASH', "Not blessed anymore" ); my $a; my $r; $r = bless \$r, 'Pie'; $a->[1] = $r; my $got = get_blessed( $a ); is( scalar @$got, 1, "1 blessed thing" ); is( $got->[0], $r ); is( ref( $got->[0] ), 'Pie' ); is( $a, unbless( $a ), "Have unblessed array" ); is( $got->[0], $r ); isnt( ref( $got->[0] ), 'Pie' ); Data-Structure-Util-0.15/t/04utf8.t0000644000076500000240000000612210764754146015540 0ustar andystaff#!/usr/bin/perl use blib; use strict; use warnings; use Data::Dumper; use Storable qw(dclone); use bytes; BEGIN { if ( $] < 5.008 ) { my $reason = "This version of perl ($]) doesn't have proper utf8 support, 5.8.0 or higher is needed"; eval qq{ use Test::More skip_all => "$reason" }; exit; } else { eval q{ use Data::Structure::Util qw(has_utf8 utf8_off utf8_on _utf8_on _utf8_off); use Test::More tests => 27; }; die $@ if $@; } } ok( 1, "we loaded fine..." ); my $string = ''; for my $v ( 32 .. 126, 195 .. 255 ) { $string .= chr( $v ); } my $hash = { key1 => $string . "\n", }; my $hash2 = test_utf8( $hash ); if ( $hash2 ) { ok( 1, "Got a utf8 string" ); } else { $hash2 = dclone( $hash ); ok( utf8_on( $hash ), "Have encoded utf8" ); } $string = $hash->{key1}; my $string2 = $hash2->{key1}; is( utf8_on( $string ), $string, "Got string back" ); is( utf8_on( $string2 ), $string2, "Got string back" ); is( utf8_off( $string ), $string, "Got string back" ); is( utf8_off( $string2 ), $string2, "Got string back" ); ok( !has_utf8( $hash ), "Has not utf8" ); ok( has_utf8( $hash2 ), "Has utf8" ); is( has_utf8( $hash2 ), $hash2, "Has utf8" ); is( $hash2->{key1}, $hash->{key1}, "Same string" ); ok( !compare( $hash2->{key1}, $hash->{key1} ), "Different encoding" ); ok( utf8_off( $hash2 ), "Have decoded utf8" ); ok( !has_utf8( $hash2 ), "Has not utf8" ); is( $hash2->{key1}, $hash->{key1}, "Same string" ); ok( compare( $hash2->{key1}, $hash->{key1} ), "Same encoding" ); ok( utf8_on( $hash ), "Have encoded utf8" ); is( $hash2->{key1}, $hash->{key1}, "Same string" ); ok( !compare( $hash2->{key1}, $hash->{key1} ), "Different encoding" ); sub compare { my $str1 = shift; my $str2 = shift; my $i = 0; my @chars2 = unpack 'C*', $str2; for my $char1 ( unpack 'C*', $str1 ) { return if ( ord( $char1 ) != ord( $chars2[ $i++ ] ) ); } 1; } sub test_utf8 { my $hash = shift; eval q{ use Encode }; if ( $@ ) { warn "Encode not installed - will try XML::Simple\n"; eval q{ use XML::Simple qw(XMLin XMLout) }; if ( $@ ) { warn "XML::Simple not installed\n"; return; } my $xml = XMLout( $hash, keyattr => [], noattr => 1, suppressempty => undef, xmldecl => '' ); return XMLin( $xml, keyattr => [], suppressempty => undef ); } my $hash2 = dclone( $hash ) or die "Could not clone"; my $utf8 = decode( "iso-8859-1", $hash->{key1} ); $hash2->{key1} = $utf8; $hash2; } use utf8; my $wide = { hello => ['world ᛰ'] }; ok( has_utf8( $wide ) ); ok( _utf8_off( $wide ), "remove utf8 flag" ); ok( !has_utf8( $wide ) ); my $latin = { hello => ['world'] }; ok( !has_utf8( $latin ) ); ok( _utf8_on( $latin ), "added utf8 flag" ); ok( has_utf8( $latin ) ); my $a; $a->[1] = "Pie"; ok( !has_utf8( $a ) ); ok( utf8_on( $a ), "convert to utf8" ); ok( _utf8_off( $a ), "utf8" ); Data-Structure-Util-0.15/t/05refs.t0000644000076500000240000000316510764754146015616 0ustar andystaff#!/usr/bin/perl use blib; use strict; use warnings; use Data::Structure::Util qw(unbless get_blessed get_refs has_circular_ref); use Data::Dumper; use Test::More tests => 18; ok( 1, "we loaded fine..." ); my $obj = bless { key1 => [ 1, 2, 3, bless {} => 'Tagada' ], key2 => undef, key3 => { key31 => {}, key32 => bless { bla => [undef] } => 'Tagada', }, key5 => bless [] => 'Ponie', } => 'Scoobidoo'; $obj->{key4} = \$obj; $obj->{key3}->{key33} = $obj->{key3}->{key31}; ok( my $objects = get_refs( $obj ), "Got references" ); is( @$objects, 9, "got all" ); my $found; for my $ref ( @$objects ) { if ( $ref == $obj ) { $found++; ok( 1 ) } if ( $ref == $obj->{key1} ) { $found++; ok( 1 ) } if ( $ref == $obj->{key1}->[3] ) { $found++; ok( 1 ) } if ( $ref == $obj->{key3} ) { $found++; ok( 1 ) } if ( $ref == $obj->{key3}->{key31} ) { $found++; ok( 1 ) } if ( $ref == $obj->{key3}->{key32} ) { $found++; ok( 1 ) } if ( $ref == $obj->{key3}->{key32}->{bla} ) { $found++; ok( 1 ) } if ( $ref == $obj->{key5} ) { $found++; ok( 1 ) } if ( $ref == \$obj ) { $found++; ok( 1 ) } } is( $found, @$objects, "Found " . scalar( @$objects ) ); is( @{ get_refs( undef ) }, 0, "undef" ); is( @{ get_refs( 'hello' ) }, 0, "hello" ); is( @{ get_refs() }, 0, "undef" ); my $a; my $r; $r = \$r; $a->[1] = $r; my $got = get_refs( $a ); is( scalar @$got, 2, "2 references" ); is( $got->[0], $r, "list is depth first, so first result should be the scalar" ); Data-Structure-Util-0.15/t/06signature.t0000644000076500000240000000417110764740233016647 0ustar andystaff#!/usr/bin/perl use blib; use strict; use warnings; use Data::Dumper; my $PERL_HAS_UTF8; BEGIN { if ( $] < 5.008 ) { eval q{ use Data::Structure::Util qw(signature) }; die $@ if $@; $PERL_HAS_UTF8 = 0; } else { eval q{ use Data::Structure::Util qw(has_utf8 utf8_off utf8_on signature) }; die $@ if $@; $PERL_HAS_UTF8 = 1; } } use Test::More tests => 16; ok( 1, "we loaded fine..." ); my $obj = {}; isnt( signature( $obj ), signature( {} ), "Signature 1" ); my $obj2 = []; isnt( signature( $obj2 ), signature( [] ), "Signature 2" ); my $obj3 = bless { key1 => 1 }; ok( my $sig3 = signature( $obj3 ) ); isnt( $sig3, signature( bless { key1 => 1 } ), "Signature 3" ); $obj3->{key1} = 1; is( $sig3, signature( $obj3 ), "Signature 3" ); my $obj4 = bless { key1 => $obj3, key2 => $obj2, key3 => $obj, key4 => undef }; ok( my $sig4 = signature( $obj4 ) ); isnt( $sig4, signature( bless { key1 => $obj3, key2 => $obj2, key3 => $obj, key4 => undef } ), "Signature 3" ); $obj4->{key1} = bless { key1 => 1 }; isnt( signature( $obj4 ), $sig4, "Signature 4" ); ok( signature(), "none" ); is( signature(), signature(), "empty list" ); ok( my $sigundef = signature( undef ), "none" ); isnt( $sigundef, signature( undef ), "none" ); # BELOW THIS LINE REQUIRES PERL 5.8.0 OR GREATER SKIP: { unless ( $PERL_HAS_UTF8 ) { my $reason = "This version of perl ($]) doesn't have proper utf8 support, 5.8.0 or higher is needed"; skip( $reason, 2 ); exit; } # Have to use a hash ref rather than a hash and keep taking references, # as temporary refs are in the signature, and their address can differ # each time round the loop my $hash = { key1 => "Hello" }; utf8_off( $hash ); my $sig5 = signature( $hash ); ok( $sig5 eq signature( $hash ), "signature 5" ); utf8_on( $hash ); ok( $sig5 ne signature( $hash ), "signature 5" ); } my $a; my $r; $a->[1] = \$r; ok( signature( $a ), "signature where av_fetch() returns 0 should not SEGV" );