ext/Data/Dumper/Dumper.xs Data pretty printer, externals
ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer
ext/Data/Dumper/t/dumper.t See if Data::Dumper works
+ext/Data/Dumper/t/pair.t See if Data::Dumper pair separator works
ext/Data/Dumper/t/overload.t See if Data::Dumper works for overloaded data
ext/Data/Dumper/Todo Data pretty printer, futures
ext/DB_File/Changes Berkeley DB extension change log
$Bless = "bless" unless defined $Bless;
#$Expdepth = 0 unless defined $Expdepth;
$Maxdepth = 0 unless defined $Maxdepth;
+$Pair = ' => ' unless defined $Pair;
$Useperl = 0 unless defined $Useperl;
$Sortkeys = 0 unless defined $Sortkeys;
$Deparse = 0 unless defined $Deparse;
xpad => "", # padding-per-level
apad => "", # added padding for hash keys n such
sep => "", # list separator
+ pair => $Pair, # hash key/value separator: defaults to ' => '
seen => {}, # local (nested) refs (id => [name, val])
todump => $v, # values to dump []
names => $n, # optional names for values []
$out .= ($name =~ /^\@/) ? ')' : ']';
}
elsif ($realtype eq 'HASH') {
- my($k, $v, $pad, $lpad, $mname);
+ my($k, $v, $pad, $lpad, $mname, $pair);
$out .= ($name =~ /^\%/) ? '(' : '{';
$pad = $s->{sep} . $s->{pad} . $s->{apad};
$lpad = $s->{apad};
+ $pair = $s->{pair};
($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
# omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
my $nk = $s->_dump($k, "");
$nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
$sname = $mname . '{' . $nk . '}';
- $out .= $pad . $ipad . $nk . " => ";
+ $out .= $pad . $ipad . $nk . $pair;
# temporarily alter apad
$s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
}
}
+sub Pair {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
+}
+
sub Pad {
my($s, $v) = @_;
defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
=item *
+$Data::Dumper::Pair I<or> $I<OBJ>->Pair(I<[NEWVAL]>)
+
+Can be set to a string that specifies the separator between hash keys
+and values. To dump nested hash, array and scalar values to JavaScript,
+use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript
+is left as an exercise for the reader.
+A function with the specified name exists, and accepts the same arguments
+as the builtin.
+
+Default is: C< =E<gt> >.
+
+=item *
+
$Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>)
Can be set to a positive integer that specifies the depth beyond which
$Data::Dumper::Useqq = 1; # print strings in double quotes
print Dumper($boo);
+ $Data::Dumper::Pair = " : "; # specify hash key/value separator
+ print Dumper($boo);
+
########
# recursive structures
static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
HV *seenhv, AV *postav, I32 *levelp, I32 indent,
- SV *pad, SV *xpad, SV *apad, SV *sep,
+ SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
SV *freezer, SV *toaster,
I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
I32 maxdepth, SV *sortkeys);
static I32
DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
- SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
+ SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
{
char tmpbuf[128];
if (realpack) { /* blessed */
sv_catpvn(retval, "do{\\(my $o = ", 13);
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
- postav, levelp, indent, pad, xpad, apad, sep,
+ postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
maxdepth, sortkeys);
sv_catpvn(retval, ")}", 2);
else {
sv_catpvn(retval, "\\", 1);
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
- postav, levelp, indent, pad, xpad, apad, sep,
+ postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
maxdepth, sortkeys);
}
sv_catpvn(namesv, "}", 1);
sv_catpvn(retval, "\\", 1);
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
- postav, levelp, indent, pad, xpad, apad, sep,
+ postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
maxdepth, sortkeys);
SvREFCNT_dec(namesv);
sv_catsv(retval, totpad);
sv_catsv(retval, ipad);
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
+ levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
maxdepth, sortkeys);
if (ix < ixmax)
There should also be less tests for the (probably currently)
more common doesn't need quoting case.
The code is also smaller (22044 vs 22260) because I've been
- able to pull the comon logic out to both sides. */
+ able to pull the common logic out to both sides. */
if (quotekeys || needs_quote(key)) {
if (do_utf8) {
STRLEN ocur = SvCUR(retval);
sv_catpvn(sname, nkey, nlen);
sv_catpvn(sname, "}", 1);
- sv_catpvn(retval, " => ", 4);
+ sv_catsv(retval, pair);
if (indent >= 2) {
char *extra;
I32 elen = 0;
newapad = apad;
DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
- postav, levelp, indent, pad, xpad, newapad, sep,
+ postav, levelp, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
maxdepth, sortkeys);
SvREFCNT_dec(sname);
DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
seenhv, postav, &nlevel, indent, pad, xpad,
- newapad, sep, freezer, toaster, purity,
+ newapad, sep, pair, freezer, toaster, purity,
deepcopy, quotekeys, bless, maxdepth,
sortkeys);
SvREFCNT_dec(e);
I32 level = 0;
I32 indent, terse, i, imax, postlen;
SV **svp;
- SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
+ SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
SV *freezer, *toaster, *bless, *sortkeys;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
char tmpbuf[1024];
todumpav = namesav = Nullav;
seenhv = Nullhv;
- val = pad = xpad = apad = sep = varname
+ val = pad = xpad = apad = sep = pair = varname
= freezer = toaster = bless = &PL_sv_undef;
name = sv_newmortal();
indent = 2;
apad = *svp;
if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
sep = *svp;
+ if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
+ pair = *svp;
if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
varname = *svp;
if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
newapad = apad;
DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
- postav, &level, indent, pad, xpad, newapad, sep,
+ postav, &level, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys,
bless, maxdepth, sortkeys);
--- /dev/null
+#!./perl -w
+#
+# test for $Data::Dumper::Pair AKA Data::Dumper->new([ ... ])->Pair('...')
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+ print "1..0 # Skip: Data::Dumper was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use vars qw($want_colon $want_comma);
+use Test::More tests => 9;
+
+no warnings qw(once);
+
+require_ok 'Data::Dumper';
+
+my $HASH = { alpha => 'beta', gamma => 'vlissides' };
+my $WANT = q({'alpha' => 'beta','gamma' => 'vlissides'});
+
+$Data::Dumper::Useperl = 1;
+$Data::Dumper::Indent = 0;
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Sortkeys = 1;
+
+$want_colon = $want_comma = $WANT;
+$want_colon =~ s/=>/:/g;
+$want_comma =~ s/ => /,/g;
+
+####################### XS Tests #####################
+
+SKIP: {
+ skip 'XS extension not loaded', 3 unless (defined &Data::Dumper::Dumpxs);
+ is (Data::Dumper::DumperX($HASH), $WANT,
+ 'XS: Default hash key/value separator: " => "');
+ local $Data::Dumper::Pair = ' : ';
+ is (Data::Dumper::DumperX($HASH), $want_colon, 'XS: $Data::Dumper::Pair = " : "');
+ my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
+ is ($dd->Dumpxs(), $want_comma,
+ 'XS: Data::Dumper->new([ $HASH ])->Pair(",")->Dumpxs()');
+};
+
+###################### Perl Tests ####################
+
+{
+ is ($Data::Dumper::Pair, ' => ', 'Perl: $Data::Dumper::Pair eq " => "');
+ is (Data::Dumper::Dumper($HASH), $WANT,
+ 'Perl: Default hash key/value separator: " => "');
+ local $Data::Dumper::Pair = ' : ';
+ is (Data::Dumper::Dumper($HASH), $want_colon, 'Perl: $Data::Dumper::Pair = " : "');
+ my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
+ is ($dd->Pair(), ',',
+ 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Pair() eq ","');
+ is ($dd->Dump(), $want_comma, 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Dump()');
+}
printf "%s 11 - masked SIGINT received %s\n",
$sigint_called ? "ok" : "not ok",
- $^O eq 'darwin' ? "# TODO Darwin seems to loose blocked signals"
- : '';
+ # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5.
+ $^O =~ /^(?:darwin|freebsd)$/ ?
+ "# TODO $^O seems to loose blocked signals"
+ : '';
print "ok 12 - signal masks successful\n";
libswanted="$*"
;;
esac
+ case "$osvers" in
+ [012].*|3.[0-3])
+ # Broken at least up to OpenBSD 3.2, we'll see about 3.3.
+ d_getservbyname_r=$undef ;;
+ esac
esac
EOCBU
use Carp;
use Symbol qw(gensym qualify);
-$VERSION = 1.0104;
+$VERSION = 1.0105;
@ISA = qw(Exporter);
@EXPORT = qw(open3);
C<exec> failures in the child are not detected. You'll have to
trap SIGPIPE yourself.
+Note if you specify C<-> as the command, in an analogous fashion to
+C<open(FOO, "-|")> the child process will just be the forked Perl
+process rather than an external command. This feature isn't yet
+supported on Win32 platforms.
+
open3() does not wait for and reap the child process after it exits.
Except for short programs where it's acceptable to let the operating system
take care of this, you need to do this yourself. This is normally as
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
# fixed for autovivving FHs, tchrist again
# allow fd numbers to be used, by Frank Tobin
+# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
#
# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
#
} else {
xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
}
+ if ($cmd[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ if @cmd > 1;
+ return 0;
+ }
local($")=(" ");
exec @cmd # XXX: wrong process to croak from
or croak "$Me: exec of @cmd failed";
our @rl_term_set;
*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+sub PERL_UNICODE_STDIN () { 0x0001 }
+
sub ReadLine {'Term::ReadLine::Stub'}
sub readline {
my $self = shift;
#$str = scalar <$in>;
$str = $self->get_line;
$str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
+ utf8::upgrade($str)
+ if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
+ utf8::valid($str);
print $out $rl_term_set[3];
# bug in 5.000: chomping empty string creats length -1:
chomp $str if defined $str;
package Term::ReadLine; # So late to allow the above code be defined?
-our $VERSION = '1.00';
+our $VERSION = '1.01';
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ?
mg_find(sv, PERL_MAGIC_utf8) : NULL;
if (mg && mg->mg_len >= 0)
- mg->mg_len += utf8_length(STRING(scan),
- STRING(scan)+STR_LEN(scan));
+ mg->mg_len += utf8_length((U8*)STRING(scan),
+ (U8*)STRING(scan)+STR_LEN(scan));
}
if (UTF)
SvUTF8_on(data->last_found);
$DEV =~ s{^.+?\s\..+?$}{}m;
@DEV = grep { ! m{^\..+$} } @DEV;
+ # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'.
+ if ($^O eq 'irix') {
+ $DEV =~ s{^S(.+?)}{s$1}mg;
+ }
+
my $try = sub {
my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg];
my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV];
$hz ||= 1;
if( $opt_r ){
- $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
+ $$runtime = ($rrun_rtime - $overhead)/$hz;
}
elsif( $opt_s ){
- $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
+ $$runtime = ($rrun_stime - $overhead)/$hz;
}
elsif( $opt_u ){
- $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
+ $$runtime = ($rrun_utime - $overhead)/$hz;
}
else{
- $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
+ $$runtime = ($rrun_ustime - $overhead)/$hz;
}
$$runtime = 0 unless $$runtime > 0;
}
exclusives_in_tree($deep_times);
my $kid;
- local *kids = $deep_times->{kids}; # %kids
my $time;
- if (%kids) {
+ if (%{$deep_times->{kids}}) {
$time = sprintf '%.*fs = (%.*f + %.*f)',
$time_precision, $deep_times->{incl_time}/$hz,
$time_precision, $deep_times->{excl_time}/$hz,
print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
if $deep_times->{count};
- for $kid (sort kids_by_incl keys %kids) {
+ for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
}
}
sub move_keys {
my ($source, $dest) = @_;
- my $kid;
-
- for $kid (keys %$source) {
- if (exists $dest->{$kid}) {
- $dest->{count} += $source->{count};
- $dest->{incl_time} += $source->{incl_time};
- move_keys($source->{kids},$dest->{kids});
+
+ for my $kid_name (keys %$source) {
+ my $source_kid = delete $source->{$kid_name};
+
+ if (my $dest_kid = $dest->{$kid_name}) {
+ $dest_kid->{count} += $source_kid->{count};
+ $dest_kid->{incl_time} += $source_kid->{incl_time};
+ move_keys($source_kid->{kids},$dest_kid->{kids});
} else {
- $dest->{$kid} = delete $source->{$kid};
+ $dest->{$kid_name} = $source_kid;
}
}
}
$name = $curdeep_times->[-1]{name};
}
die "Shorted?!" unless @$curdeep_times >= 2;
- $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {},
- incl_time => 0,
- }
- unless exists $curdeep_times->[-2]{kids}{$name};
- my $entry = $curdeep_times->[-2]{kids}{$name};
+ my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
+ count => 0,
+ kids => {},
+ incl_time => 0,
+ };
# Now transfer to the new node (could not do earlier, since name can change)
$entry->{count}++;
$entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
my( $x, $z, $c, $id, $pack );
my @stack = ();
my @tstack = ();
+ my %outer;
my $tab = 3;
my $in = 0;
my $l_name = '';
my $repcnt = 0;
my $repstr = '';
- my $dprof_t = 0;
my $dprof_stamp;
my %cv_hash;
my $in_level = not defined $opt_g; # Level deep in report grouping
$name = defined $syst ? $syst : $cv_hash{$usert};
}
- next unless $in_level or $name eq $opt_g or $dir eq '*';
+ next unless $in_level or $name eq $opt_g;
if ( $dir eq '-' or $dir eq '*' ) {
my $ename = $dir eq '*' ? $stack[-1][0] : $name;
$overhead += $over_per_call;
if ($name eq "Devel::DProf::write") {
- $dprof_t += $t - $dprof_stamp;
+ $overhead += $t - $dprof_stamp;
next;
} elsif (defined $opt_g and $ename eq $opt_g) {
$in_level--;
}
add_to_tree($curdeep_times, $ename,
- $t - $dprof_t - $overhead) if $opt_S;
+ $t - $overhead) if $opt_S;
exitstamp( \@stack, \@tstack,
- $t - $dprof_t - $overhead,
+ $t - $overhead,
$times, $ctimes, $ename, \$in, $tab,
- $curdeep_times );
+ $curdeep_times, \%outer );
}
next unless $in_level or $name eq $opt_g;
if( $dir eq '+' or $dir eq '*' ){
push( @$idkeys, $name );
}
$calls->{$name}++;
+ $outer{$name}++;
push @$curdeep_times, { kids => {},
name => $name,
- enter_stamp => $t - $dprof_t - $overhead,
+ enter_stamp => $t - $overhead,
} if $opt_S;
- $x = [ $name, $t - $dprof_t - $overhead ];
+ $x = [ $name, $t - $overhead ];
push( @stack, $x );
# my children will put their time here
print ' ' x $l_in, "$l_name$repstr\n";
}
+ while (my ($key, $count) = each %outer) {
+ next unless $count;
+ warn "$key has $count unstacked calls in outer\n";
+ }
+
if( @stack ){
if( ! $opt_F ){
warn "Garbled profile is missing some exit time stamps:\n";
foreach $x ( reverse @stack ){
$name = $x->[0];
exitstamp( \@stack, \@tstack,
- $t - $dprof_t - $overhead, $times,
+ $t - $overhead, $times,
$ctimes, $name, \$in, $tab,
- $curdeep_times );
+ $curdeep_times, \%outer );
add_to_tree($curdeep_times, $name,
- $t - $dprof_t - $overhead)
+ $t - $overhead)
if $opt_S;
}
}
}
sub exitstamp {
- my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
+ my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
my( $x, $c, $z );
$x = pop( @$stack );
$c = pop( @$tstack );
# total time this func has been active
$z = $t - $x->[1];
- $ctimes->{$name} += $z;
- $times->{$name} += ($z > $c)? $z - $c: 0;
+ $ctimes->{$name} += $z
+ unless --$outer->{$name};
+ $times->{$name} += $z - $c;
# pass my time to my parent
if( @$tstack ){
$c = pop( @$tstack );
format CSTAT_top =
Total Elapsed Time = @>>>>>>> Seconds
-(($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
+(($rrun_rtime - $overhead) / $hz)
@>>>>>>>>>> Time = @>>>>>>> Seconds
$whichtime, $runtime
@<<<<<<<< Times
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
- 'NAME' => '$module',
- 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
- 'PREREQ_PM' => {$prereq_pm}, # e.g., Module::Name => 1.1
- (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
- AUTHOR => '$author <$email>') : ()),
+ NAME => '$module',
+ VERSION_FROM => '$modfname.pm', # finds \$VERSION
+ PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
+ (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
+ AUTHOR => '$author <$email>') : ()),
END
if (!$opt_X) { # print C stuff, unless XS is disabled
$opt_F = '' unless defined $opt_F;
EOC
print PL <<END;
- 'LIBS' => ['$extralibs'], # e.g., '-lm'
- 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
-$Icomment 'INC' => '$I', # e.g., '${Ihelp}-I/usr/include/other'
+ LIBS => ['$extralibs'], # e.g., '-lm'
+ DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
+$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
END
my $C = grep {$_ ne "$modfname.c"}
EOC
print PL <<END;
-$Ccomment $Cpre\'OBJECT' => '\$(O_FILES)', # link all the C files too
+$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
END
} # ' # Grr
print PL ");\n";
https://perl5.git.perl.org / perl5.git / commitdiff