Data-Dump-Streamer
view release on metacpan or search on metacpan
lib/Data/Dump/Streamer.pm view on Meta::CPAN
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.42';
$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];
lib/Data/Dump/Streamer.pm view on Meta::CPAN
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<Dump()>
will be scanned.
Returns $self.
=cut
sub _add_queue {
my ($self, $queue, $type, $item, $depth, $name, $rcount, $arg)= @_;
print "add_queue($name)\n" if $DEBUG;
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;
ITEM:
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 ITEM;
lib/Data/Dump/Streamer.pm view on Meta::CPAN
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 (!$self->{style}{terse}) {
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] } ]
},
lib/Data/Dump/Streamer.pm view on Meta::CPAN
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<Data::Dumper>
- the mother of them all
L<Data::Dumper::Simple>
- Auto named vars with source filter interface.
L<Data::Dumper::Names>
- Auto named vars without source filtering.
L<Data::Dumper::EasyOO>
- easy to use wrapper for DD
L<Data::Dump>
- Has cool feature to squeeze data
( run in 0.757 second using v1.01-cache-2.11-cpan-39bf76dae61 )