Data-Dump-Streamer-2.39000755001750001750 012636703716 15065 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/README000444001750001750 213112636703716 16077 0ustar00yortonyorton000000000000INSTALLATION To install this module type the following: perl Build.PL ./Build ./Build test ./Build install The modules requires a functional C compiler, however PPM support for Win32 users will also be available sometime soon. It is known to work correctly on Perl 5.6 and later on both Win32 and *nix operating systems. Not all 5.8.x features are available in 5.8.0 DEPENDENCIES This module requires these other modules and libraries: Module::Build ExtUtils::Depends B::Utils and optionally for enhanced testing Algortihm::Diff and later versions of Data::Dumper All other dependencies are part of the standard distribution as of Perl 5.6. AUTHOR AND COPYRIGHT Yves Orton, (demerphq) Copyright (C) 2003 Yves Orton 2003-2005 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Contains code derived from works by Gisle Aas, Graham Barr, Jeff Pinyan, Richard Clamp, and Gurusamy Sarathy as well as material taken from the core. Data-Dump-Streamer-2.39/Changes000444001750001750 2357112636703716 16545 0ustar00yortonyorton0000000000002.37 Various changes. See github log for changes. NOTE, I have little time to maintain this package. If a secondary maintainer wants to step up I would be happy to grant the appropriate permissions so that new releases do not take so long. 2.36 Er... I forgot to update the changes file for this release. 2.35 Apply patches by Ilmari and D. Steinbrunner. Should work on 5.18 now. 2.34 Administrative release to eliminate build dependency on module used only for testing. 2.33 Caught up with various RT reports, and fixed a bunch of them. [RT #74198] fixed dumps containing read-only objects (obtained via JSON::XS) [RT #74198], Fixed stringification of code compiled under strict in later perls. Thanks to Father Chrysotomos for the patch and nudge. Also eliminated a false-fail prone test which was actually pretty useless, which should close several tickets which I wont bother to list. This release also is the first from the new git repository at https://github.com/demerphq/Data-Dump-Streamer 2.32 Disable overloading in a <=5.8.8 safe way [RT #53700] 2.31 React to Strawberry perl $. strangeness [RT #58528] 2.29 Add .answer to .gitignore Update t/madness for perl-5.6 Syntax fix print() for perl-5.6 Correct ${^WARNING_BITS} in t/madness.t for perl-5.8.7 and earlier 2.28 Strip illegal regexp modifiers [RT #65355] Update file permissions 2.27 Test for new regexp /u flag [RT #65339] Import less private functions Removed obsolete svn version info 2.26 Keep a glob reference open while inspecting through it with B. [RT #65272] 2.25 (2011-01-24) Oops, add ppport.h to the packaged distribution 2.24 (2011-01-23) Fix weakref breakage from perl-5648c0a. [RT #62605] Add ppport.h Add .gitignore 2.23 (2011-01-18) Fix DumpLex for bug #44621 2.22 (2010-07-11) Build.PL fixed to accept DDS and NODDS again 2.21 (2010-06-19) Resynchronize internal VERSION declarations 2.20 Skipped version 2.20 because version numbers don't play nice when they end in zeros. 2.19 (2010-06-19) Tweak t/madness.t to deal with how perl-5.8.[0-8] deparses the pragma `use warnings' differently. 2.18 (2010-06-12) Continue to refine t/lexicals.t response to Perl commit "e02c0f79a8059eaf4981f798cc21d7dc3c8b916e shift; optimization". The change happened after 5.13.0 and is released in 5.13.1. 2.17 (2010-06-11) Declare ExtUtils::CBuilder as a build_requries dependency 2.16 (2010-06-11) Manually add VERSION to Data::Dump::Streamer::Deparser to make CPAN indexer happy. 2.15 (2010-06-11) Perl commit "538f5756c002f0583190831238bbf6bd54855cdc shift; optimization" changed B::Deparse Switch from ExtUtils::MakeMaker to Module::Build for configure_requires support 2.14 (2010-06-08) Our Makefile.PL must abort if we're going to need to build B::Utils but we don't have ExtUtils::Depends because it doesn't work to let the build chain do this dependency resolution. Perhaps there is a version that this all "just works" in? t/dump.t required some styling state changes but was skipping them when some modules weren't installed. 2.13 (2010-04-05) No really, *actually* removed re.pm debugging code 2.12 (2010-04-05) Removed re.pm debugging code (which also broke compat w/ perl-5.8 2.11 (2010-04-04) perl-5.12.0 blesses file handles into IO::File, not IO::Handle 2.10 (2010-04-04) Perl-5.12.0 has: - qr// as a native - $! isn't auto-filled with 'Bad file descriptor' as often 2.09 (2009-03-24) Hashkeys ending in newline were incorrectly quoted. Sorry Ambrus. Make it possible to hackily dump *GLOB{IO} objects. This is mostly to make merijn happy. Afaik we dont have the information to do it properly. 2.08 (2007-12-22 01:34:13) Hashkeys starting with '-' were sometimes incorrectly quoted. See RT #29608 at http://rt.cpan.org/Ticket/Display.html?id=29608 Thanks to Maddingue for the heads up. 2.07 (2007-12-22 01:10:02) Version 2.06 broke on Perls < 5.10 due to a stupid thinko. Should build on the main Perls fine now. 2.06 (2007-12-21 22:27:45) Finally got DDS running under blead/Perl 5.10 Currently we duplicate code that is in Perl 5.10's Hash::Util (*), this code should not be compiled under Perl 5.10 and we should just use Hash::Util instead. (*) Actually Hash::Util duplicates this code, but whatever, thats called progress. :-) 2.05 (2007-08-23 00:23:19) Fix http://rt.cpan.org/Ticket/Display.html?id=28053, where undef and '' are confused inside of repeat value folding logic. 2.04 (2007-08-23 00:09:55) Remove various unsavoury items from INSTALL.SKIP and bump the version number. 2.03 Fixed some issues with dmping proxy objects with circular links. Started integrating subversion into the perl build process to prevent stuff like releasing unchecked in code, and to include the subversion build number in the distribution file name. Reversed the order of the change file so that newest stuff is at top. 2.02 Added OptSpace() which can be used to control optional whitespace. Indent(0) automatically disables optional whitespace. String compression support has been provided. Use Compress() to specify how long a string should be before it is compressed. Use Compressor() to supply a callback to handle the compression. More tests, better documentation. 2.01 Bug fixes, documentation patches and a few more tests. DumpNames() renamed to DumpVars(). This fixes test failures that were coming from lexicals.t 2.00 *WARNING* Interface change!! This release is interface incompatible with earlier releases. The whole framework for overriding how objects and classes are represented has been changed, hopefully, to be more intuitive and easier to use. All of the previous Freeze related functionality has been replaced by the new Freezer() method and interface. There is now support for class authors to add a DDS_freeze() method to control serialization and deserialization. HashKeys has had an interface change and has been renamed to KeyOrder. HashKeys() is still maintained but undocumented at this time. Added more documentation. Added support for Padwalker functionality that Robin Housten implemented. Long quoted strings are now split to be easier to read. 1.14 Jim Cromie put together a patch to make aliasing less intrusive. As the term alias was fairly heavily used already I changed his 'alias' mechanism to 'as', blame me not him for the silly name. Also includes a few minor fixes, and a little bit of pod cleanup. 1.12 Dan Brook noticed that closures that referenced closures were not being handled properly as the code wasnt iterating into the nested closures. This is fixed now. 1.11 Reworked how objects blessed into classes with overloads are handled to prevent any overloaded methods from firing during the eval of their dump. There may be problems with this and the Freeze/Thaw processing so YMMV. Thanks to [diotalevi] from perlmonks for the base implementation of this. Added support for weakreferences. Under some circumstances weakrefs caused DDS to get very confused, and there was no support for recreating weakrefs in the structure. This has been rectified. Its possible that output including weakrefs may not eval correctly as the restored data may be missing external references that keep the overall data structure alive. For instance if everything in the dump is a weakref the resulting vars may have returned to undef prior to completing the eval. YMMV. Thanks to [ysth] from perlmonks for the pointer to how weakrefs work. Added method behaviour to Dump() so its not just subroutine based. This should make using it as a method more or less DWIM. Also thanks to [diotalevi] Added support for dumping the lexical context of CODE refs. Heavily experimental, YMMV. 1.10 Added dualvar support. Added support for a low purity mode and Purity() overall. Refactored some code. More tests. 1.09 Changed the way DDS is implemented to something a little simpler. Also enhanced the Makefile.pl stuff, and added mention of it to D::D::S's pod. 1.08 Doc fixes, and removed a relic of earlier development that polluted @INC. 1.07 Fixed some incorrect error messages in Streamer.xs. Updated CHANGES with 1.06 info which I forgot from that release. Fixed utf8 related error. Thanks to Yitzchak for the patch. Provided a way to optionally install a 'DDS' alias for the module so that its easier to use from the command line. Doesn't install it by default, or via a normal CPAN install for namespace pollution reasons, and because I hate modules that dont automatically install. If you do perl Makefile.PL DDS [STANDARD OPTS] then it will be installed. To disable this once its enabled you can say perl Makefile.PL NODDS [STANDARD OPTS] 1.06 Added additional support for utf8 and some minor doc fixes. Thanks to Yitzchak yet again for the patches and advice. 1.05 Added support for locked hashes. Probably there are still bugs in here, but for now it looks good. Thanks to Yitzchak for pointing out this wasn't implemented. Also started adding support for a "smart indent mode". Try using Indent(1) instead of Indent(2). 1.03, 1.04 Enhanced format support for FORMAT refs. Yitzchak pointed out some bugs in the original handling. DeparseFormat() has been removed. It should never have existed in the first place. DeparseGlob() was the correct method/attribute to use. FormatStub() attribute added. This release I'm introducing some new testing code that im trying out. Once im happy with it I intend to convert all my old tests to use it and do away with the really quite horrible same() and _same() in test_helper.pl. 1.02 Changed test 14 of dump.t, added a few tests, and some support code for future enhancements, and most notably support for deparsing formats. Thanks to Yitzchak Scott-Thoennes for the latter. 1.01 Post-release minor fix to provide SortKeys and Hashkeys aliases to both SortKeys and HashKeys. Thanks to Slaven Rezic for the heads up. Added documentation improvements and fixes as well as a very slight and subtle change to the behaviour of Dump() in list context. 1.0 Release version. Name changed to Data::Dump::Streamer which will be future name. Data-Dump-Streamer-2.39/typemap000444001750001750 220012636703716 16616 0ustar00yortonyorton000000000000TYPEMAP B::OP T_OP_OBJ B::UNOP T_OP_OBJ B::BINOP T_OP_OBJ B::LOGOP T_OP_OBJ B::LISTOP T_OP_OBJ B::PMOP T_OP_OBJ B::SVOP T_OP_OBJ B::PADOP T_OP_OBJ B::PVOP T_OP_OBJ B::LOOP T_OP_OBJ B::COP T_OP_OBJ B::SV T_SV_OBJ B::PV T_SV_OBJ B::IV T_SV_OBJ B::NV T_SV_OBJ B::PVMG T_SV_OBJ B::PVLV T_SV_OBJ B::BM T_SV_OBJ B::RV T_SV_OBJ B::GV T_SV_OBJ B::CV T_SV_OBJ B::HV T_SV_OBJ B::AV T_SV_OBJ B::IO T_SV_OBJ B::FM T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV STRLEN T_UV PADOFFSET T_UV INPUT T_OP_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_SV_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_MG_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") OUTPUT T_OP_OBJ sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); T_SV_OBJ make_sv_object(aTHX_ ($arg), (SV*)($var)); T_MG_OBJ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); Data-Dump-Streamer-2.39/.gitignore000444001750001750 17012636703716 17170 0ustar00yortonyorton000000000000*~ .answer Build MYMETA.yml MYMETA.json _build/ build/ blib/ lib/Data/Dump/Streamer.c lib/Data/Dump/Streamer.o *.tar.gz Data-Dump-Streamer-2.39/INSTALL.SKIP000444001750001750 36612636703716 17005 0ustar00yortonyorton000000000000:#$Id: INSTALL.SKIP 33 2007-08-22 22:00:26Z demerphq $id # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \b_darcs\b # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ # Avoid Devel::Cover files. \bcover_db\b Data-Dump-Streamer-2.39/META.yml000444001750001750 273212636703716 16477 0ustar00yortonyorton000000000000--- abstract: 'Accurately serialize a data structure as Perl code.' author: - 'Yves Orton , Joshua ben Jore ' build_requires: B::Deparse: '0' Carp: '0' Config: '0' Data::Dumper: '0' Devel::Peek: '0' ExtUtils::CBuilder: '0' Symbol: '0' Test::More: '0' Text::Abbrev: '0' base: '0' overload: '0' re: '0' strict: '0' utf8: '0' vars: '0' warnings: '0' configure_requires: ExtUtils::Depends: '0' Module::Build: '0' perl: '5.006' dynamic_config: 1 generated_by: 'Module::Build version 0.4214, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Data-Dump-Streamer provides: Data::Dump::Streamer: file: lib/Data/Dump/Streamer.pm version: '2.39' Data::Dump::Streamer::Deparser: file: lib/Data/Dump/Streamer.pm version: '2.39' recommends: Algorithm::Diff: '0' Compress::Zlib: '0' JSON::XS: '0' MIME::Base64: '0' PadWalker: '0.99' requires: B: '0' B::Deparse: '0' B::Utils: '0' Data::Dumper: '0' DynaLoader: '0' Exporter: '0' Hash::Util: '0' IO::File: '0' Symbol: '0' Text::Abbrev: '0' Text::Balanced: '0' overload: '0' re: '0' strict: '0' vars: '0' warnings: '0' warnings::register: '0' resources: license: http://dev.perl.org/licenses/ repository: https://github.com/demerphq/Data-Dump-Streamer version: '2.39' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Data-Dump-Streamer-2.39/Build.PL000444001750001750 424212636703716 16520 0ustar00yortonyorton000000000000#!perl use 5.006_000; BEGIN { push @INC, 'inc'; } use My::Builder; my $build = My::Builder->new( module_name => 'Data::Dump::Streamer', dist_author => 'Yves Orton , Joshua ben Jore ', license => 'perl', configure_requires => { 'perl' => '5.006', # Core 5.009_004+ 'Module::Build' => 0, # CPAN 'ExtUtils::Depends' => 0, }, build_requires => { # Core modules 'B::Deparse' => 0, 'Carp' => 0, 'Config' => 0, 'Data::Dumper' => 0, 'Devel::Peek' => 0, 'ExtUtils::CBuilder' => 0, 'Symbol' => 0, 'Test::More' => 0, 'Text::Abbrev' => 0, 'base' => 0, 'overload' => 0, 'strict' => 0, 'utf8' => 0, 'vars' => 0, 'warnings' => 0, $] >= 5.012 ? ( 're' => 0 ) : (), }, requires => { 'B' => 0, 'B::Deparse' => 0, 'B::Utils' => 0, 'Data::Dumper' => 0, 'DynaLoader' => 0, 'Exporter' => 0, 'IO::File' => 0, 'Symbol' => 0, 'Text::Abbrev' => 0, 'Text::Balanced' => 0, 'overload' => 0, 'strict' => 0, 'vars' => 0, 'warnings' => 0, 'warnings::register' => 0, $] >= 5.009_004 ? ( 're' => 0 ) : (), $] >= 5.008 ? ( 'Hash::Util' => 0 ) : (), # CPAN 'B::Utils' => 0, }, recommends => { # Core 5.007_003+ 'MIME::Base64' => 0, # Core 5.009_003+ 'Compress::Zlib' => 0, # CPAN 'Algorithm::Diff' => 0, 'PadWalker' => '0.99', # optional for testing 'JSON::XS' => 0, }, meta_merge => { resources => { repository => 'https://github.com/demerphq/Data-Dump-Streamer' } }, ); $build->create_build_script(); Data-Dump-Streamer-2.39/MANIFEST000444001750001750 106612636703716 16356 0ustar00yortonyorton000000000000.patch .gitignore Build.PL Changes inc/My/Builder.pm INSTALL.SKIP lib/Data/Dump/ppport.h lib/Data/Dump/Streamer.pm lib/Data/Dump/Streamer.xs lib/Data/Dump/Streamer/_/Printers.pm MANIFEST This list of files MANIFEST.SKIP META.yml README t/as.t t/blessed.t t/dogpound.t t/dump.t t/filter.t t/globtest.t t/hardrefs.t t/impure_madness.t t/lexicals.t t/locked.t t/madness.t t/madness_json.t t/madness_w.t t/names.t t/overload.t t/readonly.t t/refaddr.t t/refcount.t t/refelem.t t/reftype.t t/sortkeys.t t/test_helper.pl t/tree.t t/usage.t t/xs_subs.t typemap META.json Data-Dump-Streamer-2.39/MANIFEST.SKIP000444001750001750 131412636703716 17117 0ustar00yortonyorton000000000000# $Id: MANIFEST.SKIP 29 2006-04-16 15:28:40Z demerphq $ # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ ^Build$ ^\.git/ ^lib/Data/Dump/Streamer\.o$ ^lib/Data/Dump/Streamer\.c$ ^lib/Data/Dump/Streamer\.bs$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ # Avoid Devel::Cover files. \bcover_db\b #DDS Specific \.answer$ \.build\.tmpl$ \.tar\.gz$ DDS\.pm \.(bs|c|def|obj|pdb)$ ^dds\w+\.pl ^MYMETA.yml$ Data-Dump-Streamer-2.39/META.json000444001750001750 472612636703716 16654 0ustar00yortonyorton000000000000{ "abstract" : "Accurately serialize a data structure as Perl code.", "author" : [ "Yves Orton , Joshua ben Jore " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4214", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Data-Dump-Streamer", "prereqs" : { "build" : { "requires" : { "B::Deparse" : "0", "Carp" : "0", "Config" : "0", "Data::Dumper" : "0", "Devel::Peek" : "0", "ExtUtils::CBuilder" : "0", "Symbol" : "0", "Test::More" : "0", "Text::Abbrev" : "0", "base" : "0", "overload" : "0", "re" : "0", "strict" : "0", "utf8" : "0", "vars" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "ExtUtils::Depends" : "0", "Module::Build" : "0", "perl" : "5.006" } }, "runtime" : { "recommends" : { "Algorithm::Diff" : "0", "Compress::Zlib" : "0", "JSON::XS" : "0", "MIME::Base64" : "0", "PadWalker" : "0.99" }, "requires" : { "B" : "0", "B::Deparse" : "0", "B::Utils" : "0", "Data::Dumper" : "0", "DynaLoader" : "0", "Exporter" : "0", "Hash::Util" : "0", "IO::File" : "0", "Symbol" : "0", "Text::Abbrev" : "0", "Text::Balanced" : "0", "overload" : "0", "re" : "0", "strict" : "0", "vars" : "0", "warnings" : "0", "warnings::register" : "0" } } }, "provides" : { "Data::Dump::Streamer" : { "file" : "lib/Data/Dump/Streamer.pm", "version" : "2.39" }, "Data::Dump::Streamer::Deparser" : { "file" : "lib/Data/Dump/Streamer.pm", "version" : "2.39" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/demerphq/Data-Dump-Streamer" } }, "version" : "2.39", "x_serialization_backend" : "JSON::PP version 2.27300" } Data-Dump-Streamer-2.39/.patch000444001750001750 212636703716 16232 0ustar00yortonyorton00000000000040Data-Dump-Streamer-2.39/t000755001750001750 012636703716 15330 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/t/readonly.t000444001750001750 156712636703716 17500 0ustar00yortonyorton000000000000#!./perl #$Id: readonly.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; keys %Config; # Silence warning if ($Config{extensions} !~ /\bList\/Util\b/) { print "1..0 # Skip: List::Util was not built\n"; exit 0; } } } use Data::Dump::Streamer qw(readonly); print "1..9\n"; print "not " unless readonly(1); print "ok 1\n"; my $var = 2; print "not " if readonly($var); print "ok 2\n"; print "not " unless $var == 2; print "ok 3\n"; print "not " unless readonly("fred"); print "ok 4\n"; $var = "fred"; print "not " if readonly($var); print "ok 5\n"; print "not " unless $var eq "fred"; print "ok 6\n"; $var = \2; print "not " if readonly($var); print "ok 7\n"; print "not " unless readonly($$var); print "ok 8\n"; print "not " if readonly(*STDOUT); print "ok 9\n"; Data-Dump-Streamer-2.39/t/impure_madness.t000444001750001750 1241012636703716 20703 0ustar00yortonyorton000000000000use Test::More tests => 8; #$Id: impure_madness.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); is( $o->Purity, 1 ,'Purity is the norm...'); $o->Purity(0); is( $o->Purity, 0 ,'... but some like it impure!'); { local *icky; *icky=\ "icky"; our $icky; my $id = 0; my $btree; $btree = sub { my ( $d, $m, $p ) = @_; return $p if $d > $m; return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ]; }; my $t = $btree->( 0, 1, '' ); my ( $x, $y, $qr ); $x = \$y; $y = \$x; $qr = bless qr/this is a test/m, 'foo_bar'; my $array = []; my $hash = bless { A => \$array, 'B-B' => ['$array'], 'CCCD' => [ 'foo', 'bar' ], 'E'=>\\1, 'F'=>\\undef, 'Q'=>sub{\@_}->($icky), }, 'ThisIsATest'; $hash->{G}=\$hash; my $boo = 'boo'; @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo ); my $cap = capture( $x, $y, $qr, $x, $y, $qr ); test_dump( { name=>'Impure Impure Madness cap( $qr,$qr )', no_redump=>1, no_dumper=>1, }, $o, capture( $qr, $qr ), <<'EXPECT'); $ARRAY1 = [ bless( qr/this is a test/m, 'foo_bar' ), alias_to($ARRAY1->[0]) ]; EXPECT test_dump( {name=>"Total Impure Madness", no_redump=>1, no_dumper=>1, }, $o, ( $cap,$array,$boo,$hash,$qr ), <<'EXPECT'); $ARRAY1 = [ \$ARRAY1->[1], \$ARRAY1->[0], alias_to($foo_bar1), alias_to($ARRAY1->[0]), alias_to($ARRAY1->[1]), alias_to($foo_bar1) ]; $ARRAY2 = [ \$ThisIsATest1, $ARRAY2->[0], $ARRAY2->[0], \$foo_bar1, $ARRAY2->[3], \'foo', \$VAR1 ]; $VAR1 = 'boo'; $ThisIsATest1 = bless( { A => \$ARRAY2, "B-B" => [ '$array' ], CCCD => [ 'foo', 'bar' ], E => \\1, F => \\undef, G => $ARRAY2->[0], Q => [ make_ro( 'icky' ) ] }, 'ThisIsATest' ); $foo_bar1 = bless( qr/this is a test/m, 'foo_bar' ); EXPECT } { my ($x,$y); $x=\$y; $y=\$x; my $a=[1,2]; $a->[0]=\$a->[1]; $a->[1]=\$a->[0]; #$cap->[-1]=5; my $s; $s=\$s; my $bar='bar'; my $foo='foo'; my $halias= {foo=>1,bar=>2}; alias_hv(%$halias,'foo',$foo); alias_hv(%$halias,'bar',$bar); alias_hv(%$halias,'foo2',$foo); my ($t,$u,$v,$w)=(1,2,3,4); my $cap=sub{ \@_ }->($x,$y); my $q1=qr/foo/; my $q2=bless qr/bar/,'bar'; my $q3=\bless qr/baz/,'baz'; #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Impure Madness", $o ); test_dump( { name=>"More Impure Madness", no_redump=>1, no_dumper=>1, }, $o, ( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3], {1..4},$cap,$cap,$t,$u,$v,$halias), <<'EXPECT'); $ARRAY1 = [ \$ARRAY1->[1], \$ARRAY1->[0] ]; $Regexp1 = qr/foo/; $bar1 = bless( qr/bar/, 'bar' ); $REF1 = \bless( qr/baz/, 'baz' ); $ARRAY2 = [ \$ARRAY5->[1], \$ARRAY5->[0] ]; $ARRAY3 = [ \$ARRAY3->[0], $ARRAY2->[0], $ARRAY2->[1] ]; $VAR1 = 1; $VAR2 = 2; $VAR3 = 3; alias_ref(\$VAR4,\$VAR1); $ARRAY4 = [ 1, 2, 3 ]; $HASH1 = { 1 => 2, 3 => 4 }; $ARRAY5 = [ $ARRAY2->[0], $ARRAY2->[1] ]; alias_ref(\$ARRAY6,\$ARRAY5); alias_ref(\$VAR5,\$VAR1); alias_ref(\$VAR6,\$VAR2); alias_ref(\$VAR7,\$VAR3); $HASH2 = { bar => 'bar', foo => 'foo', foo2 => alias_to($HASH2->{foo}) }; EXPECT } { #local $Data::Dump::Streamer::DEBUG = 1; my $x; $x = sub { \@_ }->( $x, $x ); push @$x, $x; test_dump( { name=>"Impure Alias Array", no_redump=>1, no_dumper=>1, }, $o, ( $x ), <<'EXPECT'); $ARRAY1 = [ alias_to($ARRAY1), alias_to($ARRAY1), $ARRAY1 ]; EXPECT } __END__ # test_dump( {name=>"merlyns test 2", verbose=>1}, $o, ( \\@a ), <<'EXPECT', ); # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/refaddr.t000444001750001750 141412636703716 17261 0ustar00yortonyorton000000000000use Data::Dump::Streamer qw(refaddr); use vars qw($t $y $x *F $v $r); use Symbol qw(gensym); #$Id: refaddr.t 26 2006-04-16 15:18:52Z demerphq $# # Ensure we do not trigger and tied methods tie *F, 'MyTie'; print "1..13\n"; my $i = 1; foreach $v (undef, 10, 'string') { print "not " if refaddr($v); print "ok ",$i++,"\n"; } foreach $r ({}, \$t, [], \*F, sub {}) { my $addr = $r + 0; print "not " unless refaddr($r) == $addr; print "ok ",$i++,"\n"; my $obj = bless $r, 'FooBar'; print "not " unless refaddr($r) == $addr; print "ok ",$i++,"\n"; } package FooBar; use overload '0+' => sub { 10 }, '+' => sub { 10 + $_[1] }; package MyTie; sub TIEHANDLE { bless {} } sub DESTROY {} sub AUTOLOAD { warn "$AUTOLOAD called"; exit 1; # May be in an eval } Data-Dump-Streamer-2.39/t/sortkeys.t000444001750001750 1505712636703716 17565 0ustar00yortonyorton000000000000use Test::More tests => 10; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; #$Id: sortkeys.t 26 2006-04-16 15:18:52Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { use warnings FATAL=>'all'; my $hash={(map {$_ => $_, "1$_"=>"1$_" } 0..9,'a'..'j','A'..'J'),map { ( chr(65+$_).$_ => $_, $_.chr(65+$_) => $_) } 0..9}; same( "Sortkeys Mixed Default (smart)", $o , <<'EXPECT',$hash ); $HASH1 = { 0 => 0, "0A" => 0, 1 => 1, "1A" => '1A', "1a" => '1a', "1B" => 1, "1b" => '1b', "1C" => '1C', "1c" => '1c', "1D" => '1D', "1d" => '1d', "1E" => '1E', "1e" => '1e', "1F" => '1F', "1f" => '1f', "1G" => '1G', "1g" => '1g', "1H" => '1H', "1h" => '1h', "1I" => '1I', "1i" => '1i', "1J" => '1J', "1j" => '1j', 2 => 2, "2C" => 2, 3 => 3, "3D" => 3, 4 => 4, "4E" => 4, 5 => 5, "5F" => 5, 6 => 6, "6G" => 6, 7 => 7, "7H" => 7, 8 => 8, "8I" => 8, 9 => 9, "9J" => 9, 10 => 10, 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, 16 => 16, 17 => 17, 18 => 18, 19 => 19, A => 'A', a => 'a', A0 => 0, B => 'B', b => 'b', B1 => 1, C => 'C', c => 'c', C2 => 2, D => 'D', d => 'd', D3 => 3, E => 'E', e => 'e', E4 => 4, F => 'F', f => 'f', F5 => 5, G => 'G', g => 'g', G6 => 6, H => 'H', h => 'h', H7 => 7, I => 'I', i => 'i', I8 => 8, J => 'J', j => 'j', J9 => 9 }; EXPECT same( "Sortkeys Mixed Lexico", $o->SortKeys('lex'), <<'EXPECT',( $hash )); $HASH1 = { 0 => 0, "0A" => 0, 1 => 1, 10 => 10, 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, 16 => 16, 17 => 17, 18 => 18, 19 => 19, "1A" => '1A', "1B" => 1, "1C" => '1C', "1D" => '1D', "1E" => '1E', "1F" => '1F', "1G" => '1G', "1H" => '1H', "1I" => '1I', "1J" => '1J', "1a" => '1a', "1b" => '1b', "1c" => '1c', "1d" => '1d', "1e" => '1e', "1f" => '1f', "1g" => '1g', "1h" => '1h', "1i" => '1i', "1j" => '1j', 2 => 2, "2C" => 2, 3 => 3, "3D" => 3, 4 => 4, "4E" => 4, 5 => 5, "5F" => 5, 6 => 6, "6G" => 6, 7 => 7, "7H" => 7, 8 => 8, "8I" => 8, 9 => 9, "9J" => 9, A => 'A', A0 => 0, B => 'B', B1 => 1, C => 'C', C2 => 2, D => 'D', D3 => 3, E => 'E', E4 => 4, F => 'F', F5 => 5, G => 'G', G6 => 6, H => 'H', H7 => 7, I => 'I', I8 => 8, J => 'J', J9 => 9, a => 'a', b => 'b', c => 'c', d => 'd', e => 'e', f => 'f', g => 'g', h => 'h', i => 'i', j => 'j' }; EXPECT $hash={map { $_ => 1} (1,10,11,2,20,100)}; same( "Sortkeys Numeric Alph==Lex", $o->SortKeys('alph'), <<'EXPECT', ( $hash ) ); $HASH1 = { 1 => 1, 10 => 1, 100 => 1, 11 => 1, 2 => 1, 20 => 1 }; EXPECT same( "Sortkeys Numeric", $o->SortKeys('num') , <<'EXPECT', ( $hash ) ); $HASH1 = { 1 => 1, 2 => 1, 10 => 1, 11 => 1, 20 => 1, 100 => 1 }; EXPECT same( "Sortkeys Numeric Smart", $o->SortKeys('smart'), <<'EXPECT', ( $hash ) ); $HASH1 = { 1 => 1, 2 => 1, 10 => 1, 11 => 1, 20 => 1, 100 => 1 }; EXPECT same( $dump = $o->SortKeys(sub {[ sort grep { /1/ } keys %{shift @_} ]})->Data( $hash )->Out, <<'EXPECT', "Sortkeys Custom Filter", $o ); $HASH1 = { 1 => 1, 10 => 1, 100 => 1, 11 => 1 }; EXPECT $o->SortKeys('smart'); } { #local $Data::Dump::Streamer::DEBUG=1; my $h={'A'...'J'}; my $h2={'A'..'J'}; my $foo_bar=bless {foo=>1,bar=>2,baz=>3},'Foo::Bar'; $o->HashKeys('Foo::Bar'=>[qw(foo bar)],$h=>[qw( C G E )]); same( $dump = $o->Data($h2,$h,$foo_bar)->Out, <<'EXPECT', "HashKeys - array", $o ); $HASH1 = { A => 'B', C => 'D', E => 'F', G => 'H', I => 'J' }; $HASH2 = { C => 'D', G => 'H', E => 'F' }; $Foo_Bar1 = bless( { foo => 1, bar => 2 }, 'Foo::Bar' ); EXPECT $o->HashKeys($h2=>sub { return ['I'] }); same( $dump = $o->Data($h2,$h,$foo_bar)->Out, <<'EXPECT', "HashKeys - coderef", $o ); $HASH1 = { I => 'J' }; $HASH2 = { C => 'D', G => 'H', E => 'F' }; $Foo_Bar1 = bless( { foo => 1, bar => 2 }, 'Foo::Bar' ); EXPECT $o->HashKeys(); } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { } Data-Dump-Streamer-2.39/t/reftype.t000444001750001750 201412636703716 17325 0ustar00yortonyorton000000000000# this is from the Scalar::Utils distro use Data::Dump::Streamer qw(reftype); use vars qw($t $y $x *F); use Symbol qw(gensym); #$Id: reftype.t 26 2006-04-16 15:18:52Z demerphq $# # Ensure we do not trigger and tied methods tie *F, 'MyTie'; @test = ( [ undef, 1], [ undef, 'A'], [ HASH => {} ], [ ARRAY => [] ], [ SCALAR => \$t ], [ REF => \(\$t) ], [ GLOB => \*F ], [ GLOB => gensym ], [ CODE => sub {} ], # [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN ); print "1..", @test*4, "\n"; my $i = 1; foreach $test (@test) { my($type,$what) = @$test; my $pack; foreach $pack (undef,"ABC","0",undef) { print "# $what\n"; my $res = reftype($what); printf "# '%s' - '%s'\n", map { defined $_ ? $_ : 'undef' } $type,$res; print "not " if $type ? $res ne $type : $res; bless $what, $pack if $type && defined $pack; print "ok ",$i++,"\n"; } } package MyTie; sub TIEHANDLE { bless {} } sub DESTROY {} sub AUTOLOAD { warn "$AUTOLOAD called"; exit 1; # May be in an eval } Data-Dump-Streamer-2.39/t/lexicals.t000444001750001750 1534012636703716 17501 0ustar00yortonyorton000000000000use strict; use warnings; #$Id: lexicals.t 26 2006-04-16 15:18:52Z demerphq $# use Data::Dump::Streamer; use Test::More tests => 14; (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; diag "\nPadWalker ", eval "use PadWalker 0.99; 1" ? qq($PadWalker::VERSION is) : "isn't", " installed"; $::No_Redump=$::No_Redump=1; $::No_Dumper=$::No_Dumper=1; { my $v = 'foo'; my @v = ('f','o','o'); my $z = 1; no warnings; sub get_sub { my @v=(@v,1); my @y=('b','a','r'); my $x = join " ", @_, @v, $v, $z; sub { my @y = ( $x, "A".."G", @y); my @v = ( "M".."R", @v); my $x = join ":", @y, @v, $z||'undef'; $x . "!!"; }, sub { $x = shift; $z = shift if @_; }, do { my @y=split //,'fuzz'; sub { return join "+",$z,$x,@y;} }, } } { my $expect; if ( $] >= 5.013_001 ) { $expect = <<'EXPECT'; my ($x,$z,@v,@y,@y_eclipse_1); $x = 'f o o 1 foo 1'; $z = 1; @v = ( 'f', ( 'o' ) x 2, 1 ); @y = ( 'b', 'a', 'r' ); @y_eclipse_1 = ( 'f', 'u', ( 'z' ) x 2 ); $CODE1 = sub { my(@y) = ($x, ('A', 'B', 'C', 'D', 'E', 'F', 'G'), @y); my(@v) = (('M', 'N', 'O', 'P', 'Q', 'R'), @v); my $x = join(':', @y, @v, $z || 'undef'); $x . '!!'; }; $CODE2 = sub { $x = shift(); $z = shift() if @_; }; $CODE3 = sub { return join('+', $z, $x, @y_eclipse_1); }; EXPECT } else { $expect = <<'EXPECT'; my ($x,$z,@v,@y,@y_eclipse_1); $x = 'f o o 1 foo 1'; $z = 1; @v = ( 'f', ( 'o' ) x 2, 1 ); @y = ( 'b', 'a', 'r' ); @y_eclipse_1 = ( 'f', 'u', ( 'z' ) x 2 ); $CODE1 = sub { my(@y) = ($x, ('A', 'B', 'C', 'D', 'E', 'F', 'G'), @y); my(@v) = (('M', 'N', 'O', 'P', 'Q', 'R'), @v); my $x = join(':', @y, @v, $z || 'undef'); $x . '!!'; }; $CODE2 = sub { $x = shift @_; $z = shift @_ if @_; }; $CODE3 = sub { return join('+', $z, $x, @y_eclipse_1); }; EXPECT } test_dump( 'Lexicals!!', scalar(Dump()), ( get_sub() ), $expect); } { # local $Data::Dump::Streamer::DEBUG=1; my $x; $x = sub { $x }; test_dump( "Self-referential", scalar(Dump()),( $x ), <<'EXPECT'); $x = sub { $x; }; EXPECT } { my $a; my $b = sub { $a }; test_dump( "Nested closure with shared state", scalar(Dump()), ( sub { $a, $b } ), <<'EXPECT'); my ($a,$b); $a = undef; $b = sub { $a; }; $CODE1 = sub { $a, $b; }; EXPECT } { my $a; my $b; my $z = sub { $a, $b }; my $y = do { my $b; sub { $a, $b } }; test_dump( "Overlapping declarations", scalar(Dump()), ( $y, $z ), <<'EXPECT'); my ($a,$b,$b_eclipse_1); $a = undef; $b = undef; $b_eclipse_1 = undef; $CODE1 = sub { $a, $b; }; $CODE2 = sub { $a, $b_eclipse_1; }; EXPECT } { my $a; my $z = sub { $a }; my $b; my $y = sub { $a, $b }; test_dump( "Overlapping declarations two", scalar(Dump()), ( $y, $z ), <<'EXPECT'); my ($a,$b); $a = undef; $b = undef; $CODE1 = sub { $a, $b; }; $CODE2 = sub { $a; }; EXPECT } { my $z = do { my $a; sub { $a }; }; my $y = do { my $a; sub { $a }; }; test_dump( "Unrelated environments", scalar(Dump()), ( $z, $y ), <<'EXPECT'); my ($a,$a_eclipse_1); $a = undef; $a_eclipse_1 = undef; $CODE1 = sub { $a; }; $CODE2 = sub { $a_eclipse_1; }; EXPECT } { my $bad = \&Not::Implemented; test_dump( "Unimplemented code", scalar(Dump()), ( $bad ), <<'EXPECT'); $CODE1 = \&Not::Implemented; EXPECT } { my $a; my $z = sub { $a }; test_dump( "Shared state/enclosed", scalar(Dump()), ( $z, sub { $a, $z } ), <<'EXPECT'); my ($a); $a = undef; $z = sub { $a; }; $CODE1 = sub { $a, $z; }; EXPECT test_dump( "Named Shared state/enclosed", scalar(Dump())->Names('foo','bar'), ( $z, sub { $a, $z } ), <<'EXPECT'); my ($a); $a = undef; $foo = sub { $a; }; $bar = sub { $a, $foo; }; EXPECT } { no warnings; our $b; my $a; my $b = sub { $b }; test_dump( "sub b", scalar(Dump()), ( $b ), <<'EXPECT'); $CODE1 = sub { $b; }; EXPECT test_dump( "double sub b", scalar(Dump()), ( sub { $b } ), <<'EXPECT'); my ($b); $b = sub { $b; }; $CODE1 = sub { $b; }; EXPECT } { my $a = "foo"; my $x = sub { return $a . "bar" }; sub f { print $x->() } test_dump( "recursively nested subs", scalar(Dump()), ( \&f ), <<'EXPECT'); my ($a,$x); $a = 'foo'; $x = sub { return $a . 'bar'; }; $CODE1 = sub { print &$x(); }; EXPECT } { test_dump( "EclipseName", Dump->EclipseName('%d_foiled_%s'), ( [ map { my $x; my $x_eclipse_1; sub {$x}, sub {$x_eclipse_1}; } 1, 2 ] ), <<'EXPECT'); my ($1_foiled_x,$1_foiled_x_eclipse_1,$x,$x_eclipse_1); $1_foiled_x = undef; $1_foiled_x_eclipse_1 = undef; $x = undef; $x_eclipse_1 = undef; $ARRAY1 = [ sub { $x; }, sub { $x_eclipse_1; }, sub { $1_foiled_x; }, sub { $1_foiled_x_eclipse_1; } ]; EXPECT } { test_dump( "EclipseName 2", Dump->EclipseName('%s_muhaha_%d'), ( [ map { my $x; my $x_eclipse_1; sub {$x}, sub {$x_eclipse_1}; } 1, 2 ] ), <<'EXPECT'); my ($x,$x_eclipse_1,$x_eclipse_1_muhaha_1,$x_muhaha_1); $x = undef; $x_eclipse_1 = undef; $x_eclipse_1_muhaha_1 = undef; $x_muhaha_1 = undef; $ARRAY1 = [ sub { $x; }, sub { $x_eclipse_1; }, sub { $x_muhaha_1; }, sub { $x_eclipse_1_muhaha_1; } ]; EXPECT } if (0){ #no warnings; my @close; my ($x,$y)=(3.141,5); for my $a ($x, $y) { for my $b ($x, $y) { push @close, sub { ++$a, ++$b; return } if \$a != \$b } } my $out=Dump(\@close)->Out(); print $out; #print B::Deparse::WARN_MASK; } __END__ Data-Dump-Streamer-2.39/t/dump.t000444001750001750 3305212636703716 16642 0ustar00yortonyorton000000000000use Test::More tests => 49; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump DumpLex DumpVars) ); } use strict; use warnings; use Data::Dumper; #$Id: dump.t 40 2007-12-22 00:37:55Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { our ($foo,@foo,%foo,$bar); local $foo='yada'; local @foo=((1)x10,(2) x 10); no warnings; local %foo=(2,*bar,3,sub{ print ('this is a test'),'foo'; print qq(\"bar\"\n); }); use warnings; local $bar='BAR'; my $x=*foo; same( do {$dump = $o->Data( $x )->Out; $dump=~s/^\s*(?:use|no).*\n//mg; $dump}, <<'EXPECT', "DumpGlob, Rle, Deparse", $o ); $VAR1 = *::foo; *::foo = \do { my $v = 'yada' }; *::foo = { 2 => *::bar, 3 => sub { print('this is a test'), 'Useless const omitted'; print qq["bar"\n]; } }; *::foo = [ ( 1 ) x 10, ( 2 ) x 10 ]; *::bar = \do { my $v = 'BAR' }; EXPECT } { local $\="\n"; same( "Bart's Refs", $o,<<'EXPECT', ( \{},\[],\do{my $x="foo"},\('bar') ) ); $REF1 = \{}; $REF2 = \[]; $SCALAR1 = \do { my $v = 'foo' }; $SCALAR2 = \'bar'; EXPECT # originally the $o was an accident that exposed a bug # it was supposed to be $t all along, but they tickle different things. my $t={}; bless $t,"Barts::Object::${t}::${o}"; same( "Bart's Funky Refs", $o,<<'EXPECT', ( $t ) ); $Barts_Object_HASH1 = bless( {}, 'Barts::Object::HASH(0xdeadbeef)::Data::Dump::Streamer=HASH(0xdeadbeef)' ); EXPECT } { my ($a,$b); $a = [{ a => \$b }, { b => undef }]; $b = [{ c => \$b }, { d => \$a }]; same("Simple Arrays of Simple Hashes", $o, <<'EXPECT', ( $a,$b ) ); $ARRAY1 = [ { a => \$ARRAY2 }, { b => undef } ]; $ARRAY2 = [ { c => $ARRAY1->[0]{a} }, { d => \$ARRAY1 } ]; EXPECT same( "Predeclare Simple Arrays of Simple Hashes", $o->Declare(1), <<'EXPECT',( $a,$b ) ); my $ARRAY1 = [ { a => 'R: $ARRAY2' }, { b => undef } ]; my $ARRAY2 = [ { c => 'V: $ARRAY1->[0]{a}' }, { d => \$ARRAY1 } ]; $ARRAY1->[0]{a} = \$ARRAY2; $ARRAY2->[0]{c} = $ARRAY1->[0]{a}; EXPECT } { my $x=\"foo"; my $y=\$x; same( "Many Refs ( \$x, \$y ) No declare 1", $o->Declare(0), <<'EXPECT', ( $x, $y ) ); $SCALAR1 = \'foo'; $REF1 = \$SCALAR1; EXPECT #same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y ); #same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o ); same( "Many Refs Declare ( \$x, \$y ) 1", $o->Declare(1), <<'EXPECT', ( $x, $y ) ); my $SCALAR1 = \'foo'; my $REF1 = \$SCALAR1; EXPECT same( "Many Refs Declare ( \$y, \$x ) 1", $o->Declare(1), <<'EXPECT', ( $y,$x ) ); my $REF1 = 'R: $SCALAR1'; my $SCALAR1 = \'foo'; $REF1 = \$SCALAR1; EXPECT same("Many Refs ( \$y, \$x ) No Declare 1", $o->Declare(0), <<'EXPECT', ( $y,$x ) ); $REF1 = \$SCALAR1; $SCALAR1 = \'foo'; EXPECT } { my $x=\\"foo"; my $y=\\$x; same( "Many Refs ( \$x, \$y ) No declare 2", $o->Declare(0), <<'EXPECT', ( $x, $y ) ); $REF1 = \\'foo'; $REF2 = \\$REF1; EXPECT #same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y ); #same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o ); same( "Many Refs Declare ( \$x, \$y ) 2", $o->Declare(1), <<'EXPECT', ( $x, $y ) ); my $REF1 = \\'foo'; my $REF2 = \\$REF1; EXPECT same( "Many Refs Declare ( \$y, \$x ) 2", $o->Declare(1), <<'EXPECT', ( $y,$x ) ); my $REF1 = \do { my $f = 'R: $REF2' }; my $REF2 = \\'foo'; $$REF1 = \$REF2; EXPECT same("Many Refs ( \$y, \$x ) No Declare 2", $o->Declare(0), <<'EXPECT', ( $y,$x ) ); $REF1 = \\$REF2; $REF2 = \\'foo'; EXPECT } { my $x=\\\"foo"; my $y=\\\$x; same( "Many Refs ( \$x, \$y ) No declare 3", $o->Declare(0), <<'EXPECT', ( $x, $y ) ); $REF1 = \\\'foo'; $REF2 = \\\$REF1; EXPECT #same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y ); #same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o ); same( "Many Refs Declare ( \$x, \$y ) 3", $o->Declare(1), <<'EXPECT', ( $x, $y ) ); my $REF1 = \\\'foo'; my $REF2 = \\\$REF1; EXPECT same( "Many Refs Declare ( \$y, \$x ) 3", $o->Declare(1), <<'EXPECT', ( $y,$x ) ); my $REF1 = \\do { my $f = 'R: $REF2' }; my $REF2 = \\\'foo'; $$$REF1 = \$REF2; EXPECT same("Many Refs ( \$y, \$x ) No Declare 3", $o->Declare(0), <<'EXPECT', ( $y,$x ) ); $REF1 = \\\$REF2; $REF2 = \\\'foo'; EXPECT } # with eval testing { my $x=[(1) x 4, 0, (1) x 4]; same( "Rle(1)", $o->Declare(0)->Rle(0), <<'EXPECT', ( $x ) ); $ARRAY1 = [ 1, 1, 1, 1, 0, 1, 1, 1, 1 ]; EXPECT same( "Rle(1) Tight", $o->Verbose(0)->Indent(0)->Rle(1), <<'EXPECT', ( $x ) ); $A1=[(1)x4,0,(1)x4]; EXPECT same( "Rle(1)", $o->Verbose(1)->Indent(2)->Rle(1), <<'EXPECT', ( $x ) ); $ARRAY1 = [ ( 1 ) x 4, 0, ( 1 ) x 4 ]; EXPECT #local $Data::Dump::Streamer::DEBUG=1; my $one=1; #do this to avoid problems with differing behaviour in (1) x 3 my @one=(1,1,1); my @two=(1,1,1); my $y=sub { \@_ }->(@one,$one,0,$one,@two); same( "Rle(1) Alias", $o->Rle(1), <<'EXPECT', ( $y ) ); $ARRAY1 = [ ( 1 ) x 3, 1, 0, 'A: $ARRAY1->[3]', ( 1 ) x 3 ]; make_ro($ARRAY1->[4]); alias_av(@$ARRAY1, 5, $ARRAY1->[3]); EXPECT } { my $x={ hash => {0..5}, array => [0..5], object => bless(\do{my $x='Foo!'},'Bar'), regex => qr/(?:baz)/, }; same( "Indent", $o->Indent(2), <<'EXPECT', ( $x ) ); $HASH1 = { array => [ 0, 1, 2, 3, 4, 5 ], hash => { 0 => 1, 2 => 3, 4 => 5 }, object => bless( \do { my $v = 'Foo!' }, 'Bar' ), regex => qr/(?:baz)/ }; EXPECT same( "Indent(0)", $o->Indent(0), <<'EXPECT', ( $x ) ); $HASH1={array=>[0,1,2,3,4,5],hash=>{0=>1,2=>3,4=>5},object=>bless(\do{my$v='Foo!'},'Bar'),regex=>qr/(?:baz)/}; EXPECT same( "IndentCols(0)", $o->Indent(2)->IndentCols(0), <<'EXPECT', ( $x ) ); $HASH1 = { array => [ 0, 1, 2, 3, 4, 5 ], hash => { 0 => 1, 2 => 3, 4 => 5 }, object => bless( \do { my $v = 'Foo!' }, 'Bar' ), regex => qr/(?:baz)/ }; EXPECT same( "IndentCols(4)", $o->Indent(2)->IndentCols(4), <<'EXPECT', ( $x ) ); $HASH1 = { array => [ 0, 1, 2, 3, 4, 5 ], hash => { 0 => 1, 2 => 3, 4 => 5 }, object => bless( \do { my $v = 'Foo!' }, 'Bar' ), regex => qr/(?:baz)/ }; EXPECT same( "IndentCols(2)", $o->Indent(2)->IndentCols(2), <<'EXPECT', ( $x ) ); $HASH1 = { array => [ 0, 1, 2, 3, 4, 5 ], hash => { 0 => 1, 2 => 3, 4 => 5 }, object => bless( \do { my $v = 'Foo!' }, 'Bar' ), regex => qr/(?:baz)/ }; EXPECT } { my $nums=['00123','00','+001','-001','1e40','-0.1000',-0.1000,1.0,'1.0']; same( "Numbers", $o, <<'EXPECT', ( $nums ) ); $ARRAY1 = [ '00123', '00', '+001', '-001', '1e40', '-0.1000', -0.1, 1, '1.0' ]; EXPECT } # with eval testing { my ($x,$y)=10; my $obj=Dump(); isa_ok($obj, "Data::Dump::Streamer","Dump() Return noarg/scalar"); $obj=Dump($x,$y); isa_ok($obj, "Data::Dump::Streamer","Dump() Return arg/scalar"); my @lines=Dump($x,$y); ok(!ref($lines[0]),"Dump() Return args/list"); @lines=Dump($x,$y)->Indent(0)->Out(); ok(!ref($lines[0]),"Dump() Return args/list-scalar"); } # with eval testing { my $x=1; my $y=[]; my $array=sub{\@_ }->( $x,$x,$y ); push @$array,$y,1; unshift @$array,\$array->[-1]; #Dump($array); same( "Documentation example", $o, <<'EXPECT', ( $array ) ); $ARRAY1 = [ 'R: $ARRAY1->[5]', 1, 'A: $ARRAY1->[1]', [], 'V: $ARRAY1->[3]', 1 ]; $ARRAY1->[0] = \$ARRAY1->[5]; alias_av(@$ARRAY1, 2, $ARRAY1->[1]); $ARRAY1->[4] = $ARRAY1->[3]; EXPECT } # with eval testing { my @a = ('a0'..'a9'); unshift @a, \\$a[2]; same( "merlyns test", $o, <<'EXPECT', ( \\@a ) ); $REF1 = \[ \do { my $v = 'R: ${$REF1}->[3]' }, 'a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', 'a8', 'a9' ]; ${${$REF1}->[0]} = \${$REF1}->[3]; EXPECT } { my @a = ('a0'..'a9'); unshift @a, \\$a[2]; test_dump( {name=>"merlyns test 2", verbose=>1}, $o, ( \\@a ), <<'EXPECT', ); $REF1 = \[ \do { my $v = 'R: ${$REF1}->[3]' }, 'a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', 'a8', 'a9' ]; ${${$REF1}->[0]} = \${$REF1}->[3]; EXPECT } { my $expect = $] >= 5.013_010 ? <<'U_FLAG' : <<'NO_U_FLAG'; $VAR1 = "This contains unicode: /\x{263a}/"; $Regexp1 = qr!This contains unicode: /\x{263a}/!u; U_FLAG $VAR1 = "This contains unicode: /\x{263a}/"; $Regexp1 = qr!This contains unicode: /\x{263a}/!; NO_U_FLAG use utf8; my $r = "This contains unicode: /\x{263A}/"; my $qr= qr/$r/; test_dump( {name=>"Unicode qr// and string", no_dumper => 1, verbose => 1 }, $o, ( $r,$qr ), $expect); } { use utf8; my $r = "\x{100}\x{101}\x{102}"; test_dump( {name=>"Unicode qr// and string", no_dumper=>1,verbose=>1}, $o, ( $r ), <<'EXPECT', ); $VAR1 = "\x{100}\x{101}\x{102}"; EXPECT } { use warnings FATAL=>'all'; my $r = "Gnter"; test_dump( {name=>"Non unicode, high char", verbose=>1}, $o, ( $r ), <<'EXPECT', ); $VAR1 = "G\374nter"; EXPECT } { my $dv=dualvar(unpack('N','JAPH'),'JAPH'); test_dump( {name=>"Dualvars(0) ", verbose=>1}, $o->Dualvars(0), ( $dv ), <<'EXPECT', ); $VAR1 = 'JAPH'; EXPECT test_dump( {name=>"Dualvars(1)", verbose=>1}, $o->Dualvars(1), ( $dv ), <<'EXPECT', ); $VAR1 = dualvar( 1245794376, 'JAPH' ); EXPECT } { my ($x,%y,@z); $x=\@z; our $global=\@z; my $res1=Dump($x,\%y,\@z)->Names(qw(x *y *z))->Out(); my $res3=DumpVars(x=>$x,-y=>\%y,-z=>\@z)->Out(); is($res1,$res3,'DumpVars'); SKIP: { skip "needs PadWalker 0.99 or later", 3 if !eval "use PadWalker 0.99; 1"; my $res2=DumpLex($x,\%y,\@z)->Out(); is($res1,$res2,'DumpLex'); is($res2,$res3,'DumpLex eq DumpVars'); is("".DumpLex($x,$global)->Out(),<<'EXPECT','DumpLex w/global'); $x = []; $global = $x; EXPECT } } SKIP: { skip "needs Compress::Zlib and MIME::Base64", 2 if !eval "use Compress::Zlib; use MIME::Base64; 1"; my $str="a" x 1000; my $i=bless \$str,"Fnorble"; my $rep=MIME::Base64::encode(Compress::Zlib::compress($str,9),""); $o->Compress(-1); my $out=$o->Data($i)->Out(); (my $expect=<<'EXPECT')=~s/XXX/$rep/; use Data::Dump::Streamer qw(usqz); $Fnorble1 = bless( \do { my $v = usqz('XXX') }, 'Fnorble' ); EXPECT is($out,$expect,"Compress literal"); $o->OptSpace(""); $out=$o->Data($i)->Out(); ($expect=<<'EXPECT')=~s/XXX/$rep/; use Data::Dump::Streamer qw(usqz); $Fnorble1=bless(\do{my$v=usqz('XXX')},'Fnorble'); EXPECT is($out,$expect,"Optspace"); $o->Compress(0); } { my $h={'-'=>1,'-1efg'=>1}; $o->OptSpace(""); same( "'-' hashkeys", $o, <<'EXPECT', ( $h ) ); $HASH1={ "-1efg"=>1, "-" =>1 }; EXPECT } # with eval testing { my $h= { "blah\n" => 1,"blah\nblah\n" => 2, "blahblahblah\n\n" => 3 }; same( "hashkeys with newlines", $o, <<'EXPECT', ( $h ) ); $HASH1={ "blah\n" =>1, "blah\nblah\n" =>2, "blahblahblah\n\n"=>3 }; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/refcount.t000444001750001750 213512636703716 17500 0ustar00yortonyorton000000000000use Test::More tests => 18; use Devel::Peek; #$Id: refcount.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(refcount sv_refcount is_numeric looks_like_number weak_refcount weaken isweak)); } my $sv="Foo"; my $rav=[]; my $rhv={}; is sv_refcount($sv),1,"sv_refcount"; is refcount($rav),1,"refcount av"; is refcount($rhv),1,"refcount hv"; is refcount(\$sv),2,'refcount \\$foo'; my $ref=\$sv; is sv_refcount($sv),2,'sv_refcount after'; is refcount(\$sv),3,'refcount after'; SKIP: { skip ( "No Weak Refs", 3 ) unless eval { weaken($ref) }; is isweak($ref),1,"is weakened"; is sv_refcount($sv),2,"weakened sv_refcount"; is weak_refcount($sv),1,"weak_refcount"; is refcount(\$sv),3,"weakened refcount"; } { use strict; my $sv="Foo"; my $iv=100; my $nv=1.234; my $dbl=1e40; my %hash=(100=>1,1.234=>1,1e40=>1); for my $t ( [$sv,''], [$iv,1], [$nv,1], [$dbl,1], map {[$_,'']} keys %hash ){ is is_numeric($t->[0]),$t->[1],"Test:".$t->[0]; } } __END__ Data-Dump-Streamer-2.39/t/as.t000444001750001750 77012636703716 16241 0ustar00yortonyorton000000000000#!perl -w #$Id: as.t 26 2006-04-16 15:18:52Z demerphq $# use Test::More tests => 4; use_ok 'Data::Dump::Streamer'; import Data::Dump::Streamer as => 'DDS'; { package Foo; use base Data::Dump::Streamer; import Data::Dump::Streamer as => 'Bar'; } my $dds; $dds = DDS->new; ok($dds, "aliased namespace works for object construction"); $dds = Foo->new; ok($dds, "derived package constructor works"); $dds = Bar->new; ok($dds, "aliased namespace works with derived package constructor"); Data-Dump-Streamer-2.39/t/madness_w.t000444001750001750 1343312636703716 17656 0ustar00yortonyorton000000000000use Test::More tests => 6; #$Id: madness_w.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump weaken) ); } use strict; use warnings; use Data::Dumper; SKIP:{ my ($_item,$_ref); $_ref=\$_item; skip ( "No Weak Refs", 5 ) unless eval { weaken($_ref) }; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { local *icky; *icky=\ "icky"; our $icky; my $id = 0; my $btree; $btree = sub { my ( $d, $m, $p ) = @_; return $p if $d > $m; return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ]; }; my $t = $btree->( 0, 1, '' ); my ( $x, $y, $qr ); $x = \$y; $y = \$x; $qr = bless qr/this is a test/m, 'foo_bar'; weaken($y); my $array = []; my $hash = bless { A => \$array, 'B-B' => ['$array'], 'CCCD' => [ 'foo', 'bar' ], 'E'=>\\1, 'F'=>\\undef, 'Q'=>sub{\@_}->($icky), }, 'ThisIsATest'; $hash->{G}=\$hash; my $boo = 'boo'; @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo ); my $cap = capture( $x, $y, $qr, $x, $y, $qr ); same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) ); $ARRAY1 = [ bless( qr/this is a test/m, 'foo_bar' ), 'A: $ARRAY1->[0]' ]; alias_av(@$ARRAY1, 1, $ARRAY1->[0]); EXPECT #same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o ); same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) ); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]', 'A: $foo_bar1', 'A: $ARRAY1->[0]', 'A: $ARRAY1->[1]', 'A: $foo_bar1' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; weaken($ARRAY1->[1]); alias_av(@$ARRAY1, 3, $ARRAY1->[0]); alias_av(@$ARRAY1, 4, $ARRAY1->[1]); $ARRAY2 = [ \$ThisIsATest1, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[0]', \$foo_bar1, 'V: $ARRAY2->[3]', \'foo', \$VAR1 ]; $ARRAY2->[1] = $ARRAY2->[0]; $ARRAY2->[2] = $ARRAY2->[0]; $ARRAY2->[4] = $ARRAY2->[3]; $VAR1 = 'boo'; $ThisIsATest1 = bless( { A => \$ARRAY2, "B-B" => [ '$array' ], CCCD => [ 'foo', 'bar' ], E => \\1, F => \\undef, G => $ARRAY2->[0], Q => [ 'icky' ] }, 'ThisIsATest' ); make_ro($ThisIsATest1->{Q}[0]); $foo_bar1 = bless( qr/this is a test/m, 'foo_bar' ); alias_av(@$ARRAY1, 2, $foo_bar1); alias_av(@$ARRAY1, 5, $foo_bar1); EXPECT } { my ($x,$y); $x=\$y; $y=\$x; my $a=[1,2]; $a->[0]=\$a->[1]; $a->[1]=\$a->[0]; weaken($a->[1]); weaken($x); #$cap->[-1]=5; my $s; $s=\$s; my $bar='bar'; my $foo='foo'; my $halias= {foo=>1,bar=>2}; alias_hv(%$halias,'foo',$foo); alias_hv(%$halias,'bar',$bar); alias_hv(%$halias,'foo2',$foo); my ($t,$u,$v,$w)=(1,2,3,4); my $cap=sub{ \@_ }->($x,$y); my $q1=qr/foo/; my $q2=bless qr/bar/,'bar'; my $q3=\bless qr/baz/,'baz'; #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o ); same( "More Madness", $o , <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; weaken($ARRAY1->[1]); $Regexp1 = qr/foo/; $bar1 = bless( qr/bar/, 'bar' ); $REF1 = \bless( qr/baz/, 'baz' ); $ARRAY2 = [ 'R: $ARRAY5->[1]', 'R: $ARRAY5->[0]' ]; $ARRAY3 = [ \do { my $v = 'V: $ARRAY3->[0]' }, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; ${$ARRAY3->[0]} = $ARRAY3->[0]; $VAR1 = 1; $VAR2 = 2; $VAR3 = 3; alias_ref(\$VAR4,\$VAR1); $ARRAY4 = [ 1, 2, 3 ]; $HASH1 = { 1 => 2, 3 => 4 }; $ARRAY5 = [ 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; $ARRAY2->[0] = \$ARRAY5->[1]; $ARRAY2->[1] = \$ARRAY5->[0]; $ARRAY3->[1] = $ARRAY2->[0]; $ARRAY3->[2] = $ARRAY2->[1]; $ARRAY5->[0] = $ARRAY2->[0]; weaken($ARRAY5->[0]); $ARRAY5->[1] = $ARRAY2->[1]; alias_ref(\$ARRAY6,\$ARRAY5); alias_ref(\$VAR5,\$VAR1); alias_ref(\$VAR6,\$VAR2); alias_ref(\$VAR7,\$VAR3); $HASH2 = { bar => 'bar', foo => 'foo', foo2 => 'A: $HASH2->{foo}' }; alias_hv(%$HASH2, 'foo2', $HASH2->{foo}); EXPECT } { skip ( "Causes error at global destruction on 5.8.0", 1 ) if $]==5.008; #local $Data::Dump::Streamer::DEBUG = 1; my $x; $x = sub { \@_ }->( $x, $x ); my $y = $x; #keep it alive weaken($x); push @$x, $x; same( "Tye Alias Array", $o, <<'EXPECT',( $x ) ); $ARRAY1 = [ 'A: $ARRAY1', 'A: $ARRAY1', 'V: $ARRAY1' ]; alias_av(@$ARRAY1, 0, $ARRAY1); alias_av(@$ARRAY1, 1, $ARRAY1); $ARRAY1->[2] = $ARRAY1; weaken($ARRAY1); EXPECT } undef $o; } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/refelem.t000444001750001750 131512636703716 17271 0ustar00yortonyorton000000000000print "1..5\n"; #$Id: refelem.t 26 2006-04-16 15:18:52Z demerphq $# use strict; use Data::Dump::Streamer qw(alias_av push_alias alias_hv); my $a = "a"; my @a = (1, 2, 3, 4); alias_av(@a, 1, $a); push_alias(@a, $a); print "not " unless "@a" eq "1 a 3 4 a"; print "ok 1\n"; $a = 2; print "not " unless "@a" eq "1 2 3 4 2"; print "ok 2\n"; $a[1] = "z"; print "not " unless $a[4] eq "z"; print "ok 3\n"; my %h; alias_hv(%h, "foo", $a); $h{foo} = "bar"; print "not " unless $a eq "bar"; print "ok 4\n"; $a[2] = [3]; alias_av(@a, 2, $a[2][0]); print "not " unless $a[2] == 3; print "ok 5\n"; if (shift) { require Devel::Peek; Devel::Peek::Dump($a); Devel::Peek::Dump(\@a); Devel::Peek::Dump(\%h); } Data-Dump-Streamer-2.39/t/globtest.t000444001750001750 2264312636703716 17524 0ustar00yortonyorton000000000000use Test::More tests=>19; #$Id: globtest.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(regex Dump alias_av alias_hv) ); } use strict; use warnings; use Data::Dumper; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { no strict; # no. 3 - a glob { local *g; same( scalar $o->Data(*g)->Out, <<'EXPECT', "a glob", $o ); $VAR1 = *::g; EXPECT } # no. 4 - scalar slot { local *g = \"a string"; ## XXX: the empty globs are an icky 5.8.0 bug $^V lt v5.8 ? same( scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o ) $VAR1 = *::g; *::g = \'a string'; EXPECT : same( scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o ) $VAR1 = *::g; *::g = \'a string'; *::g = {}; *::g = []; EXPECT ; } # no. 5 - data slots { local *g; $g = 'a string'; @g = qw/a list/; %g = qw/a hash/; our ($off,$width,$bits,$val,$res); ($off,$width,$bits,$val,$res)=($off,$width,$bits,$val,$res); eval' format g = vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $off, $width, $bits, $val, $res vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $off, $width, $bits, $val, $res . '; if ( 5.021009 <= $] ) { same( scalar $o->Data(*g)->Out, <<'EXPECT', "data slots (glob/FORMAT)", $o ); $VAR1 = *::g; *::g = \do { my $v = 'a string' }; *::g = { a => 'hash' }; *::g = [ 'a', 'list' ]; format g = vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> use warnings; ; $off, $width, $bits, $val, $res vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $off, $width, $bits, $val, $res . EXPECT } else { same( scalar $o->Data(*g)->Out, <<'EXPECT', "data slots (glob/FORMAT)", $o ); $VAR1 = *::g; *::g = \do { my $v = 'a string' }; *::g = { a => 'hash' }; *::g = [ 'a', 'list' ]; format g = vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $off, $width, $bits, $val, $res vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $off, $width, $bits, $val, $res . EXPECT } SKIP: { skip "no FORMAT refs before ".vstr(5,7)." and this is ".vstr(), my $NUM=3 unless 5.008 <= $]; if ( 5.021009 <= $] ) { same( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (ref/FORMAT)", $o ); $FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # use warnings; # ; $off, $width, $bits, $val, $res # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # . _EOF_FORMAT_ }; EXPECT } else { same( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (ref/FORMAT)", $o ); $FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # . _EOF_FORMAT_ }; EXPECT } my $y=bless *g{FORMAT},"Thank::YSTH"; if ( 5.021009 <= $] ) { #same ( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (blessed FORMAT)", $o ); test_dump( {name=>"data slots (blessed FORMAT)", verbose=>1, pre_eval=>'our ($off,$width,$bits,$val,$res);', no_dumper=>1, no_redump=>1, }, $o, *g{FORMAT}, <<'EXPECT' ); $Thank_YSTH1 = bless( do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # use warnings; # ; $off, $width, $bits, $val, $res # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # . _EOF_FORMAT_ }, 'Thank::YSTH' ); EXPECT } else { test_dump( {name=>"data slots (blessed FORMAT)", verbose=>1, pre_eval=>'our ($off,$width,$bits,$val,$res);', no_dumper=>1, }, $o, *g{FORMAT}, <<'EXPECT' ); $Thank_YSTH1 = bless( do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> # $off, $width, $bits, $val, $res # . _EOF_FORMAT_ }, 'Thank::YSTH' ); EXPECT } our $gg=1; #silence a warning; same( scalar $o->Data(*gg{FORMAT})->Out, <<'EXPECT', "data slots (empty FORMAT)", $o ); $VAR1 = undef; EXPECT }; } # no. 6 - self glob { local *g; $g = *g{SCALAR}; same( scalar $o->Data(*g)->Out, <<'EXPECT', "self glob", $o ); $VAR1 = *::g; *::g = \do { my $v = 'V: *::g{SCALAR}' }; ${*::g} = *::g{SCALAR}; EXPECT } # no. 7 - icky readonly scalars { local(*g, $s); *g = \"cannae be modified"; $s = "do as you please"; same( scalar $o->Data($g,$s)->Out, <<'EXPECT', "icky SCALAR slot", $o ); $RO1 = 'cannae be modified'; make_ro($RO1); $VAR1 = 'do as you please'; EXPECT } } { #local $Data::Dump::Streamer::DEBUG=1; our $foo = 5; our @foo = (-10,\*foo); our %foo = (a=>1,b=>\$foo,c=>\@foo); $foo{d} = \%foo; $foo[2] = \%foo; same( "Named Globs", $o->Declare(0)->Names('*foo', '*bar', '*baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) ); $foo = \\*::foo; *::foo = \do { my $v = 5 }; $bar = \[ -10, $$foo, 'V: $$baz' ]; *::foo = $$bar; $baz = \{ a => 1, b => *::foo{SCALAR}, c => $$bar, d => 'V: $$baz' }; *::foo = $$baz; ${$bar}->[2] = $$baz; ${$baz}->{d} = $$baz; EXPECT same( "Named Globs Two", $o->Names('foo', 'bar', 'baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) ); $foo = \\*::foo; *::foo = \do { my $v = 5 }; $bar = \[ -10, $$foo, 'V: $$baz' ]; *::foo = $$bar; $baz = \{ a => 1, b => *::foo{SCALAR}, c => $$bar, d => 'V: $$baz' }; *::foo = $$baz; ${$bar}->[2] = $$baz; ${$baz}->{d} = $$baz; EXPECT same( "Named Globs Declare", $o->Declare(1)->Names('*foo', '*bar', '*baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) ); my $foo = \\*::foo; *::foo = \do { my $v = 5 }; my $bar = \[ -10, $$foo, 'V: $$baz' ]; *::foo = $$bar; my $baz = \{ a => 1, b => *::foo{SCALAR}, c => $$bar, d => 'V: $$baz' }; *::foo = $$baz; ${$bar}->[2] = $$baz; ${$baz}->{d} = $$baz; EXPECT same( "Named Globs Two Declare", $o->Names('foo', 'bar', 'baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) ); my $foo = \\*::foo; *::foo = \do { my $v = 5 }; my $bar = \[ -10, $$foo, 'V: $$baz' ]; *::foo = $$bar; my $baz = \{ a => 1, b => *::foo{SCALAR}, c => $$bar, d => 'V: $$baz' }; *::foo = $$baz; ${$bar}->[2] = $$baz; ${$baz}->{d} = $$baz; EXPECT } # with eval testing { use Symbol; my $x=gensym; my $names=$o->Names(); # scalar context same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 1", $o ); my $foo = do{ require Symbol; Symbol::gensym }; EXPECT my @names=$o->Names(); # scalar context same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 2", $o ); my $foo = do{ require Symbol; Symbol::gensym }; EXPECT $o->Names(); same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 3", $o ); my $GLOB1 = do{ require Symbol; Symbol::gensym }; EXPECT #local $Data::Dump::Streamer::DEBUG=1; $x=\gensym; # *$$x = $x; *$$x = $names; *$$x = { Thank => '[ysth]', Grr => bless \gensym,'Foo' }; #Devel::Peek::Dump $x same( scalar $o->Data( $x )->Out(),<<'EXPECT', "Symbol 4", $o ); my $REF1 = \do{ require Symbol; Symbol::gensym }; *$$REF1 = { Grr => bless( \Symbol::gensym, 'Foo' ), Thank => '[ysth]' }; *$$REF1 = [ 'foo', 'bar', 'baz' ]; *$$REF1 = $REF1; EXPECT } { same( my $dump=$o->Data(*{gensym()})->Out, <<'EXPECT', "Symbol 5", $o ); my $VAR1 = *{ do{ require Symbol; Symbol::gensym } }; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/names.t000444001750001750 4014112636703716 16775 0ustar00yortonyorton000000000000use Test::More tests => 50; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); } use strict; use warnings; use Data::Dumper; #$Id: names.t 26 2006-04-16 15:18:52Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); # Make sure Dump($var)->Names($name)->Out() works... is (scalar(Dump(@{[0,1]})->Names('foo','bar')->Out()),"\$foo = 0;\n\$bar = 1;\n",'Dump()->Names()'); { same( "Named", $o->Declare(0)->Names('x','y'), <<'EXPECT', ( @{[ 0 , 1 ]} ) ); $x = 0; $y = 1; EXPECT } { my $s=0; my $a=[]; my $h={}; my $c=sub{1}; same( "Named Vars ", $o->Declare(0)->Names('*s','*a','*h','*c'), <<'EXPECT', ( $s,$a,$h,$c ) ); $s = 0; @a = (); %h = (); sub c { 1; }; EXPECT #local $Data::Dump::Streamer::DEBUG=0; same( "Named Vars Refs", $o->Declare(0)->Names('*s','*a','*h','*c'), <<'EXPECT', ( $s,$a,$h,$c, ),\( $s,$a,$h,$c, ) ); $s = 0; @a = (); %h = (); sub c { 1; }; $SCALAR1 = \$s; $REF1 = \\@a; $REF2 = \\%h; $REF3 = \\&c; EXPECT #$o->diag; } { my $z=[1,2,3]; my $x=\$z->[0]; my $y=\$z->[2]; same( "Named() two", $o->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) ); @z = ( 1, 2, 3 ); $x = \$z[0]; $y = \$z[2]; EXPECT #local $Data::Dump::Streamer::DEBUG=1; same( "Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) ); $x = 'R: $z[0]'; $y = 'R: $z[2]'; @z = ( 1, 2, 3 ); $x = \$z[0]; $y = \$z[2]; EXPECT } { my ($a,$b); $a = [{ a => \$b }, { b => undef }]; $b = [{ c => \$b }, { d => \$a }]; same( "Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) ); @prime = ( { a => \$ref }, { b => undef } ); $ref = [ { c => $prime[0]{a} }, { d => \\@prime } ]; EXPECT same( "Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) ); $prime = [ { a => \\@ref }, { b => undef } ]; @ref = ( { c => $prime->[0]{a} }, { d => \$prime } ); EXPECT same( "Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) ); @prime = ( { a => \\@ref }, { b => undef } ); @ref = ( { c => $prime[0]{a} }, { d => \\@prime } ); EXPECT #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($a,$b); $a = [undef, { b => undef }]; $b = [undef, { d => $a }]; $b->[0]={ c => $b }; $a->[0]={ a => $b }; same( "Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) ); @prime = ( { a => 'V: $ref' }, { b => undef } ); $ref = [ { c => 'V: $ref' }, { d => \@prime } ]; $prime[0]{a} = $ref; $ref->[0]{c} = $ref; EXPECT same( "Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) ); $prime = [ { a => \@ref }, { b => undef } ]; @ref = ( { c => \@ref }, { d => $prime } ); EXPECT same( "Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) ); @prime = ( { a => \@ref }, { b => undef } ); @ref = ( { c => \@ref }, { d => \@prime } ); EXPECT #print $o->diag; } { same( "Declare Named()", $o->Declare(1)->Names('x','y'), <<'EXPECT', ( @{[ 0 , 1 ]} ) ); my $x = 0; my $y = 1; EXPECT } { my $z=[1,2,3]; my $x=\$z->[0]; my $y=\$z->[2]; same( "Declare Named() two", $o->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) ); my @z = ( 1, 2, 3 ); my $x = \$z[0]; my $y = \$z[2]; EXPECT same( "Declare Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) ); my $x = 'R: $z[0]'; my $y = 'R: $z[2]'; my @z = ( 1, 2, 3 ); $x = \$z[0]; $y = \$z[2]; EXPECT } { #local $Data::Dump::Streamer::DEBUG=1; my ($a,$b); $a = [{ a => \$b }, { b => undef }]; $b = [{ c => \$b }, { d => \$a }]; same( "Declare Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) ); my @prime = ( { a => 'R: $ref' }, { b => undef } ); my $ref = [ { c => 'V: $prime[0]{a}' }, { d => \\@prime } ]; $prime[0]{a} = \$ref; $ref->[0]{c} = $prime[0]{a}; EXPECT same( "Declare Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) ); my $prime = [ { a => \do { my $v = 'V: @ref' } }, { b => undef } ]; my @ref = ( { c => $prime->[0]{a} }, { d => \$prime } ); ${$prime->[0]{a}} = \@ref; EXPECT same( "Declare Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) ); my @prime = ( { a => \do { my $v = 'V: @ref' } }, { b => undef } ); my @ref = ( { c => $prime[0]{a} }, { d => \\@prime } ); ${$prime[0]{a}} = \@ref; EXPECT #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($a,$b); $a = [undef, { b => undef }]; $b = [undef, { d => $a }]; $b->[0]={ c => $b }; $a->[0]={ a => $b }; same( "Declare Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) ); my @prime = ( { a => 'V: $ref' }, { b => undef } ); my $ref = [ { c => 'V: $ref' }, { d => \@prime } ]; $prime[0]{a} = $ref; $ref->[0]{c} = $ref; EXPECT same( "Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) ); my $prime = [ { a => 'V: @ref' }, { b => undef } ]; my @ref = ( { c => 'V: @ref' }, { d => $prime } ); $prime->[0]{a} = \@ref; $ref[0]{c} = \@ref; EXPECT same( "Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) ); my @prime = ( { a => 'V: @ref' }, { b => undef } ); my @ref = ( { c => 'V: @ref' }, { d => \@prime } ); $prime[0]{a} = \@ref; $ref[0]{c} = \@ref; EXPECT #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [($x={ a => \$y }), { b => undef }]; $y = [{ c => \$y }, ({ d => \$z })]; same( "Hash Named Harder", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( a => \$ref ); $ref = [ { c => $prime{a} }, { d => \[ \%prime, { b => undef } ] } ]; EXPECT same( "Hash Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $y,$x ) ); $prime = [ { c => 'V: $ref{a}' }, { d => \[ \%ref, { b => undef } ] } ]; %ref = ( a => \$prime ); $prime->[0]{c} = $ref{a}; EXPECT same( "Hash Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( a => \\@ref ); @ref = ( { c => $prime{a} }, { d => \[ \%prime, { b => undef } ] } ); EXPECT #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = [undef, { d => $z }]; $x=$y->[0]={ c => $y }; $z->[0]={ a => $y }; same( "Hash Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => 'V: $ref' ); $ref = [ \%prime, { d => [ { a => 'V: $ref' }, { b => undef } ] } ]; $prime{c} = $ref; $ref->[1]{d}[0]{a} = $ref; EXPECT same( "Hash Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); $prime = { c => \@ref }; @ref = ( $prime, { d => [ { a => \@ref }, { b => undef } ] } ); EXPECT same( "Hash Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => \@ref ); @ref = ( \%prime, { d => [ { a => \@ref }, { b => undef } ] } ); EXPECT #print $o->diag; } { my $z={0..3}; my $x=\$z->{0}; my $y=\$z->{2}; same( "Hash Declare Named() two", $o->Declare(1)->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) ); my %z = ( 0 => 1, 2 => 3 ); my $x = \$z{0}; my $y = \$z{2}; EXPECT same( "Hash Declare Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) ); my $x = 'R: $z{0}'; my $y = 'R: $z{2}'; my %z = ( 0 => 1, 2 => 3 ); $x = \$z{0}; $y = \$z{2}; EXPECT } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [($x={ a => \$y }), { b => undef }]; $y = [{ c => \$y }, { d => \$z }]; same( "Hash Declare Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( a => 'R: $ref' ); my $ref = [ { c => 'V: $prime{a}' }, { d => \[ \%prime, { b => undef } ] } ]; $prime{a} = \$ref; $ref->[0]{c} = $prime{a}; EXPECT same( "Hash Declare Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); my $prime = { a => \do { my $v = 'V: @ref' } }; my @ref = ( { c => $prime->{a} }, { d => \[ $prime, { b => undef } ] } ); ${$prime->{a}} = \@ref; EXPECT same( "Hash Declare Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( a => \do { my $v = 'V: @ref' } ); my @ref = ( { c => $prime{a} }, { d => \[ \%prime, { b => undef } ] } ); ${$prime{a}} = \@ref; EXPECT #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = [undef, { d => $z }]; $x=$y->[0]={ c => $y }; $z->[0]={ a => $y }; same( "Hash Declare Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => 'V: $ref' ); my $ref = [ \%prime, { d => [ { a => 'V: $ref' }, { b => undef } ] } ]; $prime{c} = $ref; $ref->[1]{d}[0]{a} = $ref; EXPECT same( "Hash Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); my $prime = { c => 'V: @ref' }; my @ref = ( $prime, { d => [ { a => 'V: @ref' }, { b => undef } ] } ); $prime->{c} = \@ref; $ref[1]{d}[0]{a} = \@ref; EXPECT same( "Hash Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => 'V: @ref' ); my @ref = ( \%prime, { d => [ { a => 'V: @ref' }, { b => undef } ] } ); $prime{c} = \@ref; $ref[1]{d}[0]{a} = \@ref; EXPECT $o->Declare(0); #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = bless [undef, { d => $z }],'bar'; $x=bless(($y->[0]={ c => $y }),'foo'); $z->[0]={ a => $y }; same( "Blessed Declare Named Simpler", $o->Declare(1)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => 'V: $ref' ); my $ref = bless( [ bless( \%prime, 'foo' ), { d => [ { a => 'V: $ref' }, { b => undef } ] } ], 'bar' ); $prime{c} = $ref; $ref->[1]{d}[0]{a} = $ref; EXPECT same( "Blessed Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); my $prime = bless( { c => 'V: @ref' }, 'foo' ); my @ref = ( $prime, { d => [ { a => 'V: @ref' }, { b => undef } ] } ); $prime->{c} = bless( \@ref, 'bar' ); $ref[1]{d}[0]{a} = bless( \@ref, 'bar' ); EXPECT same( "Blessed Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => 'V: @ref' ); my @ref = ( bless( \%prime, 'foo' ), { d => [ { a => 'V: @ref' }, { b => undef } ] } ); $prime{c} = bless( \@ref, 'bar' ); $ref[1]{d}[0]{a} = bless( \@ref, 'bar' ); EXPECT $o->Declare(0); #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = bless [undef, { d => $z }],'bar'; $x=bless(($y->[0]={ c => $y }),'foo'); $z->[0]={ a => $y }; same( "Blessed Named Simpler", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => 'V: $ref' ); $ref = bless( [ bless( \%prime, 'foo' ), { d => [ { a => 'V: $ref' }, { b => undef } ] } ], 'bar' ); $prime{c} = $ref; $ref->[1]{d}[0]{a} = $ref; EXPECT same( "Blessed Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); $prime = bless( { c => bless( \@ref, 'bar' ) }, 'foo' ); @ref = ( $prime, { d => [ { a => bless( \@ref, 'bar' ) }, { b => undef } ] } ); EXPECT same( "Blessed Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => bless( \@ref, 'bar' ) ); @ref = ( bless( \%prime, 'foo' ), { d => [ { a => bless( \@ref, 'bar' ) }, { b => undef } ] } ); EXPECT $o->Declare(0); #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = bless [undef, { d => \$z }],'bar'; $x=bless(($y->[0]={ c => \$y }),'foo'); $z->[0]={ a => \$y }; same( "Harder Blessed Named", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => \$ref ); $ref = bless( [ bless( \%prime, 'foo' ), { d => \[ { a => $prime{c} }, { b => undef } ] } ], 'bar' ); EXPECT same( "Harder Blessed Named Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); $prime = bless( { c => \bless( \@ref, 'bar' ) }, 'foo' ); @ref = ( $prime, { d => \[ { a => $prime->{c} }, { b => undef } ] } ); EXPECT same( "Harder Blessed Named Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); %prime = ( c => \bless( \@ref, 'bar' ) ); @ref = ( bless( \%prime, 'foo' ), { d => \[ { a => $prime{c} }, { b => undef } ] } ); EXPECT $o->Declare(0); #print $o->diag; } { #local $Data::Dump::Streamer::DEBUG=1; my ($x,$y,$z); $z = [undef, { b => undef }]; $y = bless [undef, { d => \$z }],'bar'; $x=bless(($y->[0]={ c => \$y }),'foo'); $z->[0]={ a => \$y }; same( "Declare Harder Blessed Named", $o->Declare(1)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => 'R: $ref' ); my $ref = bless( [ bless( \%prime, 'foo' ), { d => \[ { a => 'V: $prime{c}' }, { b => undef } ] } ], 'bar' ); $prime{c} = \$ref; ${$ref->[1]{d}}->[0]{a} = $prime{c}; EXPECT same( "Declare Harder Blessed Named Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) ); my $prime = bless( { c => \do { my $v = 'V: @ref' } }, 'foo' ); my @ref = ( $prime, { d => \[ { a => $prime->{c} }, { b => undef } ] } ); ${$prime->{c}} = bless( \@ref, 'bar' ); EXPECT same( "Declare Harder Blessed Named Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) ); my %prime = ( c => \do { my $v = 'V: @ref' } ); my @ref = ( bless( \%prime, 'foo' ), { d => \[ { a => $prime{c} }, { b => undef } ] } ); ${$prime{c}} = bless( \@ref, 'bar' ); EXPECT $o->Declare(0); #print $o->diag; } { my $x=[]; push @$x,\$x; same( "Doc Array Self ref", $o->Names('*x')->Declare(0), <<'EXPECT', ( $x ) ); @x = ( \\@x ); EXPECT } #Dump->Names('*x')->Out($x); __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/madness.t000444001750001750 2506612636703716 17335 0ustar00yortonyorton000000000000use Test::More tests => 7; #$Id: madness.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { local *icky; *icky=\ "icky"; our $icky; my $id = 0; my $btree; $btree = sub { my ( $d, $m, $p ) = @_; return $p if $d > $m; return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ]; }; my $t = $btree->( 0, 1, '' ); my ( $x, $y, $qr ); $x = \$y; $y = \$x; $qr = bless qr/this is a test/m, 'foo_bar'; my $array = []; my $hash = bless { A => \$array, 'B-B' => ['$array'], 'CCCD' => [ 'foo', 'bar' ], 'E'=>\\1, 'F'=>\\undef, 'Q'=>sub{\@_}->($icky), }, 'ThisIsATest'; $hash->{G}=\$hash; my $boo = 'boo'; @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo ); my $cap = capture( $x, $y, $qr, $x, $y, $qr ); same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) ); $ARRAY1 = [ bless( qr/this is a test/m, 'foo_bar' ), 'A: $ARRAY1->[0]' ]; alias_av(@$ARRAY1, 1, $ARRAY1->[0]); EXPECT #same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o ); same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) ); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]', 'A: $foo_bar1', 'A: $ARRAY1->[0]', 'A: $ARRAY1->[1]', 'A: $foo_bar1' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; alias_av(@$ARRAY1, 3, $ARRAY1->[0]); alias_av(@$ARRAY1, 4, $ARRAY1->[1]); $ARRAY2 = [ \$ThisIsATest1, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[0]', \$foo_bar1, 'V: $ARRAY2->[3]', \'foo', \$VAR1 ]; $ARRAY2->[1] = $ARRAY2->[0]; $ARRAY2->[2] = $ARRAY2->[0]; $ARRAY2->[4] = $ARRAY2->[3]; $VAR1 = 'boo'; $ThisIsATest1 = bless( { A => \$ARRAY2, "B-B" => [ '$array' ], CCCD => [ 'foo', 'bar' ], E => \\1, F => \\undef, G => $ARRAY2->[0], Q => [ 'icky' ] }, 'ThisIsATest' ); make_ro($ThisIsATest1->{Q}[0]); $foo_bar1 = bless( qr/this is a test/m, 'foo_bar' ); alias_av(@$ARRAY1, 2, $foo_bar1); alias_av(@$ARRAY1, 5, $foo_bar1); EXPECT } { my ($x,$y); $x=\$y; $y=\$x; my $a=[1,2]; $a->[0]=\$a->[1]; $a->[1]=\$a->[0]; #$cap->[-1]=5; my $s; $s=\$s; my $bar='bar'; my $foo='foo'; my $halias= {foo=>1,bar=>2}; alias_hv(%$halias,'foo',$foo); alias_hv(%$halias,'bar',$bar); alias_hv(%$halias,'foo2',$foo); my ($t,$u,$v,$w)=(1,2,3,4); my $cap=sub{ \@_ }->($x,$y); my $q1=qr/foo/; my $q2=bless qr/bar/,'bar'; my $q3=\bless qr/baz/,'baz'; #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o ); same( "More Madness", $o , <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; $Regexp1 = qr/foo/; $bar1 = bless( qr/bar/, 'bar' ); $REF1 = \bless( qr/baz/, 'baz' ); $ARRAY2 = [ 'R: $ARRAY5->[1]', 'R: $ARRAY5->[0]' ]; $ARRAY3 = [ \do { my $v = 'V: $ARRAY3->[0]' }, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; ${$ARRAY3->[0]} = $ARRAY3->[0]; $VAR1 = 1; $VAR2 = 2; $VAR3 = 3; alias_ref(\$VAR4,\$VAR1); $ARRAY4 = [ 1, 2, 3 ]; $HASH1 = { 1 => 2, 3 => 4 }; $ARRAY5 = [ 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; $ARRAY2->[0] = \$ARRAY5->[1]; $ARRAY2->[1] = \$ARRAY5->[0]; $ARRAY3->[1] = $ARRAY2->[0]; $ARRAY3->[2] = $ARRAY2->[1]; $ARRAY5->[0] = $ARRAY2->[0]; $ARRAY5->[1] = $ARRAY2->[1]; alias_ref(\$ARRAY6,\$ARRAY5); alias_ref(\$VAR5,\$VAR1); alias_ref(\$VAR6,\$VAR2); alias_ref(\$VAR7,\$VAR3); $HASH2 = { bar => 'bar', foo => 'foo', foo2 => 'A: $HASH2->{foo}' }; alias_hv(%$HASH2, 'foo2', $HASH2->{foo}); EXPECT } { #local $Data::Dump::Streamer::DEBUG = 1; my $x; $x = sub { \@_ }->( $x, $x ); push @$x, $x; same( "Tye Alias Array", $o, <<'EXPECT',( $x ) ); $ARRAY1 = [ 'A: $ARRAY1', 'A: $ARRAY1', 'V: $ARRAY1' ]; alias_av(@$ARRAY1, 0, $ARRAY1); alias_av(@$ARRAY1, 1, $ARRAY1); $ARRAY1->[2] = $ARRAY1; EXPECT } { undef $!; format STDOUT = @<<<<<< @││││││ @>>>>>> "left", "middle", "right" . my $expected_dot; if ( defined $. && length $. ) { $expected_dot = $.; } elsif ( defined $. ) { $expected_dot = "''"; } else { $expected_dot = 'undef'; } my %hash = ( UND => undef, IV => 1, NV => 3.14159265358979, PV => "string", PV8 => "ab\ncd\x{20ac}\t", RV => \$., AR => [ 1..2 ], HR => { key => "value" }, CR => sub { "code"; }, GLB => *STDERR, IO => *{$::{STDERR}}{IO}, FMT => \*{$::{STDOUT}}{FORMAT}, OBJ => bless(qr/("[^"]+")/,"Zorp"), ); # Dumping differences per perl version: # 5.12.0+: # # IO handles are now blessed into IO::File, I guess? # if ( $] >= 5.012_000 ) { my $expect = <<'EXPECT'; $HASH1 = { AR => [ 1, 2 ], CR => sub { use warnings; use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::File' ), IV => 1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; EXPECT require B::Deparse; if (new B::Deparse -> coderef2text ( sub { no strict; 1; use strict; 1; } ) !~ 'refs') { $expect =~ s/strict 'refs'/strict/; } same( $dump= $o->Data(\%hash)->Out, template( $expect, expected_dot => $expected_dot ), "", $o); } elsif ( $] >= 5.008_008 ) { same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o); $HASH1 = { AR => [ 1, 2 ], CR => sub { use warnings; use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; EXPECT } elsif ( $] >= 5.008_000 ) { same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o); $HASH1 = { AR => [ 1, 2 ], CR => sub { BEGIN {${^WARNING_BITS} = "UUUUUUUUUUUU"} use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; EXPECT } else { same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o); $HASH1 = { AR => [ 1, 2 ], CR => sub { 'code'; }, FMT => \do { my $v = undef }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; EXPECT } } sub template { my ( $pattern, %replacements ) = @_; for ( keys %replacements ) { $pattern =~ s/$_/$replacements{$_}/g; } return $pattern; } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/test_helper.pl000444001750001750 4113512636703716 20364 0ustar00yortonyorton000000000000use strict; use warnings; use Test::More; use Data::Dumper; use vars qw/%Has/; BEGIN { $Has{diff}=!!eval "use Algorithm::Diff qw(sdiff diff); 1"; $Has{sortkeys}=!!eval "Data::Dumper->new([1])->Sortkeys(1)->Dump()"; } #$Id: test_helper.pl 26 2006-04-16 15:18:52Z demerphq $# # all of this is acumulated junk used for making the various test easier. # as a close inspection shows, this all derives from different periods of # the module and is pretty nasty/hacky to look at. Slowly id like to convert # everything over to test_dump() and get rid of same(). sub string_diff { my ( $str1, $str2, $title1, $title2 ) = @_; $title1 ||= "Got"; $title2 ||= "Expected"; my $line = ( caller(2) )[2]; #print $str1,"\n---\n",$str2; my $seq1 = ( ref $str1 ) ? $str1 : [ split /\n/, $str1 ]; my $seq2 = ( ref $str2 ) ? $str2 : [ split /\n/, $str2 ]; # im sure theres a more elegant way to do all this as well my @array; my $are_diff; Algorithm::Diff::traverse_sequences( $seq1, $seq2, { MATCH => sub { my ( $t, $u ) = @_; push @array, [ '=', $seq1->[$t], $t, $u ]; }, DISCARD_A => sub { my ( $t, $u ) = @_; push @array, [ '-', $seq1->[$t], $t, $u ]; $are_diff++; }, DISCARD_B => sub { my ( $t, $u ) = @_; push @array, [ '+', $seq2->[$u], $t, $u ]; $are_diff++; }, } ); return "" unless $are_diff; my $return = "-$title1\n+$title2\n"; #especially this bit. my ( $last, $skipped ) = ( "=", 1 ); foreach ( 0 .. $#array ) { my $elem = $array[$_]; my ( $do, $str, $pos, $eq ) = @$elem; if ( $do eq $last && $do eq '=' && ( $_ < $#array && $array[ $_ + 1 ][0] eq "=" || $_ == $#array ) ) { $skipped = 1; next; } $str .= "\n" unless $str =~ /\n\z/; if ($skipped) { $return .= sprintf( "\@%d,%d (%d)\n", $eq + 1, $pos + 1, $line + $eq + 1 ); $skipped = 0; } $last = $do; $return .= join ( "", $do, " ", $str ); } return $return; } sub capture { \@_ } sub _similar { my ( $str1, $str2, $name, $obj ) = @_; s/\s+$//gm for $str1, $str2; s/\r\n/\n/g for $str1, $str2; s/\(0x[0-9a-xA-X]+\)/(0xdeadbeef)/g for $str1, $str2; my @vars = $str2 =~ m/^(?:my\s*)?(\$\w+)\s*=/gm; #warn "@vars"; my $text = "\n" . $str1; my $pat = "\n" . $str2; unless ( like( $text, $pat ) ) { if ( $] >= 5.012 ) { eval qq{ use re qw( Debug EXECUTE ); \$text =~ \$pat; 1; } or die $@; } $obj->diag; } } sub _same { my ( $str1, $str2, $name, $obj ) = @_; s/\s+$//gm for $str1, $str2; s/\r\n/\n/g for $str1, $str2; s/\(0x[0-9a-xA-X]+\)/(0xdeadbeef)/g for $str1, $str2; my @vars = $str2 =~ m/^(?:my\s*)?(\$\w+)\s*=/gm; for ($str1, $str2) { s/^\s+# use warnings;\n//mg; s/^\s+# use strict[^;]*;\n//mg; s/# ;/#/g; } #warn "@vars"; unless ( ok( "\n" . $str1 eq "\n" . $str2, $name ) ) { if ( $str2 =~ /\S/ ) { eval { print string_diff( "\n" . $str2, "\n" . $str1, "Expected", "Result" ); print "Got:\n" . $str1 . "\n"; 1; } or do { print "Expected:\n$str2\nGot:\n$str1\n"; } } else { print $str1, "\n"; } $obj->diag; } } { my $version=""; my %errors; my @errors=(''); sub _dumper { my ($todump)=@_; my $dump; my $error= ""; foreach my $use_perl (1) { my $warned=""; local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; $dump=eval { scalar Data::Dumper->new( $todump )->Purity(1)->Sortkeys(1)->Quotekeys(1)->Useperl($use_perl)->Dump() }; if ( !$@ ) { normalize($dump); return ($dump, $error . $warned); } else { unless ($version) { $version="\tSomething is wrong with Data::Dumper v" . Data::Dumper->VERSION . "\n"; $error= $version; } my $msg=$@.$warned; unless ($errors{$msg}) { (my $err=$msg)=~s/^/\t/g; push @errors,$msg; $errors{$msg}=$#errors; $error.=sprintf "\tData::Dumper (Useperl==$use_perl) Error(%#d):\n\t%s", $#errors,$err; } else { $error.=sprintf "\tData::Dumper (Useperl==$use_perl) Error %#d\n",$errors{$msg}; } next } } #warn $error; return ($dump,$error); } } sub vstr {Data::Dump::Streamer::__vstr(@_)} our $Clean; sub normalize { my @x=@_; foreach (@x) { #warn "\n$_\n"; s/^\s*(no|use).*\n//gm; s/^\s*BEGIN\s*\{.*\}\n//gm; s/\A(?:\s*(?:#\*\.*)?\n)+//g; if (/^\s+(#\s*)/) { my $ind=$1; s/^\s+$ind//gm; } s/\(0x[0-9a-fA-F]+\)/(0xdeadbeef)/g; s/\r\n/\n/g; s/\s+$//gm; s{\\\\undef}{\\do { my \$v = \\do { my \$v = undef } }}g if $] < 5.020; $_.="\n"; #warn "\n$_\n"; } unless (defined wantarray) { $_[$_-1]=$x[$_-1] for 1..@_; } wantarray ? @x : $x[0] } sub similar { goto &_similar unless ref( $_[1] ); my $name = shift; my $obj = shift; my ($expect,$result) = normalize(shift, scalar $obj->Data(@_)->Out()); my $main_pass = like( "\n$result", "\n$expect" ); if ( ! $main_pass ) { $obj->diag; } my @declare=grep { /^[\$\@\%]/ } @{$obj->{declare}}; my @dump =map { /^[\@\%\&]/ ? "\\$_" : $_ } @{$obj->{out_names}}; my $dumpvars=join ( ",", @dump ); print $result,"\n" if $name=~/Test/; my ($dumper,$error) = _dumper(\@_); if ($error) { diag( "$name\n$error" ) if $ENV{TEST_VERBOSE}; } if ($dumper) { my $result2_eval = $result . "\n" . 'scalar( $obj->Data(' . $dumpvars . ")->Out())\n"; my $dd_result_eval = $result . "\nscalar(Data::Dumper->new(" . 'sub{\@_}->(' . $dumpvars . ")" . ")->Purity(1)->Sortkeys(1)->Quotekeys(1)->" . "Useperl(1)->Dump())\n"; unless ( $obj->Declare ) { $dd_result_eval = "my(" . join ( ",", @declare ) . ");\n" . $dd_result_eval; $result2_eval = "my(" . join ( ",", @declare ) . ");\n" . $result2_eval; } foreach my $test ( [ "Data::Dumper", $dd_result_eval, $dumper ], [ "Data::Dump::Streamer", $result2_eval, $result ] ) { my ( $test_name, $eval, $orig ) = @$test; my ($warned,$res); { local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; $res = eval $eval; if ($warned) { print "Eval $test_name produced warnings:$warned\n$eval" }; } normalize($res); my $fail = 0; if ($@) { print join "\n", "Failed $test_name eval()", $eval, $@, ""; $fail = 1; } elsif ( $res ne $orig ) { print "Failed $test_name second time\n"; eval { print string_diff( $orig, $res, "Orig", "Result" ) }; print "Orig:\n$orig\nResult:\n$res\nEval:\n$eval\n"; $fail = 1; } $obj->diag if $fail; return fail($name) if $fail; } #print join "\n",$result,$result2,$dumper,$dd_result,""; } ok( $main_pass, $name ) } sub same { goto &_same unless ref( $_[1] ); my $name = shift; my $obj = shift; my ($expect,$result) = normalize(shift, scalar $obj->Data(@_)->Out()); my $main_pass; { my $r=$result; my $e=$expect; #warn "@vars"; $main_pass="\n" . $r eq "\n" . $e; unless ( $main_pass ) { if ( $e =~ /\S/ ) { eval { print string_diff( "\n" . $e, "\n" . $r, "Expected", "Result" ); print "$name Got:\n" . $r . "\nEXPECT\n"; } or do { print "$name Expected:\n$e\nGot:\n$r\n"; } } else { print $r, "\n"; } $obj->diag; } } my @declare=grep { /^[\$\@\%]/ } @{$obj->{declare}}; my @dump =map { /^[\@\%\&]/ ? "\\$_" : $_ } @{$obj->{out_names}}; my $dumpvars=join ( ",", @dump ); print $result,"\n" if $name=~/Test/; my ($dumper,$error) = _dumper(\@_); if ($error) { diag( "$name\n$error" ) if $ENV{TEST_VERBOSE}; } if ($dumper) { my $result2_eval = $result . "\n" . 'scalar( $obj->Data(' . $dumpvars . ")->Out())\n"; my $dd_result_eval = $result . "\nscalar(Data::Dumper->new(" . 'sub{\@_}->(' . $dumpvars . ")" . ")->Purity(1)->Sortkeys(1)->Quotekeys(1)->" . "Useperl(1)->Dump())\n"; unless ( $obj->Declare ) { $dd_result_eval = "my(" . join ( ",", @declare ) . ");\n" . $dd_result_eval; $result2_eval = "my(" . join ( ",", @declare ) . ");\n" . $result2_eval; } foreach my $test ( [ "Data::Dumper", $dd_result_eval, $dumper ], [ "Data::Dump::Streamer", $result2_eval, $result ] ) { my ( $test_name, $eval, $orig ) = @$test; my ($warned,$res); { local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; $res = eval $eval; if ($warned) { print "Eval $test_name produced warnings:$warned\n$eval" }; } normalize($res); my $fail = 0; if ($@) { print join "\n", "Failed $test_name eval()", $eval, $@, ""; $fail = 1; } elsif ( $res ne $orig ) { print "Failed $test_name second time\n"; eval { print string_diff( $orig, $res, "Orig", "Result" ) }; print "Orig:\n$orig\nResult:\n$res\nEval:\n$eval\n"; $fail = 1; } $obj->diag if $fail; return fail($name) if $fail; } #print join "\n",$result,$result2,$dumper,$dd_result,""; } ok( $main_pass, $name ) } =pod test_dump( "Name", $obj, @vars, $expect ) =cut my %Methods=( 'Data::Dumper'=>'->new(sub{\\@_}->(@_))'. '->Purity(1)'. '->Sortkeys(1)'. '->Quotekeys(1)'. '->Useperl(1)'. '->Dump()', 'Data::Dump::Streamer'=>'->Data(@_)->Out()', ); use constant NO_EVAL=>''; sub _dmp { my $obj=shift; my $eval=shift; my $class=ref($obj) || $obj; my $objname=ref($obj) ? '$obj' : $obj; my @lines; my $method=$Methods{$class}; if ($eval) { return @$eval if @$eval!=1; my ($names,$declare,%arg)=@_; my @declare= grep { /^[\$\@\%]/ } @$declare; my @to_dump= map { /^[\@\%\&]/ ? "\\$_" : $_ } @$names; my $decl=@$declare ? "my(" . join ( ",", @declare ) . ");" : ""; push @lines,$decl,$arg{pre_eval},$eval->[0],$arg{post_eval}; $method=~s/\(\@_\)/"(".join (", ",@to_dump).")"/ge; } push @lines,"normalize ( scalar $objname$method )"; my $eval_str=join ";\n",map { !$_ ? () : (s/[\s;]+\z//g || 1) && $_ } @lines; #print "\n---\n",$eval_str,"\n---\n"; my $res; { my @w; { local $SIG{__WARN__}=sub { push @w,join "",@_; ""}; $res=eval $eval_str; } warn "Test $class$method produced warnings. Code:\n$eval_str\nWarnings:\n".join("\n",@w)."\n" if @w; return ($res,"$class$method failed dump:\n$eval_str\n$@") if $@; } return ($res); } my %ldchar=(u=>'=','+'=>'+','-'=>'-','c'=>'!'); my %mdchar=(u=>'|','+'=>'>','-'=>'<','c'=>'*'); sub _my_diff { my ($e,$g,$mode)=@_; unless ($Has{diff}) { if ($e ne $g) { return join "\n","Expected:",$e,"Got:",$g,"" } else { return } } my @exp=split /\n/,$e; my @got=split /\n/,$g; my $line=0; my $diff=0; my $lw=length('Expected'); my $u=3; my @buff; my @lines=map{ if ($_->[0]ne'u') { $diff=1; $u=0; } else { $u++; } $lw=length $_->[1] if $lw < length $_->[1]; unshift @$_,$line++; if ($u<3) { my @r=$u==0 && @buff ? (@buff,$_) : ($_); @buff=() unless $u; @r } else { shift @buff if @buff>=2; push @buff,$_; (); } } sdiff(\@exp,\@got); my $as_str=join("\n", sprintf("%7s%*s%3s%s",'',-$lw,'Expected','','Result'), map { sprintf "%4d %1s %*s %1s %s", $_->[0],$ldchar{$_->[1]}, -$lw,$_->[2]||'',$mdchar{$_->[1]}, $_->[3]||'' } @lines)."\n"; return $diff ? $as_str : ''; } sub _eq { my ($exp,$res,$test,$name)=@_; my ($exp_err,$res_err); # if they are arrays then they from tests involving _dmp # but if they are empty then the test isnt performed and # we can forget it return 1 if ref $exp and !@$exp or ref($res) and !@$res; ($exp,$exp_err)=@$exp if ref $exp; ($res,$res_err)=@$res if ref $res; # the thing we are trying to compare against was a failure # so assume we suceed. (or rather the test cant be counted) return 1 if $exp_err; # result was a failure if ($res_err) { if ($test->{verbose}) { diag "Error:\n$test->{name} subtest $name:\n",$res_err; } return 0 } # finally both $exp and $res should hold results my $diff=_my_diff($exp,$res); if ($diff && $test->{verbose}) { diag "Error:\n$test->{name} subtest $name failed to return the expected result:\n", $diff } return !$diff; } # eventually id like to move everything over to this. # test_dump( {name=>"merlyns test 2", # verbose=>1}, $o, ( \\@a ), # <<'EXPECT', ); $::Pre_Eval = ""; $::Post_Eval = ""; $::No_Dumper = 0; $::No_Redump = 0; sub test_dump { my $test = shift; my $obj = shift; my $exp = normalize(pop @_); # vars are now left in @_ $test = { name => $test, } unless ref $test; $test->{pre_eval}= $::Pre_Eval unless exists $test->{pre_eval}; $test->{post_eval}= $::Post_Eval unless exists $test->{post_eval}; $test->{no_dumper}= $::No_Dumper unless exists $test->{no_dumper}; $test->{no_redump}= $::No_Redump unless exists $test->{no_redump}; $test->{verbose} = 1 if not exists $test->{verbose} and $ENV{TEST_VERBOSE}; $test->{no_dumper} = 1 if !$Has{sortkeys}; my @res=_dmp($obj,NO_EVAL,@_); if (@res==2) { diag "Error:\n",$res[1]; fail($test->{name}); return } my $to_dump=$obj->{out_names}; my $to_decl=$obj->Declare ? [] : $obj->{declare}||[]; my @dmp =!$test->{no_dumper} ? _dmp('Data::Dumper',NO_EVAL,@_) : (); if (@dmp==2 and $test->{verbose}) { diag "Error:\n",$dmp[1]; } my @reres=!$test->{no_redump} ? _dmp($obj,\@res,$to_dump,$to_decl,pre_eval=>$test->{pre_eval},post_eval=>$test->{post_eval}) : (); my @redmp=!$test->{no_redump} && !$test->{no_dumper} ? _dmp('Data::Dumper',\@res,$to_dump,$to_decl,pre_eval=>$test->{pre_eval},post_eval=>$test->{post_eval}) : (); my $ok= @dmp<2 && _eq($exp, \@res,$test,"Expected") && _eq($exp, \@reres,$test,"Second time") && _eq(\@dmp,\@redmp,$test,"Both Dumper's same "); unless ($ok) { warn "Got <<'EXPECT';\n$res[0]\nEXPECT\n"; } ok( $ok, $test->{name} ); } 1; Data-Dump-Streamer-2.39/t/filter.t000444001750001750 1011212636703716 17152 0ustar00yortonyorton000000000000use Test::More tests => 11; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; #$Id: filter.t 26 2006-04-16 15:18:52Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { my $ig=bless {},"Ignore"; my %h=(One=>1,Two=>2,Three=>$ig); same( $dump = $o->Ignore('Ignore'=>1)->Data( \%h )->Out, <<'EXPECT', "Ignore(1)", $o ); $HASH1 = { One => 1, Three => 'Ignored Obj [Ignore=HASH(0x24b89cc)]', Two => 2 }; EXPECT same( $dump = $o->Ignore('Ignore'=>0)->Data( \%h )->Out, <<'EXPECT', "Ignore(0)", $o ); $HASH1 = { One => 1, Three => bless( {}, 'Ignore' ), Two => 2 }; EXPECT } { #$Data::Dump::Streamer::DEBUG=1; sub Water::DDS_freeze { my ($self)=@_; return bless(\do{my $x=join "-",@$self},ref $self), 'DDS_thaw'; } sub Water::DDS_thaw { my ($self)=@_; $_[0]= bless([ map {split /-/,$_ } $$self ],ref $self); } sub Water::Freeze { my ($self)=@_; return bless(\do{my $x=join "-",@$self},ref $self), '->DDS_thaw'; } sub Juice::Freeze { my ($self)=@_; return bless(\do{my $x=join "-",@$self},ref $self), 'Thaw'; } sub Juice::Thaw { my ($self)=@_; $_[0]= bless([ map {split /-/,$_ } $$self ],ref $self); } my $ig=bless ["A".."D"],"Water"; my %h=(One=>1,Two=>2,Three=>$ig); same( $dump = $o->Data( \%h )->Out, <<'EXPECT', "FreezeThaw", $o ); $HASH1 = { One => 1, Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' ), Two => 2 }; $HASH1->{Three}->DDS_thaw(); EXPECT { no warnings 'redefine'; local *Water::DDS_freeze=sub { return }; same( $dump = $o->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 2", $o ); $HASH1 = { One => 1, Three => bless( [ 'A', 'B', 'C', 'D' ], 'Water' ), Two => 2 }; EXPECT } { same( $dump = $o->Freezer('Freeze')->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 3", $o ); $HASH1 = { One => 1, Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' )->DDS_thaw(), Two => 2 }; EXPECT } { same( $dump = $o->Freezer('')->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 3", $o ); $HASH1 = { One => 1, Three => bless( [ 'A', 'B', 'C', 'D' ], 'Water' ), Two => 2 }; EXPECT } { same( $dump = $o->ResetFreezer()->Data( \%h )->Out, <<'EXPECT', "ResetFreezer()", $o ); $HASH1 = { One => 1, Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' ), Two => 2 }; $HASH1->{Three}->DDS_thaw(); EXPECT } } { my $x=bless [],'CIO'; my $y={x=>$x}; $x->[0]=$y; my $nope=0; sub CIO::DDS_freeze { my $self=shift; return if $nope; return { x0 => $self->[0] },'Unfreeze()' } same( $dump = $o->Data( $x,$y )->Out, <<'EXPECT', "freeze/circular", $o ); $CIO1 = { x0 => 'V: $HASH1' }; $HASH1 = { x => 'V: $CIO1' }; $CIO1->{x0} = $HASH1; Unfreeze( $CIO1 ); $HASH1->{x} = $CIO1; EXPECT $nope=1; same( $dump = $o->Data( $x,$y )->Out, <<'EXPECT', "nofreeze / circular", $o ); $CIO1 = bless( [ 'V: $HASH1' ], 'CIO' ); $HASH1 = { x => $CIO1 }; $CIO1->[0] = $HASH1; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/hardrefs.t000444001750001750 667212636703716 17463 0ustar00yortonyorton000000000000use Test::More tests => 16; #$Id: hardrefs.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { # Hard Refs my $array = []; my $hash = {A => \$array}; @$array = ( \$hash ); my $top = [ $array, $hash ]; #same( $dump = $o->Data($top)->Out, <<'EXPECT', "Hard Refs", $o ); same( "Hard Refs", $o ,<<'EXPECT', ( $top ) ); $ARRAY1 = [ [ \do { my $v = 'V: $ARRAY1->[1]' } ], { A => \do { my $v = 'V: $ARRAY1->[0]' } } ]; ${$ARRAY1->[0][0]} = $ARRAY1->[1]; ${$ARRAY1->[1]{A}} = $ARRAY1->[0]; EXPECT same( "Hard Refs Two", $o, <<'EXPECT', ( $array, $hash ) ); $ARRAY1 = [ \$HASH1 ]; $HASH1 = { A => \$ARRAY1 }; EXPECT same("Hard Refs Three", $o->Declare(1), <<'EXPECT',( $array, $hash ) ); my $ARRAY1 = [ 'R: $HASH1' ]; my $HASH1 = { A => \$ARRAY1 }; $ARRAY1->[0] = \$HASH1; EXPECT ; same( "Hard Refs Five", $o->Declare(1), <<'EXPECT', ( $hash,$array, ) ); my $HASH1 = { A => 'R: $ARRAY1' }; my $ARRAY1 = [ \$HASH1 ]; $HASH1->{A} = \$ARRAY1; EXPECT same( "Hard Refs Four", $o->Declare(0), <<'EXPECT', ( $hash, $array, ) ); $HASH1 = { A => \$ARRAY1 }; $ARRAY1 = [ \$HASH1 ]; EXPECT } { # Scalar Cross my ( $ar, $x, $y ) = ( [ 1, 2 ] ); $x = \$y; $y = \$x; $ar->[0] = \$ar->[1]; $ar->[1] = \$ar->[0]; same( "Scalar Cross One (\$ar)", $o, <<'EXPECT', ($ar) ); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; EXPECT { #local $Data::Dump::Streamer::DEBUG=1; same( "Scalar Cross Two (\$x,\$y)", $o, <<'EXPECT', ( $x, $y ) ); $REF1 = \$REF2; $REF2 = \$REF1; EXPECT } #local $Data::Dump::Streamer::DEBUG=1; same( "Scalar Cross Three [ \$x,\$y ]", $o , <<'EXPECT', [ $x, $y ] ); $ARRAY1 = [ \do { my $v = 'V: $ARRAY1->[1]' }, \do { my $v = 'V: $ARRAY1->[0]' } ]; ${$ARRAY1->[0]} = $ARRAY1->[1]; ${$ARRAY1->[1]} = $ARRAY1->[0]; EXPECT } { my $x; $x = \$x; same("Declare Leaf One ( \$x )", $o->Declare(1),<<'EXPECT',$x ); my $REF1 = 'R: $REF1'; $REF1 = \$REF1; EXPECT same( "Declare Leaf Two [ \$x ]", $o->Declare(1) , <<'EXPECT', [$x] ); my $ARRAY1 = [ \do { my $v = 'V: $ARRAY1->[0]' } ]; ${$ARRAY1->[0]} = $ARRAY1->[0]; EXPECT same( 'Declare Leaf Three ( \\$x )', $o->Declare(1), <<'EXPECT', \$x ); my $REF1 = \do { my $v = 'V: $REF1' }; $$REF1 = $REF1; EXPECT same("Leaf One ( \$x )", $o->Declare(0),<<'EXPECT',$x ); $REF1 = \$REF1; EXPECT same( "Leaf Two [ \$x ]", $o->Declare(0) , <<'EXPECT', [$x] ); $ARRAY1 = [ \do { my $v = 'V: $ARRAY1->[0]' } ]; ${$ARRAY1->[0]} = $ARRAY1->[0]; EXPECT same( 'Leaf Three ( \\$x )', $o->Declare(0), <<'EXPECT', \$x ); $REF1 = \do { my $v = 'V: $REF1' }; $$REF1 = $REF1; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/locked.t000444001750001750 1045312636703716 17136 0ustar00yortonyorton000000000000use vars qw /$TESTS/; use Test::More tests=>2+($TESTS=9); #$Id: locked.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); } use strict; use warnings; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); SKIP:{ skip "No locked hashes before 5.8.0", $TESTS if $]<5.008; skip "Can't tell which keys are locked before 5.8.1", $TESTS if $]==5.008; { my %h = ('a0'..'a9'); lock_keys(%h); test_dump( {name=>"locked_ref_keys", verbose=>1}, $o, ( \%h ), <<'EXPECT', ); $HASH1 = lock_ref_keys( { a0 => 'a1', a2 => 'a3', a4 => 'a5', a6 => 'a7', a8 => 'a9' } ); EXPECT delete (@h{qw(a2 a6)}); test_dump( {name=>"locked_ref_keys_plus", verbose=>1}, $o, ( \%h ), <<'EXPECT', ); $HASH1 = lock_ref_keys_plus( { a0 => 'a1', a4 => 'a5', a8 => 'a9' }, 'a2', 'a6' ); EXPECT } { my %h = ('a0'..'a9'); lock_keys(%h); test_dump( {name=>"locked_keys", verbose=>1}, $o->Names('*h'), ( \%h ), <<'EXPECT', ); %h = ( a0 => 'a1', a2 => 'a3', a4 => 'a5', a6 => 'a7', a8 => 'a9' ); lock_keys( %h ); EXPECT delete (@h{qw(a2 a6)}); test_dump( {name=>"locked_keys_plus", verbose=>1}, $o, ( \%h ), <<'EXPECT', ); %h = ( a0 => 'a1', a4 => 'a5', a8 => 'a9' ); lock_keys_plus( %h, 'a2', 'a6'); EXPECT $o->Names(); } { my $h = bless {'a0'..'a9'},'locked'; lock_keys(%$h); test_dump( {name=>"blessed locked_ref_keys", verbose=>1}, $o, ( \%$h ), <<'EXPECT', ); $locked1 = lock_ref_keys( bless( { a0 => 'a1', a2 => 'a3', a4 => 'a5', a6 => 'a7', a8 => 'a9' }, 'locked' ) ); EXPECT delete (@$h{qw(a2 a6)}); test_dump( {name=>"blessed locked_ref_keys_plus", verbose=>1}, $o, ( \%$h ), <<'EXPECT', ); $locked1 = lock_ref_keys_plus( bless( { a0 => 'a1', a4 => 'a5', a8 => 'a9' }, 'locked' ), 'a2', 'a6' ); EXPECT } { my $h = bless {'a0'..'a9'},'locked'; lock_keys(%$h); test_dump( {name=>"blessed locked_keys", verbose=>1}, $o->Names('*h'), ( $h,$h ), <<'EXPECT', ); %h = ( a0 => 'a1', a2 => 'a3', a4 => 'a5', a6 => 'a7', a8 => 'a9' ); $locked1 = bless( \%h, 'locked' ); lock_keys( %h ); EXPECT delete (@$h{qw(a2 a6)}); test_dump( {name=>"blessed locked_keys_plus", verbose=>1}, $o, ( $h,$h ), <<'EXPECT', ); %h = ( a0 => 'a1', a4 => 'a5', a8 => 'a9' ); $locked1 = bless( \%h, 'locked' ); lock_keys_plus( %h, 'a2', 'a6'); EXPECT $o->Names(); } { my $x=0; my %hashes=map { $_=>lock_ref_keys_plus({foo=>$_},$x++) } 1..10; lock_keys_plus(%hashes,10..19); test_dump( {name=>"blessed locked_keys_plus", verbose=>1}, $o, ( \%hashes ), <<'EXPECT', ); $HASH1 = lock_ref_keys_plus( { 1 => lock_ref_keys_plus( { foo => 1 }, 0 ), 2 => lock_ref_keys_plus( { foo => 2 }, 1 ), 3 => lock_ref_keys_plus( { foo => 3 }, 2 ), 4 => lock_ref_keys_plus( { foo => 4 }, 3 ), 5 => lock_ref_keys_plus( { foo => 5 }, 4 ), 6 => lock_ref_keys_plus( { foo => 6 }, 5 ), 7 => lock_ref_keys_plus( { foo => 7 }, 6 ), 8 => lock_ref_keys_plus( { foo => 8 }, 7 ), 9 => lock_ref_keys_plus( { foo => 9 }, 8 ), 10 => lock_ref_keys_plus( { foo => 10 }, 9 ) }, 11, 12, 13, 14, 15, 16, 17, 18, 19 ); EXPECT } }# SKIP __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/usage.t000444001750001750 153712636703716 16764 0ustar00yortonyorton000000000000our (@tests,$x,$obj,@list,$string); BEGIN { @tests=( 'Dump($x);', '$obj=Dump(); ref $obj eq "Data::Dump::Streamer"', '$obj=Dump($x); ref $obj eq "Data::Dump::Streamer"', '$obj=Dump($x)->Purity(0); ref $obj eq "Data::Dump::Streamer"', '@list=$obj->Dump; @list>0', '$obj->Purity()==0', '$string=$obj->Dump($x)->Out(); $string =~/1,/', '$string=$obj->Names("foo")->Data($x)->Dump(); $string =~/1,/ && $string=~/foo/', ); } use Test::More tests => 1+@tests; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); } use strict; use warnings; $obj=""; $x=[1..10]; for my $snippet (@tests){ my ($title)=split /;/,$snippet; @list=(); $string=""; ok(eval($snippet)&&!$@,$title) or diag @list ? "[@list]" : $string; } #$Id: usage.t 26 2006-04-16 15:18:52Z demerphq $# Data-Dump-Streamer-2.39/t/dogpound.t000444001750001750 1067612636703716 17523 0ustar00yortonyorton000000000000use Test::More tests => 11; #$Id: dogpound.t 26 2006-04-16 15:18:52Z demerphq $# BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); { our @dogs = ( 'Fido', 'Wags' ); our %kennel = ( First => \$dogs[0], Second => \$dogs[1], ); $dogs[2] = \%kennel; our $mutts = \%kennel; $mutts = $mutts; # avoid warning same( "Dog Pound 1", $o->Declare(1), <<'EXPECT', ( \@dogs,\%kennel,$mutts ) ); my $ARRAY1 = [ 'Fido', 'Wags', 'V: $HASH1' ]; my $HASH1 = { First => \$ARRAY1->[0], Second => \$ARRAY1->[1] }; $ARRAY1->[2] = $HASH1; my $HASH2 = $HASH1; EXPECT same( "Dog Pound 2",$o->Declare(1), <<'EXPECT', ( \%kennel,\@dogs,$mutts ) ); my $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; my $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; my $HASH2 = $HASH1; EXPECT same( "Dog Pound 3", $o->Declare(1), <<'EXPECT',( \%kennel,$mutts,\@dogs )); my $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; my $HASH2 = $HASH1; my $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; EXPECT same( "Dog Pound 4", $o->Declare(1), <<'EXPECT',( $mutts,\%kennel,\@dogs )); my $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; my $HASH2 = $HASH1; my $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; EXPECT same( "Dog Pound 5", $o->Declare(1), <<'EXPECT',( $mutts,\@dogs,\%kennel, ) ); my $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; my $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; my $HASH2 = $HASH1; EXPECT same( "Dog Pound 6", $o->Declare(0), <<'EXPECT',( \@dogs,\%kennel,$mutts )); $ARRAY1 = [ 'Fido', 'Wags', 'V: $HASH1' ]; $HASH1 = { First => \$ARRAY1->[0], Second => \$ARRAY1->[1] }; $ARRAY1->[2] = $HASH1; $HASH2 = $HASH1; EXPECT same( "Dog Pound 7", $o->Declare(0), <<'EXPECT',( \%kennel,\@dogs,$mutts ) ); $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; $HASH2 = $HASH1; EXPECT same( "Dog Pound 8",$o->Declare(0), <<'EXPECT', ( \%kennel,$mutts,\@dogs )); $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; $HASH2 = $HASH1; $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; EXPECT same( "Dog Pound 9", $o->Declare(0), <<'EXPECT',( $mutts,\%kennel,\@dogs ) ); $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; $HASH2 = $HASH1; $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; EXPECT same( "Dog Pound 10", $o->Declare(0), <<'EXPECT', ( $mutts,\@dogs,\%kennel, ) ); $HASH1 = { First => 'R: $ARRAY1->[0]', Second => 'R: $ARRAY1->[1]' }; $ARRAY1 = [ 'Fido', 'Wags', $HASH1 ]; $HASH1->{First} = \$ARRAY1->[0]; $HASH1->{Second} = \$ARRAY1->[1]; $HASH2 = $HASH1; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/tree.t000444001750001750 1503312636703716 16633 0ustar00yortonyorton000000000000use Test::More tests => 6; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } use strict; use warnings; use Data::Dumper; #$Id: tree.t 26 2006-04-16 15:18:52Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { sub tree { my ($nodes,$md,$t,$d,$p,$par)=@_; $t||='@'; $d||=0; $p=':' unless defined $p; if ($d<$md) { my $node; if ($t eq '%') { $node={}; push @$nodes,$node; %$node=(par=>$par, left=>tree ( $nodes,$md,$t,$d+1,$p.'0',$node), right=>tree ( $nodes,$md,$t,$d+1,$p.'1',$node) ); } else { $node=[]; push @$nodes,$node; push @$node,$par, tree ( $nodes,$md,$t,$d+1,$p.'0',$node), tree ( $nodes,$md,$t,$d+1,$p.'1',$node); } return $node; } return $p; } my (@anodes,@hnodes); my $at=tree(\@anodes,3,'@'); my $ht=tree(\@hnodes,3,'%'); same( "Parent Array Tree", $o, <<'EXPECT',( $at ) ); $ARRAY1 = [ undef, [ 'V: $ARRAY1', [ 'V: $ARRAY1->[1]', ':000', ':001' ], [ 'V: $ARRAY1->[1]', ':010', ':011' ] ], [ 'V: $ARRAY1', [ 'V: $ARRAY1->[2]', ':100', ':101' ], [ 'V: $ARRAY1->[2]', ':110', ':111' ] ] ]; $ARRAY1->[1][0] = $ARRAY1; $ARRAY1->[1][1][0] = $ARRAY1->[1]; $ARRAY1->[1][2][0] = $ARRAY1->[1]; $ARRAY1->[2][0] = $ARRAY1; $ARRAY1->[2][1][0] = $ARRAY1->[2]; $ARRAY1->[2][2][0] = $ARRAY1->[2]; EXPECT same( "Parent tree Array Nodes", $o , <<'EXPECT', ( \@anodes ) ); $ARRAY1 = [ [ undef, 'V: $ARRAY1->[1]', 'V: $ARRAY1->[4]' ], [ 'V: $ARRAY1->[0]', 'V: $ARRAY1->[2]', 'V: $ARRAY1->[3]' ], [ 'V: $ARRAY1->[1]', ':000', ':001' ], [ 'V: $ARRAY1->[1]', ':010', ':011' ], [ 'V: $ARRAY1->[0]', 'V: $ARRAY1->[5]', 'V: $ARRAY1->[6]' ], [ 'V: $ARRAY1->[4]', ':100', ':101' ], [ 'V: $ARRAY1->[4]', ':110', ':111' ] ]; $ARRAY1->[0][1] = $ARRAY1->[1]; $ARRAY1->[0][2] = $ARRAY1->[4]; $ARRAY1->[1][0] = $ARRAY1->[0]; $ARRAY1->[1][1] = $ARRAY1->[2]; $ARRAY1->[1][2] = $ARRAY1->[3]; $ARRAY1->[2][0] = $ARRAY1->[1]; $ARRAY1->[3][0] = $ARRAY1->[1]; $ARRAY1->[4][0] = $ARRAY1->[0]; $ARRAY1->[4][1] = $ARRAY1->[5]; $ARRAY1->[4][2] = $ARRAY1->[6]; $ARRAY1->[5][0] = $ARRAY1->[4]; $ARRAY1->[6][0] = $ARRAY1->[4]; EXPECT same( "Parent tree Hash", $o , <<'EXPECT',( $ht )); $HASH1 = { left => { left => { left => ':000', par => 'V: $HASH1->{left}', right => ':001' }, par => 'V: $HASH1', right => { left => ':010', par => 'V: $HASH1->{left}', right => ':011' } }, par => undef, right => { left => { left => ':100', par => 'V: $HASH1->{right}', right => ':101' }, par => 'V: $HASH1', right => { left => ':110', par => 'V: $HASH1->{right}', right => ':111' } } }; $HASH1->{left}{left}{par} = $HASH1->{left}; $HASH1->{left}{par} = $HASH1; $HASH1->{left}{right}{par} = $HASH1->{left}; $HASH1->{right}{left}{par} = $HASH1->{right}; $HASH1->{right}{par} = $HASH1; $HASH1->{right}{right}{par} = $HASH1->{right}; EXPECT same( "Parent Tree Hash Nodes", $o, <<'EXPECT', ( \@hnodes ) ); $ARRAY1 = [ { left => 'V: $ARRAY1->[1]', par => undef, right => 'V: $ARRAY1->[4]' }, { left => 'V: $ARRAY1->[2]', par => 'V: $ARRAY1->[0]', right => 'V: $ARRAY1->[3]' }, { left => ':000', par => 'V: $ARRAY1->[1]', right => ':001' }, { left => ':010', par => 'V: $ARRAY1->[1]', right => ':011' }, { left => 'V: $ARRAY1->[5]', par => 'V: $ARRAY1->[0]', right => 'V: $ARRAY1->[6]' }, { left => ':100', par => 'V: $ARRAY1->[4]', right => ':101' }, { left => ':110', par => 'V: $ARRAY1->[4]', right => ':111' } ]; $ARRAY1->[0]{left} = $ARRAY1->[1]; $ARRAY1->[0]{right} = $ARRAY1->[4]; $ARRAY1->[1]{left} = $ARRAY1->[2]; $ARRAY1->[1]{par} = $ARRAY1->[0]; $ARRAY1->[1]{right} = $ARRAY1->[3]; $ARRAY1->[2]{par} = $ARRAY1->[1]; $ARRAY1->[3]{par} = $ARRAY1->[1]; $ARRAY1->[4]{left} = $ARRAY1->[5]; $ARRAY1->[4]{par} = $ARRAY1->[0]; $ARRAY1->[4]{right} = $ARRAY1->[6]; $ARRAY1->[5]{par} = $ARRAY1->[4]; $ARRAY1->[6]{par} = $ARRAY1->[4]; EXPECT } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/t/xs_subs.t000444001750001750 725212636703716 17346 0ustar00yortonyorton000000000000 #$Id: xs_subs.t 26 2006-04-16 15:18:52Z demerphq $# use vars qw/$XTRA/; use Test::More tests=>10+($XTRA=26); BEGIN { use_ok( 'Data::Dump::Streamer', qw( Dump readonly hidden_keys legal_keys lock_keys lock_ref_keys lock_keys_plus lock_ref_keys_plus )); } # from Scalar::Util readonly.t ok(readonly(1),'readonly(1)'); my $var = 2; ok(!readonly($var),'$var = 2; readonly($var)'); ok($var == 2,'$var==2'); ok(readonly("fred"),'readonly("fred")'); $var = "fred"; ok(!readonly($var),'$var = fred; readonly($var)'); ok($var eq "fred",'$var eq "fred"'); $var = \2; ok(!readonly($var),'$var=\2; readonly($var)'); ok(readonly($$var),'readonly($$var)'); ok(!readonly(*STDOUT),'readonly(*STDOUT)'); # new SKIP:{ skip "No locked key semantics before 5.8.0", $XTRA if $]<5.008; { my %hash=map { $_ => 1 } qw( a b c d e f); delete $hash{c}; lock_keys(%hash); ok(Internals::SvREADONLY(%hash),'lock_keys'); # we do this skip here just to make sure lock_keys is correctly setup. skip "Cant tell if a key is locked in 5.8.0", $XTRA - 1 if $]==5.008; delete @hash{qw(b e)}; my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); #warn "@legal\n@keys\n"; is("@hidden","b e",'lock_keys @hidden'); is("@legal","a b d e f",'lock_keys @legal'); is("@keys","a d f",'lock_keys @keys'); } { my %hash=(0..9); lock_keys(%hash); ok(Internals::SvREADONLY(%hash),'lock_keys'); Hash::Util::unlock_keys(%hash); ok(!Internals::SvREADONLY(%hash),'unlock_keys'); } { my %hash=(0..9); lock_keys(%hash,keys(%hash),'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_keys args'); my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); is("@hidden","a b c d e f",'lock_keys() @hidden'); is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal'); is("@keys","0 2 4 6 8",'lock_keys() @keys'); } { my %hash=map { $_ => 1 } qw( a b c d e f); delete $hash{c}; lock_ref_keys(\%hash); ok(Internals::SvREADONLY(%hash),'lock_ref_keys'); delete @hash{qw(b e)}; my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); #warn "@legal\n@keys\n"; is("@hidden","b e",'lock_ref_keys @hidden'); is("@legal","a b d e f",'lock_ref_keys @legal'); is("@keys","a d f",'lock_ref_keys @keys'); } { my %hash=(0..9); lock_ref_keys(\%hash,keys %hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_ref_keys args'); my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); is("@hidden","a b c d e f",'lock_ref_keys() @hidden'); is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal'); is("@keys","0 2 4 6 8",'lock_ref_keys() @keys'); } { my %hash=(0..9); lock_ref_keys_plus(\%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_ref_keys args'); my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden'); is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal'); is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys'); } { my %hash=(0..9); lock_keys_plus(%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_keys args'); my @hidden=sort(hidden_keys(%hash)); my @legal=sort(legal_keys(%hash)); my @keys=sort(keys(%hash)); is("@hidden","a b c d e f",'lock_keys_plus() @hidden'); is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal'); is("@keys","0 2 4 6 8",'lock_keys_plus() @keys'); } } Data-Dump-Streamer-2.39/t/blessed.t000444001750001750 104112636703716 17267 0ustar00yortonyorton000000000000# This is from the Scalar::Utils distro use Data::Dump::Streamer qw(blessed); #$Id: blessed.t 26 2006-04-16 15:18:52Z demerphq $# use vars qw($t $y $x); print "1..7\n"; print "not " if blessed(1); print "ok 1\n"; print "not " if blessed('A'); print "ok 2\n"; print "not " if blessed({}); print "ok 3\n"; print "not " if blessed([]); print "ok 4\n"; $y = \$t; print "not " if blessed($y); print "ok 5\n"; $x = bless [], "ABC"; print "not " unless blessed($x); print "ok 6\n"; print "not " unless blessed($x) eq 'ABC'; print "ok 7\n"; Data-Dump-Streamer-2.39/t/overload.t000444001750001750 537112636703716 17473 0ustar00yortonyorton000000000000use Test::More tests => 7; use Data::Dump::Streamer 'Dump'; use Carp (); use Symbol 'gensym'; use strict; use warnings; require overload; #$Id: overload.t 26 2006-04-16 15:18:52Z demerphq $# # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; sub dump_obj { my $obj = shift; my $error; if ( not eval { my @list = Dump( $obj ); 1 } ) { $error = $@; diag( $error ); } return ! defined $error; } ok( dump_obj( bless( do{ my $v="FooBar"; \ $v }, 'T' ) ), '${} overloading' ); { my $h={a=>'b'}; ok( dump_obj( [ bless( [ 1, 2, 3, 4, $h ], 'T' ),$h ] ), '@{} overloading' ); } ok( dump_obj( bless( {a=>'b',c=>[1,2,3,4]}, 'T' ) ), '%{} overloading' ); ok( dump_obj( bless( sub{}, 'T' ) ), '&{} overloading' ); ok( dump_obj( bless( gensym(), 'T' ) ), '*{} overloading' ); our @foofoo=qw(foo foo); our $foofoo=bless \@foofoo,'T'; my $x=bless \*foofoo,'T'; ok( dump_obj( $x ),'containing glob' ); { my ($r1,$r2); $r1 = \$r2; $r2 = \$r1; my $c= sub {die}; my $fh= gensym(); my $gv= \*foofoo ; my $h={a=>'b',r1=>$r1,r2=>$r2,c=>$c,gv=>$gv}; my $a1=[ 0..4, $h, $r1, $r2,$c,$fh,$gv ]; $h->{array}=$a1; my $a2=[$a1,$h]; bless $_,'T' for $r1,$r2,$c,$fh,$gv,$h,$a1,$a2; my $o=Dump(); test_dump( {name=>'overloading madness',no_dumper=>1}, $o, $a2, <<'EXPECT'); $T1 = [ [ 0, 1, 2, 3, 4, 'V: $T1->[1]', \do { my $v = 'V: $T1->[0][7]' }, \do { my $v = 'V: $T1->[0][6]' }, sub { die; }, do{ require Symbol; Symbol::gensym }, \*::foofoo ], { a => 'b', array => 'V: $T1->[0]', c => 'V: $T1->[0][8]', gv => 'V: $T1->[0][10]', r1 => 'V: $T1->[0][6]', r2 => 'V: $T1->[0][7]' } ]; $T1->[0][5] = $T1->[1]; ${$T1->[0][6]} = $T1->[0][7]; ${$T1->[0][7]} = $T1->[0][6]; $T1->[1]{array} = $T1->[0]; $T1->[1]{c} = $T1->[0][8]; $T1->[1]{gv} = $T1->[0][10]; $T1->[1]{r1} = $T1->[0][6]; $T1->[1]{r2} = $T1->[0][7]; *::foofoo = \do { my $v = 'V: *::foofoo{ARRAY}' }; *::foofoo = [ ( 'foo' ) x 2 ]; ${*::foofoo} = *::foofoo{ARRAY}; bless( $T1->[0][6], 'T' ); bless( $T1->[0][7], 'T' ); bless( $T1->[0][8], 'T' ); bless( $T1->[0][9], 'T' ); bless( $T1->[0][10], 'T' ); bless( $T1->[0], 'T' ); bless( $T1->[1], 'T' ); bless( $T1, 'T' ); bless( *::foofoo{ARRAY}, 'T' ); EXPECT } package T; BEGIN { overload->import( map { my $operation = $_; $operation => sub { Carp::confess( "The overloaded method $operation was called" ) } } map { split( ' ' ) } values %overload::ops ); } Data-Dump-Streamer-2.39/t/madness_json.t000444001750001750 2620512636703716 20362 0ustar00yortonyorton000000000000use Test::More; use strict; use warnings; use Data::Dumper; BEGIN { if (eval"require JSON::XS; 1") { plan tests => 7; } else { plan skip_all => "No JSON::XS"; exit; # not sure if this is needed } }; BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); } # imports same() (my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/; require $helper; # use this one for simple, non evalable tests. (GLOB) # same ( $got,$expected,$name,$obj ) # # use this one for eval checks and dumper checks but NOT for GLOB's # same ( $name,$obj,$expected,@args ) my $dump; my $o = Data::Dump::Streamer->new(); isa_ok( $o, 'Data::Dump::Streamer' ); { local *icky; *icky=\ "icky"; our $icky; my $id = 0; my $btree; $btree = sub { my ( $d, $m, $p ) = @_; return $p if $d > $m; return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ]; }; my $t = $btree->( 0, 1, '' ); my ( $x, $y, $qr ); $x = \$y; $y = \$x; $qr = bless qr/this is a test/m, 'foo_bar'; my $array = []; my $hash = bless { A => \$array, 'B-B' => ['$array'], 'CCCD' => [ 'foo', 'bar' ], 'E'=>\\1, 'F'=>\\undef, 'Q'=>sub{\@_}->($icky), }, 'ThisIsATest'; $hash->{G}=\$hash; my $boo = 'boo'; @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo ); my $cap = capture( $x, $y, $qr, $x, $y, $qr ); same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) ); $ARRAY1 = [ bless( qr/this is a test/m, 'foo_bar' ), 'A: $ARRAY1->[0]' ]; alias_av(@$ARRAY1, 1, $ARRAY1->[0]); EXPECT #same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o ); same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) ); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]', 'A: $foo_bar1', 'A: $ARRAY1->[0]', 'A: $ARRAY1->[1]', 'A: $foo_bar1' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; alias_av(@$ARRAY1, 3, $ARRAY1->[0]); alias_av(@$ARRAY1, 4, $ARRAY1->[1]); $ARRAY2 = [ \$ThisIsATest1, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[0]', \$foo_bar1, 'V: $ARRAY2->[3]', \'foo', \$VAR1 ]; $ARRAY2->[1] = $ARRAY2->[0]; $ARRAY2->[2] = $ARRAY2->[0]; $ARRAY2->[4] = $ARRAY2->[3]; $VAR1 = 'boo'; $ThisIsATest1 = bless( { A => \$ARRAY2, "B-B" => [ '$array' ], CCCD => [ 'foo', 'bar' ], E => \\1, F => \\undef, G => $ARRAY2->[0], Q => [ 'icky' ] }, 'ThisIsATest' ); make_ro($ThisIsATest1->{Q}[0]); $foo_bar1 = bless( qr/this is a test/m, 'foo_bar' ); alias_av(@$ARRAY1, 2, $foo_bar1); alias_av(@$ARRAY1, 5, $foo_bar1); EXPECT } { my ($x,$y); $x=\$y; $y=\$x; my $a=[1,2]; $a->[0]=\$a->[1]; $a->[1]=\$a->[0]; #$cap->[-1]=5; my $s; $s=\$s; my $bar='bar'; my $foo='foo'; my $halias= {foo=>1,bar=>2}; alias_hv(%$halias,'foo',$foo); alias_hv(%$halias,'bar',$bar); alias_hv(%$halias,'foo2',$foo); my ($t,$u,$v,$w)=(1,2,3,4); my $cap=sub{ \@_ }->($x,$y); my $q1=qr/foo/; my $q2=bless qr/bar/,'bar'; my $q3=\bless qr/baz/,'baz'; #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o ); same( "More Madness", $o , <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)); $ARRAY1 = [ 'R: $ARRAY1->[1]', 'R: $ARRAY1->[0]' ]; $ARRAY1->[0] = \$ARRAY1->[1]; $ARRAY1->[1] = \$ARRAY1->[0]; $Regexp1 = qr/foo/; $bar1 = bless( qr/bar/, 'bar' ); $REF1 = \bless( qr/baz/, 'baz' ); $ARRAY2 = [ 'R: $ARRAY5->[1]', 'R: $ARRAY5->[0]' ]; $ARRAY3 = [ \do { my $v = 'V: $ARRAY3->[0]' }, 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; ${$ARRAY3->[0]} = $ARRAY3->[0]; $VAR1 = 1; $VAR2 = 2; $VAR3 = 3; alias_ref(\$VAR4,\$VAR1); $ARRAY4 = [ 1, 2, 3 ]; $HASH1 = { 1 => 2, 3 => 4 }; $ARRAY5 = [ 'V: $ARRAY2->[0]', 'V: $ARRAY2->[1]' ]; $ARRAY2->[0] = \$ARRAY5->[1]; $ARRAY2->[1] = \$ARRAY5->[0]; $ARRAY3->[1] = $ARRAY2->[0]; $ARRAY3->[2] = $ARRAY2->[1]; $ARRAY5->[0] = $ARRAY2->[0]; $ARRAY5->[1] = $ARRAY2->[1]; alias_ref(\$ARRAY6,\$ARRAY5); alias_ref(\$VAR5,\$VAR1); alias_ref(\$VAR6,\$VAR2); alias_ref(\$VAR7,\$VAR3); $HASH2 = { bar => 'bar', foo => 'foo', foo2 => 'A: $HASH2->{foo}' }; alias_hv(%$HASH2, 'foo2', $HASH2->{foo}); EXPECT } { #local $Data::Dump::Streamer::DEBUG = 1; my $x; $x = sub { \@_ }->( $x, $x ); push @$x, $x; same( "Tye Alias Array", $o, <<'EXPECT',( $x ) ); $ARRAY1 = [ 'A: $ARRAY1', 'A: $ARRAY1', 'V: $ARRAY1' ]; alias_av(@$ARRAY1, 0, $ARRAY1); alias_av(@$ARRAY1, 1, $ARRAY1); $ARRAY1->[2] = $ARRAY1; EXPECT } { undef $!; format STDOUT = @<<<<<< @││││││ @>>>>>> "left", "middle", "right" . my $expected_dot; if ( defined $. && length $. ) { $expected_dot = $.; } elsif ( defined $. ) { $expected_dot = "''"; } else { $expected_dot = 'undef'; } my $jstrue= JSON::XS::decode_json("true"); my %hash = ( UND => undef, IV => 1, NV => 3.14159265358979, PV => "string", PV8 => "ab\ncd\x{20ac}\t", RV => \$., AR => [ 1..2 ], HR => { key => "value" }, CR => sub { "code"; }, GLB => *STDERR, IO => *{$::{STDERR}}{IO}, FMT => \*{$::{STDOUT}}{FORMAT}, OBJ => bless(qr/("[^"]+")/,"Zorp"), JSB => $jstrue, ); my $expect; my $json_bool_class = ref( $jstrue ); # Dumping differences per perl version: # 5.12.0+: # # IO handles are now blessed into IO::File, I guess? # if ( $] >= 5.012_000 ) { # This fixes https://github.com/demerphq/Data-Dump-Streamer/issues/8 $expect = <<'EXPECT'; $HASH1 = { AR => [ 1, 2 ], CR => sub { use warnings; use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::File' ), IV => 1, JSB => \1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; bless( $HASH1->{JSB}, 'JSON::XS::Boolean' ); EXPECT require B::Deparse; if (new B::Deparse -> coderef2text ( sub { no strict; 1; use strict; 1; } ) !~ 'refs') { $expect =~ s/strict 'refs'/strict/; } } elsif ( $] >= 5.008_008 ) { $expect = <<'EXPECT'; $HASH1 = { AR => [ 1, 2 ], CR => sub { use warnings; use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, JSB => \1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; bless( $HASH1->{JSB}, 'JSON::XS::Boolean' ); EXPECT } elsif ( $] >= 5.008_000 ) { $expect = <<'EXPECT'; $HASH1 = { AR => [ 1, 2 ], CR => sub { BEGIN {${^WARNING_BITS} = "UUUUUUUUUUUU"} use strict 'refs'; 'code'; }, FMT => \do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT}; # format F = # @<<<<<< @││││││ @>>>>>> # 'left', 'middle', 'right' # . _EOF_FORMAT_ }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, JSB => \1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; bless( $HASH1->{JSB}, 'JSON::XS::Boolean' ); EXPECT } else { $expect = <<'EXPECT'; $HASH1 = { AR => [ 1, 2 ], CR => sub { 'code'; }, FMT => \do { my $v = undef }, GLB => *::STDERR, HR => { key => 'value' }, IO => bless( *{Symbol::gensym()}{IO}, 'IO::Handle' ), IV => 1, JSB => \1, NV => 3.14159265358979, OBJ => bless( qr/("[^"]+")/, 'Zorp' ), PV => 'string', PV8 => "ab\ncd\x{20ac}\t", RV => \do { my $v = expected_dot }, UND => undef }; bless( $HASH1->{JSB}, 'JSON::XS::Boolean' ); EXPECT } # In JSON::XS < 3, the boolean class is JSON::XS::Boolean # In JSON::XS >= 3, the boolean class is JSON::PP::Boolean my $json_boolean_class = ref JSON::XS::decode_json("true"); $expect =~ s{JSON::XS::Boolean}{$json_boolean_class}g; same( $dump= $o->Data(\%hash)->Out, template( $expect, expected_dot => $expected_dot ), "", $o); } sub template { my ( $pattern, %replacements ) = @_; for ( keys %replacements ) { $pattern =~ s/$_/$replacements{$_}/g; } return $pattern; } __END__ # with eval testing { same( "", $o, <<'EXPECT', ( ) ); EXPECT } # without eval testing { same( $dump = $o->Data()->Out, <<'EXPECT', "", $o ); EXPECT } Data-Dump-Streamer-2.39/lib000755001750001750 012636703716 15633 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/lib/Data000755001750001750 012636703716 16504 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/lib/Data/Dump000755001750001750 012636703716 17411 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/lib/Data/Dump/Streamer.xs000444001750001750 6023312636703716 21730 0ustar00yortonyorton000000000000/* * Streamer.xs * * Code from Array::RefElem * Copyright (c) 1997-2000 Graham Barr . All rights reserved. * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * * Code From Scalar::Util * Copyright 2000 Gisle Aas. * This library is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * A good chunk of the XS is morphed or taken directly from this module. * Thanks Gisle. * * alias_ref is from Lexical::Alias by Jeff Pinyan which * was borrowed/modified from Devel::LexAlias by Richard Clamp * * * Additional Code and Modifications * Copyright 2003 Yves Orton. * This library is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * */ #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #ifdef __cplusplus } #endif #ifndef PERL_VERSION # include # if !(defined(PERL_VERSION) || (PERL_SUBVERSION > 0 && defined(PATCHLEVEL))) # include # endif # define PERL_REVISION 5 # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION PERL_SUBVERSION #endif #if PERL_VERSION < 8 # define PERL_MAGIC_qr 'r' /* precompiled qr// regex */ # define BFD_Svs_SMG_OR_RMG SVs_RMG #elif ((PERL_VERSION==8) && (PERL_SUBVERSION >= 1) || (PERL_VERSION>8)) # define BFD_Svs_SMG_OR_RMG SVs_SMG # define MY_PLACEHOLDER PL_sv_placeholder #else # define BFD_Svs_SMG_OR_RMG SVs_RMG # define MY_PLACEHOLDER PL_sv_undef #endif #if (((PERL_VERSION == 9) && (PERL_SUBVERSION >= 4)) || (PERL_VERSION > 9)) # define NEW_REGEX_ENGINE 1 #endif #if (((PERL_VERSION == 8) && (PERL_SUBVERSION >= 1)) || (PERL_VERSION > 8)) #define MY_CAN_FIND_PLACEHOLDERS #define HAS_SV2OBJ #endif #ifdef SvWEAKREF # ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' # endif #define ADD_WEAK_REFCOUNT do { \ MAGIC *mg = NULL; \ if( SvMAGICAL(sv) \ && (mg = mg_find(sv, PERL_MAGIC_backref) ) \ ){ \ SV **svp = (SV**)mg->mg_obj; \ if (svp && *svp) { \ RETVAL += \ SvTYPE(*svp) == SVt_PVAV \ ? av_len((AV*)*svp)+1 \ : 1; \ } \ } \ } while (0) #else #define ADD_WEAK_REFCOUNT #endif #if PERL_VERSION < 7 /* Not in 5.6.1. */ # define SvUOK(sv) SvIOK_UV(sv) # ifdef cxinc # undef cxinc # endif # define cxinc() my_cxinc(aTHX) static I32 my_cxinc(pTHX) { cxstack_max = cxstack_max * 3 / 2; Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */ return cxstack_ix + 1; } #endif #if PERL_VERSION < 6 # define NV double #endif #if PERL_VERSION < 8 # define MY_XS_AMAGIC #endif #if ((PERL_VERSION == 8) && (PERL_SUBVERSION <= 8)) # define MY_XS_AMAGIC #endif /* the following three subs are outright stolen from Data::Dumper ( Dumper.xs ) from the 5.6.1 distribution of Perl. Probably Gurusamy Sarathy's work. As is much of the code in _globname and globname */ /* does a string need to be protected? */ static I32 needs_q(register char *s) { TOP: if (s[0] == ':') { if (*++s) { if (*s++ != ':') return 1; } else return 1; } if (isIDFIRST(*s)) { while (*++s) if (!isALNUM(*s)) { if (*s == ':') goto TOP; else return 1; } } else return 1; return 0; } /* count the number of "'"s and "\"s in string */ static I32 num_q(register char *s, register STRLEN slen) { register I32 ret = 0; while (slen > 0) { if (*s == '\'' || *s == '\\') ++ret; ++s; --slen; } return ret; } /* returns number of chars added to escape "'"s and "\"s in s */ /* slen number of characters in s will be escaped */ /* destination must be long enough for additional chars */ static I32 esc_q(register char *d, register char *s, register STRLEN slen) { register I32 ret = 0; while (slen > 0) { switch (*s) { case '\'': case '\\': *d = '\\'; ++d; ++ret; default: *d = *s; ++d; ++s; --slen; break; } } return ret; } XS(XS_Data__Dump__Streamer_SvREADONLY); XS(XS_Data__Dump__Streamer_SvREADONLY) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); if (items == 1) { if (SvREADONLY(sv)) XSRETURN_YES; else XSRETURN_NO; } else if (items == 2) { if (SvTRUE(ST(1))) { SvREADONLY_on(sv); XSRETURN_YES; } else { /* I hope you really know what you are doing. */ SvREADONLY_off(sv); XSRETURN_NO; } } XSRETURN_UNDEF; /* Can't happen. */ } XS(XS_Data__Dump__Streamer_SvREFCNT); XS(XS_Data__Dump__Streamer_SvREFCNT) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ else if (items == 2) { /* I hope you really know what you are doing. */ SvREFCNT(sv) = SvIV(ST(1)); XSRETURN_IV(SvREFCNT(sv)); } XSRETURN_UNDEF; /* Can't happen. */ } /* this is from B is perl 5.9.2 */ typedef SV *B__SV; MODULE = B PACKAGE = B::SV #ifndef HAS_SV2OBJ #define object_2svref(sv) sv #define SVREF SV * SVREF object_2svref(sv) B::SV sv #endif MODULE = Data::Dump::Streamer PACKAGE = Data::Dump::Streamer void dualvar(num,str) SV * num SV * str PROTOTYPE: $$ CODE: { STRLEN len; char *ptr = SvPV(str,len); ST(0) = sv_newmortal(); (void)SvUPGRADE(ST(0),SVt_PVNV); sv_setpvn(ST(0),ptr,len); if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { SvNVX(ST(0)) = SvNV(num); SvNOK_on(ST(0)); } #ifdef SVf_IVisUV else if (SvUOK(num)) { SvUVX(ST(0)) = SvUV(num); SvIOK_on(ST(0)); SvIsUV_on(ST(0)); } #endif else { SvIVX(ST(0)) = SvIV(num); SvIOK_on(ST(0)); } if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) SvTAINTED_on(ST(0)); XSRETURN(1); } bool _could_be_dualvar(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = ((SvNIOK(sv)) && (SvPOK(sv))) ? 1 : 0; } OUTPUT: RETVAL int alias_av(avref, key, val) SV* avref I32 key SV* val PROTOTYPE: \@$$ PREINIT: AV* av; CODE: { if (!SvROK(avref) || SvTYPE(SvRV(avref)) != SVt_PVAV) croak("First argument to alias_av() must be an array reference"); av = (AV*)SvRV(avref); SvREFCNT_inc(val); if (!av_store(av, key, val)) { SvREFCNT_dec(val); RETVAL=0; } else { RETVAL=1; } } OUTPUT: RETVAL void push_alias(avref, val) SV* avref SV* val PROTOTYPE: \@$ PREINIT: AV* av; CODE: if (!SvROK(avref) || SvTYPE(SvRV(avref)) != SVt_PVAV) croak("First argument to push_alias() must be an array reference"); av = (AV*)SvRV(avref); SvREFCNT_inc(val); av_push(av, val); int alias_hv(hvref, key, val) SV* hvref SV* key SV* val PROTOTYPE: \%$$ PREINIT: HV* hv; CODE: { if (!SvROK(hvref) || SvTYPE(SvRV(hvref)) != SVt_PVHV) croak("First argument to alias_hv() must be a hash reference"); hv = (HV*)SvRV(hvref); SvREFCNT_inc(val); if (!hv_store_ent(hv, key, val, 0)) { SvREFCNT_dec(val); RETVAL=0; } else { RETVAL=1; } } OUTPUT: RETVAL char * blessed(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(!sv_isobject(sv)) { XSRETURN_UNDEF; } RETVAL = (char *)sv_reftype(SvRV(sv),TRUE); } OUTPUT: RETVAL UV refaddr(sv) SV * sv PROTOTYPE: $ CODE: { if(!SvROK(sv)) { RETVAL = 0; } else { RETVAL = PTR2UV(SvRV(sv)); } } OUTPUT: RETVAL void weaken(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvWEAKREF sv_rvweaken(sv); XSRETURN_YES; #else croak("weak references are not implemented in this release of perl"); #endif void isweak(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvWEAKREF ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); XSRETURN(1); #else XSRETURN_NO; #endif IV weak_refcount(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL=0; ADD_WEAK_REFCOUNT; } OUTPUT: RETVAL IV sv_refcount(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = SvREFCNT(sv); ADD_WEAK_REFCOUNT; } OUTPUT: RETVAL IV refcount(sv) SV * sv PROTOTYPE: $ CODE: { if(!SvROK(sv)) { RETVAL=0; } else { sv = (SV*)SvRV(sv); RETVAL = SvREFCNT(sv); ADD_WEAK_REFCOUNT; } } OUTPUT: RETVAL bool is_numeric(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = (SvNIOK(sv)) ? 1 : 0; } OUTPUT: RETVAL int _make_ro(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = SvREADONLY_on(sv); OUTPUT: RETVAL SV * make_ro(sv) SV *sv PROTOTYPE: $ CODE: SvREADONLY_on(sv); SvREFCNT_inc(sv); RETVAL=sv; OUTPUT: RETVAL int readonly_set(sv,set) SV *sv SV *set PROTOTYPE: $ CODE: if (SvTRUE(set)) { RETVAL = SvREADONLY_on(sv); } else { RETVAL = SvREADONLY_off(sv); } OUTPUT: RETVAL int readonly(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = SvREADONLY(sv); OUTPUT: RETVAL int looks_like_number(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = looks_like_number(sv); OUTPUT: RETVAL int alias_ref (dst,src) SV *dst SV *src CODE: { AV* padv = PL_comppad; int dt, st; int ok=0; I32 i; if (!SvROK(src) || !SvROK(dst)) croak("destination and source must be references"); dt = SvTYPE(SvRV(dst)); st = SvTYPE(SvRV(src)); if (!(dt < SVt_PVAV && st < SVt_PVAV || dt == st && dt <= SVt_PVHV)) croak("destination and source must be same type (%d != %d)",dt,st); for (i = 0; i <= av_len(padv); ++i) { SV** myvar_ptr = av_fetch(padv, i, 0); if (myvar_ptr) { if (SvRV(dst) == *myvar_ptr) { av_store(padv, i, SvRV(src)); SvREFCNT_inc(SvRV(src)); ok=1; } } } if (!ok) croak("Failed to created alias"); RETVAL = ok; } OUTPUT: RETVAL char * reftype(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(!SvROK(sv)) { XSRETURN_NO; } else { RETVAL = (char *)sv_reftype(SvRV(sv),FALSE); } } OUTPUT: RETVAL char * _globname(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { XSRETURN_NO; } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { STRLEN i; RETVAL = SvPV(sv, i); } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * reftype_or_glob(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { RETVAL = newSVpv(sv_reftype(SvRV(sv),FALSE),0); } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; /* i have a feeling this will cause problems with utf8 glob names */ i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * refaddr_or_glob(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { UV uv; uv = PTR2UV(SvRV(sv)); RETVAL = newSVuv(uv); } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * globname(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { XSRETURN_NO; } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL #ifdef MY_XS_AMAGIC void SvAMAGIC_off(sv) SV * sv PROTOTYPE: $ CODE: SvAMAGIC_off(sv); void SvAMAGIC_on(sv,klass) SV * sv SV * klass PROTOTYPE: $$ CODE: SvAMAGIC_off(sv); #endif #ifndef NEW_REGEX_ENGINE void regex(sv) SV * sv PROTOTYPE: $ PREINIT: STRLEN patlen; char reflags[6]; int left; PPCODE: { /* Checks if a reference is a regex or not. If the parameter is not a ref, or is not the result of a qr// then returns undef. Otherwise in list context it returns the pattern and the modifiers, in scalar context it returns the pattern just as it would if the qr// was blessed into the package Regexp and stringified normally. */ if (SvMAGICAL(sv)) { /* is this if needed??? Why?*/ mg_get(sv); } if(!SvROK(sv)) { /* bail if we dont have a ref. */ XSRETURN_UNDEF; } patlen=0; left=0; if (SvTHINKFIRST(sv)) { sv = (SV*)SvRV(sv); if (sv) { MAGIC *mg; if (SvTYPE(sv)==SVt_PVMG) { if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { /* Housten, we have a regex! */ SV *pattern; regexp *re = (regexp *)mg->mg_obj; I32 gimme = GIMME_V; if ( gimme == G_ARRAY ) { /* we are in list/array context so stringify the modifiers that apply. We ignore "negative modifiers" in this scenario. Also we dont cache the modifiers. AFAICT there isnt anywhere for them to go. :-( */ char *fptr = "msix"; char ch; U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } reganch >>= 1; } pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen)); if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern); /* return the pattern and the modifiers */ XPUSHs(pattern); XPUSHs(sv_2mortal(newSVpvn(reflags,left))); XSRETURN(2); } else { /* Non array/list context. So we build up the stringified form just as PL_sv_2pv does, and like it we also cache the result. The entire content of the if() is directly taken from PL_sv_2pv */ if (!mg->mg_ptr ) { char *fptr = "msix"; char ch; int right = 4; char need_newline = 0; U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } else { reflags[right--] = ch; } reganch >>= 1; } if(left != 4) { reflags[left] = '-'; left = 5; } mg->mg_len = re->prelen + 4 + left; /* * If /x was used, we have to worry about a regex * ending with a comment later being embedded * within another regex. If so, we don't want this * regex's "commentization" to leak out to the * right part of the enclosing regex, we must cap * it with a newline. * * So, if /x was used, we scan backwards from the * end of the regex. If we find a '#' before we * find a newline, we need to add a newline * ourself. If we find a '\n' first (or if we * don't find '#' or '\n'), we don't need to add * anything. -jfriedl */ if (PMf_EXTENDED & re->reganch) { char *endptr = re->precomp + re->prelen; while (endptr >= re->precomp) { char c = *(endptr--); if (c == '\n') break; /* don't need another */ if (c == '#') { /* we end while in a comment, so we need a newline */ mg->mg_len++; /* save space for it */ need_newline = 1; /* note to add it */ break; } } } /**/ New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); Copy("(?", mg->mg_ptr, 2, char); Copy(reflags, mg->mg_ptr+2, left, char); Copy(":", mg->mg_ptr+left+2, 1, char); Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); if (need_newline) mg->mg_ptr[mg->mg_len - 2] = '\n'; mg->mg_ptr[mg->mg_len - 1] = ')'; mg->mg_ptr[mg->mg_len] = 0; } /* return the pattern in (?msix:..) format */ pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len)); if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern); XPUSHs(pattern); XSRETURN(1); } } } } } /* 'twould appear it aint a regex, so return undef/empty list */ XSRETURN_UNDEF; } #endif #ifdef MY_CAN_FIND_PLACEHOLDERS void all_keys(hash,keys,placeholder) SV* hash SV* keys SV* placeholder PROTOTYPE: \%\@\@ PREINIT: AV* av_k; AV* av_p; HV* hv; SV *key; HE *he; CODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to all_keys() must be an HASH reference"); if (!SvROK(keys) || SvTYPE(SvRV(keys)) != SVt_PVAV) croak("Second argument to all_keys() must be an ARRAY reference"); if (!SvROK(placeholder) || SvTYPE(SvRV(placeholder)) != SVt_PVAV) croak("Third argument to all_keys() must be an ARRAY reference"); hv = (HV*)SvRV(hash); av_k = (AV*)SvRV(keys); av_p = (AV*)SvRV(placeholder); av_clear(av_k); av_clear(av_p); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); if (HeVAL(he) == &MY_PLACEHOLDER) { SvREFCNT_inc(key); av_push(av_p, key); } else { SvREFCNT_inc(key); av_push(av_k, key); } } void hidden_keys(hash) SV* hash PROTOTYPE: \% PREINIT: HV* hv; SV *key; HE *he; PPCODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to hidden_keys() must be an HASH reference"); hv = (HV*)SvRV(hash); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); if (HeVAL(he) == &MY_PLACEHOLDER) { XPUSHs( key ); } } void legal_keys(hash) SV* hash PROTOTYPE: \% PREINIT: HV* hv; SV *key; HE *he; PPCODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to legal_keys() must be an HASH reference"); hv = (HV*)SvRV(hash); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); XPUSHs( key ); } #endif BOOT: newXSproto("Data::Dump::Streamer::SvREADONLY_ref", XS_Data__Dump__Streamer_SvREADONLY, file,"$;$"); newXSproto("Data::Dump::Streamer::SvREFCNT_ref", XS_Data__Dump__Streamer_SvREFCNT, file,"$;$"); Data-Dump-Streamer-2.39/lib/Data/Dump/ppport.h000444001750001750 52540612636703716 21317 0ustar00yortonyorton000000000000#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.19 Automatically created by Devel::PPPort running under perl 5.013003. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.19 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.19; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV_set|5.011000||p DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSVn|5.009003||p GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.011000| HeVAL||5.004000| HvNAMELEN_get|5.009003||p HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.011000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_DUP||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.011000| PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.011000||p PL_bufptr|5.011000||p PL_compiling|5.004050||p PL_copline|5.011000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.011000||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.011000||p PL_in_my|5.011000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.011000||p PL_lex_stuff|5.011000||p PL_linestr|5.011000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_parser|5.009005||p PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.011000||p POP_MULTICALL||5.011000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.011000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.011000||p aTHXR|5.011000||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak_xs_usage||5.011000| croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.011000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| fetch_cop_label||5.011000| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_isa_hash||| get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_flags||5.011000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUMC|5.006000||p isALNUM||| isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isGRAPH|5.006000||p isGV_with_GP|5.009004||p isLOWER||| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSPACE||| isUPPER||| isXDIGIT|5.006000||p is_an_int||| is_gv_magical_sv||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie_failtable||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mem_log_common|||n mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_from_name||5.011000| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.011000| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_register||5.011000| mro_set_mro||5.011000| mro_set_private_data||5.011000| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.011000| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new_common||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv_and_mortalize||5.011000| save_pptr||| save_pushi32ptr||| save_pushptri32ptr||| save_pushptrptr||| save_pushptr||5.011000| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| search_const||| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.011000| stdize_locale||| store_cop_label||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup_inc_multiple||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert_flags||5.011000| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doint. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Data-Dump-Streamer-2.39/lib/Data/Dump/Streamer.pm000444001750001750 37763612636703716 21754 0ustar00yortonyorton000000000000package Data::Dump::Streamer; use strict; use warnings; use warnings::register; use B (); use B::Deparse (); use B::Utils (); use Data::Dumper (); use DynaLoader (); use Exporter (); use IO::File (); use Symbol (); use Text::Abbrev (); use Text::Balanced (); use overload (); use Data::Dump::Streamer::_::Printers; # use overload qw("" printit); # does diabolical stuff. use vars qw( $VERSION $XS_VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS %Freeze %Thaw $DEBUG $HasPadWalker ); $DEBUG=0; BEGIN{ $HasPadWalker=eval "use PadWalker 0.99; 1"; } BEGIN { $VERSION ='2.39'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; # used for beta stuff. @ISA = qw(Exporter DynaLoader); @EXPORT=qw(Dump DumpLex DumpVars); @EXPORT_OK = qw( Dump DumpLex DumpVars Stream alias_av alias_hv alias_ref push_alias dualvar alias_to blessed reftype refaddr refcount sv_refcount looks_like_number regex readonly make_ro _make_ro reftype_or_glob refaddr_or_glob globname is_numeric all_keys legal_keys hidden_keys lock_ref_keys lock_keys lock_ref_keys_plus lock_keys_plus SvREADONLY_ref SvREFCNT_ref isweak weaken weak_refcount readonly_set Dumper DDumper alias sqz usqz ); %EXPORT_TAGS = ( undump => [ qw( alias_av alias_hv alias_ref make_ro lock_ref_keys lock_keys lock_ref_keys_plus lock_keys_plus alias_to dualvar weaken usqz ) ], special=> [ qw( readonly_set ) ], all => [ @EXPORT,@EXPORT_OK ], alias => [ qw( alias_av alias_hv alias_ref push_alias ) ], bin => [ @EXPORT_OK ], Dumper => [ qw( Dumper DDumper )], util => [ qw ( dualvar blessed reftype refaddr refcount sv_refcount readonly looks_like_number regex is_numeric make_ro readonly_set reftype_or_glob refaddr_or_glob globname weak_refcount isweak weaken ) ], ); sub alias_to { return shift } #warn $VERSION; Data::Dump::Streamer->bootstrap($XS_VERSION); if ($]>=5.013010) { # As I write this, 5.13.10 doesn't exist so I'm guessing that # we can begin using the ordinary core function again. eval q[ use re qw(regexp_pattern is_regexp); *regex= *regexp_pattern; ] or die $@; } elsif ($]>=5.013006) { # Perl-5.13.6 through perl-5.13.9 began returning modifier # flags that weren't yet legal at the time. eval q[ use re qw(regexp_pattern is_regexp); sub regex { if (wantarray) { my ($pat,$mod) = regexp_pattern($_[0]); if ($mod) { $mod =~ tr/dlua?//d; } return ($pat,$mod); } else { return scalar regexp_pattern($_[0]); } } 1; ] or die $@; } elsif ($]>=5.009004) { eval q[ use re qw(regexp_pattern is_regexp); *regex= *regexp_pattern; 1; ] or die $@; } else { eval q[sub is_regexp($) { defined regex($_[0]) }]; } if ($]<=5.008) { *hidden_keys=sub(\%) { return () }; *legal_keys=sub(\%) { return keys %{$_[0]} }; *all_keys=sub(\%\@\@) { @{$_[1]}=keys %{$_[0]}; @$_[2]=(); }; } if ( $]<5.008 ) { no strict 'refs'; foreach my $sub (qw(lock_keys lock_keys_plus )) { *$sub=sub(\%;@) { warnings::warn "$sub doesn't do anything before Perl 5.8.0\n"; return $_[0]; } } foreach my $sub (qw(lock_ref_keys lock_ref_keys_plus )) { *$sub=sub($;@) { warnings::warn "$sub doesn't do anything before Perl 5.8.0\n"; return $_[0]; } } } else { eval <<'EO_HU' use Hash::Util qw(lock_keys); sub lock_ref_keys($;@) { my $hash=shift; Carp::confess("lock_ref_keys(): Not a ref '$hash'") unless ref $hash; lock_keys(%$hash,@_); $hash } EO_HU ; *lock_ref_keys_plus=sub($;@){ my ($hash,@keys)=@_; my @delete; Internals::hv_clear_placeholders(%$hash); foreach my $key (@keys) { unless (exists($hash->{$key})) { $hash->{$key}=undef; push @delete,$key; } } SvREADONLY_ref($hash,1); delete @{$hash}{@delete}; $hash }; *lock_keys_plus=sub(\%;@){lock_ref_keys_plus(@_)}; } if ($] <= 5.008008) { *disable_overloading = \&SvAMAGIC_off; *restore_overloading = sub ($$) { SvAMAGIC_on($_[0], undef); # Visit all classes we are ISA and fetch the () entry from # every stash. my %done; my %todo = ( $_[0] => undef, UNIVERSAL => undef, ); no strict 'refs'; for my $todo_class (keys %todo) { delete $todo{$todo_class}; $done{$todo_class} = undef; for my $isa (@{"${todo_class}::ISA"}) { $todo{$isa} = undef unless exists $done{$isa}; } } }; } else { *disable_overloading = sub ($) { # we use eval because $_[0] might be read-only # its a crappy solution, but whatever, it works eval { bless $_[0], 'Does::Not::Exist' }; }; *restore_overloading = sub ($$) { eval { bless $_[0], $_[1] } }; } my %fail=map { ( $_ => 1 ) } @EXPORT_FAIL; @EXPORT_OK=grep { !$fail{$_} } @EXPORT_OK; } sub import { my ($pkg) = @_; my ($idx, $alias); if ($idx = (grep lc($_[$_]) eq 'as', 0..$#_)) { #print "found alias at $idx:\n"; ($idx, $alias) = splice(@_, $idx, 2); #print "found alias: $idx => $alias\n"; no strict 'refs'; *{$alias.'::'} = *{__PACKAGE__.'::'}; } $pkg->export_to_level(1,@_); } # NOTE # ---- # This module uses the term 'sv' in a way that is misleading. # It doesn't always mean the same as it would in the core. # # 1. data is breadth first traversed first, in the pretty much # self contained Data() routine which farms out a bit to # _reg_ref and _reg_scalar which handle "registering" items for # later use, such as their depth, refcount, "name", etc. But # ONLY for references and scalars whose refcount is over 2. # Most real SV's will have a refcount of 2 when we look at them # (from the perl side) so we actually don't know about them (trust me) # They _cant_ be referenced twice, and they can't be aliased so we can # can just ignore them until the second pass. # 2.Once this has happened Out() is called which starts off a # normal depth first traverse over the structure. It calls into # 3._dump_sv which in the case of a reference falls through to _dump_rv. # Aliasing and a bunch of stuff like that are checked here before we even # look at the reference type. # 4.If its a ref we fall through to dumping the reference in _dump_rv. # Here we handle duplicate refs, and manage depth checks, blessing, refs #(which is scary nasty horrible code) and then pass on to _dump_type where # type is one of 'code', 'qr', 'array' etc. Each of these which have children # then call back into _dump_sv as required. # 5. Because of the way perl works, we can't emit anything more than a DAG in a # single statement, so for more complex structures we need to add in the broken # links. I call these "fix statements", and they encompass copying reference # values, creating aliases, or even dumping globs. When a fix statement is needed # any of the _dump_foo methods will call _add_fix and add to the list of fixes. # after every root level _dump_sv call from Out() any fix statements possible to be # resolved will be emitted and removed from the fix list. This happens in # _dump_apply_fix, which is another piece of horrible code. # # Anyway, its terribly ugly, but for anything I can think to throw at i works. # demerphq =encoding utf8 =head1 NAME Data::Dump::Streamer - Accurately serialize a data structure as Perl code. =head1 SYNOPSIS use Data::Dump::Streamer; use DDS; # optionally installed alias Dump($x,$y); # Prints to STDOUT Dump($x,$y)->Out(); # " " my $o=Data::Dump::Streamer->new(); # Returns a new ... my $o=Dump(); # ... uninitialized object. my $o=Dump($x,$y); # Returns an initialized object my $s=Dump($x,$y)->Out(); # " a string of the dumped obj my @l=Dump($x,$y); # " a list of code fragments my @l=Dump($x,$y)->Out(); # " a list of code fragments Dump($x,$y)->To(\*STDERR)->Out(); # Prints to STDERR Dump($x,$y)->Names('foo','bar') # Specify Names ->Out(); Dump($x,$y)->Indent(0)->Out(); # No indent Dump($x,$y)->To(\*STDERR) # Output to STDERR ->Indent(0) # ... no indent ->Names('foo','bar') # ... specify Names ->Out(); # Print... $o->Data($x,$y); # OO form of what Dump($x,$y) does. $o->Names('Foo','Names'); # ... $o->Out(); # ... =head1 DESCRIPTION Given a list of scalars or reference variables, writes out their contents in perl syntax. The references can also be objects. The contents of each variable is output using the least number of Perl statements as convenient, usually only one. Self-referential structures, closures, and objects are output correctly. The return value can be evaled to get back an identical copy of the original reference structure. In some cases this may require the use of utility subs that L will optionally export. This module is very similar in concept to the core module L, with the major differences being that this module is designed to output to a stream instead of constructing its output in memory (trading speed for memory), and that the traversal over the data structure is effectively breadth first versus the depth first traversal done by the others. In fact the data structure is scanned twice, first in breadth first mode to perform structural analysis, and then in depth first mode to actually produce the output, but obeying the depth relationships of the first pass. =head2 Caveats Dumping Closures (CODE Refs) As of version 1.11 DDS has had the ability to dump closures properly. This means that the lexicals that are bound to the closure are dumped along with the subroutine that uses them. This makes it much easier to debug code that uses closures and to a certain extent provides a persistency framework for closure based code. The way this works is that DDS figures out what all the lexicals are that are bound to CODE refs it is dumping and then pretends that it had originally been called with all of them as its arguments, (along with the original arguments as well of course.) One consequence of the way the dumping process works is that all of the recreated subroutines will be in the same scope. This of course can lead to collisions as two subroutines can easily be bound to different variables that have the same name. The way that DDS resolves these collisions is that it renames one of the variables with a special name so that presumably there are no collisions. However this process is very simplistic with no checks to prevent collisions with other lexicals or other globals that may be used by other dumped code. In some situations it may be necessary to change the default value of the rename template which may be done by using the C method. Similarly to the problem of colliding lexicals is the problem of colliding lexicals and globals. DDS pays no attention to globals when dumping closures which can potentially result in lexicals being declared that will eclipse their global namesake. There is currently no way around this other than to avoid accessing a global and a lexical with the same name from the subs being dumped. An example is my $a = sub { $a++ }; Dump( sub { $a->() } ); which will not be dumped correctly. Generally speaking this kind of thing is bad practice anyway, so this should probably be viewed as a "feature". :-) Generally if the closures being dumped avoid accessing lexicals and globals with the same name from out of scope and that all of the CODE being dumped avoids vars with the C in their names the dumps should be valid and should eval back into existence properly. Note that the behaviour of dumping closures is subject to change in future versions as its possible that I will put some additional effort into more sophisticated ways of avoiding name collisions in the dump. =head1 USAGE While Data::Dump::Streamer is at heart an object oriented module, it is expected (based on experience with using L) that the common case will not exploit these features. Nevertheless the method based approach is convenient and accordingly a compromise hybrid approach has been provided via the C subroutine. Such as Dump($foo); $as_string= Dump($foo)->Out(); All attribute methods are designed to be chained together. This means that when used as set attribute (called with arguments) they return the object they were called against. When used as get attributes (called without arguments) they return the value of the attribute. From an OO point of view the key methods are the C and C methods. These correspond to the breadth first and depth first traversal, and need to be called in this order. Some attributes I be set prior to the C phase and some need only be set before the C phase. Attributes once set last the lifetime of the object, unless explicitly reset. =head2 Controlling Object Representation This module provides hooks to allow objects to override how they are represented. The basic idea is that a subroutine (or method) is provided which is responsible for the override. The return of the method governs how the object will be represented when dumped, and how it will be restored. The basic calling convention is my ( $proxy, $thaw, $postop )= $callback->($obj); #or = $obj->$method(); The L|/Freezer> method controls what methods to use as a default method and also allows per class overrides. When dumping an object of a given class the first time it tries to execute the class specific handler if it is specified, then the user specific generic handler if its been specified and then "DDS_freeze". This means that class authors can implement a C method and their objects will automatically be serialized as necessary. B that if either the class specific or generic handler is defined but false C will not be used even if it is present. The interface of the L|/Freezer> handler in detail is as follows: =over 4 =item B> The object being dumped. =item B> This is what will be dumped instead of C<$obj>. It may be one of the following values: =over 8 =item I> (first time only) On the first time a serialization hook is called in a dump it may return undef or the empty list to indicate that it shouldn't be used again for this class during this pass. Any other time undef is treated the same as false. =item I A false value for C<$proxy> is taken to mean that it should be ignored. Its like saying IgnoreClass(ref($obj)); B that undef has a special meaning when the callback is called the first time. =item I A reference that will be dumped instead of the object. =item I A string that is to be treated as code and inserted directly into the dump stream as a proxy for the original. Note that the code must be able to execute inline or in other words must evaluate to a perl EXPR. Use C to wrap multistatement code. =back =item B> This values is used to allow extra control over how the object will be recreated when dumped. It is used for converting the C<$proxy> representation into the real thing. It is only relevant when C<$proxy> is a reference. =over 8 =item I Indicates no thaw action is to be included for this object. =item I A string matching C<< /^(->)?((?:\w*::)\w+)(\(\))?$/ >> in which case it is taken as a sub name when the string ends in () and a method name when the string doesn't. If the C<< -> >> is present then the sub or method is called inline. If it is not then the sub or method is called after the main dump. =item I Any other string, in which case the result will be taken as code which will be emitted after the main dump. It will be wrapped in a for loop that aliases C<$_> to the variable in question. =back =item B> This is the similar to C<$thaw> but is called in process instead of being emitted as part of the dump. Any return is ignored. It is only relevant when C<$proxy> is a reference. =over 8 =item I No postdump action is to occur. =item I The code ref will be called after serialization is complete with the object as the argument. =item I The method will be called after serialization is complete =back =back An example DDS_freeze method is one I had to put together for an object which contained a key whose value was a ref to an array tied to the value of another key. Dumping this got crazy, so I wanted to suppress dumping the tied array. I did it this way: sub DDS_freeze { my $self=shift; delete $self->{'tie'}; return ($self,'->fix_tie','fix_tie'); } sub fix_tie { my $self=shift; if ( ! $self->{'tie'} ) { $self->{str}="" unless defined $self->{str}; tie my @a, 'Tie::Array::PackedC', $self->{str}; $self->{'tie'} = \@a; } return $self; } The C<$postop> means the object is relatively unaffected after the dump, the C<$thaw> says that we should also include the method inline as we dump. An example dump of an object like this might be $Foo1=bless({ str=>'' },'Foo')->fix_tie(); Wheras if we omit the C<< -> >> then we would get: $Foo1=bless({ str=>'' },'Foo'); $Foo1->fix_tie(); In our example it wouldn't actually make a difference, but the former style can be nicer to read if the object is embedded in another. However the non arrow notation is slightly more dangerous, in that its possible that the internals of the object will not be fully linked when the method is evaluated. The second form guarantees that the object will be fully linked when the method is evaluated. See L for a different way to control the representation of hash based objects. =head2 Controlling Hash Traversal and Display Order When dumping a hash you may control the order the keys will be output and which keys will be included. The basic idea is to specify a subroutine which takes a hash as an argument and returns a reference to an array containing the keys to be dumped. You can use the L routine or the L routine to specify the sorter to be used. The routine will be called in the following way: ( $key_array, $thaw ) = $sorter->($hash,($pass=0),$addr,$class); ( $key_array,) = $sorter->($hash,($pass=1),$addr,$class); C<$hash> is the hash to be dumped, C<$addr> is the refaddr() of the C<$hash>, and C<$class> will be set if the hash has been blessed. When C<$pass> is 0 the C<$thaw> variable may be supplied as well as the keyorder. If it is defined then it specifies what thaw action to perform after dumping the hash. See L|/$thaw> in L for details as to how it works. This allows an object to define those keys needed to recreate itself properly, and a followup hook to recreate the rest. B that if a L method is defined and returns a L|/$thaw> then the L|/$thaw> returned by the sorter will override it. =head2 Controlling Array Presentation and Run Length Encoding By default Data::Dump::Streamer will "run length encode" array values. This means that when an array value is simple (ie, its not referenced and does contain a reference) and is repeated multiple times the output will be single a list multiplier statement, and not each item output separately. Thus: L|/Dump> will be output something like $ARRAY1 = [ (0) x 4 ]; This is particularly useful when dealing with large arrays that are only partly filled, and when accidentally the array has been made very large, such as with the improper use of pseudo-hash notation. To disable this feature you may set the L property to FALSE, by default it is enabled and set to TRUE. =head2 Installing I as a package alias Its possible to have an alias to Data::Dump::Streamer created and installed for easier usage in one liners and short scripts. Data::Dump::Streamer is a bit long to type sometimes. However because this technically means polluting the root level namespace, and having it listed on CPAN, I have elected to have the installer not install it by default. If you wish it to be installed you must explicitly state so when Build.Pl is run: perl Build.Pl DDS [Other Module::Build options] Then a normal './Build test, ./Build install' invocation will install DDS. Using DDS is identical to Data::Dump::Streamer. =head2 use-time package aliasing You can also specify an alias at use-time, then use that alias in the rest of your program, thus avoiding the permanent (but modest) namespace pollution of the previous method. use Data::Dumper::Streamer as => 'DDS'; # or if you prefer use Data::Dumper::Streamer; import Data::Dumper::Streamer as => 'DDS'; You can use any alias you like, but that doesn't mean you should.. Folks doing as => 'DBI' will be mercilessly ridiculed. =head2 PadWalker support If PadWalker 1.0 is installed you can use DumpLex() to try to automatically determine the names of the vars being dumped. As long as the vars being dumped have my or our declarations in scope the vars will be correctly named. Padwalker will also be used instead of the B:: modules when dumping closures when it is available. =head1 INTERFACE =head2 Data::Dumper Compatibility For drop in compatibility with the Dumper() usage of Data::Dumper, you may request that the L method is exported. It will not be exported by default. In addition the standard Data::Dumper::Dumper() may be exported on request as C. If you provide the tag C<:Dumper> then both will be exported. =over 4 =item Dumper =item Dumper LIST A synonym for scalar Dump(LIST)->Out for usage compatibility with L =item DDumper =item DDumper LIST A secondary export of the actual L subroutine. =back =head2 Constructors =over 4 =item new Creates a new Data::Dump::Streamer object. Currently takes no arguments and simply returns the new object with a default style configuration. See C for a better way to do things. =cut sub _compressor { return "use Data::Dump::Streamer qw(usqz);\n" if !@_; return sqz($_[0], "usqz('", "')" ); } sub new { my $class = shift; my $self = bless { style => { hashsep => '=>', # use this to separate key vals arysep => ',', pairsep => ',', optspace => ' ', bless => 'bless()', # use this to bless objects, needs fixing compress => 0, # if nonzero use compressor to compress strings # longer than this value. compressor => \&_compressor, indent => 2, # should we indent at all? indentkeys => 1, # indent keys declare => 0, # predeclare vars? allows refs to root vars if 0 sortkeys => {}, verbose => 1, # use long names and detailed fill ins dumpglob => 1, # dump glob contents deparseglob => 1, deparse => 1, # deparse code refs? freezer => 'DDS_freeze', # default freezer freeze_class => {}, # freeze classes rle => 1, # run length encode arrays ignore => {}, # ignore classes indentcols => 2, # indent this number of cols ro => 1, # track readonly vars dualvars => 1, # dump dualvars eclipsename => "%s_eclipse_%d", purity => 1, # test # use this if deparse is 0 codestub => 'sub { Carp::confess "Dumped code stub!" }', formatstub => 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }', # use these opts if deparse is 1 deparseopts => ["-sCi2v'Useless const omitted'"], special => 0, # not yet implemented array_warn => 10_000, # warn if an array has more than this number of elements array_chop => 32_767, # chop arrays over this size array_max => 1_000_000, # die if arrays have more than this size smart_array => 1, # special handling of very large arrays # with hashes as their 0 index. (pseudo-hash error detection) }, debug => 0, cataloged => 0, ref_id => 0, sv_id => 0 }, $class; return $self; } sub _safe_self { my $self = shift; unless ( ref $self ) { $self = $self->new(); } return $self; } sub Dumper { return scalar Dump(@_)->Out(); } sub DDumper { return Data::Dumper::Dumper(@_); } #sub _is_utf8 { length $_[0] != do { use bytes; length $_[0] } } BEGIN { my $numeric_rex=qr/\A-?(?:0|[1-9]\d*)(\.\d+(? "\\a", "\b" => "\\b", "\t" => "\\t", "\n" => "\\n", "\f" => "\\f", "\r" => "\\r", "\e" => "\\e", ); # Taken from Data::Dumper::qquote() 2.12. # Changed utf8 handling from that version # put a string value in double quotes # Fixes by [ysth] sub _qquote { my $str = shift; my @ret; while (length($str)) { local($_)=substr($str,0,72,""); s/([\\\"\@\$])/\\$1/g; unless (/[^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/) { push @ret,qq("$_"); # fast exit next; } s/([\a\b\t\n\f\r\e])/$esc{$1}/g; if ( ord('^') == 94 ) { # ascii / utf8 # no need for 3 digits in escape if followed by a digit s/([\0-\037])(?!\d) / sprintf '\\%o', ord($1)/xeg; s/([\0-\037\177]) / sprintf '\\%03o', ord($1)/xeg; if (length $_ != do { use bytes; length $_ }) { use utf8; #perl 5.6.1 needs this, 5.9.2 doesn't. sigh s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg; s/([^\040-\176])/ sprintf '\\x{%x}', ord($1)/xeg; } else { # must not be under "use utf8" for 5.6.x s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg; } } else { # ebcdic s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} { my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v) }eg; s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} {'\\'.sprintf('%03o',ord($1))}eg; } push @ret,qq("$_"); } return join ".\n\t",@ret; } # single quote sub _quote { my $v = join "", @_; if ($v=~$numeric_rex) { return $v; } elsif ($v!~/[^\x20-\x7E]/) { $v =~ s/([\\''])/\\$1/g; return "'$v'"; } return _qquote($v); } # quote a key sub _quotekey { my $key = shift; if (!defined($key) or $key eq '') { return '""' } elsif ($key=~$numeric_rex or $key =~ /\A-?[A-Za-z_]\w*\z/) { return $key } else { _qquote($key); } } } my %ttrans = ( reftype( {} ) => '%', reftype( [] ) => '@', reftype( \ 'foo' ) => '$', reftype( \\'foo' ) => '$', # REF reftype( sub{} ) => '&', '' => '$', ); sub _make_name { my ( $self, $obj, $indx ) = @_; #warn Dumper($self->{unames})."'$self->{unames}' # : @{$self->{unames}||[]} @{[defined $indx ? $indx : '-']}"; my $uname = ( $self->{unames} || [] )->[ $indx || 0 ]; unless ($uname) { my $name = blessed($_[1]) || reftype($_[1]) || ((readonly($_[1]) && (\$_[1] != \undef)) ? "RO" : "VAR"); unless ($self->{style}{verbose}) { my $n=1; (my $abr=$name)=~s/(\w)\w*::/$1/g; $self->{type_abrv}{$name}||=$name; while ($n<=length($abr) and $self->{type_abrv}{substr($abr,0,$n)} and $self->{type_abrv}{substr($abr,0,$n)} ne $name) { $n++; } if ($n<=length($abr)) { $self->{type_abrv}{substr($abr,0,$n)}=$name; return '$' . substr($abr,0,$n) . ( ++$self->{type_ids}{$name} ); } } $name =~ s/::/_/g; ($name)=$name=~/(\w+)/; #take the first word; return '$' . $name . ( ++$self->{type_ids}{$name} ); } elsif ( $uname =~ /^[-*]/ ) { my $type = reftype( $_[1] ) || ''; $uname =~ s//$ttrans{$type}/; $uname; } else { return '$' . $uname; } } #=item diag # #Outputs to STDOUT a list of all values that have been identified of being #worth of study. For development/debugging purposes only at this point. # #=cut sub diag { my $self=shift; my $handle=shift || \*STDOUT; print $handle "+---+\n"; my $oidx; foreach my $idx (1..$self->{sv_id}) { print $handle $self->diag_sv_idx($idx); } print "-----\n" if $self->{ref_id} and $self->{sv_id}; foreach my $idx (1..($self->{ref_id}||0)) { print $handle $self->diag_ref_idx($idx); } print $handle "+---+\n"; $self; } sub remove_deref { my $var=shift; my ($brace,$rest,$sigil); if ($var=~s/^([\@\%\$])(?=\$)//) { ($sigil,$brace)=($1,$var) } else { local $@; ($brace,$rest,$sigil)= Text::Balanced::extract_bracketed( $var, '{q}',qr/[\@\%\$]/ ); } if ($brace and !$rest) { $brace=~s/^\{(.*)\}$/$1/; return wantarray ? ($sigil,$brace) : $brace; } else { return; } } my %tname=qw(HASH % ARRAY @ SCALAR $ REF $); sub _build_name { my ( $self, $name, $type, $val ) = @_; $DEBUG>1 and print STDOUT " _build_name( $name '$type' => "; $type=$tname{$type} if $tname{$type}; if ($type=~/[[{]/) { $name=~s/[\@\%]\$/\$/; my ($sigil,$brace)=remove_deref($name); if ( $name =~ /^([\@\%\$])(\w+)$/ or $sigil or $name=~/^\*.*\{(?:SCALAR|HASH|ARRAY)\}$/ ) { $name .= '->' if !($name =~ s/^[\@\%]/\$/) or $sigil; $name=~s/^\$(\$.*)->$/\$\{$1\}->/; } $DEBUG>1 and print STDOUT "$name => "; if ( $type eq '[' ) { $name .= "[$val]"; } elsif ( $type eq '{' ) { $name .= "{" . _quotekey($val) . "}"; } else { Carp::confess "Fallen off the end of the world..."; } } elsif ( $type =~ /^[\@\%\$]$/ ) { $name = "{$name}" if $name =~ /[\[\{]/ or $name=~/^\*/; $name = $type . $name unless substr( $name, 0, 1 ) eq $type and $type ne '$'; } else { no warnings; # XXX - why is this here? Yves Carp::confess "unimplemented _build_name"; } $DEBUG>1 and print "$name )\n"; $name; } sub _reset { my $self=shift; foreach my $key (keys %$self) { next unless $key=~/^(sv|ref|fix|cat|type|names|reqs|cache)/; delete $self->{$key}; } $self->{sv_id}=$self->{ref_id}=0; $self; } sub diag_sv_idx { my $self=shift; my $idx=shift; my $prefix=shift||''; my $oidx=$self->{ref}{$self->{sva}[$idx]}; my $ret=$prefix. sprintf "S%s%2d : %#x(c%2d|%2d) Dp:%2d %s Du:%s => %s %s %s %s\n", ($self->{special}{$idx} ? '*' : ' '),$idx, (map { $self->{$_}[$idx] } qw( sva svc svt svd )), ($self->{svro}[$idx] ? 'RO ' : 'RW'), (!$self->{svdu}[$idx] ? '-' : defined ${$self->{svdu}[$idx]} ? ${$self->{svdu}[$idx]} : '?'), $self->{svn}[$idx], (defined $self->{unames}[$idx-1] ? "($self->{unames}[$idx-1])" : ""), (($oidx) ? "< $self->{refn}[$oidx] >" : ""), ($self->{svon}{$idx} ? ": $self->{svon}{$idx}" : "") ; if ($prefix and $oidx) { $ret.=$prefix.$self->diag_ref_idx($oidx); } $ret; } sub diag_ref_idx { my $self=shift; my $idx=shift; my $oidx=$self->{sv}{$self->{refa}[$idx]}; sprintf "R %2d : %#x(c%2d|%2d) Dp:%2d Du:%s => %s %s\n", $idx, (map { defined $self->{$_}[$idx] ? $self->{$_}[$idx] : -1 } qw(refa refc reft refd )), (!$self->{refdu}[$idx] ? '-' : defined ${$self->{refdu}[$idx]} ? ${$self->{refdu}[$idx]} : '?'), $self->{refn}[$idx], (($oidx) ? " < $self->{svn}[$oidx] >" : "") ; } =item Dump =item Dump VALUES Smart non method based constructor. This routine behaves very differently depending on the context it is called in and whether arguments are provided. If called with no arguments it is exactly equivalent to calling Data::Dump::Streamer->new() which means it returns an object reference. If called with arguments and in scalar context it is equivalent to calling Data::Dump::Streamer->new()->Data(@vals) except that the actual depth first traversal is I until C is called. This means that options that must be provided before the C phase can be provided after the call to C. Again, it returns a object reference. If called with arguments and in void or list context it is equivelent to calling Data::Dump::Streamer->new()->Data(@vals)->Out() The reason this is true in list context is to make C do the right thing. And also that combined with method chaining options can be added or removed as required quite easily and naturally. So to put it short: my $obj=Dump($x,$y); # Returns an object my $str=Dump($x,$y)->Out(); # Returns a string of the dump. my @code=Dump($x,$y); # Returns a list of the dump. Dump($x,$y); # prints the dump. print Dump($x,$y); # prints the dump. It should be noted that the setting of C<$\> will affect the behaviour of both of Dump($x,$y); print Dump($x,$y); but it will not affect the behaviour of print scalar Dump($x,$y); B As of 1.11 Dump also works as a method, with identical properties as when called as a subroutine, with the exception that when called with no arguments it is a synonym for C. Thus $obj->Dump($foo)->Names('foo')->Out(); will work fine, as will the odd looking: $obj->Dump($foo)->Names('foo')->Dump(); which are both the same as $obj->Names('foo')->Data($foo)->Out(); Hopefully this should make method use more or less DWIM. =cut my %args_insideout; sub DESTROY { my $self=shift; delete $args_insideout{Data::Dump::Streamer::refaddr $self} if $self; } sub Dump { my $obj; if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) { $obj=shift; } if (@_) { if ( defined wantarray and !wantarray ) { $obj ||= __PACKAGE__->new(); $obj->_make_args(@_); return $obj; } else { $obj||=__PACKAGE__; return $obj->Data(@_)->Out(); } } else { if ($obj) { return $obj->Out(); } else { return __PACKAGE__->new(); } } } =item DumpLex VALUES DumpLex is similar to Dump except it will try to automatically determine the names to use for the variables being dumped by using PadWalker to have a poke around the calling lexical scope to see what is declared. If a name for a var can't be found then it will be named according to the normal scheme. When PadWalker isn't installed this is just a wrapper for L. Thanks to Ovid for the idea of this. See L for a similar wrapper around L. =cut sub DumpLex { if ( ! $HasPadWalker ) { #warn( "Can't use DumpLex without ". # "PadWalker v1.0 or later installed."); goto &Dump; } my $obj; if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) { $obj=shift; } my @names; # = map { # PadWalker::var_name(1,\$_) # || PadWalker::var_name(1,\$_) # (ref $_ && PadWalker::var_name(1,$_)); # $str # } @_; #if ( !@names && @_ ) { my %pad_vars; foreach my $pad ( PadWalker::peek_my(1), PadWalker::peek_our(1) ){ while (my ($var,$ref) = each %$pad) { $pad_vars{ refaddr $ref } ||= $var; } } foreach (@_) { my $name; INNER:foreach ( \$_, $_ ) { $name=$pad_vars{refaddr $_} and last INNER; } push @names, $name; } if ( defined wantarray and !wantarray ) { $obj ||= __PACKAGE__->new(); $obj->_make_args(@_); $obj->Names(@names); return $obj; } else { $obj||=__PACKAGE__; return $obj->Names(@names)->Data(@_)->Out(); } } =item DumpVars PAIRS This is wrapper around L which expect to receive a list of name=>value pairs instead of a list of values. Otherwise behaves like L. Note that names starting with a '-' are treated the same as those starting with '*' when passed to L. =cut sub DumpVars { my $obj; if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) { $obj=shift; } if (@_ % 2) { warnings::warnif "Odd number of arguments in DumpVars"; pop @_; } my @names; my @args; for ( 0 .. $#_/2 ) { $names[$_]=$_[$_*2]; $args[$_]=$_*2+1; } #die "@_:@names|@args"; if ( defined wantarray and !wantarray ) { $obj ||= __PACKAGE__->new(); $obj->_make_args(@_[@args]); $obj->Names(@names); return $obj; } else { $obj||=__PACKAGE__; return $obj->Data(@_[@args])->Names(@names)->Out(); } } sub _reg_ref { my ($self,$item,$depth,$name,$cnt,$arg)=@_; warn "_ref_ref($depth,$name,$cnt)\n" if $DEBUG; my $addr=refaddr $item; $arg->{raddr}=$addr if $arg; my $idx; unless ($idx=$self->{ref}{$addr}) { $idx=$self->{ref}{$addr}=++$self->{ref_id}; $arg->{ridx}=$idx if $arg; $self->{refn}[$idx]=$name; $self->{refd}[$idx]=$depth; $self->{refa}[$idx]=$addr; $self->{refc}[$idx]=$cnt; return wantarray ? ($idx,0) : $idx } $self->{reft}[$idx]++; $arg->{ridx}=$idx if $arg; return wantarray ? ($idx,1) : undef; } sub _reg_scalar { my ($self,$item,$depth,$cnt,$ro,$name,$arg)=@_; Carp::cluck $name if $name=~/^\$\*/; my $addr=refaddr \$_[1]; my $idx; $arg->{addr}=$addr if $arg; unless ($idx=$self->{sv}{$addr}) { $idx=$self->{sv}{$addr}=++$self->{sv_id}; $self->{svd}[$idx]=$depth; $self->{sva}[$idx]=$addr; $self->{svro}[$idx]=$ro; $self->{svc}[$idx]=$cnt; $self->{svw}{$addr}=!0 if isweak($_[1]); ($self->{svn}[$idx]=$name)=~s/^[\@\%\&]/\$/; if ($self->{svn}[$idx] ne $name) { $self->{svn}[$idx].="_"; #XXX #warn "$self->{svn}[$idx] ne $name" $self->{svon}{$idx}=$name; } } else{ if ($DEBUG>9) { print $self->diag_sv_idx($idx); print "$name is already registered as $self->{svn}[$idx] ". "Depth ($self->{svd}[$idx]) $depth\n"; } if ($self->{svn}[$idx]=~/^\$\{?\$/ and $name!~/^\$\{?\$/) { $self->{svn}[$idx]=$name; } } $self->{svt}[$idx]++; $arg->{idx}=$idx if $arg; Carp::confess "Dupe name!" if $self->{svrt}{$name}; $self->{svrt}{$name}=$idx; return $name; } *Precise=\&Dump; # we make an array of hashes containing useful info about the arguments sub _make_args { my $self=shift; $args_insideout{refaddr $self}= [ map { { item => \$_[$_], ro => readonly($_[$_]), refcnt => sv_refcount($_[$_]), } } 0..$#_ ]; return $args_insideout{refaddr $self} } =back =head2 Methods =over 4 =item Data =item Data LIST Analyzes a list of variables in breadth first order. If called with arguments then the internal object state is reset before scanning the list of arguments provided. If called with no arguments then whatever arguments were provided to C will be scanned. Returns $self. =cut sub _add_queue { my ($self,$queue,$type,$item,$depth,$name,$rcount,$arg)=@_; if (substr($type,0,1) ne '*') { push @$queue,[\$item,$depth,$name,$rcount,$arg]; } elsif($self->{style}{dumpglob}) { local @_; foreach my $t ($self->_glob_slots('FORMAT')) { #warn $type.":$t\n"; #register? #$self->_reg_scalar(*$item{$t},$depth+1,sv_refcount(*$item{$t}), # readonly(*$item{$t}),'*'.$name."{$t}"); my $v=*$item{$t}; next unless defined $v; next if $t eq 'SCALAR' and !defined($$v); push @$queue,[ \*$item{$t}, $depth+1, $type."{$t}", refcount(\*$item{$t}) ]; } } #use Scalar::Util qw(weaken); $self; } sub Data { my $self=shift->_safe_self; my $args; print "Data(".scalar(@_)." vars)\n" if $DEBUG; if (@_) { $self->_reset; $self->_make_args(@_); } elsif ( $self->{cataloged} ) { $self->_reset; } $args= $args_insideout{refaddr $self} || Carp::carp "No arguments!"; my $pass=1; PASS:{ my @queue; my $idx=0; foreach my $arg (@$args) { #($self,$item,$depth,$cnt,$ro,$name) my $make_name=$self->_make_name(${ $arg->{item} },$idx++); my $name=$self->_reg_scalar( ${ $arg->{item} }, 1, $arg->{refcnt}, $arg->{ro}, $make_name, $arg ); $arg->{name}=$name; if (my $type=reftype_or_glob ${ $arg->{item} }) { $self->_add_queue(\@queue, $type, ${ $arg->{item} }, 2, $name, refcount ${ $arg->{item} },$arg) } } my %lex_addr; my %lex_addr2name; my %lex_name; my %lex_special; while (@queue) { # If the scalar (container) is of any interest it is # already registered by the time we see it here. # at this point we only care about the contents, not the # container. print Data::Dumper->new([\@queue],['*queue'])->Maxdepth(3)->Dump if $DEBUG>=10; my ($ritem, $cdepth, $cname, $rcnt, $arg)=@{shift @queue}; my ($frozen,$item,$raddr,$class); DEQUEUE:{ $item=$$ritem; $raddr=refaddr($item); $class=blessed($item); if ($self->{ref_fz}{$raddr}) { print "Skipping frozen element $raddr\n" if $DEBUG; next; } $DEBUG and print "Q-> $item $cdepth $cname $rcnt ($raddr)\n"; unless ($raddr) { $DEBUG and print " Skipping '$cname' as it isn't a reference.\n"; next; } last DEQUEUE if $frozen; $frozen=1; if ($self->{style}{ignore}{"#$raddr"} || ($class&& $self->{style}{ignore}{".$class"})) { $DEBUG and print "Ignoring '$cname' as its class ($class) in ". "our ignore list.\n"; next; } elsif ($class && !$self->{"cache_skip_freeze"}{$class}) { my $freezer= $self->{cache_freeze_class}{$class}; my ( $proxy, $thaw, $postop ); if (! defined $freezer ) { for ( $self->{style}{freeze_class}{$class}, $self->{style}{freezer}, 'DDS_freeze' ) { $freezer= $_; if ( $freezer ) { if (ref $freezer) { eval { ($proxy,$thaw,$postop)= $freezer->($$ritem); }; last if !$@; } elsif ( $class->can($freezer) ) { eval { ($proxy,$thaw,$postop)= ${$ritem}->$freezer(); }; last if !$@; } } elsif ( defined $freezer ) { last; } } if (! defined $proxy) { $self->{"cache_skip_freeze"}{$class}=1; } else { $self->{cache_freeze_class}{$class}= $freezer; } } elsif (ref $freezer) { ($proxy,$thaw)= $freezer->($$ritem); } else { ($proxy,$thaw)= ${$ritem}->$freezer(); } if ( $thaw ) { $self->{ref_thaw}{$raddr}= $thaw; } if ( $postop ) { $self->{ref_postop}{$raddr}= $postop; } if ( refaddr($proxy) != $raddr ) { $self->{ref_fz}{$raddr}= $proxy; $ritem= \$proxy; if (ref $proxy) { redo DEQUEUE; } else { next; } } } } my ($idx,$dupe)=$self->_reg_ref($item,$cdepth,$cname,$rcnt,$arg); $DEBUG and print " Skipping '$cname' as it is a dupe of ". "$self->{refn}[$idx]\n" if $dupe; $DEBUG>9 and $self->diag; next if $dupe; my $reftype=reftype $item; my $cnt=refcount($item); my $overloaded=undef; my $isoverloaded=0; if (defined $class and overload::Overloaded($item)) { disable_overloading( $item ); $overloaded= $class; $isoverloaded= 1; } if ( $reftype eq 'SCALAR' or $reftype eq 'REF' or $reftype eq 'GLOB' ) { my $name=$self->_build_name($cname,'$'); my $cnt=sv_refcount($$item); if ($cnt>1) { $self->_reg_scalar($$item,$cdepth+1,$cnt, readonly($$item),$name); } if (my $type=reftype_or_glob $$item) { $self->_add_queue(\@queue,$type,$$item, $cdepth+2,$name,$cnt) } } elsif ($reftype eq 'ARRAY') { foreach my $idx (0..$#$item) { my $name=$self->_build_name($cname,'[',$idx); my $cnt=sv_refcount($item->[$idx]); if ($cnt>1) { print "refcount($name)==$cnt\n" if $DEBUG>9; $self->_reg_scalar($item->[$idx],$cdepth+1,$cnt, readonly($item->[$idx]),$name); } if (my $type=reftype_or_glob $item->[$idx]) { $self->_add_queue(\@queue,$type,$item->[$idx], $cdepth+2,$name,$cnt) } } } elsif ($reftype eq 'HASH') { my $ik=$self->{style}{indentkeys}; my ($keyary, $thaw)= $self->_get_keys($item,0,$raddr,$class); if ($thaw) { $self->{ref_thaw}{$raddr}= $thaw; } my $key_len=0; my $key_sum=0; my $key_count=0; die reftype $keyary if $keyary && reftype($keyary) ne 'ARRAY'; while ( defined( my $key = defined $keyary ? $keyary->[$key_count] : each %$item )) { if ($ik) { my $qk=_quotekey($key); $key_sum+=length($qk); $key_len=length($qk) if $key_len_build_name($cname,'{',$key); my $cnt=sv_refcount($item->{$key}); if ($cnt>1) { $self->_reg_scalar($item->{$key},$cdepth+1,$cnt, readonly($item->{$key}),$name); } if (my $type=reftype_or_glob $item->{$key}) { $self->_add_queue(\@queue,$type,$item->{$key}, $cdepth+2,$name,$cnt); } } my $avg=$key_count>0 ? $key_sum/$key_count : 0; $self->{ref_hklen}{$raddr}=($key_len>8 && (2/3*$key_len)>$avg) ? int(0.5+$avg) : $key_len; $self->{ref_hkcnt}{$raddr}=$key_count; #warn "$raddr => $key_count"; } elsif ($reftype eq 'CODE') { if ($pass == 1) { my $used=_get_lexicals($item); foreach my $name (keys %$used) { next unless $name=~/\D/; my $addr=refaddr($used->{$name}); if ( !$lex_addr{$addr} ) { $lex_addr{$addr}=$used->{$name}; if ( $lex_name{$name} ) { my $tmpname=sprintf "%s".$self->{style}{eclipsename}, substr($name,0,1), $self->{style}{eclipsename}=~/^[^%]*%s/ ? ( substr($name,1), ++$lex_special{$name}, ) : ( ++$lex_special{$name}, substr($name,1), ); $lex_name{$tmpname}=$addr; $lex_addr2name{$addr}=$tmpname; $self->_add_queue(\@queue,reftype_or_glob $used->{$name}, $used->{$name},$cdepth+1,$tmpname,2); } else { $lex_name{$name}=$addr; $lex_addr2name{$addr}=$name; $self->_add_queue(\@queue,reftype_or_glob $used->{$name}, $used->{$name},$cdepth+1,$name,2); } } } } } elsif ($reftype eq 'FORMAT') { # Code similar to that of CODE should go here I think. } else { # IO? Carp::confess "Data() can't handle '$reftype' objects yet ($item)\n :-(\n" if $ENV{DDS_STRICT}; } if ($isoverloaded) { restore_overloading( $item, $overloaded ); } } if ( $pass++ == 1 ) { my %items; for my $idx ( 0..$#{$args_insideout{refaddr $self}} ) { my $item=$args_insideout{refaddr $self}[$idx]; $items{ refaddr $item->{item} } = $idx; } my @add; my $added=0; if (0) { @add=keys %lex_addr; } else { for my $addr (keys %lex_addr) { if ( exists $items{$addr} ) { my $idx = $items{$addr}; if ( !$self->{unames}[$idx] ){ for ($self->{unames}[$idx] = $lex_addr2name{$addr}) { s/^[^\$]/*/; s/^\$//; } $added++; } else { my $new=$self->{unames}[$idx]; my $old=$lex_addr2name{$addr}; $new=~s/^(\*)?/substr($old,0,1)/e; delete $lex_name{$lex_addr2name{$addr}}; $lex_addr2name{$addr}=$new; $lex_name{$self->{unames}[$idx]} = $addr; # xxx } } else { push @add,$addr; } } } @add=sort {$lex_addr2name{$a} cmp $lex_addr2name{$b}} @add; $self->{lexicals}={ a2n => \%lex_addr2name, name => \%lex_name }; if (@add) { unshift @{$args_insideout{refaddr $self}}, map { my $rt=reftype($lex_addr{$_}); my $item; if ($rt ne 'SCALAR' and $rt ne 'GLOB' and $rt ne 'REF') { $item=\$lex_addr{$_}; } else { $item=$lex_addr{$_}; } { item => $item, usemy => 1, ro => 0, refcnt => refcount($lex_addr{$_}), } } @add; $self->{lexicals}{added}={ map { $lex_addr2name{$_} => 1 } @add }; unshift @{$self->{unames}}, map { (my $n=$lex_addr2name{$_})=~s/^[^\$]/*/; $n=~s/^\$//; $n } @add; $self->_reset; redo PASS; } elsif ($added) { $self->_reset; redo PASS; } } } $self->{cataloged}=1; return $self; } sub _add_fix { my ($self,@args)=@_; # 'var','glob','method call','lock','ref','sv','#' # TODO # add a fix statement to the list of fixes. my $fix=@args==1 ? shift @args : [@args]; unless ($fix->[0]=~/^(var|glob|thaw|ref|sv|#|sub call|lock|bless)$/) { Carp::confess "Unknown variant:".Dumper($fix); } if ($args[0] eq 'var') { unshift @{$self->{fix}},$fix; } else { push @{$self->{fix}},$fix; } } sub _glob_slots { my ($self,$inc_format)=@_; # $inc_format is for a special case. return ( qw(SCALAR HASH ARRAY), (($self->{style}{deparse} && $self->{style}{deparseglob}) ? 'CODE' : ()), (($inc_format && $self->{style}{deparse} && $self->{style}{deparseglob}) ? 'FORMAT' : () ) ); } sub _dump_apply_fix { #handle fix statements and GLOB's here. my ($self,$isfinal)=@_; # go through the fix statements and out any that are # now fully dumped. # currently the following types are grokked: # 'var','glob','method call','tlock','ref','sv','#' my @globs; GLOB:{ @globs=(); @{$self->{fix}}=grep { my $keep=1; my $fix=$_; if (ref $fix) { my ($type,$lhs,$rhs,$class)=@$fix; if ($type eq '#') { $self->{fh}->print(map "# $_\n",@$fix[0..$#$fix]); $keep=0; } elsif ($type eq 'bless') { if ($isfinal) { # $self->{"refdu"}[$lhs] $lhs=$self->{"refn"}[$lhs]; $self->{fh}->print( substr($self->{style}{bless},0,-1)," ",$lhs,", ", _quote($rhs)," ",substr($self->{style}{bless},-1), ";\n"); $keep=0; } } elsif ($type eq 'sv') { my $dref=$_->[-1]; if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) { $rhs=$self->{$type."n"}[$rhs]; my ($sigil,$var)=remove_deref($lhs); if ($sigil) { $rhs="\\".$rhs; $lhs=$var; } $self->{fh}->print("$lhs = $rhs;\n"); $$dref=1 if ref $dref; $keep=0 } } elsif ($type eq 'ref') { if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) { $rhs=$self->{$type."n"}[$rhs]; if ($rhs=~/^[\@\%\&]/) { $rhs="\\".$rhs; $rhs="bless( $rhs, "._quote($class).' )' if $class; } # Warn if $self->{fh}->print("$lhs = $rhs;\n"); $keep=0 } } elsif ($type eq 'lock') { if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) { $lhs=$self->{"refn"}[$lhs]; $self->{fh}->print(@$rhs ? "lock_keys_plus( $lhs, " : "lock_keys( $lhs ", join(", ",map{ _quote($_) } @$rhs), ");\n"); $keep=0; } } elsif ($type eq 'thaw') { # these have to happen at the end. if ($isfinal) { #if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) { ${$self->{refdu}[$lhs]}=1; $lhs=$self->{"refn"}[$lhs]; my @args=@$_[3..$#$_]; if ($rhs=~/^(->)?((?:\w*::)*\w+)(\(\))?$/) { if ($3) { $self->{fh}->print("$2( ".join(", ",$lhs,@args)." );\n"); } else { $self->{fh}->print("$lhs->$2(".join(", ",@args).");\n"); } } else { $rhs=~s/^\t//mg; $self->{fh}->print("for ($lhs) {\n$rhs\n}\n"); } $keep=0; } } elsif ($type eq 'glob') { push @globs,$_; $keep=0; } elsif ($type eq 'var') { $rhs="\\".$rhs; $rhs="bless( $rhs, "._quote($class).' )' if $class; $self->{fh}->print(($self->{style}{declare} ? 'my ' : ""),"$lhs = $rhs;\n"); $keep=0; } elsif ($type eq 'sub call') { my @r=grep { ref $_ and (!$self->{svdu}[$$_] or !${$self->{svdu}[$$_]}) } @$fix; unless (@r) { my ($type,$sub,@args)=map { ref $_ ? $self->{svn}[$$_] : $_ } @$fix; $self->{fh}->print("$sub(",join(", ",@args),");\n"); $keep=0; } } else { die "Bad fix: ",Dumper($fix); } } $keep; } @{$self->{fix}}; foreach my $glob (@globs) { my ($type,$lhs,$rhs,$depth,$name)=@$glob; print "Symbol: $name\n" if $DEBUG and $name; local @_; $name=$name ? '*'.$name : $rhs; my $overloaded=undef; my $isoverloaded=0; if (defined( blessed $lhs ) and overload::Overloaded( $lhs ) ) { $overloaded=blessed $lhs; disable_overloading( $lhs ); $isoverloaded=1; } foreach my $t ($self->_glob_slots('')) { my $v=*$lhs{$t}; if ( not(defined $v) or ($t eq 'SCALAR' and !defined($$v))) { next; } my $dumped=0; my $gaddr=refaddr(*$lhs{$t}); my $gidx=$self->{ref}{$gaddr}; unless ($gidx) { next } elsif ($self->{refd}[$gidx]<$depth+1) { $self->_add_fix('ref',$name,$gidx,blessed(*$lhs{$t})); next; } $self->{fh}->print("$name = "); my $ret=$self->_dump_sv(*$lhs{$t},$depth,\$dumped,$name,length($name)+3); Carp::confess "\nUnhandled alias value '$ret' returned to _dump_apply_fix()!" if $ret; $self->{fh}->print(";\n"); $dumped=1; } if ($self->{style}{deparse} && $self->{style}{deparseglob} #and defined *$lhs{FORMAT} ) { # from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org # translate arg (or reference to it) into a B::* object # To work-around perl commit # 2acc3314e31a9342e325f35c5b592967c9850c9b, keep the # value \*$lhs alive while we inspect it as a B object # or else it'll be reaped while we're using it. my $lhs_glob = \*$lhs; my $Bobj = B::svref_2object($lhs_glob); # if passed a glob or globref, get the format $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV'; if (ref $Bobj eq 'B::FM') { (my $cleaned=$name)=~s/^\*(::)?//; $self->{fh}->print("format $cleaned =\n"); my $deparser = Data::Dump::Streamer::Deparser->new(); $self->{fh}->print( $deparser->indent($deparser->deparse_format($Bobj)) ); $self->{fh}->print("\n"); } } if ($isoverloaded) { restore_overloading( $lhs, $overloaded ); } } redo GLOB if @globs; } } =item Out =item Out VALUES Prints out a set of values to the appropriate location. If provided a list of values then the values are first scanned with C and then printed, if called with no values then whatever was scanned last with C or C is printed. If the C attribute was provided then will dump to whatever object was specified there (any object, including filehandles that accept the print() method), and will always return $self. If the C attribute was not provided then will use an internal printing object, returning either a list or scalar or printing to STDOUT in void context. This routine is virtually always called without arguments as the last method in the method chain. Dump->Arguments(1)->Out(@vars); $obj->Data(@vars)->Out(); Dump(@vars)->Out; Data::Dump::Streamer->Out(@vars); All should DWIM. =cut # # Out is just a wrapper. The overall dumping process works like this: # # Out # foreach root value # _dump_sv # _dump_rv if ref # (optionally one of) # _dump_array # _dump_hash # _dump_code # _dump_qr # _dump_apply_fix # (which may call) # _dump_sv # # _dump_array, _dump_hash, _dump_rv if needed may also call _dump_sv # # essentially _dump_sv and _dump_rv handle uniqueness checks for scalars, # and refs. _dump_sv handles the SV's containers and _dump_rv # handles the things that the SV contains a reference to. _dump_sv also # handles simple values and globs, and works with _dump_rv to handle # references to scalars correctly. If "fix" statements are required # to complete the definition of the structure (self referential structures) # then _add_fix adds them to the list, and _dump_apply_fix pulls them off. # note that _dump_apply_fix can also call _dump_sv if needed (to handle globs), # and will also emit fix statements as early as possible. no require/use # logic is currently in place. its the evalers responsibility to use the mod # w/the right tags for now... sub Out { local($\,$",$,)=("","",""); # prevent globals from messing with our output via print my $self = shift->_safe_self; print "Out(".scalar(@_)." vars)\n" if $DEBUG; if ( !$self->{in_printit} and (@_ or !$self->{cataloged} )) { $self->Data(@_); } my $fh; unless ( $self->{fh} ) { print " no filehandle using " if $DEBUG; if (defined wantarray) { my $class= __PACKAGE__ . (wantarray ? "::_::ListPrinter" : "::_::StringPrinter"); print $class,"\n" if $DEBUG; $fh = $class->new() or Carp::confess "$class failed to build!"; $self->{'return'} = $fh; } else { print "STDOUT\n" if $DEBUG; $fh = \*STDOUT; } $self->{fh} = $fh; } # loop over the list # and dump out each one in turn # handling any potential fixes after # each definition is complete $self->{out_names}=[]; $self->{declare}=[]; $self->{special}={}; $DEBUG>9 and $self->diag; my @items=@{$args_insideout{refaddr $self}}; my $namestr=""; push @{$self->{out_names}},map{$_->{name}}@items; #must push @{$self->{declare}},map{$_->{name}}@items; if ($self->{style}{special}) { warn DDumper(\@items) if $DEBUG; $namestr="# (".join (", ",@{$self->{out_names}}).")\n"; @items=sort { $self->{svc}[$b->{idx}] <=> $self->{svc}[$a->{idx}]|| ($b->{raddr} ? $self->{refc}[$b->{ridx}] : 0) <=> ($a->{raddr} ? $self->{refc}[$a->{ridx}] : 0) } @items; warn DDumper(\@items) if $DEBUG; } if ($self->{style}{compress} && $self->{style}{compressor}) { my $prelude=$self->{style}{compressor}->(); $self->{fh}->print($prelude) if $prelude; } $self->{fh}->print("my (",join(",",sort keys %{$self->{lexicals}{added}}),");\n") if $self->{lexicals}{added}; foreach my $item (@items) { my $dumped=0; my $ret=$self->_dump_sv(${$item->{item}},1,\$dumped,$item->{name}); Carp::confess "\nUnhandled alias value '$ret' returned to Out()!" if $ret; $self->{fh}->print(";\n"); $dumped=1; $self->_dump_apply_fix(); } $self->_dump_apply_fix('final'); $self->{fh}->print($namestr) if $namestr; $self->diag if $DEBUG; #warn "@{$self->{out_names}}"; if ( $self->{return} and defined wantarray) { my $r = delete $self->{return}; delete $self->{fh}; return $r->value; } else { return $self; } } sub print_token { my ($self, $str)=@_; $self->{fh}->print($str); } sub print_quoted { my ( $self, $str )=@_; $self->{fh}->print($str); } # sqz(str,begin,end) sub sqz { require Compress::Zlib; require MIME::Base64; my $res= Compress::Zlib::compress($_[0],9); return $_[1] ? $_[1] . MIME::Base64::encode($res,"") . $_[2] : MIME::Base64::encode($res,""); } # usqz(str) sub usqz { return Compress::Zlib::uncompress( MIME::Base64::decode($_[0]) ); } sub _dump_sv { my ($self,$item,$depth,$dumped,$name,$indent,$is_ref)=@_; $self->{do_nl}=0; my $addr=refaddr(\$_[1]); my $idx=$self->{sv}{$addr}; my $ro; $DEBUG and printf "_dump_sv %d %s %#x - %d\n",$depth, $name,$addr,$idx||0; $name||=$self->{svn}[$idx]; (my $clean_name=$name)=~s/^[\@\%\&](\w+)/\$${1}_/; # XXX my $optspace=$self->{style}{optspace}; if ($idx) { # Its a monitored scalar. my $pre_dumped=$self->{svdu}[$idx]; my $name_diff=( $self->{svd}[$idx]==$depth and $self->{svn}[$idx] ne $clean_name and $clean_name!~/\*/ and $name!~/^\&/ ); #print "Idx: $idx Special keys:",join("-",keys %{$self->{special}}),"\n" # if $DEBUG and keys %{$self->{special}}; print "sv_dump Monitored:\n",$self->diag_sv_idx($idx," ") if $DEBUG; if (( $pre_dumped and !$self->{svon}{$idx}) or (!$self->{svon}{$idx} ? ($self->{svd}[$idx]<$depth or $name_diff) : undef) ) { print "PREDUMPED: $self->{svon}{$idx}\n" if $DEBUG and $self->{svon}{$idx} and $pre_dumped and $$pre_dumped; # We've seen it before. # Unless its a ref it must be an alias print(($name_diff ? "Name diff" : "No name diff"), " $name, $clean_name","\n") if $DEBUG; my ($str,$ret)=('',undef); if ($is_ref) { if ($self->{svd}[$idx]==1 && !$self->{style}{declare} || ($pre_dumped && $$pre_dumped) ) { $str="\\$self->{svn}[$idx]"; } else { #see the 'Many refs' tests in t\dump.t for #why this is here. basically we need to #ensure the ref is modifiable. If its two $'s #then its modifiable anyway, more and it wont be. # $ref=\\$x; $ref=RW $$ref=RO $$$ref=$x=RW unless ($self->{style}{purity}) { $str="\\$self->{svn}[$idx]"; } else { my $need_do=($name=~/^\$\$\$+/); if ($need_do) { $str.=join($optspace,qw( do { my $f = ),''); } $str.=!$self->{style}{verbose} ? "'R'" : _quote($DEBUG ? 'SR: ' : 'R: ', "$self->{svn}[$idx]"); $ret=\do{my $nope=0}; $self->_add_fix('sv',$name,$idx,$ret); $str.="$optspace}" if ($need_do) } } } else { if ($depth==1) { if ($self->{style}{declare}) { $str.="my $name;\n"; } #push @{$self->{out_names}},$name; #push @{$self->{declare}},$name; $str.="alias_ref(\\$name,\\$self->{svn}[$idx])"; } elsif ($self->{style}{purity}) { $str.=!$self->{style}{verbose} ? "'A'" : _quote("A: ",$self->{svn}[$idx]); $ret=\$idx; } else { $str.="alias_to($self->{svn}[$idx])"; $ret=''; } } $self->{buf}+=length($str); $self->{buf}=length($1) if $str=~/\n([^\n]*)\s*\z/; $self->{fh}->print($str); return $ret ? $ret : () } else { # we've never seen it before and we need to dump it. $self->{svdu}[$idx]||=$dumped; print "Defining Special:".$self->diag_sv_idx($idx) if $DEBUG and $self->{special}{$idx}; $self->{svn}[$idx]=$name if $self->{special}{$idx}; $self->{svd}[$idx]=$depth if $self->{special}{$idx}; } $ro=$self->{svro}[$idx]; } else { $ro=readonly $_[1] unless defined $ro; } print "sv_dump: Postindexed\n" if $DEBUG; if ($depth==1) { # root level object. declare it if ($name ne $clean_name and $name!~/^\*/ and $self->{svc}[$idx]>1) { print "Special $name\n" if $DEBUG; my $oidx=$self->{ref}{$self->{sva}[$idx]}; if ($oidx) { #theres a ref to us out there my $name=$self->_build_name($self->{refn}[$oidx],'$'); $self->{svn}[$idx]=$name; print "Oindex! $oidx $name\n" if $DEBUG; #$self->{svd}[$idx]=$self->{refd}[$idx]+1; } #$self->{special}{$idx}++; $self->{svdu}[$idx]=undef; print $self->diag_sv_idx($idx,1) if $DEBUG; } #push @{$self->{out_names}},$name; #must #push @{$self->{declare}},$name; unless ($name=~/^\&/) { # XXX my $str=(($self->{style}{declare} && $name!~/^\*/ && !$self->{lexicals}{added}{$name} ) ? "my$optspace" : "" )."$name$optspace=$optspace"; $self->{fh}->print($str); $indent=length($str); $self->{buf}=0; } else { $indent=0; } print "toplevel\n" if $DEBUG; } my $iaddr=refaddr $item; $self->{fh}->print("\\") if $is_ref; my $glob=globname $item; my $add_do=$self->{style}{purity} && !$ro && $is_ref && !blessed($_[1]) && !$glob && do { my $rtype= reftype($_[1]); $rtype eq "" or ($rtype eq "SCALAR" and ( $] < 5.020 or !readonly(${ $_[1] }) ) ) } ; if ($add_do) { #warn "\n!$ro && $is_ref && !blessed($_[1]) && !$glob"; $self->{fh}->print(join $optspace,qw(do { my $v = ),''); $self->{buf}+=13; } unless ($iaddr) { print "iaddr $glob\n" if $DEBUG; unless (defined $item) { $self->{fh}->print('undef'); $self->{buf}+=5; } else { my $is_ro=($self->{style}{ro} && $ro && !$is_ref); if ($is_ro and !$self->{style}{purity}) { $self->{fh}->print("make_ro($optspace"); } if ($glob) { if ($glob=~/^\*Symbol::GEN/) { $self->_dump_symbol($_[1],$name,$glob,'deref',$depth); } else { $self->{buf}+=length($glob); $self->{fh}->print($glob); if ($self->{style}{dumpglob} and !$self->{sv_glob_du}{$glob}++) { $self->_add_fix('glob',$_[1],$glob,$depth+1); } } } else { my $quoted; if ($self->{style}{dualvars}) { no warnings 'numeric'; # XXX: is this required? if (_could_be_dualvar($item) && 0+$item ne $item && "$item" != $item ) { $quoted="dualvar( ".join(",$optspace",0+$item,_quote("$item"))."$optspace)"; } } # XXX main scalar output here! if ( ! $quoted ) { my $style= $self->{style}; if ( $style->{compress} && $style->{compressor} && length($_[1]) > $style->{compress} ){ $quoted= $style->{compressor}->($_[1],$self); } else { $quoted=_quote($item); } } $self->{buf}+=length($quoted); $self->{buf}=length($1) if $quoted=~/\n([^\n]*)\s*\z/; $self->{fh}->print($quoted); #; } if ($is_ro && $self->{style}{purity}) { $self->_add_fix('sub call','make_ro',$name); } elsif ($is_ro) { $self->{fh}->print("$optspace)"); } #return } $self->{do_nl}=0; } else { $self->{do_nl}=1; $self->_dump_rv($item,$depth+1,$dumped,$name,$indent,$is_ref && !$add_do); } $self->{fh}->print("$optspace}") if $add_do; $self->_add_fix('sub call','weaken',$name) if $self->{svw}{$addr}; return } sub _brace { my ($self,$name,$type,$cond,$indent,$child)=@_; my $open=$type=~/[\{\[\(]/; my $brace= $name !~ /^[%@]/ ? $type : $type =~ /[\{\[\(]/ ? '(' : ')'; $child= $child ? $self->{style}{optspace} : ""; if ( $cond ) { $_[-2] += $open ? $self->{style}{indentcols} : -$self->{style}{indentcols}; $self->{fh}->print($open ? "" : "\n".(" " x $_[-2]), $brace, $open ? "\n".(" " x $_[-2]) : ""); } else { $self->{fh}->print($open ? "" : $child , $brace, $open ? $child : ""); } return } sub _dump_qr { my ($self,$pat,$mod)=@_; my %counts; $counts{$_}++ foreach split //,$pat; my ($quotes,$best)=('',length($pat)+1); foreach my $char (qw( / ! % & <> {} " ),'#') { #" my $bad=0; $bad+=$counts{$_}||0 for split //,$char; ($quotes,$best)=($char,$bad) if $bad<$best; last unless $best; } $pat=~s/(?!\\)([$quotes])/\\$1/g if $best; { use utf8; #$pat=~s/([^\x00-\x7f])/sprintf '\\x{%x}',ord $1/ge; $pat=~s/([^\040-\176])/sprintf "\\x{%x}", ord($1)/ge; } $self->{fh}->print('qr',substr($quotes,0,1),$pat,substr($quotes,-1),$mod); return } =for uedit32 sub _default_key_sorters{} =cut my %default_key_sorters= ( numeric => sub { [ sort {$a <=> $b} keys %{$_[0]} ] }, lexical => sub { [ sort keys %{$_[0]} ] }, smart => sub { [ map { $_->[-1] } sort { ( $a->[2] <=> $b->[2] ) || ( defined($a->[0]) ? $a->[0] <=> $b->[0] || ($a->[1] cmp $b->[1]) : $a->[1] cmp $b->[1] ) || ( $a->[-1] cmp $b->[-1] ) } map { my $chars=lc($_); my $num; $num=$1 if $chars=~ s/\A(-?(?:0|[1-9]\d{0,8})(?:\.\d{0,15})?)(?!\d)//; $chars=~s/\W//g; [ $num, $chars, !defined $num ? 2 : # length($chars) ? 1 : 0, $_ ] } keys %{$_[0]} ] }, 'each'=>sub { undef }, ); $default_key_sorters{alphabetical}=$default_key_sorters{lexical}; $default_key_sorters{intelligent}=$default_key_sorters{smart}; for my $h (\%default_key_sorters) { my $abr=Text::Abbrev::abbrev(keys %$h); foreach my $short (keys %$abr) { $h->{$short}=$h->{$abr->{$short}}; } } sub _get_keys { my ($self,$item,$pass,$addr,$class)=@_; my $sorter; $class= "" if ! defined $class; $sorter= $self->{style}{sortkeys}{"#$addr"} || $self->{cache_sorter}{$class}; if ( ! $sorter ) { $sorter= $self->{style}{sortkeys}{".$class"} || ($class && $class->can("DDS_sortkeys") ) || $self->{style}{sortkeys}{"."}; ; $self->{cache_sorter}{$class}= ($sorter ||= $default_key_sorters{smart}); } my ($ary,$thaw)=$sorter->( $item, $pass, $addr, $class ); die "$item:$pass:$addr:$class:$ary:$thaw" if $ary and reftype($ary) ne "ARRAY"; return ($ary,$thaw); } sub _dump_hash { my ($self,$item,$depth,$dumped,$name,$indent,$addr,$class)=@_; #Carp::confess "$name" unless defined $self->{ref_hkcnt}{$addr}; my ($keyary)= $self->_get_keys($item,1,$addr,$class); if ($keyary and $DEBUG) { warn "Keys: $keyary : @$keyary" } my $full_indent=$self->{style}{indent}>1; my $ind=($self->{style}{indent}) && (!defined($self->{ref_hkcnt}{$addr}) or $self->{ref_hkcnt}{$addr}>1); $self->_brace($name,'{',$ind,$indent,$self->{ref_hkcnt}{$addr}) ; my $indkey=($ind && $self->{style}{indentkeys}) ? $self->{ref_hklen}{$addr} : 0; my $cindent= $indent; my $style= $self->{style}; my $optspace= $style->{optspace}; my $sep= $optspace . $self->{style}{hashsep} . $optspace; my $pairsep= $self->{style}{pairsep}; if ($indkey) { $cindent+= $indkey + length($sep); } $DEBUG==10 and print "Indent $ind $indkey $cindent\n"; my ($kc,$ix)=(0,0); my $last_n=0; my $ind_str=" " x $indent; while (defined(my $k=defined $keyary ? $keyary->[$ix++] : each %$item)) { $last_n=0 if ref $item->{$k}; if ( $kc ) { my $do_ind=$ind && !$last_n ; $self->{fh}->print($pairsep, $do_ind ? "\n$ind_str" : $optspace); $self->{buf}++; if ($do_ind) { $self->{buf}=0; } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) { $self->{fh}->print("\n"); $self->{buf}=0; } } else { #$self->{fh}->print("\n$ind_str") if !$last_n; $kc=1; } if ($indkey) { my $qk=_quotekey($k); my $str=$indkey>=length($qk) ? join "",$qk," " x ($indkey-length($qk)), $sep : join "",$qk,"\n$ind_str"," " x $indkey, $sep ; $self->{buf}+=length($str); $self->{fh}->print($str); } else { my $str=_quotekey($k).$sep; $self->{buf}+=length($str); $self->{fh}->print($str); } my $alias=$self->_dump_sv($item->{$k},$depth+1,$dumped, $self->_build_name($name,'{',$k), $cindent ); if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) { #warn "$self->{buf}\n"; $last_n++; } else { #warn "$self->{buf}\n"; $last_n=0; } if ($alias) { $self->_add_fix('sub call','alias_hv', $self->_build_name($name,'%'), _quote($k), $alias ); } } $self->_brace($name,'}',$ind,$indent,$self->{ref_hkcnt}{$addr}); return } sub _dump_array { my ($self,$item,$depth,$dumped,$name,$indent)=@_; my $full_indent=$self->{style}{indent}>1; my $ind=$self->{style}{indent} && @$item>1; $self->_brace($name,'[',$ind,$indent,scalar @$item); my $last_n=0; my $ind_str=(" " x $indent); my ($optspace,$sep)=@{$self->{style}}{qw(optspace arysep)}; unless ($self->{style}{rle} ) { foreach my $k (0..$#$item) { my $do_ind=$ind && (!$last_n || ref $item->[$k]); if ($k) { $self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace); if ($do_ind) { $self->{buf}=0; } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) { $self->{fh}->print("\n"); $self->{buf}=0; } } my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped, $self->_build_name($name,'[',$k), $indent ); if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) { #warn "$last_n\n"; $last_n++; } else { $last_n=0; } if ($alias) { $self->_add_fix('sub call','alias_av', $self->_build_name($name,'@'), $k, $alias ); } } } else { # this is evil and must be changed. # ... evil ... totally evil... blech for ( my $k = 0 ; $k <= $#$item ; ) { my $v = $item->[$k]; my $count = 1; if (!refaddr($item->[$k]) and !readonly($item->[$k]) and (!$self->{sv}{refaddr(\$item->[$k])} or $self->{svt}[$self->{sv}{refaddr(\$item->[$k])}]==1) ) { COUNT:while ( $k + $count <= $#$item and !refaddr($item->[ $k + $count ]) and !readonly($item->[ $k + $count ]) and (!$self->{sv}{refaddr(\$item->[$k + $count])} or $self->{svt}[$self->{sv}{refaddr(\$item->[$k + $count])}]==1) and !$v == !$item->[ $k + $count ] and defined($v) == defined($item->[ $k + $count ]) ) { if (!defined( $item->[ $k + $count ] )) { last COUNT if defined($v); } else { last COUNT if $v ne overload::StrVal( $item->[ $k + $count ] ) } $count++; } } my $do_ind=$ind && (!$last_n || ref $item->[$k]); $self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace) if $k; $self->{buf}=0 if $do_ind and $k; if ($count>1){ $self->{fh}->print("($optspace"); $self->{buf}+=2; } my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped, $self->_build_name($name,'[',$k), $indent ); if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) { $last_n++; } else { $last_n=0; } if ($alias) { $self->_add_fix('sub call','alias_av', $self->_build_name($name,'@'), $k, $alias ); } if ($count>1) { my $str=join $optspace,'',')','x',$count; $self->{buf}+=length($str); $self->{fh}->print($str); } $k += $count; } } $self->_brace($name,']',$ind,$indent,scalar @$item); return } sub __vstr { my ($v,@v); unless (@_) { $v=$]; } elsif (@_==1) { $v=shift; } else { @v=@_; } return join ".", @v ? (@v,(0) x 3)[0..2] : map { $v * 1000**$_ % 1000 } 0..2 } sub _dump_code { my ($self,$item,$name,$indent,$class)=@_; unless ($self->{style}{deparse}) { $self->{fh}->print($self->{style}{codestub}); } else { #deparseopts my $cv=B::svref_2object($item); if (ref($cv->ROOT)=~/NULL/) { my $gv=$cv->GV; $self->{fh}->print("\\&",$gv->STASH->NAME,"::",$gv->SAFENAME); return; } my $deparser=Data::Dump::Streamer::Deparser->new(@{$self->{style}{deparseopts}}); my $used= _get_lexicals($item); my %targ; foreach my $targ (keys %$used) { next if $targ=~/\D/; my $addr=refaddr($used->{$targ}); $targ{$targ}=$self->{lexicals}{a2n}{$addr} if $self->{lexicals}{a2n}{$addr}; } # we added this method, its not a normal method. see bottom of file. $deparser->dds_usenames(\%targ); my $bless=undef; my $code; DEPARSE:{ $bless=($class,bless($item,$bless))[0] if defined $bless; eval { $code=$deparser->coderef2text($item) }; bless $item,$bless if defined $bless; if (!defined $bless and $@ and $@ =~ /^\QUsage: ->coderef2text(CODEREF)\E/) { $bless='CODE'; redo DEPARSE; } elsif ($@) { warnings::warnif "Using CODE stub for $name as ". "B::Deparse->coderef2text (v$B::Deparse::VERSION". " on v@{[__vstr]}) failed. Message was:\n $@"; $self->{fh}->print($self->{style}{codestub}); return; } } #$self->{fh}->print("\n#",join " ",keys %$used,"\n"); #$code=~s/^\s*(\([^)]+\)|)\s*/sub$1\n/; $code="sub".($code=~/^\s*\(/ ? "" : " ").$code; if ($self->{style}{indent}) { $code=~s/\n/"\n"." " x $indent/meg; } #warn $name; if ($name=~s/^\&//) { $code=~s/sub(\s)?/sub $name$1/; } $self->{fh}->print("$code"); } return } sub _dump_format { # from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org # translate arg (or reference to it) into a B::* object my ($self,$item,$name,$indent)=@_; if ($self->{style}{deparse}) { my $Bobj = B::svref_2object($item); # if passed a glob or globref, get the format $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV'; if (ref $Bobj eq 'B::FM') { my $format; eval { my $deparser = Data::Dump::Streamer::Deparser->new(); $format=$deparser->indent($deparser->deparse_format($Bobj)); }; if ($@) { warnings::warnif "B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n"; $format="B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n.\n"; } my $ind=$self->{style}{indent} ? ' ' x $indent : ''; $format="format F =\n$format"; $format=~s/^/${ind}# /gm; my $end='_EOF_FORMAT_'; $end=~s/T(\d*)_/sprintf "T%02d_",($1||0)+1/e while $format=~/$end/; $self->{fh}->print("do{ local *F; my \$F=<<'$end'; \$F=~s/^\\s+# //mg; eval \$F; die \$F.\$@ if \$@; *F{FORMAT};\n$format\n$end\n$ind}"); return } } $self->{fh}->print($self->{style}{formatstub}); } sub _dump_symbol { my ($self,$item,$name,$glob,$deref,$depth)=@_; my $ret="Symbol::gensym"; $ret="do{ require Symbol; $ret }" unless $self->{reqs}{Symbol}++; $ret="*{ $ret }" if $deref; $self->{fh}->print( $ret ); if ($self->{style}{dumpglob} and !$self->{sv_glob_du}{$glob}++) { $self->_add_fix('glob',$_[1],$glob,$depth+1,$name); } } sub _dump_rv { my ($self,$item,$depth,$dumped,$name,$indent,$add_do)=@_; my ($addr,$idx,$type,$class,$is_frozen_replacement,$overloaded, $raddr); GETITEM: { $addr=refaddr($item) or Carp::confess "$name : $item"; $idx=$self->{ref}{$addr}; $type=reftype($item); $class=blessed($item); $class=undef if $class and $class eq 'Regexp' and is_regexp $item; $DEBUG and printf "_dump_rv %d %s %#x\n",$depth,$name,$addr; my $ignore=0; if ($self->{ref_fz}{$addr}) { $item= $self->{ref_fz}{$addr}; if ( ! $item ) { $ignore=1; } elsif (ref $item) { $is_frozen_replacement=1; $dumped= \do{my $d}; $raddr=$addr; redo GETITEM; } else { $self->{buf}+=length($item); $self->{fh}->print($item); return } } if ($ignore or $self->{style}{ignore}{"#".($raddr||$addr)} or (defined $class and $self->{style}{ignore}{".$class"} ) ){ my $str= _quote("Ignored Obj [".overload::StrVal($item)."]"); $self->{buf} += length($str); $self->{fh}->print($str); return } } unless ($idx) { #Carp::confess "Unhandled address $addr $name\n"; # this should only happen for localized globs. ($idx)=$self->_reg_ref($item,$depth,$name,refcount($item)); } my $optspace=$self->{style}{optspace}; if ($idx) { my $pre_dumped=$self->{refdu}[$idx]; my $str=""; if ($pre_dumped and $$pre_dumped) { # its been dumped totally $DEBUG and print " predumped $self->{refn}[$idx]\n"; if ($self->{refn}[$idx]=~/^[\@\%\&]/) { if (SvREADONLY_ref($item)) { my @hidden_keys=sort(hidden_keys(%$item)); $self->_add_fix('lock',$idx,\@hidden_keys); } $str=join "",($class ? "bless($optspace" : ''), '\\'.$self->{refn}[$idx], ($class ? ",$optspace"._quote($class)."$optspace)" : ''); } else { $str=$self->{refn}[$idx]; } $self->{buf}+=length($str); $self->{fh}->print($str); return } elsif ($pre_dumped or $self->{refd}[$idx] < $depth) { $DEBUG and print " inprocess or depth violation: $self->{refd}[$idx] < $depth\n"; # we are in the process of dumping it # output a place holder and add a fix statement # XXX is this sigil test correct? why not $? if ($self->{refn}[$idx]=~/^[\@\%\&]/ and (!$self->{style}{declare})) { $str=join"",( $class ? "bless($optspace" : '' ), '\\'.$self->{refn}[$idx], ( $class ? ",$optspace"._quote($class)."$optspace)" : '' ); } else { if ($self->{style}{purity}) { $str=join"",$add_do ? join($optspace,qw(do { my $v = ),'') : '', !$self->{style}{verbose} ? "'V'" : _quote("V: ",$self->{refn}[$idx]), $add_do ? $optspace."}" : ''; #Carp::cluck "$name $self->{refd}[$idx] < $depth" if $name=~/\*/; $self->_add_fix('ref',$name,$idx,$class); } else { $str=$self->{refn}[$idx]; } } $self->{buf}+=length($str); $self->{fh}->print($str); return } $self->{refdu}[$idx]||=$dumped; #$name=$self->{refn}[$idx]; # override inherited names. ??? maybe not needed } else { Carp::confess "Unhandled object '$item'\n"; } my $isoverloaded=0; if (defined $class and overload::Overloaded($item)) { disable_overloading( $item ); $overloaded= $class; $isoverloaded= 1; } my $thaw= $self->{ref_thaw}{$raddr||$addr}; my ($inline,$thawtype); if ( $thaw ) { if ($thaw =~ /[^\w:>()-]/) { $thawtype= "code"; } else{ $inline= $thaw=~s/^->//; $thawtype= $thaw=~s/\(\)$// ? "sub" : "method"; } if ($inline && $thawtype eq 'sub') { $self->{buf}+=length($thaw)+1; $self->{fh}->print($thaw."(${optspace}"); } } $self->{do_nl}=1; my $add_lock=($type eq 'HASH') && SvREADONLY_ref($item); my $fix_lock=0; my @hidden_keys=$add_lock ? sort(hidden_keys(%$item)) : (); if ($add_lock) { #warn "$name\n"; if ($name!~/^\$/) { $fix_lock=1; $add_lock=0; } else { $self->{fh}->print("lock_ref_keys", @hidden_keys ? '_plus' : '', "(${optspace}" ); } } my $add_bless=defined($class) && ($name!~/^[\@\%\&]/); if ($add_bless && !$overloaded) { $self->{fh}->print(substr($self->{style}{bless},0,-1),$optspace); } $DEBUG and print " $type : Start typecheck\n"; if ($type eq 'SCALAR' or $type eq 'REF' or $type eq 'GLOB') { my ($pat,$mod)=$type eq 'SCALAR' ? regex($item) : (); my $glob=$type eq 'GLOB' ? globname $$item : ''; if ($glob=~/^\*Symbol::GEN/) { $self->_dump_symbol($_[1],$name,$glob,0,$depth); } elsif (defined $pat) { # its a regex $self->_dump_qr($pat,$mod); } else { my $ret=$self->_dump_sv($$item,$depth+1,$dumped, $self->_build_name($name,'$'), $indent,'is_ref' ); $self->{refdu}[$idx]=$ret if $ret; } } elsif ($type eq 'ARRAY') { $self->_dump_array($item,$depth,$dumped,$name,$indent); } elsif ($type eq 'HASH') { $self->_dump_hash($item,$depth,$dumped,$name,$indent,$addr,$class); } elsif ($type eq 'CODE') { $self->_dump_code($item,$name,$indent,$class); } elsif ($type eq 'FORMAT') { #$self->_dump_code($item,$name,$indent,$class); #muwhahahah $self->_dump_format($item,$name,$indent); } elsif ($type eq 'IO') { $self->{fh}->print("*{Symbol::gensym()}{IO}"); } elsif ($type eq 'ORANGE' || $type eq 'Regexp' || $type eq 'REGEXP') { my ($pat,$mod)=regex($item); $self->_dump_qr($pat,$mod); } else { Carp::confess "_dump_rv() can't handle '$type' objects yet\n :-(\n"; } if ($add_bless) { unless ( defined $overloaded ) { $self->{fh}->print(",${optspace}",_quote($class),$optspace,substr($self->{style}{bless},-1)) } else { $self->_add_fix('bless',$idx,$overloaded); } if ($isoverloaded) { restore_overloading( $item, $overloaded ); } } if ($fix_lock && !defined($class)) { $self->_add_fix('lock',$idx,\@hidden_keys); } if ($add_lock) { if (@hidden_keys) { $self->{fh}->print(",${optspace}",join(",${optspace}",map {_quote($_)} @hidden_keys)); } $self->{fh}->print("${optspace})"); } if ( $thaw ) { if ($inline) { if ($thawtype eq 'sub') { $self->{fh}->print("${optspace})"); } elsif ($thawtype eq 'method') { $self->{fh}->print("->$thaw()"); } #$$dumped=1; } else { $self->_add_fix('thaw', $idx, $thaw.($thawtype eq 'sub' ? "()" :"" )); } } if ( my $postop=$self->{ref_postop}{$raddr||$addr} ) { if (ref $postop) { $postop->($_[1]); } else { $_[1]->$postop(); } } $self->{do_nl}=1; return } =item Names =item Names LIST =item Names ARRAYREF Takes a list of strings or a reference to an array of strings to use for var names for the objects dumped. The names may be prefixed by a * indicating the variable is to be dumped as its dereferenced type if it is an array, hash or code ref. Otherwise the star is ignored. Other sigils may be prefixed but they will be silently converted to *'s. If no names are provided then names are generated automatically based on the type of object being dumped, with abbreviations applied to compound class names. If called with arguments then returns the object itself, otherwise in list context returns the list of names in use, or in scalar context a reference or undef. In void context with no arguments the names are cleared. B Must be called before C is called. =cut sub Names { my $self = shift->_safe_self; if (@_) { my $v=(@_==1 and reftype $_[0] eq 'ARRAY') ? shift @_ : \@_; $self->{unames} = [ map { ( my $s = $_ ) =~ s/^[\@\%\&-]/*/; $s=~s/^\$//; Carp::confess "Bad name '$_'" if $s && $s!~/^\*?\w+$/; $s } grep {defined} @$v ]; return $self; } elsif (! defined wantarray ) { $self->{unames}=[]; } #elsif ( eval { require PadWalker; 1 } ) { # print DDumper(PadWalker::peek_my(1)); # return $self; #} return wantarray ? @{$self->{unames}||[]} : $self->{unames} } =for UEDIT sub Purity {} =item Purity =item Purity BOOL This option can be used to set the level of purity in the output. It defaults to TRUE, which results in the module doing its best to ensure that the resulting dump when eval()ed is precisely the same as the input. However, at times such as debugging this can be tedious, resulting in extremely long dumps with many "fix" statements involved. By setting Purity to FALSE the resulting output won't necessarily be legal Perl, but it will be more legible. In this mode the output is broadly similar to that of the default setting of Data::Dumper (Purity(0)). When set to TRUE the behaviour is likewise similar to Data::Dumper in Purity(1) but more accurate. When Purity() is set to FALSE aliases will be output with a function call wrapper of 'alias_to' whose argument will be the value the item is an alias to. This wrapper does nothing, and is only there as a visual cue. Likewise, 'make_ro' will be output when the value was readonly, and again the effect is cosmetic only. =item To =item To STREAMER Specifies the object to print to. Data::Dump::Streamer can stream its output to any object supporting the print method. This is primarily meant for streaming to a filehandle, however any object that supports the method will do. If a filehandle is specified then it is used until it is explicitly changed, or the object is destroyed. =cut sub To { my $self = shift->_safe_self; if (@_) { $self->{fh} = shift; return $self; } return $self->{fh}; } =for UEDIT sub Declare {} =item Declare =item Declare BOOL If Declare is True then each object is dumped with 'my' declarations included, and all rules that follow are obeyed. (Ie, not referencing an undeclared variable). If Declare is False then all objects are expected to be previously defined and references to top level objects can be made at any time. Defaults to False. =cut sub Indent { my $self=shift->_safe_self(); if (@_) { my $val=shift; if ( $val == 0 && length $self->{style}{optspace} ) { $self->{style}{last_optspace}= $self->{style}{optspace}; $self->{style}{optspace}= ""; } elsif( !$self->{style}{indent} && ! length $self->{style}{optspace} ) { $self->{style}{optspace}= $self->{style}{last_optspace}; } $self->{style}{indent}= $val; return $self } else { return $self->{style}{indent} } } =item Indent =item Indent INT If Indent is True then data is output in an indented and fairly neat fashion. If the value is 2 then hash key/value pairs and array values each on their own line. If the value is 1 then a "smart" indenting mode is activated where multiple key/value or values may be printed to the same line. The heuristics for this mode are still experimental so it may occasional not indent very nicely. Default is Indent(2) If indent is False then no indentation is done, and all optional whitespace. is omitted. See for more details. Defaults to True. Newlines are appended to each statement regardless of this value. =for UEDIT sub IndentKeys {} =item Indentkeys =item Indentkeys BOOL If Indent() and Indentkeys are True then hashes with more than one key value pair are dumped such that the keys and values line up. Note however this means each key has to be quoted twice. Not advised for very large data structures. Additional logic may enhance this feature soon. Defaults to True. B Must be set before C is called. =for UEDIT sub OptSpace {} =item OptSpace =item OptSpace STR Normally DDS emits a lot of whitespace in between tokens that it emits. Using this method you can control how much whitespace it will emit, or even if some other string should be used. If Indent is set to 0 then this value is automatically set to the empty string. When Indent is set back to a non zero value the old value will be restored if it has not been changed from the empty string in the intervening time. =for UEDIT sub Keyorder {} =item KeyOrder TYPE_OR_OBJ =item KeyOrder TYPE_OR_OBJ, VALUE Sets or returns the key order to for use for a given type or object. TYPE_OR_OBJ may be a string representing a class, or "" for representing unblessed objects, or it maybe a reference to a hash. VALUE may be a string representing one of built in sort mechanisms, or it may be a reference to a subroutine, or a method name if TYPE_OR_OBJ is not an object. The built in sort mechanisms are 'aphabetical'/'lexical', 'numeric', 'smart'/'intelligent' and 'each'. If VALUE is omitted returns the current value for the given type. If TYPE_OR_OBJ is omitted or FALSE it defaults to "" which represents unblessed hashes. See L<"Controlling Hash Traversal and Display Order"> for more details. =item SortKeys =item SortKeys VALUE This is a wrapper for KeyOrder. It allows only the generic hash sort order to be specified a little more elegantly than via KeyOrder(). It is syntactically equivalent to $self->KeyOrder( "", @_ ); =for UEDIT sub Verbose {} =item Verbose =item Verbose BOOL If Verbose is True then when references that cannot be resolved in a single statement are encountered the reference is substituted for a descriptive tag saying what type of forward reference it is, and to what is being referenced. The type is provided through a prefix, "R:" for reference, and "A:" for alias, "V:" for a value and then the name of the var in a string. Automatically generated var names are also reduced to the shortest possible unique abbreviation, with some tricks thrown in for Long::Class::Names::Like::This (which would abbreviate most likely to LCNLT1) If Verbose if False then a simple placeholder saying 'A' or 'R' is provided. (In most situations perl requires a placeholder, and as such one is always provided, even if technically it could be omitted.) This setting does not change the followup statements that fix up the structure, and does not result in a loss of accuracy, it just makes it a little harder to read. OTOH, it means dumps can be quite a bit smaller and less noisy. Defaults to True. B Must be set before C is called. =for UEDIT sub DumpGlob {} =item DumpGlob =item DumpGlob BOOL If True then globs will be followed and fully defined, otherwise the globs will still be referenced but their current value will not be set. Defaults to True B Must be set before C is called. =for UEDIT sub Deparse {} =item Deparse =item Deparse BOOL If True then CODE refs will be deparsed use L and included in the dump. If it is False the a stub subroutine reference will be output as per the setting of C. Caveat Emptor, dumping subroutine references is hardly a secure act, and it is provided here only for convenience. Note using this routine is at your own risk as of DDS 1.11, how it interacts with the newer advanced closure dumping process is undefined. =for UEDIT sub EclipseName {} =item EclipseName =item EclipseName SPRINTF_FORMAT When necessary DDS will rename vars output during deparsing with this value. It is a sprintf format string that should contain only and both of the "%s" and a "%d" formats in any order along with whatever other literal text you want in the name. No checks are performed on the validity of this value so be careful. It defaults to "%s_eclipse_%d" where the "%s" represents the name of the var being eclipsed, and the "%d" a counter to ensure all such mappings are unique. =for UEDIT sub DeparseOpts {} =item DeparseOpts =item DeparseOpts LIST =item DeparseOpts ARRAY If Deparse is True then these options will be passed to B::Deparse->new() when dumping a CODE ref. If passed a list of scalars the list is used as the arguments. If passed an array reference then this array is assumed to contain a list of arguments. If no arguments are provided returns a an array ref of arguments in scalar context, and a list of arguments in list context. Note using this routine is at your own risk as of DDS 1.11, how it interacts with the newer advanced closure dumping process is undefined. =for UEDIT sub CodeStub {} =item CodeStub =item CodeStub STRING If Deparse is False then this string will be used in place of CODE references. Its the users responsibility to make sure its compilable and blessable. Defaults to 'sub { Carp::confess "Dumped code stub!" }' =for UEDIT sub FormatStub {} =item FormatStub =item FormatStub STRING If Deparse is False then this string will be used in place of FORMAT references. Its the users responsibility to make sure its compilable and blessable. Defaults to 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }' =for UEDIT sub DeparseGlob {} =item DeparseGlob =item DeparseGlob BOOL If Deparse is TRUE then this style attribute will determine if subroutines and FORMAT's contained in globs that are dumped will be deparsed or not. Defaults to True. =for UEDIT sub DualVars {} sub Dualvars {} =item Dualvars =item Dualvars BOOL =item Dualvars =item Dualvars BOOL If TRUE then dualvar checking will occur and the required statements emitted to recreate dualvars when they are encountered, otherwise items will be dumped in their stringified form always. It defaults to TRUE. =for UEDIT sub Rle {} sub RLE {} =item Rle =item Rle BOOL =item RLE =item RLE BOOL If True then arrays will be run length encoded using the C operator. What this means is that if an array contains repeated elements then instead of outputting each and every one a list multiplier will be output. This means that considerably less space is taken to dump redundant data. =item Freezer =item Freezer ACTION =item Freezer CLASS, ACTION This method can be used to override the DDS_freeze hook for a specific class. If CLASS is omitted then the ACTION applies to all blessed object. If ACTION is false it indicates that the given CLASS should not have any serilization hooks called. If ACTION is a string then it is taken to be the method name that will be executed to freeze the object. CLASS->can(METHOD) must return true or the setting will be ignored. If ACTION is a code ref it is executed with the object as the argument. When called with no arguments returns in scalar context the generic serialization method (defaults to 'DDS_freeze'), in list context returns the generic serialization method followed by a list of pairs of Classname=>ACTION. If the action executes a sub or method it is expected to return a list of three values: ( $proxy, $thaw, $postdump )=$obj->DDS_Freeze(); See L for more details. B Must be set before C is called. =cut sub Freezer { my $self= shift; if ( @_==1 ) { $self->{style}{freezer}= shift; return $self; } elsif ( @_==2 ) { my ( $class, $action )= @_; $self->{style}{freeze_class}{$class}= $action; return $self; } return wantarray ? ($self->{style}{freezer}, map { $_ => $self->{style}{freeze_class}{$_} } keys %{$self->{style}{freeze_class}} ) : $self->{style}{freezer}; } sub ResetFreezer { my $self=shift; $self->{style}{freezer}='DDS_freeze'; $self->{style}{freeze_class}={}; return $self; } =item Ignore =item Ignore OBJ_OR_CLASS =item Ignore OBJ_OR_CLASS, BOOL Allows a given object or class to be ignored, and replaced with a string containing the name of the item ignored. If called with no args returns a list of items ignored (using the refaddr to represent objects). If called with a single argument returns whether that argument is ignored. If called with more than one arguments then expects a list of pairs of object => is_ignored. Returns $self when setting. B Must be set before C is called. =cut sub Ignore { my $self=shift; if (@_==0) { return map { s/^.//; $_ } keys %{$self->{style}{ignore}}; } Carp::confess("Must have an even number of arguments in Ignore()") if @_>1 && @_ %2; while (@_) { my $item=shift; if ( ref $item ) { $item="#".refaddr($item); } else { $item=".$item"; } if ( ! @_ ) { return $self->{style}{ignore}{$item}; } if ( shift ) { $self->{style}{ignore}{$item}= 1; } else { delete $self->{style}{ignore}{$item}; } } return $self; } =for UEDIT sub Compress {} =item Compress =item Compress SIZE Controls compression of string values (not keys). If this value is nonzero and a string to be dumped is longer than its value then the L if defined is used to compress the string. Setting size to -1 will cause all strings to be processed, setting size to 0 will cause no strings to be processed. =for UEDIT sub Compressor {} =item Compressor =item Compressor CODE This attribute is used to control the compression of strings. It is expected to be a reference to a subroutine with the following interface: my $prelude_code=$compressor->(); # no arguments. my $code=$compressor->('string'); # string argument The sub will be called with no arguments at the beginning of the dump to allow any require statements or similar to be added. During the dump the sub will be called with a single argument when compression is required. The code returned in this case is expected to be an EXPR that will evaluate back to the original string. By default DDS will use L in conjunction with L to do compression and encoding, and exposes the 'usqz' subroutine for handling the decoding and decompression. The abbreviated name was chosen as when using the default compressor every string will be represented by a string like usqz('....') Meaning that eight characters are required without considering the data itself. Likewise Base64 was chosen because it is a representation that is high-bit safe, compact and easy to quote. Escaped strings are much less efficient for storing binary data. =cut # weird styling here deliberate. sub DeparseOpts { my $self=shift; if (@_) { if (ref $_[0]) { $self->{style}{deparseopts}=shift; } else { $self->{style}{deparseopts}=[@_]; } return $self; } else { return wantarray ? @{$self->{style}{deparseopts}} : $self->{style}{deparseopts}; } } sub KeyOrder { my $self= shift; Carp::croak("KeyOrder() Must have an even number of arguments if doing a multiple set.") if @_>2 and @_ % 2; while (@_) { my $obj= shift; my $name; if (ref $obj) { $name= "#" .refaddr($obj) } else { $name= "" if ! defined $obj; $name= ".$obj"; } if ( ! @_ ) { return $self->{style}{sortkeys_string}{$name}|| $self->{style}{sortkeys}{$name}; } my $val= shift; if ( ! defined $val ) { delete $self->{style}{sortkeys}{$name}; delete $self->{style}{sortkeys_string}{$name}; } else { if ( ! ref $val ) { my $subref= $default_key_sorters{$val}; Carp::confess("Unblessed or per object Sortkeys() must be coderefs:'$val'\n") if (!$subref or $name eq "." ) and reftype($subref) ne "CODE"; $subref ||= $obj->can($val); die "Unknown sortkeys '$val', and " . (ref($obj)||$obj)." doesn't know how to do it.\n" if !$subref; $self->{style}{sortkeys_string}{$name}=$val; $val= $subref; } elsif ( reftype($val) eq 'ARRAY' ) { my $aryref= $val; $val= sub{ return $aryref; }; } elsif ( reftype($val) ne 'CODE' ) { Carp::confess("Can't use '$val' as KeyOrder() value"); } $self->{style}{sortkeys}{$name}= $val; } } return $self; } *Keyorder=*KeyOrder; sub SortKeys { my $self=shift; $self->KeyOrder("",@_); } *Sortkeys= *SortKeys; *HashKeys = *Hashkeys = *KeyOrder; my %scalar_meth=map{ $_ => lc($_)} qw(Declare Indent IndentCols IndentKeys Verbose DumpGlob Deparse DeparseGlob DeparseFormat CodeStub FormatStub Rle RLE Purity DualVars Dualvars EclipseName Compress Compressor OptSpace); sub AUTOLOAD { (my $meth=$AUTOLOAD)=~s/^((?:\w+::)+)//; my $name; if (defined($name=$scalar_meth{$meth})) { $DEBUG and print "AUTLOADING scalar meth $meth ($name)\n"; eval ' sub '.$meth.' { my $self=shift->_safe_self(); if (@_) { $self->{style}{'.$name.'}=shift; return $self } else { return $self->{style}{'.$name.'} } } '; $@ and die "$meth:$@\n"; goto &$meth; } elsif ($meth=~/[^A-Z]/) { Carp::confess "Unhandled method/subroutine call $AUTOLOAD"; } } sub _get_lexicals { my $cv=shift; if ($HasPadWalker) { my ($names,$targs)=PadWalker::closed_over($cv); if ($PadWalker::VERSION < 1) { $names->{$_}=$names->{$targs->{$_}} for keys %$targs; } else { %$names=(%$names,%$targs); } return $names; } my $svo=B::svref_2object($cv); my @pl_array = eval { $svo->PADLIST->ARRAY }; my @name_obj = eval { $pl_array[0]->ARRAY }; my %named; for my $i ( 0..$#name_obj ) { if ( ref($name_obj[$i])!~/SPECIAL/) { $named{$i} = "${ $name_obj[$i]->object_2svref }"; } } my %inited; my %used; B::Utils::walkoptree_filtered( $svo->ROOT, sub { B::Utils::opgrep { name => [ qw[ padsv padav padhv ] ] }, @_ }, sub { my ( $op, @items )=@_; my $targ = $op->targ; my $name = $named{$targ} or return; $inited{$name}++ if $op->private & 128; if ( !$inited{$name} ) { $used{$name} = $pl_array[1]->ARRAYelt($targ)->object_2svref; $used{$targ} = $used{$name}; $inited{$name}++; } } ); return \%used; } package Data::Dump::Streamer::Deparser; use B::Deparse; our @ISA=qw(B::Deparse); my %cache; our $VERSION = '2.39'; $VERSION= eval $VERSION; if ( $VERSION ne $Data::Dump::Streamer::VERSION ) { die "Incompatible Data::Dump::Streamer::Deparser v$VERSION vs Data::Dump::Streamer v$Data::Dump::Streamer::VERSION"; } sub dds_usenames { my $self=shift; my $names=shift; $cache{Data::Dump::Streamer::refaddr $self}=$names; } sub padname { my $self = shift; my $targ = shift; if ( $cache{Data::Dump::Streamer::refaddr $self} and $cache{Data::Dump::Streamer::refaddr $self}{$targ} ) { return $cache{Data::Dump::Streamer::refaddr $self}{$targ} } return $self->padname_sv($targ)->PVX; } sub DESTROY { my $self=shift; delete $cache{Data::Dump::Streamer::refaddr $self}; } unless (B::AV->can('ARRAYelt')) { eval <<' EOF_EVAL'; sub B::AV::ARRAYelt { my ($obj,$idx)=@_; my @array=$obj->ARRAY; return $array[$idx]; } EOF_EVAL } 1; __END__ =back =head2 Reading the Output As mentioned in L there is a notation used to make understanding the output easier. However at first glance it can probably be a bit confusing. Take the following example: my $x=1; my $y=[]; my $array=sub{\@_ }->( $x,$x,$y ); push @$array,$y,1; unshift @$array,\$array->[-1]; Dump($array); Which prints (without the comments of course): $ARRAY1 = [ 'R: $ARRAY1->[5]', # resolved by fix 1 1, 'A: $ARRAY1->[1]', # resolved by fix 2 [], 'V: $ARRAY1->[3]', # resolved by fix 3 1 ]; $ARRAY1->[0] = \$ARRAY1->[5]; # fix 1 alias_av(@$ARRAY1, 2, $ARRAY1->[1]); # fix 2 $ARRAY1->[4] = $ARRAY1->[3]; # fix 3 The first entry, C<< 'R: $ARRAY1->[5]' >> indicates that this slot in the array holds a reference to the currently undefined C<< $ARRAY1->[5] >>, and as such the value will have to be provided later in what the author calls 'fix' statements. The third entry C<< 'A: $ARRAY1->[1]' >> indicates that is element of the array is in fact the exact same scalar as exists in C<< $ARRAY1->[1] >>, or is in other words, an alias to that variable. Again, this cannot be expressed in a single statement and so generates another, different, fix statement. The fifth entry C<< 'V: $ARRAY1->[3]' >> indicates that this slots holds a value (actually a reference value) that is identical to one elsewhere, but is currently undefined. In this case it is because the value it needs is the reference returned by the anonymous array constructor in the fourth element (C<< $ARRAY1->[3] >>). Again this results in yet another different fix statement. If Verbose() is off then only a 'R' 'A' or 'V' tag is emitted as a marker of some form is necessary. All of this specialized behaviour can be bypassed by setting Purity() to FALSE, in which case the output will look very similar to what Data::Dumper outputs in low Purity setting. In a later version I'll try to expand this section with more examples. =head2 A Note About Speed Data::Dumper is much faster than this module for many things. However IMO it is less readable, and definitely less accurate. YMMV. =head1 EXPORT By default exports the Dump() command. Or may export on request the same command as Stream(). A Data::Dumper::Dumper compatibility routine is provided via requesting Dumper and access to the real Data::Dumper::Dumper routine is provided via DDumper. The later two are exported together with the :Dumper tag. Additionally there are a set of internally used routines that are exposed. These are mostly direct copies of routines from Array::RefElem, Lexical::Alias and Scalar::Util, however some where marked have had their semantics slightly changed, returning defined but false instead of undef for negative checks, or throwing errors on failure. The following XS subs (and tagnames for various groupings) are exportable on request. :Dumper Dumper DDumper :undump # Collection of routines needed to undump something alias_av # aliases a given array value to a scalar alias_hv # aliases a given hashes value to a scalar alias_ref # aliases a scalar to another scalar make_ro # makes a scalar read only lock_keys # pass through to Hash::Util::lock_keys lock_keys_plus # like lock_keys, but adds keys to those present lock_ref_keys # like lock_keys but operates on a hashref lock_ref_keys_plus # like lock_keys_plus but operates on a hashref dualvar # make a variable with different string/numeric # representation alias_to # pretend to return an alias, used in low # purity mode to indicate a value is actually # an alias to something else. :alias # all croak on failure alias_av(@Array,$index,$var); alias_hv(%hash,$key,$var); alias_ref(\$var1,\$var2); push_alias(@array,$var); :util blessed($var) #undef or a class name. isweak($var) #returns true if $var contains a weakref reftype($var) #the underlying type or false but defined. refaddr($var) #a references address refcount($var) #the number of times a reference is referenced sv_refcount($var) #the number of times a scalar is referenced. weak_refcount($var) #the number of weakrefs to an object. #sv_refcount($var)-weak_refcount($var) is the true #SvREFCOUNT() of the var. looks_like_number($var) #if perl will think this is a number. regex($var) # In list context returns the pattern and the modifiers, # in scalar context returns the pattern in (?msix:) form. # If not a regex returns false. readonly($var) # returns whether the $var is readonly weaken($var) # cause the reference contained in var to become weak. make_ro($var) # causes $var to become readonly, returns the value of $var. reftype_or_glob # returns the reftype of a reference, or if its not # a reference but a glob then the globs name refaddr_or_glob # similar to reftype_or_glob but returns an address # in the case of a reference. globname # returns an evalable string to represent a glob, or # the empty string if not a glob. :all # (Dump() and Stream() and Dumper() and DDumper() # and all of the XS) :bin # (not Dump() but all of the rest of the XS) By default exports only Dump(), DumpLex() and DumpVars(). Tags are provided for exporting 'all' subroutines, as well as 'bin' (not Dump()), 'util' (only introspection utilities) and 'alias' for the aliasing utilities. If you need to ensure that you can eval the results (undump) then use the 'undump' tag. =head1 BUGS Code with this many debug statements is certain to have errors. :-) Please report them with as much of the error output as possible. Be aware that to a certain extent this module is subject to whimsies of your local perl. The same code may not produce the same dump on two different installs and versions. Luckily these don't seem to pop up often. =head1 AUTHOR AND COPYRIGHT Yves Orton, yves at cpan org. Copyright (C) 2003-2005 Yves Orton This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Contains code derived from works by Gisle Aas, Graham Barr, Jeff Pinyan, Richard Clamp, and Gurusamy Sarathy. Thanks to Dan Brook, Yitzchak Scott-Thoennes, eric256, Joshua ben Jore, Jim Cromie, Curtis "Ovid" Poe, Lars Dɪᴇᴄᴋᴏᴡ, and anybody that I've forgotten for patches, feedback and ideas. =head1 SEE ALSO (its a crowded space, isn't it!) L - the mother of them all L - Auto named vars with source filter interface. L - Auto named vars without source filtering. L - easy to use wrapper for DD L - Has cool feature to squeeze data L - The best perl dumper. But I would say that. :-) L - Non perl output, lots of rendering options And of course L and L itself. =cut Data-Dump-Streamer-2.39/lib/Data/Dump/Streamer000755001750001750 012636703716 21173 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/lib/Data/Dump/Streamer/_000755001750001750 012636703716 21411 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/lib/Data/Dump/Streamer/_/Printers.pm000444001750001750 230512636703716 23712 0ustar00yortonyorton000000000000{ package Data::Dump::Streamer::_::StringPrinter; #$Id: Printers.pm 26 2006-04-16 15:18:52Z demerphq $# $VERSION= "0.1"; my %items; sub DESTROY { delete $items{$_[0]} } sub new { my $class = shift; my $self = bless \do { my $str = '' }, $class; $self->print(@_); return $self; } sub print { my $self = shift; $items{$self} .= join "", @_; } sub value { $items{$_[0]} } sub string { $_[0]->value() } 1; } { package Data::Dump::Streamer::_::ListPrinter; $VERSION= "0.1"; my %items; sub DESTROY { delete $items{$_[0]} } sub new { my $class = shift; my $self = bless \do { my $str = '' }, $class; $items{$self} = []; $self->print(@_); return $self; } sub print { my $self = $items{shift (@_)}; my $str = join ( '', @_ ); if ( !@$self or $self->[-1] =~ /\n/ or length( $self->[-1] ) > 4000 ) { push @{$self}, $str; } else { $self->[-1] .= $str; } } sub value { @{$items{$_[0]}} } sub string { join ( '', @{$items{$_[0]}} ) } 1; } __END__ Data-Dump-Streamer-2.39/inc000755001750001750 012636703716 15636 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/inc/My000755001750001750 012636703716 16223 5ustar00yortonyorton000000000000Data-Dump-Streamer-2.39/inc/My/Builder.pm000444001750001750 654012636703716 20311 0ustar00yortonyorton000000000000package My::Builder; use strict; use warnings; use Module::Build; our @ISA = 'Module::Build'; sub new { my $class = shift @_; { my $B_Utils_required = 0.05; eval { require B::Utils; }; if ( $@ or B::Utils->VERSION < $B_Utils_required ) { # If I don't have B::Utils then I must have ExtUtils::Depends my $ExtUtils_Depends_required = 0.302; #minimum version that works on Win32+gcc eval { require ExtUtils::Depends; }; if ( $@ or ExtUtils::Depends->VERSION < $ExtUtils_Depends_required ) { print "ExtUtils::Depends $ExtUtils_Depends_required is required to configure our B::Utils dependency, please install it manually or upgrade your CPAN/CPANPLUS\n"; exit(0); } }; } # Handle both: `./Build.PL DDS' and `./Build.PL NODDS' # my $create_dds_alias; if ( @ARGV && $ARGV[0] =~ /^(?:NO)?DDS$/i ) { my $arg = uc shift @ARGV; $create_dds_alias = 'DDS' eq $arg; } print "Installing Data::Dump::Streamer\n"; if ( ! defined $create_dds_alias && -e '.answer' && open my $fh, "<", '.answer') { print "I will install (or not) the DDS shortcut as you requested previously.\n"; print "If you wish to override the previous answer then state so explicitly\n"; print "by saying 'perl Build.PL [NO]DDS'\n"; my $cached_value = <$fh>; chomp $cached_value; print "Previous answer was: $cached_value\n"; $create_dds_alias = 'yes' eq lc $cached_value; } if ( ! defined $create_dds_alias ) { my $default = ( 0 == system( qq($^X -e "chdir '/';exit( eval { require DDS } ? 0: 1 )") ) || ( -e "./lib/DDS.pm") ) ? 'yes' : 'no'; print "\n"; print "I can install a shortcut so you can use the package 'DDS'\n"; print "as though it was 'Data::Dump::Streamer'. This is handy for oneliners.\n"; print "*Note* that if you select 'no' below and you already\n"; print "have it installed then it will be removed.\n"; print "\n"; my $yn = !! $class->y_n("Would you like me to install the shortcut? (yes/no)", $default); if (open my $fh, ">", '.answer') { print $fh $yn ? "yes\n" : "no\n"; close $fh; } $create_dds_alias = $yn; } my $self = $class->SUPER::new( @_ ); if ( $create_dds_alias ) { print "I will also install DDS as an alias.\n"; open my $ofh, ">", "./lib/DDS.pm" or die "Failed to open ./lib/DDS.pm: $!"; print { $ofh } DDS(); close $ofh; $self->add_to_cleanup( './lib/DDS.pm' ); } else { unlink "./lib/DDS.pm"; } return $self; } sub DDS { my $text = <<'EOF_DDS'; ##This all has to be one line for MakeMaker version scanning. #use Data::Dump::Streamer (); BEGIN{ *DDS:: = \%Data::Dump::Streamer:: } $VERSION=$DDS::VERSION; #1; # #=head1 NAME # #DDS - Alias for Data::Dump::Streamer # #=head1 SYNOPSIS # # perl -MDDS -e "Dump \%INC" # #=head1 DESCRIPTION # #See L. # #=head1 VERSION # # $Id: Makefile.PL 30 2006-04-16 15:33:25Z demerphq $ # #=cut # EOF_DDS $text =~ s/^#//gm; return $text; } 1;