diff options
| author |   afresh1 <afresh1@openbsd.org> | 2019-02-13 21:15:00 +0000 |
|---|---|---|
| committer | afresh1 <afresh1@openbsd.org> | 2019-02-13 21:15:00 +0000 |
| commit | 9f11ffb7133c203312a01e4b986886bc88c7d74b (patch) | |
| tree | 6618511204c614b20256e4ef9dea39a7b311d638 /gnu/usr.bin/perl/dist | |
| parent | Import perl-5.28.1 (diff) | |
| download | wireguard-openbsd-9f11ffb7133c203312a01e4b986886bc88c7d74b.tar.xz wireguard-openbsd-9f11ffb7133c203312a01e4b986886bc88c7d74b.zip | |
Fix merge issues, remove excess files - match perl-5.28.1 dist
looking good sthen@, Great! bluhm@
Diffstat (limited to 'gnu/usr.bin/perl/dist')
141 files changed, 10822 insertions, 6923 deletions
diff --git a/gnu/usr.bin/perl/dist/Attribute-Handlers/lib/Attribute/Handlers.pm b/gnu/usr.bin/perl/dist/Attribute-Handlers/lib/Attribute/Handlers.pm index 7c049d48e6f..f028286fb85 100644 --- a/gnu/usr.bin/perl/dist/Attribute-Handlers/lib/Attribute/Handlers.pm +++ b/gnu/usr.bin/perl/dist/Attribute-Handlers/lib/Attribute/Handlers.pm @@ -3,8 +3,8 @@ use 5.006; use Carp; use warnings; use strict; -use vars qw($VERSION $AUTOLOAD); -$VERSION = '0.99'; # remember to update version in POD! +our $AUTOLOAD; +our $VERSION = '1.01'; # remember to update version in POD! # $DB::single=1; my %symcache; @@ -139,7 +139,9 @@ sub AUTOLOAD { croak "Attribute handler '$2' doesn't handle $1 attributes"; } -my $builtin = qr/lvalue|method|locked|unique|shared/; +my $builtin = $] ge '5.027000' + ? qr/lvalue|method|shared/ + : qr/lvalue|method|locked|shared|unique/; sub _gen_handler_AH_() { return sub { @@ -270,7 +272,7 @@ Attribute::Handlers - Simpler definition of attribute handlers =head1 VERSION -This document describes version 0.99 of Attribute::Handlers. +This document describes version 1.01 of Attribute::Handlers. =head1 SYNOPSIS diff --git a/gnu/usr.bin/perl/dist/Carp/lib/Carp.pm b/gnu/usr.bin/perl/dist/Carp/lib/Carp.pm index 92f88661af6..109b7fec770 100644 --- a/gnu/usr.bin/perl/dist/Carp/lib/Carp.pm +++ b/gnu/usr.bin/perl/dist/Carp/lib/Carp.pm @@ -87,7 +87,131 @@ BEGIN { } } -our $VERSION = '1.40'; +# is_safe_printable_codepoint() indicates whether a character, specified +# by integer codepoint, is OK to output literally in a trace. Generally +# this is if it is a printable character in the ancestral character set +# (ASCII or EBCDIC). This is used on some Perls in situations where a +# regexp can't be used. +BEGIN { + *is_safe_printable_codepoint = + "$]" >= 5.007_003 ? + eval(q(sub ($) { + my $u = utf8::native_to_unicode($_[0]); + $u >= 0x20 && $u <= 0x7e; + })) + : ord("A") == 65 ? + sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e } + : + sub ($) { + # Early EBCDIC + # 3 EBCDIC code pages supported then; all controls but one + # are the code points below SPACE. The other one is 0x5F on + # POSIX-BC; FF on the other two. + # FIXME: there are plenty of unprintable codepoints other + # than those that this code and the comment above identifies + # as "controls". + $_[0] >= ord(" ") && $_[0] <= 0xff && + $_[0] != (ord ("^") == 106 ? 0x5f : 0xff); + } + ; +} + +sub _univ_mod_loaded { + return 0 unless exists($::{"UNIVERSAL::"}); + for ($::{"UNIVERSAL::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"}; + for ($$_{"$_[0]::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"}; + for ($$_{"VERSION"}) { + return 0 unless ref \$_ eq "GLOB"; + return ${*$_{SCALAR}}; + } + } + } +} + +# _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid +# the latter if the UNIVERSAL::isa module has been loaded, to avoid infi- +# nite recursion; in that case _maybe_isa simply returns true. +my $isa; +BEGIN { + if (_univ_mod_loaded('isa')) { + *_maybe_isa = sub { 1 } + } + else { + # Since we have already done the check, record $isa for use below + # when defining _StrVal. + *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa"); + } +} + + +# We need an overload::StrVal or equivalent function, but we must avoid +# loading any modules on demand, as Carp is used from __DIE__ handlers and +# may be invoked after a syntax error. +# We can copy recent implementations of overload::StrVal and use +# overloading.pm, which is the fastest implementation, so long as +# overloading is available. If it is not available, we use our own pure- +# Perl StrVal. We never actually use overload::StrVal, for various rea- +# sons described below. +# overload versions are as follows: +# undef-1.00 (up to perl 5.8.0) uses bless (avoid!) +# 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util +# 1.18+ (perl 5.16+) uses overloading +# The ancient 'bless' implementation (that inspires our pure-Perl version) +# blesses unblessed references and must be avoided. Those using +# Scalar::Util use refaddr, possibly the pure-Perl implementation, which +# has the same blessing bug, and must be avoided. Also, Scalar::Util is +# loaded on demand. Since we avoid the Scalar::Util implementations, we +# end up having to implement our own overloading.pm-based version for perl +# 5.10.1 to 5.14. Since it also works just as well in more recent ver- +# sions, we use it there, too. +BEGIN { + if (eval { require "overloading.pm" }) { + *_StrVal = eval 'sub { no overloading; "$_[0]" }' + } + else { + # Work around the UNIVERSAL::can/isa modules to avoid recursion. + + # _mycan is either UNIVERSAL::can, or, in the presence of an + # override, overload::mycan. + *_mycan = _univ_mod_loaded('can') + ? do { require "overload.pm"; _fetch_sub overload => 'mycan' } + : \&UNIVERSAL::can; + + # _blessed is either UNIVERAL::isa(...), or, in the presence of an + # override, a hideous, but fairly reliable, workaround. + *_blessed = $isa + ? sub { &$isa($_[0], "UNIVERSAL") } + : sub { + my $probe = "UNIVERSAL::Carp_probe_" . rand; + no strict 'refs'; + local *$probe = sub { "unlikely string" }; + local $@; + local $SIG{__DIE__} = sub{}; + (eval { $_[0]->$probe } || '') eq 'unlikely string' + }; + + *_StrVal = sub { + my $pack = ref $_[0]; + # Perl's overload mechanism uses the presence of a special + # "method" named "((" or "()" to signal it is in effect. + # This test seeks to see if it has been set up. "((" post- + # dates overloading.pm, so we can skip it. + return "$_[0]" unless _mycan($pack, "()"); + # Even at this point, the invocant may not be blessed, so + # check for that. + return "$_[0]" if not _blessed($_[0]); + bless $_[0], "Carp"; + my $str = "$_[0]"; + bless $_[0], $pack; + $pack . substr $str, index $str, "="; + } + } +} + + +our $VERSION = '1.50'; $VERSION =~ tr/_//d; our $MaxEvalLen = 0; @@ -203,11 +327,33 @@ sub caller_info { my $sub_name = Carp::get_subname( \%call_info ); if ( $call_info{has_args} ) { - my @args; - if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1 - && ref $DB::args[0] eq ref \$i - && $DB::args[0] == \$i ) { - @DB::args = (); # Don't let anyone see the address of $i + # Guard our serialization of the stack from stack refcounting bugs + # NOTE this is NOT a complete solution, we cannot 100% guard against + # these bugs. However in many cases Perl *is* capable of detecting + # them and throws an error when it does. Unfortunately serializing + # the arguments on the stack is a perfect way of finding these bugs, + # even when they would not affect normal program flow that did not + # poke around inside the stack. Inside of Carp.pm it makes little + # sense reporting these bugs, as Carp's job is to report the callers + # errors, not the ones it might happen to tickle while doing so. + # See: https://rt.perl.org/Public/Bug/Display.html?id=131046 + # and: https://rt.perl.org/Public/Bug/Display.html?id=52610 + # for more details and discussion. - Yves + my @args = map { + my $arg; + local $@= $@; + eval { + $arg = $_; + 1; + } or do { + $arg = '** argument not available anymore **'; + }; + $arg; + } @DB::args; + if (CALLER_OVERRIDE_CHECK_OK && @args == 1 + && ref $args[0] eq ref \$i + && $args[0] == \$i ) { + @args = (); # Don't let anyone see the address of $i local $@; my $where = eval { my $func = $cgc or return ''; @@ -226,7 +372,6 @@ sub caller_info { = "** Incomplete caller override detected$where; \@DB::args were not set **"; } else { - @args = @DB::args; my $overflow; if ( $MaxArgNums and @args > $MaxArgNums ) { # More than we want to show? @@ -253,9 +398,10 @@ our $in_recurse; sub format_arg { my $arg = shift; - if ( ref($arg) ) { + if ( my $pack= ref($arg) ) { + # legitimate, let's not leak it. - if (!$in_recurse && + if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) && do { local $@; local $in_recurse = 1; @@ -278,8 +424,11 @@ sub format_arg { } else { - my $sub = _fetch_sub(overload => 'StrVal'); - return $sub ? &$sub($arg) : "$arg"; + # Argument may be blessed into a class with overloading, and so + # might have an overloaded stringification. We don't want to + # risk getting the overloaded stringification, so we need to + # use _StrVal, our overload::StrVal()-equivalent. + return _StrVal $arg; } } return "undef" if !defined($arg); @@ -300,32 +449,15 @@ sub format_arg { next; } my $o = ord($c); - - # This code is repeated in Regexp::CARP_TRACE() - if ($] ge 5.007_003) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20) - || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e); - } elsif (ord("A") == 65) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < 0x20 || $o > 0x7e; - } else { # Early EBCDIC - - # 3 EBCDIC code pages supported then; all controls but one - # are the code points below SPACE. The other one is 0x5F on - # POSIX-BC; FF on the other two. - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < ord(" ") || ((ord ("^") == 106) - ? $o == 0x5f - : $o == 0xff); - } + substr $arg, $i, 1, sprintf("\\x{%x}", $o) + unless is_safe_printable_codepoint($o); } } else { $arg =~ s/([\"\\\$\@])/\\$1/g; # This is all the ASCII printables spelled-out. It is portable to all # Perl versions and platforms (such as EBCDIC). There are other more # compact ways to do this, but may not work everywhere every version. - $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; } downgrade($arg, 1); return "\"".$arg."\"".$suffix; @@ -338,25 +470,12 @@ sub Regexp::CARP_TRACE { for(my $i = length($arg); $i--; ) { my $o = ord(substr($arg, $i, 1)); my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2} - - # This code is repeated in format_arg() - if ($] ge 5.007_003) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20) - || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e); - } elsif (ord("A") == 65) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < 0x20 || $o > 0x7e; - } else { # Early EBCDIC - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < ord(" ") || ((ord ("^") == 106) - ? $o == 0x5f - : $o == 0xff); - } + substr $arg, $i, 1, sprintf("\\x{%x}", $o) + unless is_safe_printable_codepoint($o); } } else { # See comment in format_arg() about this same regex. - $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; } downgrade($arg, 1); my $suffix = ""; @@ -452,6 +571,15 @@ sub longmess_heavy { return ret_backtrace( $i, @_ ); } +BEGIN { + if("$]" >= 5.017004) { + # The LAST_FH constant is a reference to the variable. + $Carp::{LAST_FH} = \eval '\${^LAST_FH}'; + } else { + eval '*LAST_FH = sub () { 0 }'; + } +} + # Returns a full stack backtrace starting from where it is # told. sub ret_backtrace { @@ -468,15 +596,25 @@ sub ret_backtrace { my %i = caller_info($i); $mess = "$err at $i{file} line $i{line}$tid_msg"; - if( defined $. ) { + if( $. ) { + # Use ${^LAST_FH} if available. + if (LAST_FH) { + if (${+LAST_FH}) { + $mess .= sprintf ", <%s> %s %d", + *${+LAST_FH}{NAME}, + ($/ eq "\n" ? "line" : "chunk"), $. + } + } + else { local $@ = ''; local $SIG{__DIE__}; eval { CORE::die; }; - if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { + if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) { $mess .= $1; } + } } $mess .= "\.\n"; @@ -594,7 +732,8 @@ sub trusts_directly { for my $var (qw/ CARP_NOT ISA /) { # Don't try using the variable until we know it exists, # to avoid polluting the caller's namespace. - if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) { + if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB' + && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) { return @{$stash->{$var}} } } @@ -636,7 +775,7 @@ Carp - alternative warn and die for modules # cluck, longmess and shortmess not exported by default use Carp qw(cluck longmess shortmess); - cluck "This is how we got here!"; + cluck "This is how we got here!"; # warn with stack backtrace $long_message = longmess( "message from cluck() or confess()" ); $short_message = shortmess( "message from carp() or croak()" ); diff --git a/gnu/usr.bin/perl/dist/Carp/lib/Carp/Heavy.pm b/gnu/usr.bin/perl/dist/Carp/lib/Carp/Heavy.pm index b05d7583c22..a9b803c76ad 100644 --- a/gnu/usr.bin/perl/dist/Carp/lib/Carp/Heavy.pm +++ b/gnu/usr.bin/perl/dist/Carp/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.40'; +our $VERSION = '1.50'; $VERSION =~ tr/_//d; # Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions diff --git a/gnu/usr.bin/perl/dist/Carp/t/Carp.t b/gnu/usr.bin/perl/dist/Carp/t/Carp.t index 9ecdf88b601..b1e399d1435 100644 --- a/gnu/usr.bin/perl/dist/Carp/t/Carp.t +++ b/gnu/usr.bin/perl/dist/Carp/t/Carp.t @@ -3,7 +3,7 @@ no warnings "once"; use Config; use IPC::Open3 1.0103 qw(open3); -use Test::More tests => 66; +use Test::More tests => 68; sub runperl { my(%args) = @_; @@ -442,6 +442,16 @@ $@ =~ s/\n.*//; # just check first line is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n", 'last handle line num is mentioned'; +# [cpan #100183] +{ + local $/ = \6; + <XD::DATA>; + eval { croak 'jeek' }; + $@ =~ s/\n.*//; # just check first line + is $@, "jeek at ".__FILE__." line ".(__LINE__-2).", <DATA> chunk 3.\n", + 'last handle chunk num is mentioned'; +} + SKIP: { skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS; @@ -478,6 +488,17 @@ SKIP: ); } +{ + package Mpar; + sub f { Carp::croak "tun syn" } + + package Phou; + $Phou::{ISA} = \42; + eval { Mpar::f }; +} +like $@, qr/tun syn/, 'Carp can handle non-glob ISA stash elems'; + + # New tests go here # line 1 "XA" @@ -531,3 +552,4 @@ __DATA__ 1 2 3 +abcdefghijklmnopqrstuvwxyz diff --git a/gnu/usr.bin/perl/dist/Carp/t/arg_regexp.t b/gnu/usr.bin/perl/dist/Carp/t/arg_regexp.t index 1575b291ab2..83e8f0359f0 100644 --- a/gnu/usr.bin/perl/dist/Carp/t/arg_regexp.t +++ b/gnu/usr.bin/perl/dist/Carp/t/arg_regexp.t @@ -1,6 +1,8 @@ use warnings; use strict; +# confirm that regexp-typed stack args are displayed correctly by longmess() + use Test::More tests => 42; use Carp (); @@ -16,12 +18,14 @@ my $e9 = sprintf "%02x", (($] ge 5.007_003) : ((ord("A") == 193) ? 0x51 : 0xE9)); -my $chr_e9 = chr eval "0x$e9"; +my $xe9 = "\\x$e9"; +my $chr_e9 = eval "\"$xe9\""; my $nl_as_hex = sprintf "%x", ord("\n"); # On Perl 5.6 we accept some incorrect quoting of Unicode characters, # because upgradedness of regexps isn't preserved by stringification, # so it's impossible to implement the correct behaviour. +# FIXME: the permissive patterns don't account for EBCDIC my $xe9_rx = "$]" < 5.008 ? qr/\\x\{c3\}\\x\{a9\}|\\x\{e9\}/ : qr/\\x\{$e9\}/; my $x666_rx = "$]" < 5.008 ? qr/\\x\{d9\}\\x\{a6\}|\\x\{666\}/ : qr/\\x\{666\}/; my $x2603_rx = "$]" < 5.008 ? qr/\\x\{e2\}\\x\{98\}\\x\{83\}|\\x\{2603\}/ : qr/\\x\{2603\}/; @@ -41,16 +45,10 @@ like lm(qr/\x{666}b/), qr/main::lm\(qr\(\\x\{666\}b\)u?\)/; like lm(rx("\x{666}b")), qr/main::lm\(qr\(${x666_rx}b\)u?\)/; like lm(qr/a\x{666}/), qr/main::lm\(qr\(a\\x\{666\}\)u?\)/; like lm(rx("a\x{666}")), qr/main::lm\(qr\(a${x666_rx}\)u?\)/; -like lm(qr/L${chr_e9}on/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\)u?\)/; +like lm(qr/L${xe9}on/), qr/main::lm\(qr\(L\\x${e9}on\)u?\)/; like lm(rx("L${chr_e9}on")), qr/main::lm\(qr\(L${xe9_rx}on\)u?\)/; - - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 2 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on \\x\{2603\} !\)u?\)/; - like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/; -} +like lm(qr/L${xe9}on \x{2603} !/), qr/main::lm\(qr\(L\\x${e9}on \\x\{2603\} !\)u?\)/; +like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/; $Carp::MaxArgLen = 5; foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar", "foo ba") { @@ -60,16 +58,10 @@ foreach my $arg ("foo b", "foo ", "foo", "fo", "f", "") { like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/; } like lm(qr/foo.bar$/sm), qr/main::lm\(qr\(fo\)\.\.\.u?ms\)/; - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 4 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; -} - +like lm(qr/L${xe9}on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(qr/L${xe9}on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; like lm(qr/foo\x{2603}/), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; like lm(rx("foo\x{2603}")), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; @@ -77,12 +69,7 @@ $Carp::MaxArgLen = 0; foreach my $arg ("wibble:" x 20, "foo bar baz") { like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/; } - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 2 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\\x\{2603\}\)u?\)/; - like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/; -} +like lm(qr/L${xe9}on\x{2603}/), qr/main::lm\(qr\(L\\x${e9}on\\x\{2603\}\)u?\)/; +like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/; 1; diff --git a/gnu/usr.bin/perl/dist/Carp/t/arg_string.t b/gnu/usr.bin/perl/dist/Carp/t/arg_string.t index dbd2e6e7f87..544a4fe0594 100644 --- a/gnu/usr.bin/perl/dist/Carp/t/arg_string.t +++ b/gnu/usr.bin/perl/dist/Carp/t/arg_string.t @@ -1,7 +1,9 @@ use warnings; use strict; -use Test::More tests => 32; +# confirm that string-typed stack args are displayed correctly by longmess() + +use Test::More tests => 33; use Carp (); @@ -15,19 +17,26 @@ my $e9 = sprintf "%02x", (($] ge 5.007_003) : ((ord("A") == 193) ? 0x51 : 0xE9)); -my $chr_e9 = chr eval "0x$e9"; +my $xe9 = "\\x$e9"; +my $chr_e9 = eval "\"$xe9\""; my $nl_as_hex = sprintf "%x", ord("\n"); like lm(3), qr/main::lm\(3\)/; like lm(substr("3\x{2603}", 0, 1)), qr/main::lm\(3\)/; like lm(-3), qr/main::lm\(-3\)/; like lm(-3.5), qr/main::lm\(-3\.5\)/; -like lm(-3.5e100), qr/main::lm\(-3\.5[eE]\+?100\)/; +like lm(-3.5e30), + qr/main::lm\( + ( + -3500000000000000000000000000000 + | -3\.5[eE]\+?0?30 + ) + \) /x; like lm(""), qr/main::lm\(""\)/; like lm("foo"), qr/main::lm\("foo"\)/; +like lm("a&b"), qr/main::lm\("a&b"\)/; like lm("a\$b\@c\\d\"e"), qr/main::lm\("a\\\$b\\\@c\\\\d\\\"e"\)/; like lm("a\nb"), qr/main::lm\("a\\x\{$nl_as_hex\}b"\)/; - like lm("a\x{666}b"), qr/main::lm\("a\\x\{666\}b"\)/; like lm("\x{666}b"), qr/main::lm\("\\x\{666\}b"\)/; like lm("a\x{666}"), qr/main::lm\("a\\x\{666\}"\)/; diff --git a/gnu/usr.bin/perl/dist/Data-Dumper/Changes b/gnu/usr.bin/perl/dist/Data-Dumper/Changes index eca3bb99957..95e3a8ab165 100644 --- a/gnu/usr.bin/perl/dist/Data-Dumper/Changes +++ b/gnu/usr.bin/perl/dist/Data-Dumper/Changes @@ -6,6 +6,66 @@ Changes - public release history for Data::Dumper =over 8 +=item 2.167_02 (Aug 4 2017) + +Attempt to work around XS deparse issues on old perls. +According to the few old perls at my disposure, this now repairs, +for example 5.18, but 5.8.9 still barfs. My debugging hasn't +really come up with much since all changes other than the deparse +change look benign to me. +Can someone who uses ancient perls please step up and take a look? +--Steffen + +=item 2.167_01 (Jul 31 2017) + +CPAN dev release with the accumulated changes from core perl. + +=item 2.166 (Nov 29 2016) + +Reduce memory usage by not importing from Carp +Reduce memory usage by removing unused overload require. + +=item 2.165 (Nov 20 2016) + +Remove impediment to compiling under C++11. + +=item 2.164 (Nov 12 2016) + +The XS implementation now handles the C<Deparse> option, so using it no +longer forces use of the pure-Perl version. + +=item 2.161 (Jul 11 2016) + +Perl 5.12 fix/workaround until fixed PPPort release. + +Pre-5.12 fixes for test dependency. + +=item 2.160 (Jul 3 2016) + +Now handles huge inputs on 64bit perls. + +Add Trailingcomma option. This is as suggested in RT#126813. + +Significant refactoring of XS implementation. + +Pure Perl implementation fixes in corner cases ("\n" dumped raw"). + +=item 2.154 (Sep 18 2014) + +Most notably, this release fixes CVE-2014-4330: + + Don't recurse infinitely in Data::Dumper + + Add a configuration variable/option to limit recursion when dumping + deep data structures. + [...] + This patch addresses CVE-2014-4330. This bug was found and + reported by: LSE Leading Security Experts GmbH employee Markus + Vervier. + +On top of that, there are several minor big fixes and improvements, +see "git log" if the core perl distribution for details. + =item 2.151 (Mar 7 2014) A "useqq" implementation for the XS version of Data::Dumper. @@ -328,7 +388,7 @@ C<require 5.002>. MLDBM example removed (as its own module, it has a separate CPAN reality now). -Fixed bugs in handling keys with weird characters. Perl can be +Fixed bugs in handling keys with wierd characters. Perl can be tripped up in its implicit quoting of the word before '=>'. The fix: C<Data::Dumper::Purity>, when set, always triggers quotes around hash keys. diff --git a/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.pm b/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.pm index 13be89d8fbd..00c99ec0f26 100644 --- a/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.pm +++ b/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.pm @@ -10,16 +10,17 @@ package Data::Dumper; BEGIN { - $VERSION = '2.160'; # Don't forget to set version and release + $VERSION = '2.170'; # Don't forget to set version and release } # date in POD below! #$| = 1; use 5.006_001; require Exporter; -require overload; -use Carp; +use constant IS_PRE_520_PERL => $] < 5.020; + +use Carp (); BEGIN { @ISA = qw(Exporter); @@ -70,7 +71,7 @@ $Maxrecurse = 1000 unless defined $Maxrecurse; sub new { my($c, $v, $n) = @_; - croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" + Carp::croak("Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])") unless (defined($v) && (ref($v) eq 'ARRAY')); $n = [] unless (defined($n) && (ref($n) eq 'ARRAY')); @@ -170,11 +171,11 @@ sub Seen { $s->{seen}{$id} = [$k, $v]; } else { - carp "Only refs supported, ignoring non-ref item \$$k"; + Carp::carp("Only refs supported, ignoring non-ref item \$$k"); } } else { - carp "Value of ref must be defined; ignoring undefined item \$$k"; + Carp::carp("Value of ref must be defined; ignoring undefined item \$$k"); } } return $s; @@ -195,7 +196,7 @@ sub Values { return $s; } else { - croak "Argument to Values, if provided, must be array ref"; + Carp::croak("Argument to Values, if provided, must be array ref"); } } else { @@ -214,7 +215,7 @@ sub Names { return $s; } else { - croak "Argument to Names, if provided, must be array ref"; + Carp::croak("Argument to Names, if provided, must be array ref"); } } else { @@ -225,13 +226,19 @@ sub Names { sub DESTROY {} sub Dump { - return &Dumpxs - unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) - || $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}) + # On old versions of perl, the xs-deparse support can fail + # mysteriously. Barring copious spare time, it's best to revert + # to the previously standard behavior of using the pure perl dumper + # for deparsing on old perls. --Steffen + if (IS_PRE_520_PERL and ($Data::Dumper::Deparse or (ref($_[0]) && $_[0]->{deparse}))) { + return &Dumpperl; + } + return &Dumpxs + unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) # Use pure perl version on earlier releases on EBCDIC platforms || (! $IS_ASCII && $] lt 5.021_010); - return &Dumpperl; + return &Dumpperl; } # @@ -439,7 +446,7 @@ sub _dump { if (ref($s->{sortkeys}) eq 'CODE') { $keys = $s->{sortkeys}($val); unless (ref($keys) eq 'ARRAY') { - carp "Sortkeys subroutine did not return ARRAYREF"; + Carp::carp("Sortkeys subroutine did not return ARRAYREF"); $keys = []; } } @@ -487,16 +494,16 @@ sub _dump { require B::Deparse; my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val); $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1); - $sub =~ s/\n/$pad/gse; + $sub =~ s/\n/$pad/gs; $out .= $sub; } else { $out .= 'sub { "DUMMY" }'; - carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; + Carp::carp("Encountered CODE ref, using dummy placeholder") if $s->{purity}; } } else { - croak "Can't handle '$realtype' type"; + Carp::croak("Can't handle '$realtype' type"); } if ($realpack and !$no_bless) { # we have a blessed ref @@ -529,8 +536,8 @@ sub _dump { $ref = \$val; if (ref($ref) eq 'GLOB') { # glob my $name = substr($val, 1); - if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') { - $name =~ s/^main::/::/; + $name =~ s/^main::(?!\z)/::/; + if ($name =~ /\A(?:[A-Z_a-z][0-9A-Z_a-z]*)?::(?:[0-9A-Z_a-z]+::)*[0-9A-Z_a-z]*\z/ && $name ne 'main::') { $sname = $name; } else { @@ -620,7 +627,7 @@ sub Reset { sub Indent { my($s, $v) = @_; - if (defined($v)) { + if (@_ >= 2) { if ($v == 0) { $s->{xpad} = ""; $s->{sep} = ""; @@ -639,92 +646,92 @@ sub Indent { sub Trailingcomma { my($s, $v) = @_; - defined($v) ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; + @_ >= 2 ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; } sub Pair { my($s, $v) = @_; - defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; + @_ >= 2 ? (($s->{pair} = $v), return $s) : $s->{pair}; } sub Pad { my($s, $v) = @_; - defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; + @_ >= 2 ? (($s->{pad} = $v), return $s) : $s->{pad}; } sub Varname { my($s, $v) = @_; - defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; + @_ >= 2 ? (($s->{varname} = $v), return $s) : $s->{varname}; } sub Purity { my($s, $v) = @_; - defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; + @_ >= 2 ? (($s->{purity} = $v), return $s) : $s->{purity}; } sub Useqq { my($s, $v) = @_; - defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; + @_ >= 2 ? (($s->{useqq} = $v), return $s) : $s->{useqq}; } sub Terse { my($s, $v) = @_; - defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; + @_ >= 2 ? (($s->{terse} = $v), return $s) : $s->{terse}; } sub Freezer { my($s, $v) = @_; - defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; + @_ >= 2 ? (($s->{freezer} = $v), return $s) : $s->{freezer}; } sub Toaster { my($s, $v) = @_; - defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; + @_ >= 2 ? (($s->{toaster} = $v), return $s) : $s->{toaster}; } sub Deepcopy { my($s, $v) = @_; - defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; + @_ >= 2 ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; } sub Quotekeys { my($s, $v) = @_; - defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; + @_ >= 2 ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; } sub Bless { my($s, $v) = @_; - defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; + @_ >= 2 ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; } sub Maxdepth { my($s, $v) = @_; - defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; + @_ >= 2 ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; } sub Maxrecurse { my($s, $v) = @_; - defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; + @_ >= 2 ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; } sub Useperl { my($s, $v) = @_; - defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; + @_ >= 2 ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; } sub Sortkeys { my($s, $v) = @_; - defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; + @_ >= 2 ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; } sub Deparse { my($s, $v) = @_; - defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; + @_ >= 2 ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; } sub Sparseseen { my($s, $v) = @_; - defined($v) ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'}; + @_ >= 2 ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'}; } # used by qquote below @@ -1212,9 +1219,10 @@ $Data::Dumper::Deparse I<or> $I<OBJ>->Deparse(I<[NEWVAL]>) Can be set to a boolean value to control whether code references are turned into perl source code. If set to a true value, C<B::Deparse> -will be used to get the source of the code reference. Using this option -will force using the Perl implementation of the dumper, since the fast -XSUB implementation doesn't support it. +will be used to get the source of the code reference. In older versions, +using this option imposed a significant performance penalty when dumping +parts of a data structure other than code references, but that is no +longer the case. Caution : use this option only if you know that your coderefs will be properly reconstructed by C<B::Deparse>. @@ -1435,15 +1443,9 @@ the C<Deparse> flag), an anonymous subroutine that contains the string '"DUMMY"' will be inserted in its place, and a warning will be printed if C<Purity> is set. You can C<eval> the result, but bear in mind that the anonymous sub that gets created is just a placeholder. -Someday, perl will have a switch to cache-on-demand the string -representation of a compiled piece of code, I hope. If you have prior -knowledge of all the code refs that your data structures are likely -to have, you can use the C<Seen> method to pre-seed the internal reference -table and make the dumped output point to them, instead. See L</EXAMPLES> -above. - -The C<Deparse> flag makes Dump() run slower, since the XSUB -implementation does not support it. +Even using the C<Deparse> flag will in some cases produce results that +behave differently after being passed to C<eval>; see the documentation +for L<B::Deparse>. SCALAR objects have the weirdest looking C<bless> workaround. @@ -1466,13 +1468,13 @@ be to use the C<Sortkeys> filter of Data::Dumper. Gurusamy Sarathy gsar@activestate.com -Copyright (c) 1996-2014 Gurusamy Sarathy. All rights reserved. +Copyright (c) 1996-2017 Gurusamy Sarathy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 VERSION -Version 2.160 (January 12 2016) +Version 2.170 =head1 SEE ALSO diff --git a/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.xs b/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.xs index 8220241cf7e..174562ccc86 100644 --- a/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.xs +++ b/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.xs @@ -12,6 +12,14 @@ # define DD_USE_OLD_ID_FORMAT #endif +#ifndef strlcpy +# ifdef my_strlcpy +# define strlcpy(d,s,l) my_strlcpy(d,s,l) +# else +# define strlcpy(d,s,l) strcpy(d,s) +# endif +#endif + /* These definitions are ASCII only. But the pure-perl .pm avoids * calling this .xs file for releases where they aren't defined */ @@ -41,6 +49,17 @@ || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) #endif +/* SvPVCLEAR only from perl 5.25.6 */ +#ifndef SvPVCLEAR +# define SvPVCLEAR(sv) sv_setpvs((sv), "") +#endif + +#ifndef memBEGINs +# define memBEGINs(s1, l, s2) \ + ( (l) >= sizeof(s2) - 1 \ + && memEQ(s1, "" s2 "", sizeof(s2)-1)) +#endif + /* This struct contains almost all the user's desired configuration, and it * is treated as constant by the recursive function. This arrangement has * the advantage of needing less memory than passing all of them on the @@ -63,6 +82,7 @@ typedef struct { I32 useqq; int use_sparse_seen_hash; int trailingcomma; + int deparse; } Style; static STRLEN num_q (const char *s, STRLEN slen); @@ -387,11 +407,11 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); #if PERL_VERSION < 10 - sprintf(r, "\\x{%"UVxf"}", k); + sprintf(r, "\\x{%" UVxf "}", k); r += strlen(r); /* my_sprintf is not supported by ppport.h */ #else - r = r + my_sprintf(r, "\\x{%"UVxf"}", k); + r = r + my_sprintf(r, "\\x{%" UVxf "}", k); #endif continue; } @@ -505,6 +525,53 @@ sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) return sv; } +static SV * +deparsed_output(pTHX_ SV *val) +{ + SV *text; + int n; + dSP; + + /* This is passed to load_module(), which decrements its ref count and + * modifies it (so we also can't reuse it below) */ + SV *pkg = newSVpvs("B::Deparse"); + + load_module(PERL_LOADMOD_NOIMPORT, pkg, 0); + + SAVETMPS; + + PUSHMARK(SP); + mXPUSHs(newSVpvs("B::Deparse")); + PUTBACK; + + n = call_method("new", G_SCALAR); + SPAGAIN; + + if (n != 1) { + croak("B::Deparse->new returned %d items, but expected exactly 1", n); + } + + PUSHMARK(SP - n); + XPUSHs(val); + PUTBACK; + + n = call_method("coderef2text", G_SCALAR); + SPAGAIN; + + if (n != 1) { + croak("$b_deparse->coderef2text returned %d items, but expected exactly 1", n); + } + + text = POPs; + SvREFCNT_inc(text); /* the caller will mortalise this */ + + FREETMPS; + + PUTBACK; + + return text; +} + /* * This ought to be split into smaller functions. (it is one long function since * it exactly parallels the perl version, which was one long thing for @@ -565,14 +632,14 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD); SPAGAIN; if (SvTRUE(ERRSV)) - warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); + warn("WARNING(Freezer method call failed): %" SVf, ERRSV); PUTBACK; FREETMPS; LEAVE; } ival = SvRV(val); realtype = SvTYPE(ival); #ifdef DD_USE_OLD_ID_FORMAT - idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival)); + idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(ival)); #else id_buffer = PTR2UV(ival); idlen = sizeof(id_buffer); @@ -630,7 +697,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, #ifdef DD_USE_OLD_ID_FORMAT warn("ref name not found for %s", id); #else - warn("ref name not found for 0x%"UVxf, PTR2UV(ival)); + warn("ref name not found for 0x%" UVxf, PTR2UV(ival)); #endif return 0; } @@ -803,7 +870,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, SV * const ixsv = newSViv(0); /* allowing for a 24 char wide array index */ New(0, iname, namelen+28, char); - (void)strcpy(iname, name); + (void) strlcpy(iname, name, namelen+28); inamelen = namelen; if (name[0] == '@') { sv_catpvs(retval, "("); @@ -848,10 +915,10 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, ilen = inamelen; sv_setiv(ixsv, ix); #if PERL_VERSION < 10 - (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); + (void) sprintf(iname+ilen, "%" IVdf, (IV)ix); ilen = strlen(iname); #else - ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix); + ilen = ilen + my_sprintf(iname+ilen, "%" IVdf, (IV)ix); #endif iname[ilen++] = ']'; iname[ilen] = '\0'; if (style->indent >= 3) { @@ -886,7 +953,6 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, SV *sname; HE *entry = NULL; char *key; - STRLEN klen; SV *hval; AV *keys = NULL; @@ -976,6 +1042,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, char *nkey_buffer = NULL; STRLEN nticks = 0; SV* keysv; + STRLEN klen; STRLEN keylen; STRLEN nlen; bool do_utf8 = FALSE; @@ -1029,7 +1096,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, if (style->quotekeys || key_needs_quote(key,keylen)) { if (do_utf8 || style->useqq) { STRLEN ocur = SvCUR(retval); - nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq); + klen = nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq); nkey = SvPVX(retval) + ocur; } else { @@ -1095,9 +1162,41 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, SvREFCNT_dec(totpad); } else if (realtype == SVt_PVCV) { - sv_catpvs(retval, "sub { \"DUMMY\" }"); - if (style->purity) - warn("Encountered CODE ref, using dummy placeholder"); + if (style->deparse) { + SV *deparsed = sv_2mortal(deparsed_output(aTHX_ val)); + SV *fullpad = sv_2mortal(newSVsv(style->sep)); + const char *p; + STRLEN plen; + I32 i; + + sv_catsv(fullpad, style->pad); + sv_catsv(fullpad, apad); + for (i = 0; i < level; i++) { + sv_catsv(fullpad, style->xpad); + } + + sv_catpvs(retval, "sub "); + p = SvPV(deparsed, plen); + while (plen > 0) { + const char *nl = (const char *) memchr(p, '\n', plen); + if (!nl) { + sv_catpvn(retval, p, plen); + break; + } + else { + size_t n = nl - p; + sv_catpvn(retval, p, n); + sv_catsv(retval, fullpad); + p += n + 1; + plen -= n + 1; + } + } + } + else { + sv_catpvs(retval, "sub { \"DUMMY\" }"); + if (style->purity) + warn("Encountered CODE ref, using dummy placeholder"); + } } else { warn("cannot handle ref type %d", (int)realtype); @@ -1144,7 +1243,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, if (namelen) { #ifdef DD_USE_OLD_ID_FORMAT - idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val)); + idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(val)); #else id_buffer = PTR2UV(val); idlen = sizeof(id_buffer); @@ -1184,9 +1283,9 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, if (DD_is_integer(val)) { STRLEN len; if (SvIsUV(val)) - len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val)); + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" UVuf, SvUV(val)); else - len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val)); + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, SvIV(val)); if (SvPOK(val)) { /* Need to check to see if this is a string such as " 0". I'm assuming from sprintf isn't going to clash with utf8. */ @@ -1205,7 +1304,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ c = SvPV(val, i); if(i) ++c, --i; /* just get the name */ - if (i >= 6 && strncmp(c, "main::", 6) == 0) { + if (memBEGINs(c, i, "main::")) { c += 4; #if PERL_VERSION < 7 if (i == 6 || (i == 7 && c[6] == '\0')) @@ -1215,37 +1314,30 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, i = 0; else i -= 4; } if (globname_needs_quote(c,i)) { -#ifdef GvNAMEUTF8 - if (GvNAMEUTF8(val)) { - sv_grow(retval, SvCUR(retval)+2); + sv_grow(retval, SvCUR(retval)+3); r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; + r[0] = '*'; r[1] = '{'; r[2] = 0; SvCUR_set(retval, SvCUR(retval)+2); - esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq); + i = 3 + esc_q_utf8(aTHX_ retval, c, i, +#ifdef GvNAMEUTF8 + !!GvNAMEUTF8(val) +#else + 0 +#endif + , style->useqq); sv_grow(retval, SvCUR(retval)+2); r = SvPVX(retval)+SvCUR(retval); r[0] = '}'; r[1] = '\0'; - i = 1; - } - else -#endif - { - sv_grow(retval, SvCUR(retval)+6+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; r[2] = '\''; - i += esc_q(r+3, c, i); - i += 3; - r[i++] = '\''; r[i++] = '}'; - r[i] = '\0'; - } + SvCUR_set(retval, SvCUR(retval)+1); + r = r+1 - i; } else { sv_grow(retval, SvCUR(retval)+i+2); r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; strcpy(r+1, c); + r[0] = '*'; strlcpy(r+1, c, SvLEN(retval)); i++; + SvCUR_set(retval, SvCUR(retval)+i); } - SvCUR_set(retval, SvCUR(retval)+i); if (style->purity) { static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; @@ -1412,53 +1504,55 @@ Data_Dumper_Dumpxs(href, ...) && (hv = (HV*)SvRV((SV*)href)) && SvTYPE(hv) == SVt_PVHV) { - if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) + if ((svp = hv_fetchs(hv, "seen", FALSE)) && SvROK(*svp)) seenhv = (HV*)SvRV(*svp); else style.use_sparse_seen_hash = 1; - if ((svp = hv_fetch(hv, "noseen", 6, FALSE))) + if ((svp = hv_fetchs(hv, "noseen", FALSE))) style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0); - if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) + if ((svp = hv_fetchs(hv, "todump", FALSE)) && SvROK(*svp)) todumpav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) + if ((svp = hv_fetchs(hv, "names", FALSE)) && SvROK(*svp)) namesav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "indent", 6, FALSE))) + if ((svp = hv_fetchs(hv, "indent", FALSE))) style.indent = SvIV(*svp); - if ((svp = hv_fetch(hv, "purity", 6, FALSE))) + if ((svp = hv_fetchs(hv, "purity", FALSE))) style.purity = SvIV(*svp); - if ((svp = hv_fetch(hv, "terse", 5, FALSE))) + if ((svp = hv_fetchs(hv, "terse", FALSE))) terse = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) + if ((svp = hv_fetchs(hv, "useqq", FALSE))) style.useqq = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "pad", 3, FALSE))) + if ((svp = hv_fetchs(hv, "pad", FALSE))) style.pad = *svp; - if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) + if ((svp = hv_fetchs(hv, "xpad", FALSE))) style.xpad = *svp; - if ((svp = hv_fetch(hv, "apad", 4, FALSE))) + if ((svp = hv_fetchs(hv, "apad", FALSE))) apad = *svp; - if ((svp = hv_fetch(hv, "sep", 3, FALSE))) + if ((svp = hv_fetchs(hv, "sep", FALSE))) style.sep = *svp; - if ((svp = hv_fetch(hv, "pair", 4, FALSE))) + if ((svp = hv_fetchs(hv, "pair", FALSE))) style.pair = *svp; - if ((svp = hv_fetch(hv, "varname", 7, FALSE))) + if ((svp = hv_fetchs(hv, "varname", FALSE))) varname = *svp; - if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) + if ((svp = hv_fetchs(hv, "freezer", FALSE))) style.freezer = *svp; - if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) + if ((svp = hv_fetchs(hv, "toaster", FALSE))) style.toaster = *svp; - if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) + if ((svp = hv_fetchs(hv, "deepcopy", FALSE))) style.deepcopy = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) + if ((svp = hv_fetchs(hv, "quotekeys", FALSE))) style.quotekeys = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "trailingcomma", 13, FALSE))) + if ((svp = hv_fetchs(hv, "trailingcomma", FALSE))) style.trailingcomma = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "bless", 5, FALSE))) + if ((svp = hv_fetchs(hv, "deparse", FALSE))) + style.deparse = SvTRUE(*svp); + if ((svp = hv_fetchs(hv, "bless", FALSE))) style.bless = *svp; - if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) + if ((svp = hv_fetchs(hv, "maxdepth", FALSE))) style.maxdepth = SvIV(*svp); - if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE))) + if ((svp = hv_fetchs(hv, "maxrecurse", FALSE))) style.maxrecurse = SvIV(*svp); - if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { + if ((svp = hv_fetchs(hv, "sortkeys", FALSE))) { SV *sv = *svp; if (! SvTRUE(sv)) style.sortkeys = NULL; @@ -1525,9 +1619,10 @@ Data_Dumper_Dumpxs(href, ...) } else { STRLEN nchars; - sv_setpvn(name, "$", 1); + sv_setpvs(name, "$"); sv_catsv(name, varname); - nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1)); + nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, + (IV)(i+1)); sv_catpvn(name, tmpbuf, nchars); } @@ -1575,7 +1670,7 @@ Data_Dumper_Dumpxs(href, ...) sv_catpvs(retval, ";"); sv_catsv(retval, style.sep); } - sv_setpvn(valstr, "", 0); + SvPVCLEAR(valstr); if (gimme == G_ARRAY) { XPUSHs(sv_2mortal(retval)); if (i < imax) /* not the last time thro ? */ diff --git a/gnu/usr.bin/perl/dist/Data-Dumper/t/dumper.t b/gnu/usr.bin/perl/dist/Data-Dumper/t/dumper.t index 643160a1c3c..e09a2ddd1f4 100755 --- a/gnu/usr.bin/perl/dist/Data-Dumper/t/dumper.t +++ b/gnu/usr.bin/perl/dist/Data-Dumper/t/dumper.t @@ -108,7 +108,7 @@ sub SKIP_TEST { ++$TNUM; print "ok $TNUM # skip $reason\n"; } -$TMAX = 450; +$TMAX = 468; # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling # it direct. Out here it lets us knobble the next if to test that the perl @@ -1740,3 +1740,66 @@ EOT TEST (qq(Dumper("\n")), '\n alone'); TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS; } +############# +our @globs = map { $_, \$_ } map { *$_ } map { $_, "s::$_" } + "foo", "\1bar", "L\x{e9}on", "m\x{100}cron", "snow\x{2603}"; +$WANT = <<'EOT'; +#$globs = [ +# *::foo, +# \*::foo, +# *s::foo, +# \*s::foo, +# *{"::\1bar"}, +# \*{"::\1bar"}, +# *{"s::\1bar"}, +# \*{"s::\1bar"}, +# *{"::L\351on"}, +# \*{"::L\351on"}, +# *{"s::L\351on"}, +# \*{"s::L\351on"}, +# *{"::m\x{100}cron"}, +# \*{"::m\x{100}cron"}, +# *{"s::m\x{100}cron"}, +# \*{"s::m\x{100}cron"}, +# *{"::snow\x{2603}"}, +# \*{"::snow\x{2603}"}, +# *{"s::snow\x{2603}"}, +# \*{"s::snow\x{2603}"} +#]; +EOT +{ + local $Data::Dumper::Useqq = 1; + TEST (q(Data::Dumper->Dump([\@globs], ["globs"])), 'globs: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()') + if $XS; +} +############# +$WANT = <<'EOT'; +#$v = { +# a => \*::ppp, +# b => \*{'::a/b'}, +# c => \*{"::a\x{2603}b"} +#}; +#*::ppp = { +# a => 1 +#}; +#*{'::a/b'} = { +# b => 3 +#}; +#*{"::a\x{2603}b"} = { +# c => 5 +#}; +EOT +{ + *ppp = { a => 1 }; + *{"a/b"} = { b => 3 }; + *{"a\x{2603}b"} = { c => 5 }; + our $v = { a => \*ppp, b => \*{"a/b"}, c => \*{"a\x{2603}b"} }; + local $Data::Dumper::Purity = 1; + TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()'); + TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS; + $WANT =~ tr/'/"/; + local $Data::Dumper::Useqq = 1; + TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()'); + TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS; +} diff --git a/gnu/usr.bin/perl/dist/Data-Dumper/t/quotekeys.t b/gnu/usr.bin/perl/dist/Data-Dumper/t/quotekeys.t index 0f6313a2649..076cdf6f8ae 100644 --- a/gnu/usr.bin/perl/dist/Data-Dumper/t/quotekeys.t +++ b/gnu/usr.bin/perl/dist/Data-Dumper/t/quotekeys.t @@ -86,10 +86,9 @@ sub run_tests_for_quotekeys { $obj->Quotekeys($quotekeys); $dumps{'objqkundef'} = _dumptostr($obj); - note("Quotekeys(undef) will fall back to the default value\nfor \$Data::Dumper::Quotekeys, which is a true value."); - isnt($dumps{'ddqkundef'}, $dumps{'objqkundef'}, + is($dumps{'ddqkundef'}, $dumps{'objqkundef'}, "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent"); - isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'}, + is($dumps{'ddqkzero'}, $dumps{'objqkundef'}, "\$Data::Dumper::Quotekeys = undef and = 0 are equivalent"); %dumps = (); diff --git a/gnu/usr.bin/perl/dist/Dumpvalue/t/Dumpvalue.t b/gnu/usr.bin/perl/dist/Dumpvalue/t/Dumpvalue.t index 8e9da198230..7063dd984c8 100644 --- a/gnu/usr.bin/perl/dist/Dumpvalue/t/Dumpvalue.t +++ b/gnu/usr.bin/perl/dist/Dumpvalue/t/Dumpvalue.t @@ -14,7 +14,7 @@ BEGIN { $^W = 0; } -use vars qw( $foo @bar %baz ); +our ( $foo, @bar, %baz ); use Test::More tests => 88; @@ -189,7 +189,7 @@ is( $out->read, "\%baz = (\n 'one' => 1, 'two' => 2\n)\n", 'dumped glob for %baz fine' ); SKIP: { - skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0); + skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, '<', $0); my $fileno = fileno(FILE); $d->dumpglob( '', 0, 'FILE', *FILE ); is( $out->read, "FileHandle(FILE) => fileno($fileno)\n", diff --git a/gnu/usr.bin/perl/dist/Exporter/lib/Exporter.pm b/gnu/usr.bin/perl/dist/Exporter/lib/Exporter.pm index 0b3db2159f4..0e8775db254 100644 --- a/gnu/usr.bin/perl/dist/Exporter/lib/Exporter.pm +++ b/gnu/usr.bin/perl/dist/Exporter/lib/Exporter.pm @@ -9,7 +9,7 @@ require 5.006; our $Debug = 0; our $ExportLevel = 0; our $Verbose ||= 0; -our $VERSION = '5.72'; +our $VERSION = '5.73'; our (%Cache); sub as_heavy { @@ -106,14 +106,14 @@ In module F<YourModule.pm>: package YourModule; require Exporter; - @ISA = qw(Exporter); - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + our @ISA = qw(Exporter); + our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request or package YourModule; use Exporter 'import'; # gives you Exporter's import() method directly - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request In other files which wish to use C<YourModule>: @@ -146,8 +146,8 @@ symbols can represent functions, scalars, arrays, hashes, or typeglobs. The symbols must be given by full name with the exception that the ampersand in front of a function is optional, e.g. - @EXPORT = qw(afunc $scalar @array); # afunc is a function - @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc + our @EXPORT = qw(afunc $scalar @array); # afunc is a function + our @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc If you are only exporting function names it is recommended to omit the ampersand, as the implementation is faster this way. @@ -234,9 +234,9 @@ include :DEFAULT explicitly. e.g., F<Module.pm> defines: - @EXPORT = qw(A1 A2 A3 A4 A5); - @EXPORT_OK = qw(B1 B2 B3 B4 B5); - %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]); + our @EXPORT = qw(A1 A2 A3 A4 A5); + our @EXPORT_OK = qw(B1 B2 B3 B4 B5); + our %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]); Note that you cannot use tags in @EXPORT or @EXPORT_OK. @@ -279,8 +279,8 @@ import function: package A; - @ISA = qw(Exporter); - @EXPORT_OK = qw($b); + our @ISA = qw(Exporter); + our @EXPORT_OK = qw($b); sub import { @@ -293,8 +293,8 @@ inheritance, as it stands Exporter::import() will never get called. Instead, say the following: package A; - @ISA = qw(Exporter); - @EXPORT_OK = qw($b); + our @ISA = qw(Exporter); + our @EXPORT_OK = qw($b); sub import { @@ -374,7 +374,7 @@ Since the symbols listed within C<%EXPORT_TAGS> must also appear in either C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>: - %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK @@ -391,7 +391,7 @@ useful to create the utility ":all" to simplify "use" statements. The simplest way to do this is: - %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); # add all the other ":class" tags to the ":all" class, # deleting duplicates @@ -460,7 +460,7 @@ variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc. our @ISA = qw(Exporter); our @EXPORT_OK = qw(munge frobnicate); -If backward compatibility for Perls under 5.6 is important, +If backward compatibility for Perls B<under> 5.6 is important, one must write instead a C<use vars> statement. use vars qw(@ISA @EXPORT_OK); diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Changes b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Changes index aaebade13bf..aa146d9c526 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Changes +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Changes @@ -1,5 +1,37 @@ Revision history for Perl extension ExtUtils::CBuilder. +0.280230 - 2017-11-22 + + Fixed: + + - Updated Changes + - Used OurPkgVersion instead of PkgVersion + +0.280229 - 2017-10-13 + + Fixed: + + - Remove dependency to 'vars' package. + +0.280228 - 2017-07-20 + + Fixed: + + - Fix link() on Windows, broken in version 0.280226. + +0.280227 - 2017-07-19 + + Fixed: + + - Restore compatibility of test suite to Perl 5.6. + +0.280226 - 2017-07-14 + + Fixed: + + - Fix C++ compiler detection (RT #131749) + (thanks to stphnlyd) + 0.280225 - 2016-01-04 Fixed: @@ -8,7 +40,7 @@ Revision history for Perl extension ExtUtils::CBuilder. 0.280224 - 2015-10-09 - Enhncements: + Enhancements: - Use warnings/strict on all modules. diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/LICENSE b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/LICENSE index 97b386c5f21..6171f8bbe8a 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/LICENSE +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/LICENSE @@ -1,4 +1,4 @@ -This software is copyright (c) 2015 by Ken Williams. +This software is copyright (c) 2017 by Ken Williams. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. @@ -12,7 +12,7 @@ b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- -This software is Copyright (c) 2015 by Ken Williams. +This software is Copyright (c) 2017 by Ken Williams. This is free software, licensed under: @@ -272,7 +272,7 @@ That's all there is to it! --- The Artistic License 1.0 --- -This software is Copyright (c) 2015 by Ken Williams. +This software is Copyright (c) 2017 by Ken Williams. This is free software, licensed under: diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Makefile.PL b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Makefile.PL index 44cb33ad44b..bc1ce75dd09 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Makefile.PL +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/Makefile.PL @@ -1,4 +1,4 @@ -# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.039. +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.010. use strict; use warnings; @@ -29,7 +29,7 @@ my %WriteMakefileArgs = ( "TEST_REQUIRES" => { "Test::More" => "0.47" }, - "VERSION" => "0.280225", + "VERSION" => "0.280228", "test" => { "TESTS" => "t/*.t" } @@ -60,6 +60,6 @@ delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{INSTALLDIRS} = 'perl' - if $] >= 5.009003 && $] <= 5.011000; + if "$]" >= 5.009003 && "$]" <= 5.011000; WriteMakefile(%WriteMakefileArgs); diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm index 6ce0c687943..8d1a0d4915a 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm @@ -1,5 +1,5 @@ package ExtUtils::CBuilder; -$ExtUtils::CBuilder::VERSION = '0.280225'; + use File::Spec (); use File::Path (); use File::Basename (); @@ -7,7 +7,8 @@ use Perl::OSType qw/os_type/; use warnings; use strict; -use vars qw(@ISA); +our $VERSION = '0.280230'; # VERSION +our @ISA; # We only use this once - don't waste a symbol table entry on it. # More importantly, don't make it an inheritable method. diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm index 60b2f432dfb..9f8427f6de2 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm @@ -1,5 +1,4 @@ package ExtUtils::CBuilder::Base; -$ExtUtils::CBuilder::Base::VERSION = '0.280225'; use strict; use warnings; use File::Spec; @@ -10,6 +9,8 @@ use Text::ParseWords; use IPC::Cmd qw(can_run); use File::Temp qw(tempfile); +our $VERSION = '0.280230'; # VERSION + # More details about C/C++ compilers: # http://developers.sun.com/sunstudio/documentation/product/compiler.jsp # http://gcc.gnu.org/ @@ -45,16 +46,26 @@ sub new { if defined $ENV{LDFLAGS}; unless ( exists $self->{config}{cxx} ) { - my ($ccpath, $ccbase, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); + + my ($ccbase, $ccpath, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); + + ## If the path is just "cc", fileparse returns $ccpath as "./" + $ccpath = "" if $self->{config}{cc} =~ /^$ccbase$ccsfx$/; + foreach my $cxx (@{$cc2cxx{$ccbase}}) { - if( can_run( File::Spec->catfile( $ccpath, $cxx, $ccsfx ) ) ) { - $self->{config}{cxx} = File::Spec->catfile( $ccpath, $cxx, $ccsfx ); + my $cxx1 = File::Spec->catfile( $ccpath, $cxx . $ccsfx); + + if( can_run( $cxx1 ) ) { + $self->{config}{cxx} = $cxx1; last; } - if( can_run( File::Spec->catfile( $cxx, $ccsfx ) ) ) { - $self->{config}{cxx} = File::Spec->catfile( $cxx, $ccsfx ); + my $cxx2 = $cxx . $ccsfx; + + if( can_run( $cxx2 ) ) { + $self->{config}{cxx} = $cxx2; last; } + if( can_run( $cxx ) ) { $self->{config}{cxx} = $cxx; last; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm index 399e254aa0c..655235ebdcf 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -1,11 +1,11 @@ package ExtUtils::CBuilder::Platform::Unix; -$ExtUtils::CBuilder::Platform::Unix::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Base; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Base); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); sub link_executable { my $self = shift; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm index e9d9f6fc2fd..020c01eb6a5 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -1,11 +1,11 @@ package ExtUtils::CBuilder::Platform::VMS; -$ExtUtils::CBuilder::Platform::VMS::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Base; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Base); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); use File::Spec::Functions qw(catfile catdir); use Config; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm index 80b8f29cd2d..8263b954abf 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -1,5 +1,4 @@ package ExtUtils::CBuilder::Platform::Windows; -$ExtUtils::CBuilder::Platform::Windows::VERSION = '0.280225'; use strict; use warnings; @@ -9,8 +8,8 @@ use File::Spec; use ExtUtils::CBuilder::Base; use IO::File; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Base); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); =begin comment @@ -151,7 +150,7 @@ sub link { # if running in perl source tree, look for libs there, not installed my $lddlflags = $cf->{lddlflags}; my $perl_src = $self->perl_src(); - $lddlflags =~ s/\Q$cf->{archlibexp}\E[\\\/]CORE/$perl_src\/lib\/CORE/ if $perl_src; + $lddlflags =~ s{\Q$cf->{archlibexp}\E[\\/]CORE}{$perl_src/lib/CORE} if $perl_src; my %spec = ( srcdir => $to, diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm index 513c4acaeea..93f47d79588 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -1,5 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::BCC; -$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION = '0.280225'; + +our $VERSION = '0.280230'; # VERSION + use strict; use warnings; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm index 19851df352e..144e31ad80f 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -1,5 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::GCC; -$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION = '0.280225'; + +our $VERSION = '0.280230'; # VERSION + use warnings; use strict; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm index c8d675f4978..c238979fb63 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -1,5 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::MSVC; -$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION = '0.280225'; + +our $VERSION = '0.280230'; # VERSION + use warnings; use strict; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm index 488d3e68bc9..0d96613b431 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -1,12 +1,12 @@ package ExtUtils::CBuilder::Platform::aix; -$ExtUtils::CBuilder::Platform::aix::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm index b9e6af3129c..7d14706a003 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm @@ -1,13 +1,13 @@ package ExtUtils::CBuilder::Platform::android; -$ExtUtils::CBuilder::Platform::android::VERSION = '0.280225'; + use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; use Config; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # The Android linker will not recognize symbols from # libperl unless the module explicitly depends on it. diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm index 339840f8c19..a5881af645b 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -1,12 +1,12 @@ package ExtUtils::CBuilder::Platform::cygwin; -$ExtUtils::CBuilder::Platform::cygwin::VERSION = '0.280225'; + use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # TODO: If a specific exe_file name is requested, if the exe created # doesn't have that name, we might want to rename it. Apparently asking diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm index 04a87da3311..82e7f2afec1 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -1,11 +1,11 @@ package ExtUtils::CBuilder::Platform::darwin; -$ExtUtils::CBuilder::Platform::darwin::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub compile { my $self = shift; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm index d503e8614bf..50efc9143a6 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -1,12 +1,12 @@ package ExtUtils::CBuilder::Platform::dec_osf; -$ExtUtils::CBuilder::Platform::dec_osf::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub link_executable { my $self = shift; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm index 8d0e3eb0dc2..b12f35d2aa2 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -1,11 +1,11 @@ package ExtUtils::CBuilder::Platform::os2; -$ExtUtils::CBuilder::Platform::os2::VERSION = '0.280225'; + use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; -use vars qw(@ISA); -@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/00-have-compiler.t b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/00-have-compiler.t index 1073277fd19..e4706a0e74b 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/00-have-compiler.t +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/00-have-compiler.t @@ -33,13 +33,13 @@ ok( $b, "got CBuilder object" ) or diag $@; # This will fork a child that will print # 'Can't exec "djaadjfkadjkfajdf"' - # or similar on STDERR; so make sure fd2 is temporarily closed before - # the fork - open(my $orig_err, ">&", \*STDERR) or die "Can't dup STDERR: $!"; - close(STDERR); + # or similar on STDERR; so make sure fd2 is temporarily redirected to + # oblivion before the fork + open(OLDERR, ">&STDERR") or die "Can't dup STDERR: $!"; + open(STDERR, ">", File::Spec->devnull()) or die "Can't redirect STDERR: $!"; my $res = $b1->have_compiler; - open(STDERR, ">&", $orig_err) or die "Can't dup \$orig_err $!"; - close($orig_err); + open(STDERR, ">&OLDERR") or die "Can't restore STDERR: $!"; + close(OLDERR); is($res, 0, "have_compiler: fake missing cc" ); } @@ -47,11 +47,11 @@ ok( $b, "got CBuilder object" ) or diag $@; my $b2 = ExtUtils::CBuilder->new(quiet => 1); configure_fake_missing_compilers($b2); - open(my $orig_err, ">&", \*STDERR) or die "Can't dup STDERR: $!"; - close(STDERR); + open(OLDERR, ">&STDERR") or die "Can't dup STDERR: $!"; + open(STDERR, ">", File::Spec->devnull()) or die "Can't redirect STDERR: $!"; my $res = $b2->have_cplusplus; - open(STDERR, ">&", $orig_err) or die "Can't dup \$orig_err $!"; - close($orig_err); + open(STDERR, ">&OLDERR") or die "Can't restore STDERR: $!"; + close(OLDERR); is($res, 0, "have_cplusplus: fake missing c++" ); } diff --git a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/02-link.t b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/02-link.t index 0c64619d541..6160c267d0c 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/02-link.t +++ b/gnu/usr.bin/perl/dist/ExtUtils-CBuilder/t/02-link.t @@ -33,7 +33,7 @@ ok $b, "created EU::CB object"; $source_file = File::Spec->catfile('t', 'linkt.c'); { - open my $FH, "> $source_file" or die "Can't create $source_file: $!"; + open my $FH, '>', $source_file or die "Can't create $source_file: $!"; print $FH "int main(void) { return 11; }\n"; close $FH; } diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/Changes b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/Changes index 108b6fa51ca..f9fb36eed16 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/Changes +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/Changes @@ -1,5 +1,20 @@ Revision history for Perl extension ExtUtils::ParseXS. +3.36 + - Make generated code avoid warnings about the "items" variable + being unused + - Avoid some unused-variable warnings generated by XS code in the + test suite + +3.35 - Mon Jul 31 17:50:00 CET 2017 + - Fix ExtUtils-ParseXS/t/*.t that needed '.' in @INC (David Mitchell) + - Remove impediment to compiling under C++11 (Karl Williamson) + - Make build reproducinle (Chris Lamb) + - (perl #127834) remove . from the end of @INC if complex modules + are loaded (Tony Cook) + - Replace :: with __ in THIS like it's done for parameters/return + values (Mattia Barbon) + 3.30 - Mon Aug 31 10:35:00 CET 2015 - Promote to stable CPAN release. diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 32d74e18e8d..e1f09407455 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -11,12 +11,12 @@ use Symbol; our $VERSION; BEGIN { - $VERSION = '3.31'; + $VERSION = '3.39'; + require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); + require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); + require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); + require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION); } -use ExtUtils::ParseXS::Constants $VERSION; -use ExtUtils::ParseXS::CountLines $VERSION; -use ExtUtils::ParseXS::Utilities $VERSION; -use ExtUtils::ParseXS::Eval $VERSION; $VERSION = eval $VERSION if $VERSION =~ /_/; use ExtUtils::ParseXS::Utilities qw( @@ -519,9 +519,10 @@ EOF EOF } else { - # cv likely to be unused + # cv and items likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ +# PERL_UNUSED_VAR(items); /* -W */ EOF } @@ -686,7 +687,7 @@ EOF var => $_, do_setmagic => $self->{DoSetMagic}, do_push => undef, - } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} }; + } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; my $prepush_done; # all OUTPUT done, so now push the return value on the stack @@ -871,6 +872,7 @@ EOF #XS_EUPXS(XS_$self->{Packid}_nil) #{ # dXSARGS; +# PERL_UNUSED_VAR(items); # XSRETURN_EMPTY; #} # diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm index 2319a24c2c8..45b567404d2 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm @@ -3,7 +3,7 @@ use strict; use warnings; use Symbol; -our $VERSION = '3.31'; +our $VERSION = '3.39'; =head1 NAME diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm index 222a95c245d..5b48449dbb4 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm @@ -1,7 +1,7 @@ package ExtUtils::ParseXS::CountLines; use strict; -our $VERSION = '3.31'; +our $VERSION = '3.39'; our $SECTION_END_MARKER; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm index 73153326e91..9eba5e50583 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm @@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval; use strict; use warnings; -our $VERSION = '3.31'; +our $VERSION = '3.39'; =head1 NAME @@ -29,7 +29,7 @@ Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: - $Package $Alias $func_name $Full_func_name $pname + $Package $ALIAS $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: @@ -63,7 +63,7 @@ Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: - $Package $Alias $func_name $Full_func_name $pname + $Package $ALIAS $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 41a9f6de57c..ae25b33b47b 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -5,7 +5,7 @@ use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); -our $VERSION = '3.31'; +our $VERSION = '3.39'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); @@ -472,7 +472,7 @@ S_croak_xs_usage(const CV *const cv, const char *const params) Perl_croak_nocontext("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ - Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm index 48d623ef71d..a762322df9f 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps; use 5.006001; use strict; use warnings; -our $VERSION = '3.31'; +our $VERSION = '3.38'; require ExtUtils::ParseXS; require ExtUtils::ParseXS::Constants; @@ -22,7 +22,7 @@ ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files # $typemap = ExtUtils::Typemaps->new(); # alternatively create an in-memory typemap by parsing a string # $typemap = ExtUtils::Typemaps->new(string => $sometypemap); - + # add a mapping $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV'); $typemap->add_inputmap( @@ -33,13 +33,13 @@ ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files ); $typemap->add_string(string => $typemapstring); # will be parsed and merged - + # remove a mapping (same for remove_typemap and remove_outputmap...) $typemap->remove_inputmap(xstype => 'SomeType'); - + # save a typemap to a file $typemap->write(file => 'anotherfile.map'); - + # merge the other typemap into this one $typemap->merge(typemap => $another_typemap); @@ -536,7 +536,7 @@ sub get_outputmap { Write the typemap to a file. Optionally takes a C<file> argument. If given, the typemap will be written to the specified file. If not, the typemap is written -to the currently stored file name (see C<-E<gt>file> above, this defaults to the file +to the currently stored file name (see L</file> above, this defaults to the file it was read from if any). =cut @@ -781,7 +781,9 @@ corresponding OUTPUT code: $var.context.value().size()); ', 'T_OUT' => ' { - GV *gv = newGVgen("$Package"); + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("$Package",1), + "__ANONIO__",10,0); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv( $arg, diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm index ffed504f9ff..3c33f548a57 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::Cmd; use 5.006001; use strict; use warnings; -our $VERSION = '3.31'; +our $VERSION = '3.38'; use ExtUtils::Typemaps; diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm index 86c646d543e..bf19df1e452 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::InputMap; use 5.006001; use strict; use warnings; -our $VERSION = '3.31'; +our $VERSION = '3.38'; =head1 NAME diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm index 32cf9f93270..90adb489780 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::OutputMap; use 5.006001; use strict; use warnings; -our $VERSION = '3.31'; +our $VERSION = '3.38'; =head1 NAME diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm index abe93cb8ebe..01bd51d4fbc 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm @@ -4,7 +4,7 @@ use strict; use warnings; require ExtUtils::Typemaps; -our $VERSION = '3.31'; +our $VERSION = '3.38'; =head1 NAME diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxs.pod b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxs.pod index e887d33ca7f..1419ee0ddf9 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxs.pod +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxs.pod @@ -418,9 +418,9 @@ automatically designated as an output value. For more complex functions the B<xsubpp> compiler will need help to determine which variables are output variables. -This keyword will normally be used to complement the CODE: keyword. +This keyword will normally be used to complement the CODE: keyword. The RETVAL variable is not recognized as an output variable when the -CODE: keyword is present. The OUTPUT: keyword is used in this +CODE: keyword is present. The OUTPUT: keyword is used in this situation to tell the compiler that RETVAL really is an output variable. @@ -454,7 +454,7 @@ parameters (needed for hash or array element parameters that must be created if they didn't exist). If for some reason, this behavior is not desired, the OUTPUT section may contain a C<SETMAGIC: DISABLE> line to disable it for the remainder of the parameters in the OUTPUT section. -Likewise, C<SETMAGIC: ENABLE> can be used to reenable it for the +Likewise, C<SETMAGIC: ENABLE> can be used to reenable it for the remainder of the OUTPUT section. See L<perlguts> for more details about 'set' magic. @@ -654,8 +654,8 @@ from Perl with either of the following statements: $status = rpcb_gettime( $timep ); -The XSUB will look like the code which follows. A CODE: -block is used to call the real rpcb_gettime() function with +The XSUB will look like the code which follows. A CODE: +block is used to call the real rpcb_gettime() function with the parameters in the correct order for that function. bool_t @@ -1027,7 +1027,7 @@ to tell the B<xsubpp> compiler that the programmer is supplying the code to control the argument stack for the XSUBs return values. Occasionally one will want an XSUB to return a list of values rather than a single value. In these cases one must use PPCODE: and then explicitly push the list of -values on the stack. The PPCODE: and CODE: keywords should not be used +values on the stack. The PPCODE: and CODE: keywords should not be used together within the same XSUB. The actual difference between PPCODE: and CODE: sections is in the @@ -1197,7 +1197,7 @@ contains the following statement will compile with only B<xsubpp> version =head2 The CLEANUP: Keyword This keyword can be used when an XSUB requires special cleanup procedures -before it terminates. When the CLEANUP: keyword is used it must follow +before it terminates. When the CLEANUP: keyword is used it must follow any CODE:, or OUTPUT: blocks which are present in the XSUB. The code specified for the cleanup block will be added as the last statements in the XSUB. @@ -1332,8 +1332,13 @@ C<BAR::getit()> for this function. Instead of writing an overloaded interface using pure Perl, you can also use the OVERLOAD keyword to define additional Perl names for your functions (like the ALIAS: keyword above). However, the -overloaded functions must be defined with three parameters (except -for the nomethod() function which needs four parameters). If any +overloaded functions must be defined in such a way as to accept the number +of parameters supplied by perl's overload system. For most overload +methods, it will be three parameters; for the C<nomethod> function it will +be four. However, the bitwise operators C<&>, C<|>, C<^>, and C<~> may be +called with three I<or> five arguments (see L<overload>). + +If any function has the OVERLOAD: keyword, several additional lines will be defined in the c file generated by xsubpp in order to register with the overload magic. @@ -1344,7 +1349,7 @@ the actual SV stored within the blessed RV. See the sample for T_PTROBJ_SPECIAL below. To use the OVERLOAD: keyword, create an XS function which takes -three input parameters ( or use the c style '...' definition) like +three input parameters (or use the C-style '...' definition) like this: SV * @@ -1361,6 +1366,10 @@ characters, you must type the parameter without quoting, separating multiple overloads with whitespace. Note that "" (the stringify overload) should be entered as \"\" (i.e. escaped). +Since, as mentioned above, bitwise operators may take extra arguments, you +may want to use something like C<(lobj, robj, swap, ...)> (with +literal C<...>) as your parameter list. + =head2 The FALLBACK: Keyword In addition to the OVERLOAD keyword, if you need to control how @@ -2051,11 +2060,18 @@ you need to do is to instantiate a Perl interpreter. This wrapping happens always when compiling Perl core source (PERL_CORE is defined) or the Perl core extensions (PERL_EXT is -defined). When compiling XS code outside of Perl core the wrapping -does not take place. Note, however, that intermixing the _r-forms -(as Perl compiled for multithreaded operation will do) and the _r-less -forms is neither well-defined (inconsistent results, data corruption, -or even crashes become more likely), nor is it very portable. +defined). When compiling XS code outside of the Perl core, the wrapping +does not take place before Perl 5.28. Starting in that release you can + + #define PERL_REENTRANT + +in your code to enable the wrapping. It is advisable to do so if you +are using such functions, as intermixing the C<_r>-forms (as Perl compiled +for multithreaded operation will do) and the C<_r>-less forms is neither +well-defined (inconsistent results, data corruption, or even crashes +become more likely), nor is it very portable. Unfortunately, not all +systems have all the C<_r> forms, but using this C<#define> gives you +whatever protection that Perl is aware is available on each system. =head1 EXAMPLES @@ -2150,7 +2166,7 @@ passed into it from the environment. This is an important difference from a generic C language program, where the underlying locale is the "C" locale unless the program changes it. As of v5.20, this underlying -locale is completely hidden from pure perl code outside the lexical +locale is completely hidden from pure Perl code outside the lexical scope of C<S<use locale>> except for a couple of function calls in the POSIX module which of necessity use it. But the underlying locale, with that @@ -2179,7 +2195,7 @@ To summarize, here's what to expect and how to handle locales in XS code: =item Non-locale-aware XS code Keep in mind that even if you think your code is not locale-aware, it -may call a C library function that is. Hopefully the man page for such +may call a library function that is. Hopefully the man page for such a function will indicate that dependency, but the documentation is imperfect. @@ -2207,20 +2223,122 @@ handled. If the locale from the user's environment is desired, there should be no need for XS code to set the locale except for C<LC_NUMERIC>, as perl has -already set it up. XS code should avoid changing the locale, as it can -adversely affect other, unrelated, code and may not be thread safe. -However, some alien libraries that may be called do set it, such as -C<Gtk>. This can cause problems for the perl core and other modules. -Starting in v5.20.1, calling the function +already set the others up. XS code should avoid changing the locale, as +it can adversely affect other, unrelated, code and may not be +thread-safe. To minimize problems, the macros +L<perlapi/STORE_LC_NUMERIC_SET_TO_NEEDED>, +L<perlapi/STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>, and +L<perlapi/RESTORE_LC_NUMERIC> should be used to affect any needed +change. + +But, starting with Perl v5.28, locales are thread-safe on platforms that +support this functionality. Windows has this starting with Visual +Studio 2005. Many other modern platforms support the thread-safe POSIX +2008 functions. The C C<#define> C<USE_THREAD_SAFE_LOCALE> will be +defined iff this build is using these. From Perl-space, the read-only +variable C<${SAFE_LOCALES}> is 1 if either the build is not threaded, or +if C<USE_THREAD_SAFE_LOCALE> is defined; otherwise it is 0. + +The way this works under-the-hood is that every thread has a choice of +using a locale specific to it (this is the Windows and POSIX 2008 +functionality), or the global locale that is accessible to all threads +(this is the functionality that has always been there). The +implementations for Windows and POSIX are completely different. On +Windows, the runtime can be set up so that the standard +L<C<setlocale(3)>> function either only knows about the global locale or +the locale for this thread. On POSIX, C<setlocale> always deals with +the global locale, and other functions have been created to handle +per-thread locales. Perl makes this transparent to perl-space code. It +continues to use C<POSIX::setlocale()>, and the interpreter translates +that into the per-thread functions. + +All other locale-senstive functions automatically use the per-thread +locale, if that is turned on, and failing that, the global locale. Thus +calls to C<setlocale> are ineffective on POSIX systems for the current +thread if that thread is using a per-thread locale. If perl is compiled +for single-thread operation, it does not use the per-thread functions, +so C<setlocale> does work as expected. + +If you have loaded the L<C<POSIX>> module you can use the methods given +in L<perlcall> to call L<C<POSIX::setlocale>|POSIX/setlocale> to safely +change or query the locale (on systems where it is safe to do so), or +you can use the new 5.28 function L<perlapi/Perl_setlocale> instead, +which is a drop-in replacement for the system L<C<setlocale(3)>>, and +handles single-threaded and multi-threaded applications transparently. + +There are some locale-related library calls that still aren't +thread-safe because they return data in a buffer global to all threads. +In the past, these didn't matter as locales weren't thread-safe at all. +But now you have to be aware of them in case your module is called in a +multi-threaded application. The known ones are + + asctime() + ctime() + gcvt() [POSIX.1-2001 only (function removed in POSIX.1-2008)] + getdate() + wcrtomb() if its final argument is NULL + wcsrtombs() if its final argument is NULL + wcstombs() + wctomb() + +Some of these shouldn't really be called in a Perl application, and for +others there are thread-safe versions of these already implemented: + + asctime_r() + ctime_r() + Perl_langinfo() + +The C<_r> forms are automatically used, starting in Perl 5.28, if you +compile your code, with + + #define PERL_REENTRANT + +See also L<perlapi/Perl_langinfo>. +You can use the methods given in L<perlcall>, to get the best available +locale-safe versions of these + + POSIX::localeconv() + POSIX::wcstombs() + POSIX::wctomb() + +And note, that some items returned by C<Localeconv> are available +through L<perlapi/Perl_langinfo>. + +The others shouldn't be used in a threaded application. + +Some modules may call a non-perl library that is locale-aware. This is +fine as long as it doesn't try to query or change the locale using the +system C<setlocale>. But if these do call the system C<setlocale>, +those calls may be ineffective. Instead, +L<C<Perl_setlocale>|perlapi/Perl_setlocale> works in all circumstances. +Plain setlocale is ineffective on multi-threaded POSIX 2008 systems. It +operates only on the global locale, whereas each thread has its own +locale, paying no attention to the global one. Since converting +these non-Perl libraries to C<Perl_setlocale> is out of the question, +there is a new function in v5.28 +L<C<switch_to_global_locale>|perlapi/switch_to_global_locale> that will +switch the thread it is called from so that any system C<setlocale> +calls will have their desired effect. The function +L<C<sync_locale>|perlapi/sync_locale> must be called before returning to +perl. + +This thread can change the locale all it wants and it won't affect any +other thread, except any that also have been switched to the global +locale. This means that a multi-threaded application can have a single +thread using an alien library without a problem; but no more than a +single thread can be so-occupied. Bad results likely will happen. + +In perls without multi-thread locale support, some alien libraries, +such as C<Gtk> change locales. This can cause problems for the Perl +core and other modules. For these, before control is returned to +perl, starting in v5.20.1, calling the function L<sync_locale()|perlapi/sync_locale> from XS should be sufficient to avoid most of these problems. Prior to this, you need a pure Perl statement that does this: POSIX::setlocale(LC_ALL, POSIX::setlocale(LC_ALL)); -In the event that your XS code may need the underlying C<LC_NUMERIC> -locale, there are macros available to access this; see -L<perlapi/Locale-related functions and macros>. +or use the methods given in L<perlcall>. =back diff --git a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxstut.pod b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxstut.pod index f8a74ddf7a7..ef154ad7311 100644 --- a/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxstut.pod +++ b/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/lib/perlxstut.pod @@ -1143,9 +1143,9 @@ Mytest.xs: hv_store(rh, "f_files", 7, newSVnv(buf.f_files), 0); hv_store(rh, "f_type", 6, newSVnv(buf.f_type), 0); - av_push(results, newRV((SV *)rh)); + av_push(results, newRV_inc((SV *)rh)); } - RETVAL = newRV((SV *)results); + RETVAL = newRV_inc((SV *)results); OUTPUT: RETVAL @@ -1216,7 +1216,7 @@ for details. =item * -To create a reference, we use the C<newRV> function. Note that you can +To create a reference, we use the C<newRV_inc> function. Note that you can cast an AV* or an HV* to type SV* in this case (and many others). This allows you to take references to arrays, hashes and scalars with the same function. Conversely, the C<SvRV> function always returns an SV*, which may diff --git a/gnu/usr.bin/perl/dist/Filter-Simple/lib/Filter/Simple.pm b/gnu/usr.bin/perl/dist/Filter-Simple/lib/Filter/Simple.pm index 82129192b82..1dcf3c80bf7 100644 --- a/gnu/usr.bin/perl/dist/Filter-Simple/lib/Filter/Simple.pm +++ b/gnu/usr.bin/perl/dist/Filter-Simple/lib/Filter/Simple.pm @@ -2,14 +2,12 @@ package Filter::Simple; use Text::Balanced ':ALL'; -use vars qw{ $VERSION @EXPORT }; - -$VERSION = '0.92'; +our $VERSION = '0.95'; use Filter::Util::Call; use Carp; -@EXPORT = qw( FILTER FILTER_ONLY ); +our @EXPORT = qw( FILTER FILTER_ONLY ); sub import { @@ -198,6 +196,7 @@ sub gen_filter_import { if ($terminator{terminator} && m/$terminator{terminator}/) { $lastline = $_; + $count++; last; } $data .= $_; diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm index 9bac7077e70..3358d602746 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm @@ -5,11 +5,10 @@ require 5.000; package I18N::LangTags; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic); require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(); -@EXPORT_OK = qw(is_language_tag same_language_tag +our @ISA = qw(Exporter); +our @EXPORT = qw(); +our @EXPORT_OK = qw(is_language_tag same_language_tag extract_language_tags super_languages similarity_language_tag is_dialect_of locale2language_tag alternate_language_tags @@ -17,9 +16,10 @@ require Exporter; implicate_supers implicate_supers_strictly ); -%EXPORT_TAGS = ('ALL' => \@EXPORT_OK); +our %EXPORT_TAGS = ('ALL' => \@EXPORT_OK); -$VERSION = "0.40"; +our $VERSION = "0.43"; +our %Panic; sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function @@ -460,7 +460,7 @@ interaction looks like: So far so good. But suppose the way you're implementing this is: my %greetings; - die unless open(IN, "<in.dat"); + die unless open(IN, "<", "in.dat"); while(<IN>) { chomp; next unless /^([^=]+)=(.+)/s; @@ -502,7 +502,7 @@ program with: use I18N::LangTags qw(encode_language_tag); my %greetings; - die unless open(IN, "<in.dat"); + die unless open(IN, "<", "in.dat"); while(<IN>) { chomp; next unless /^([^=]+)=(.+)/s; diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm index a877fbfc7f7..16b91db3366 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm @@ -5,14 +5,14 @@ require 5; package I18N::LangTags::Detect; use strict; -use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS - $USE_LITERALS $MATCH_SUPERS_TIGHTLY); +our ( $MATCH_SUPERS, $USING_LANGUAGE_TAGS, + $USE_LITERALS, $MATCH_SUPERS_TIGHTLY); BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } # define the constant 'DEBUG' at compile-time -$VERSION = "1.05_01"; -@ISA = (); +our $VERSION = "1.07"; +our @ISA = (); use I18N::LangTags qw(alternate_language_tags locale2language_tag); sub _uniq { my %seen; return grep(!($seen{$_}++), @_); } diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm index 786d7b89bb8..5eef8eebafb 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm @@ -3,8 +3,8 @@ require 5; package I18N::LangTags::List; # Time-stamp: "2004-10-06 23:26:21 ADT" use strict; -use vars qw(%Name %Is_Disrec $Debug $VERSION); -$VERSION = '0.39'; +our (%Name, %Is_Disrec, $Debug); +our $VERSION = '0.40'; # POD at the end. #---------------------------------------------------------------------- diff --git a/gnu/usr.bin/perl/dist/IO/IO.pm b/gnu/usr.bin/perl/dist/IO/IO.pm index 44b312b6a3e..9f797814b05 100644 --- a/gnu/usr.bin/perl/dist/IO/IO.pm +++ b/gnu/usr.bin/perl/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.36_01"; +our $VERSION = "1.39"; XSLoader::load 'IO', $VERSION; sub import { diff --git a/gnu/usr.bin/perl/dist/IO/IO.xs b/gnu/usr.bin/perl/dist/IO/IO.xs index fe749a63e6c..8e857f8e2e8 100644 --- a/gnu/usr.bin/perl/dist/IO/IO.xs +++ b/gnu/usr.bin/perl/dist/IO/IO.xs @@ -11,6 +11,10 @@ #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" +#define NEED_eval_pv +#define NEED_newCONSTSUB +#define NEED_newSVpvn_flags +#include "ppport.h" #include "poll.h" #ifdef I_UNISTD # include <unistd.h> @@ -318,7 +322,7 @@ PPCODE: { #ifdef HAS_POLL const int nfd = (items - 1) / 2; - SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd)); + SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd))); /* We should pass _some_ valid pointer even if nfd is zero, but it * doesn't matter what it is, since we're telling it to not check any fds. */ @@ -337,7 +341,6 @@ PPCODE: sv_setiv(ST(i), fds[j].revents); i++; } } - SvREFCNT_dec(tmpsv); XSRETURN_IV(ret); #else not_here("IO::Poll::poll"); diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm index 7326d7823d4..e583fd389a7 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm @@ -6,22 +6,21 @@ package IO::Dir; -use 5.006; +use 5.008_001; use strict; use Carp; use Symbol; use Exporter; use IO::File; -our(@ISA, $VERSION, @EXPORT_OK); use Tie::Hash; use File::stat; use File::Spec; -@ISA = qw(Tie::Hash Exporter); -$VERSION = "1.10"; -$VERSION = eval $VERSION; -@EXPORT_OK = qw(DIR_UNLINK); +our @ISA = qw(Tie::Hash Exporter); +our $VERSION = "1.39"; + +our @EXPORT_OK = qw(DIR_UNLINK); sub DIR_UNLINK () { 1 } diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm index 8b29bac2210..55c5e20d299 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm @@ -124,9 +124,8 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. =cut -use 5.006_001; +use 5.008_001; use strict; -our($VERSION, @EXPORT, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; @@ -134,11 +133,11 @@ use IO::Seekable; require Exporter; -@ISA = qw(IO::Handle IO::Seekable Exporter); +our @ISA = qw(IO::Handle IO::Seekable Exporter); -$VERSION = "1.16"; +our $VERSION = "1.39"; -@EXPORT = @IO::Seekable::EXPORT; +our @EXPORT = @IO::Seekable::EXPORT; eval { # Make all Fcntl O_XXX constants available for importing diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm index ce976b0f443..60750575c85 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm @@ -260,21 +260,19 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> =cut -use 5.006_001; +use 5.008_001; use strict; -our($VERSION, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; use IO (); # Load the XS module require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -$VERSION = "1.36"; -$VERSION = eval $VERSION; +our $VERSION = "1.39"; -@EXPORT_OK = qw( +our @EXPORT_OK = qw( autoflush output_field_separator output_record_separator @@ -366,7 +364,7 @@ sub fdopen { my ($io, $fd, $mode) = @_; local(*GLOB); - if (ref($fd) && "".$fd =~ /GLOB\(/o) { + if (ref($fd) && "$fd" =~ /GLOB\(/o) { # It's a glob reference; Alias it as we cannot get name of anon GLOBs my $n = qualify(*GLOB); *GLOB = *{*$fd}; @@ -494,7 +492,7 @@ sub stat { ## sub autoflush { - my $old = new SelectSaver qualify($_[0], caller); + my $old = SelectSaver->new(qualify($_[0], caller)); my $prev = $|; $| = @_ > 1 ? $_[1] : 1; $prev; @@ -534,7 +532,7 @@ sub input_line_number { sub format_page_number { my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); my $prev = $%; $% = $_[1] if @_ > 1; $prev; @@ -542,7 +540,7 @@ sub format_page_number { sub format_lines_per_page { my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); my $prev = $=; $= = $_[1] if @_ > 1; $prev; @@ -550,7 +548,7 @@ sub format_lines_per_page { sub format_lines_left { my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); my $prev = $-; $- = $_[1] if @_ > 1; $prev; @@ -558,7 +556,7 @@ sub format_lines_left { sub format_name { my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); my $prev = $~; $~ = qualify($_[1], caller) if @_ > 1; $prev; @@ -566,7 +564,7 @@ sub format_name { sub format_top_name { my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); my $prev = $^; $^ = qualify($_[1], caller) if @_ > 1; $prev; @@ -640,7 +638,7 @@ sub constant { sub printflush { my $io = shift; my $old; - $old = new SelectSaver qualify($io, caller) if ref($io); + $old = SelectSaver->new(qualify($io, caller)) if ref($io); local $| = 1; if(ref($io)) { print $io @_; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm index 684069f4b7e..f24220f11f4 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm @@ -6,15 +6,14 @@ package IO::Pipe; -use 5.006_001; +use 5.008_001; use IO::Handle; use strict; -our($VERSION); use Carp; use Symbol; -$VERSION = "1.15"; +our $VERSION = "1.39"; sub new { my $type = shift; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm index a02dc3db948..3e949b75f71 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm @@ -10,25 +10,24 @@ package IO::Poll; use strict; use IO::Handle; use Exporter (); -our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); -@ISA = qw(Exporter); -$VERSION = "0.10"; +our @ISA = qw(Exporter); +our $VERSION = "1.39"; -@EXPORT = qw( POLLIN +our @EXPORT = qw( POLLIN POLLOUT POLLERR POLLHUP POLLNVAL ); -@EXPORT_OK = qw( - POLLPRI +our @EXPORT_OK = qw( + POLLPRI POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND - POLLNORM + POLLNORM ); # [0] maps fd's to requested masks diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Seekable.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Seekable.pm index db1effda287..27ed663445d 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Seekable.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Seekable.pm @@ -94,21 +94,19 @@ Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> =cut -use 5.006_001; +use 5.008_001; use Carp; use strict; -our($VERSION, @EXPORT, @ISA); use IO::Handle (); # XXX we can't get these from IO::Handle or we'll get prototype # mismatch warnings on C<use POSIX; use IO::File;> :-( use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; -@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); -@ISA = qw(Exporter); +our @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +our @ISA = qw(Exporter); -$VERSION = "1.10"; -$VERSION = eval $VERSION; +our $VERSION = "1.39"; sub seek { @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm index 994f8966ab6..6176f8bbf8a 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm @@ -8,12 +8,11 @@ package IO::Select; use strict; use warnings::register; -use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.22"; +our $VERSION = "1.39"; -@ISA = qw(Exporter); # This is only so we can do version checking +our @ISA = qw(Exporter); # This is only so we can do version checking sub VEC_BITS () {0} sub FD_COUNT () {1} @@ -315,10 +314,13 @@ Return an array of all registered handles. =item can_read ( [ TIMEOUT ] ) -Return an array of handles that are ready for reading. C<TIMEOUT> is -the maximum amount of time to wait before returning an empty list, in -seconds, possibly fractional. If C<TIMEOUT> is not given and any -handles are registered then the call will block. +Return an array of handles that are ready for reading. C<TIMEOUT> is the +maximum amount of time to wait before returning an empty list (with C<$!> +unchanged), in seconds, possibly fractional. If C<TIMEOUT> is not given +and any handles are registered then the call will block indefinitely. +Upon error, an empty list is returned, with C<$!> set to indicate the +error. To distinguish between timeout and error, set C<$!> to zero +before calling this method, and check it after an empty list is returned. =item can_write ( [ TIMEOUT ] ) @@ -346,9 +348,14 @@ like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as for the core select call. -The result will be an array of 3 elements, each a reference to an array -which will hold the handles that are ready for reading, writing and have -exceptions respectively. Upon error an empty list is returned. +If at least one handle is ready for the specified kind of operation, +the result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and +have exceptions respectively. Upon timeout, an empty list is returned, +with C<$!> unchanged. Upon error, an empty list is returned, with C<$!> +set to indicate the error. To distinguish between timeout and error, +set C<$!> to zero before calling this method, and check it after an +empty list is returned. =back diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm index c78aeecc1a0..bea16ec6e40 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm @@ -7,13 +7,12 @@ package IO::Socket; -require 5.006; +use 5.008_001; use IO::Handle; use Socket 1.3; use Carp; use strict; -our(@ISA, $VERSION, @EXPORT_OK); use Exporter; use Errno; @@ -22,11 +21,11 @@ use Errno; require IO::Socket::INET; require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); -@ISA = qw(IO::Handle); +our @ISA = qw(IO::Handle); -$VERSION = "1.38"; +our $VERSION = "1.39"; -@EXPORT_OK = qw(sockatmark); +our @EXPORT_OK = qw(sockatmark); sub import { my $pkg = shift; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm index 7a1694733b5..084cb1c631b 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm @@ -7,15 +7,14 @@ package IO::Socket::INET; use strict; -our(@ISA, $VERSION); use IO::Socket; use Socket; use Carp; use Exporter; use Errno; -@ISA = qw(IO::Socket); -$VERSION = "1.35"; +our @ISA = qw(IO::Socket); +our $VERSION = "1.39"; my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm index 30b8f74eb05..a46dd593d64 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm @@ -7,13 +7,11 @@ package IO::Socket::UNIX; use strict; -our(@ISA, $VERSION); use IO::Socket; use Carp; -@ISA = qw(IO::Socket); -$VERSION = "1.26"; -$VERSION = eval $VERSION; +our @ISA = qw(IO::Socket); +our $VERSION = "1.39"; IO::Socket::UNIX->register_domain( AF_UNIX ); diff --git a/gnu/usr.bin/perl/dist/IO/poll.c b/gnu/usr.bin/perl/dist/IO/poll.c index 03f6604eeb6..344a406b529 100644 --- a/gnu/usr.bin/perl/dist/IO/poll.c +++ b/gnu/usr.bin/perl/dist/IO/poll.c @@ -18,9 +18,7 @@ #ifdef I_SYS_TIME # include <sys/time.h> #endif -#ifdef I_TIME -# include <time.h> -#endif +#include <time.h> #include <sys/types.h> #if defined(HAS_SOCKET) && !defined(VMS) && !defined(ultrix) /* VMS handles sockets via vmsish.h, ULTRIX dies of socket struct redefinitions */ # include <sys/socket.h> diff --git a/gnu/usr.bin/perl/dist/IO/t/io_linenum.t b/gnu/usr.bin/perl/dist/IO/t/io_linenum.t index 2d44f509402..734854b9287 100755 --- a/gnu/usr.bin/perl/dist/IO/t/io_linenum.t +++ b/gnu/usr.bin/perl/dist/IO/t/io_linenum.t @@ -26,7 +26,7 @@ sub lineno my $t; -open (F, $File) or die $!; +open (F, '<', $File) or die $!; my $io = IO::File->new($File) or die $!; <F> for (1 .. 10); diff --git a/gnu/usr.bin/perl/dist/IO/t/io_sock.t b/gnu/usr.bin/perl/dist/IO/t/io_sock.t index c9c443beb86..37c8dad84e9 100755 --- a/gnu/usr.bin/perl/dist/IO/t/io_sock.t +++ b/gnu/usr.bin/perl/dist/IO/t/io_sock.t @@ -24,7 +24,7 @@ BEGIN { } } -my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio'; +my $has_perlio = find PerlIO::Layer 'perlio'; $| = 1; print "1..26\n"; @@ -214,7 +214,7 @@ if ( $^O eq 'qnx' ) { ### the client. We'll use own source code ... # local @data; -if( !open( SRC, "< $0")) { +if( !open( SRC, '<', $0)) { print "not ok 15 - $!\n"; } else { @data = <SRC>; diff --git a/gnu/usr.bin/perl/dist/IO/t/io_utf8argv.t b/gnu/usr.bin/perl/dist/IO/t/io_utf8argv.t index d6485f45ddd..89f726a7a70 100644 --- a/gnu/usr.bin/perl/dist/IO/t/io_utf8argv.t +++ b/gnu/usr.bin/perl/dist/IO/t/io_utf8argv.t @@ -1,11 +1,11 @@ #!./perl BEGIN { - unless ($] >= 5.008 and find PerlIO::Layer 'perlio') { + unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } - require($ENV{PERL_CORE} ? "../../t/test.pl" : "../t/test.pl"); + require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl"); } use utf8; @@ -22,7 +22,7 @@ my $bytes = "\xcd\xbe\x0a"; if ($::IS_EBCDIC) { - require($ENV{PERL_CORE} ? "../../t/charset_tools.pl" : "../t/charset_tools.pl"); + require($ENV{PERL_CORE} ? "../../t/charset_tools.pl" : "./t/charset_tools.pl"); $bytes = byte_utf8a_to_utf8n($bytes) } diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/ChangeLog b/gnu/usr.bin/perl/dist/Locale-Maketext/ChangeLog index 571871f09ed..ac25aa6a8e3 100644 --- a/gnu/usr.bin/perl/dist/Locale-Maketext/ChangeLog +++ b/gnu/usr.bin/perl/dist/Locale-Maketext/ChangeLog @@ -1,5 +1,18 @@ Revision history for Perl suite Locale::Maketext +2016-07-25 + * Release of 1.28 to CPAN + * Fix optional runtime load for CVE-2016-1238 + +2016-06-22 + * Release of 1.27 to CPAN + +2016-04-20 + * perl #127923: note priority between the white and blacklist + +2016-03-17 + * Add blacklist and whitelist support to Locale::Maketext. + 2014-06-17 * Correct two subtle typos in Locale::Maketext POD. diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm index e73c149a068..f70438b78d4 100644 --- a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm +++ b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm @@ -1,8 +1,6 @@ - package Locale::Maketext; use strict; -use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS -$USE_LITERALS $MATCH_SUPERS_TIGHTLY); +our $USE_LITERALS; use Carp (); use I18N::LangTags (); use I18N::LangTags::Detect (); @@ -27,12 +25,12 @@ BEGIN { } -$VERSION = '1.26_01'; -@ISA = (); +our $VERSION = '1.29'; +our @ISA = (); -$MATCH_SUPERS = 1; -$MATCH_SUPERS_TIGHTLY = 1; -$USING_LANGUAGE_TAGS = 1; +our $MATCH_SUPERS = 1; +our $MATCH_SUPERS_TIGHTLY = 1; +our $USING_LANGUAGE_TAGS = 1; # Turning this off is somewhat of a security risk in that little or no # checking will be done on the legality of tokens passed to the # eval("use $module_name") in _try_use. If you turn this off, you have @@ -138,6 +136,56 @@ sub fail_with { # an actual attribute method! #-------------------------------------------------------------------------- +sub blacklist { + my ( $handle, @methods ) = @_; + + unless ( defined $handle->{'blacklist'} ) { + no strict 'refs'; + + # Don't let people call methods they're not supposed to from maketext. + # Explicitly exclude all methods in this package that start with an + # underscore on principle. + $handle->{'blacklist'} = { + map { $_ => 1 } ( + qw/ + blacklist + encoding + fail_with + failure_handler_auto + fallback_language_classes + fallback_languages + get_handle + init + language_tag + maketext + new + whitelist + /, grep { /^_/ } keys %{ __PACKAGE__ . "::" } + ), + }; + } + + if ( scalar @methods ) { + $handle->{'blacklist'} = { %{ $handle->{'blacklist'} }, map { $_ => 1 } @methods }; + } + + delete $handle->{'_external_lex_cache'}; + return; +} + +sub whitelist { + my ( $handle, @methods ) = @_; + if ( scalar @methods ) { + $handle->{'whitelist'} = {} unless defined $handle->{'whitelist'}; + $handle->{'whitelist'} = { %{ $handle->{'whitelist'} }, map { $_ => 1 } @methods }; + } + + delete $handle->{'_external_lex_cache'}; + return; +} + +#-------------------------------------------------------------------------- + sub failure_handler_auto { # Meant to be used like: # $handle->fail_with('failure_handler_auto') @@ -179,6 +227,7 @@ sub new { # Nothing fancy! my $class = ref($_[0]) || $_[0]; my $handle = bless {}, $class; + $handle->blacklist; $handle->init; return $handle; } @@ -510,7 +559,7 @@ sub _compile { # on strings that don't need compiling. return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string - my $target = ref($_[0]) || $_[0]; + my $handle = $_[0]; my(@code); my(@c) = (''); # "chunks" -- scratch. @@ -542,10 +591,10 @@ sub _compile { # preceding literal. if($in_group) { if($1 eq '') { - $target->_die_pointing($string_to_compile, 'Unterminated bracket group'); + $handle->_die_pointing($string_to_compile, 'Unterminated bracket group'); } else { - $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups'); + $handle->_die_pointing($string_to_compile, 'You can\'t nest bracket groups'); } } else { @@ -629,13 +678,15 @@ sub _compile { push @code, ' ('; } elsif($m =~ /^\w+$/s - # exclude anything fancy, especially fully-qualified module names + && !$handle->{'blacklist'}{$m} + && ( !defined $handle->{'whitelist'} || $handle->{'whitelist'}{$m} ) + # exclude anything fancy and restrict to the whitelist/blacklist. ) { push @code, ' $_[0]->' . $m . '('; } else { # TODO: implement something? or just too icky to consider? - $target->_die_pointing( + $handle->_die_pointing( $string_to_compile, "Can't use \"$m\" as a method name in bracket group", 2 + length($c[-1]) @@ -677,7 +728,7 @@ sub _compile { push @c, ''; } else { - $target->_die_pointing($string_to_compile, q{Unbalanced ']'}); + $handle->_die_pointing($string_to_compile, q{Unbalanced ']'}); } } @@ -762,8 +813,9 @@ sub _compile { sub _die_pointing { # This is used by _compile to throw a fatal error - my $target = shift; # class name - # ...leaving $_[0] the error-causing text, and $_[1] the error message + my $target = shift; + $target = ref($target) || $target; # class name + # ...leaving $_[0] the error-causing text, and $_[1] the error message my $i = index($_[0], "\n"); diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/Changes b/gnu/usr.bin/perl/dist/Module-CoreList/Changes index c0c5ff18f8c..fd08103d68c 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/Changes +++ b/gnu/usr.bin/perl/dist/Module-CoreList/Changes @@ -1,3 +1,56 @@ +5.20181129_28 + - Updated for v5.28.1 + +5.20181020 + - Updated for v5.29.4 + +5.20180920 + - Updated for v5.29.3 + +5.20180820 + - Updated for v5.29.2 + +5.20180720 + - Updated for v5.29.1 + +5.20180624 + - Updated for v5.29.0 + +5.20180622 + - Updated for v5.28.0 + +5.20180420 + - Updated for v5.27.11 + +5.20180414_26 + - Updated for v5.26.2 + +5.20180414_24 + - Updated for v5.24.4 + +5.20180221 + - Updated for v5.27.10 + +5.20180220 + - Improve handling of broken versions in is_core() + - Removed Module::CoreList::TieHashDelta + - Updated for v5.27.9 + +5.20180120 + - Updated for v5.27.8 + +5.20171220 + - Updated for v5.27.7 + +5.20171120 + - Updated for v5.27.6 + +5.20171020 + - Updated for v5.27.5 + +5.20170922_26 + - Updated for v5.26.1 + 5.20170922_24 - Updated for v5.24.3 diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/corelist b/gnu/usr.bin/perl/dist/Module-CoreList/corelist index bbe61ccee41..3d2706a8298 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/corelist +++ b/gnu/usr.bin/perl/dist/Module-CoreList/corelist @@ -14,6 +14,8 @@ See L<Module::CoreList> for one. corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ... corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ... corelist [-r <PerlVersion>] ... + corelist --utils [-d] <UtilityName> [<UtilityName>] ... + corelist --utils -v <PerlVersion> corelist --feature <FeatureName> [<FeatureName>] ... corelist --diff PerlVersion PerlVersion corelist --upstream <ModuleName> @@ -113,6 +115,15 @@ lists all of the perl releases and when they were released If you pass a perl version you get the release date for that version only. +=item --utils + +lists the first version of perl each named utility program was released with + +May be used with -d to modify the first release criteria. + +If used with -v <version> then all utilities released with that version of perl +are listed, and any utility programs named on the command line are ignored. + =item --feature, -f lists the first version bundle of each named feature given @@ -142,7 +153,7 @@ my %Opts; GetOptions( \%Opts, - qw[ help|?! man! r|release:s v|version:s a! d diff|D feature|f u|upstream ] + qw[ help|?! man! r|release:s v|version:s a! d diff|D utils feature|f u|upstream ] ); pod2usage(1) if $Opts{help}; @@ -181,6 +192,12 @@ if(exists $Opts{v} ){ } my $num_v = numify_version( $Opts{v} ); + + if ($Opts{utils}) { + utilities_in_version($num_v); + exit 0; + } + my $version_hash = Module::CoreList->find_version($num_v); if( !$version_hash ) { @@ -227,6 +244,25 @@ if ($Opts{diff}) { exit(0); } +if ($Opts{utils}) { + die "\n--utils only available with perl v5.19.1 or greater\n" + if $] < 5.019001; + + die "\nprovide at least one utility name to --utils\n" + unless @ARGV; + + warn "\n-a has no effect when --utils is used\n" if $Opts{a}; + warn "\n--diff has no effect when --utils is used\n" if $Opts{diff}; + warn "\n--upstream, or -u, has no effect when --utils is used\n" if $Opts{u}; + + my $when = maxstr(values %Module::CoreList::released); + print "\n","Data for $when\n"; + + utility_version($_) for @ARGV; + + exit(0); +} + if ($Opts{feature}) { die "\n--feature is only available with perl v5.16.0 or greater\n" if $] < 5.016; @@ -349,10 +385,10 @@ sub module_version { print $msg,"\n"; if( defined $ret and exists $Opts{u} ) { - my $upsream = $Module::CoreList::upstream{$mod}; - $upsream = 'undef' unless $upsream; - print "upstream: $upsream\n"; - if ( $upsream ne 'blead' ) { + my $upstream = $Module::CoreList::upstream{$mod}; + $upstream = 'undef' unless $upstream; + print "upstream: $upstream\n"; + if ( $upstream ne 'blead' ) { my $bugtracker = $Module::CoreList::bug_tracker{$mod}; $bugtracker = 'unknown' unless $bugtracker; print "bug tracker: $bugtracker\n"; @@ -364,6 +400,47 @@ sub module_version { } } +sub utility_version { + my ($utility) = @_; + + require Module::CoreList::Utils; + + my $released = $Opts{d} + ? Module::CoreList::Utils->first_release_by_date($utility) + : Module::CoreList::Utils->first_release($utility); + + my $removed = $Opts{d} + ? Module::CoreList::Utils->removed_from_by_date($utility) + : Module::CoreList::Utils->removed_from($utility); + + if ($released) { + print "$utility was first released with perl ", format_perl_version($released); + print " and later removed in ", format_perl_version($removed) + if $removed; + print "\n"; + } else { + print "$utility was not in CORE (or so I think)\n"; + } +} + +sub utilities_in_version { + my ($version) = @_; + + require Module::CoreList::Utils; + + my @utilities = Module::CoreList::Utils->utilities($version); + + if (not @utilities) { + print "\nModule::CoreList::Utils has no info on perl $version\n\n"; + exit 1; + } + + print "\nThe following utilities were in perl ", + format_perl_version($version), " CORE\n"; + print "$_\n" for sort { lc($a) cmp lc($b) } @utilities; + print "\n"; +} + sub max_mod_len { my $versions = shift; diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pm b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pm index a3a37adeb27..a254a1c97c5 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pm @@ -1,10 +1,26 @@ package Module::CoreList; use strict; -use vars qw/$VERSION %released %version %families %upstream - %bug_tracker %deprecated %delta/; -use Module::CoreList::TieHashDelta; + +our ( %released, %version, %families, %upstream, %bug_tracker, %deprecated, %delta ); + use version; -$VERSION = '5.20170922_24'; +our $VERSION = '5.20181129_28'; + +sub PKG_PATTERN () { q#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z# } +sub _looks_like_invocant ($) { local $@; !!eval { $_[0]->isa(__PACKAGE__) } } + +sub _undelta { + my ($delta) = @_; + my (%expanded, $delta_from, $base, $changed, $removed); + for my $v (sort keys %$delta) { + ($delta_from, $changed, $removed) = @{$delta->{$v}}{qw( delta_from changed removed )}; + $base = $delta_from ? $expanded{$delta_from} : {}; + my %full = ( %$base, %{$changed || {}} ); + delete @full{ keys %$removed }; + $expanded{$v} = \%full; + } + return %expanded; +} sub _released_order { # Sort helper, to make '?' sort after everything else (substr($released{$a}, 0, 1) eq "?") @@ -32,9 +48,8 @@ END { sub first_release_raw { + shift if defined $_[1] and $_[1] =~ PKG_PATTERN and _looks_like_invocant $_[0]; my $module = shift; - $module = shift if eval { $module->isa(__PACKAGE__) } - and scalar @_ and $_[0] =~ m#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z#; my $version = shift; my @perls = $version @@ -58,10 +73,9 @@ sub first_release { } sub find_modules { + shift if _looks_like_invocant $_[0]; my $regex = shift; - $regex = shift if eval { $regex->isa(__PACKAGE__) }; - my @perls = @_; - @perls = keys %version unless @perls; + my @perls = @_ ? @_ : keys %version; my %mods; foreach (@perls) { @@ -73,30 +87,23 @@ sub find_modules { } sub find_version { + shift if _looks_like_invocant $_[0]; my $v = shift; - if ($v->isa(__PACKAGE__)) { - $v = shift; - return if not defined $v; - } - return $version{$v} if defined $version{$v}; + return $version{$v} if defined $v and defined $version{$v}; return; } sub is_deprecated { + shift if defined $_[1] and $_[1] =~ PKG_PATTERN and _looks_like_invocant $_[0]; my $module = shift; - $module = shift if eval { $module->isa(__PACKAGE__) } - and scalar @_ and $_[0] =~ m#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z#; - my $perl_version = shift; - $perl_version ||= $]; + my $perl_version = shift || $]; return unless $module && exists $deprecated{$perl_version}{$module}; return $deprecated{$perl_version}{$module}; } sub deprecated_in { - my $module = shift; - $module = shift if eval { $module->isa(__PACKAGE__) } - and scalar @_ and $_[0] =~ m#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z#; - return unless $module; + shift if defined $_[1] and $_[1] =~ PKG_PATTERN and _looks_like_invocant $_[0]; + my $module = shift or return; my @perls = grep { exists $deprecated{$_}{$module} } keys %deprecated; return unless @perls; require List::Util; @@ -114,9 +121,8 @@ sub removed_from_by_date { } sub removed_raw { + shift if defined $_[1] and $_[1] =~ PKG_PATTERN and _looks_like_invocant $_[0]; my $mod = shift; - $mod = shift if eval { $mod->isa(__PACKAGE__) } - and scalar @_ and $_[0] =~ m#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z#; return unless my @perls = sort { $a cmp $b } first_release_raw($mod); my $last = pop @perls; my @removed = grep { $_ > $last } sort { $a cmp $b } keys %version; @@ -124,8 +130,8 @@ sub removed_raw { } sub changes_between { + shift if _looks_like_invocant $_[0]; my $left_ver = shift; - $left_ver = shift if eval { $left_ver->isa(__PACKAGE__) }; my $right_ver = shift; my $left = $version{ $left_ver }; @@ -317,6 +323,23 @@ sub changes_between { 5.027003 => '2017-08-21', 5.027004 => '2017-09-20', 5.024003 => '2017-09-22', + 5.026001 => '2017-09-22', + 5.027005 => '2017-10-20', + 5.027006 => '2017-11-20', + 5.027007 => '2017-12-20', + 5.027008 => '2018-01-20', + 5.027009 => '2018-02-20', + 5.027010 => '2018-03-20', + 5.024004 => '2018-04-14', + 5.026002 => '2018-04-14', + 5.027011 => '2018-04-20', + 5.028000 => '2018-06-22', + 5.029000 => '2018-06-26', + 5.029001 => '2018-07-20', + 5.029002 => '2018-08-20', + 5.029003 => '2018-09-20', + 5.029004 => '2018-10-20', + 5.028001 => '2018-11-29', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -12988,7 +13011,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Sys::Syslog' => '0.34_01', 'TAP::Base' => '3.36_01', 'TAP::Formatter::Base' => '3.36_01', - 'TAP::Formatter::Color' => '3.36_01', + 'TAP::Formatter::Color' => '3.36_01', 'TAP::Formatter::Console'=> '3.36_01', 'TAP::Formatter::Console::ParallelSession'=> '3.36_01', 'TAP::Formatter::Console::Session'=> '3.36_01', @@ -14436,16 +14459,1380 @@ for my $version ( sort { $a <=> $b } keys %released ) { removed => { } }, + 5.026001 => { + delta_from => 5.026000, + changed => { + 'B::Op_private' => '5.026001', + 'Config' => '5.026001', + 'Module::CoreList' => '5.20170922_26', + 'Module::CoreList::TieHashDelta'=> '5.20170922_26', + 'Module::CoreList::Utils'=> '5.20170922_26', + '_charnames' => '1.45', + 'base' => '2.26', + 'charnames' => '1.45', + }, + removed => { + } + }, + 5.027005 => { + delta_from => 5.027004, + changed => { + 'B' => '1.70', + 'B::Concise' => '1.002', + 'B::Deparse' => '1.43', + 'B::Op_private' => '5.027005', + 'B::Xref' => '1.07', + 'Config' => '5.027005', + 'Config::Perl::V' => '0.29', + 'Digest::SHA' => '5.98', + 'Encode' => '2.93', + 'Encode::CN::HZ' => '2.10', + 'Encode::JP::JIS7' => '2.08', + 'Encode::MIME::Header' => '2.28', + 'Encode::MIME::Name' => '1.03', + 'File::Fetch' => '0.54', + 'File::Path' => '2.15', + 'List::Util' => '1.49', + 'List::Util::XS' => '1.49', + 'Locale::Codes' => '3.54', + 'Locale::Codes::Constants'=> '3.54', + 'Locale::Codes::Country'=> '3.54', + 'Locale::Codes::Country_Codes'=> '3.54', + 'Locale::Codes::Country_Retired'=> '3.54', + 'Locale::Codes::Currency'=> '3.54', + 'Locale::Codes::Currency_Codes'=> '3.54', + 'Locale::Codes::Currency_Retired'=> '3.54', + 'Locale::Codes::LangExt'=> '3.54', + 'Locale::Codes::LangExt_Codes'=> '3.54', + 'Locale::Codes::LangExt_Retired'=> '3.54', + 'Locale::Codes::LangFam'=> '3.54', + 'Locale::Codes::LangFam_Codes'=> '3.54', + 'Locale::Codes::LangFam_Retired'=> '3.54', + 'Locale::Codes::LangVar'=> '3.54', + 'Locale::Codes::LangVar_Codes'=> '3.54', + 'Locale::Codes::LangVar_Retired'=> '3.54', + 'Locale::Codes::Language'=> '3.54', + 'Locale::Codes::Language_Codes'=> '3.54', + 'Locale::Codes::Language_Retired'=> '3.54', + 'Locale::Codes::Script' => '3.54', + 'Locale::Codes::Script_Codes'=> '3.54', + 'Locale::Codes::Script_Retired'=> '3.54', + 'Locale::Country' => '3.54', + 'Locale::Currency' => '3.54', + 'Locale::Language' => '3.54', + 'Locale::Script' => '3.54', + 'Math::BigFloat' => '1.999811', + 'Math::BigInt' => '1.999811', + 'Math::BigInt::Calc' => '1.999811', + 'Math::BigInt::CalcEmu' => '1.999811', + 'Math::BigInt::FastCalc'=> '0.5006', + 'Math::BigInt::Lib' => '1.999811', + 'Module::CoreList' => '5.20171020', + 'Module::CoreList::TieHashDelta'=> '5.20171020', + 'Module::CoreList::Utils'=> '5.20171020', + 'NEXT' => '0.67_01', + 'POSIX' => '1.78', + 'Pod::Perldoc' => '3.2801', + 'Scalar::Util' => '1.49', + 'Sub::Util' => '1.49', + 'Sys::Hostname' => '1.21', + 'Test2' => '1.302103', + 'Test2::API' => '1.302103', + 'Test2::API::Breakage' => '1.302103', + 'Test2::API::Context' => '1.302103', + 'Test2::API::Instance' => '1.302103', + 'Test2::API::Stack' => '1.302103', + 'Test2::Event' => '1.302103', + 'Test2::Event::Bail' => '1.302103', + 'Test2::Event::Diag' => '1.302103', + 'Test2::Event::Encoding'=> '1.302103', + 'Test2::Event::Exception'=> '1.302103', + 'Test2::Event::Fail' => '1.302103', + 'Test2::Event::Generic' => '1.302103', + 'Test2::Event::Note' => '1.302103', + 'Test2::Event::Ok' => '1.302103', + 'Test2::Event::Pass' => '1.302103', + 'Test2::Event::Plan' => '1.302103', + 'Test2::Event::Skip' => '1.302103', + 'Test2::Event::Subtest' => '1.302103', + 'Test2::Event::TAP::Version'=> '1.302103', + 'Test2::Event::Waiting' => '1.302103', + 'Test2::EventFacet' => '1.302103', + 'Test2::EventFacet::About'=> '1.302103', + 'Test2::EventFacet::Amnesty'=> '1.302103', + 'Test2::EventFacet::Assert'=> '1.302103', + 'Test2::EventFacet::Control'=> '1.302103', + 'Test2::EventFacet::Error'=> '1.302103', + 'Test2::EventFacet::Info'=> '1.302103', + 'Test2::EventFacet::Meta'=> '1.302103', + 'Test2::EventFacet::Parent'=> '1.302103', + 'Test2::EventFacet::Plan'=> '1.302103', + 'Test2::EventFacet::Trace'=> '1.302103', + 'Test2::Formatter' => '1.302103', + 'Test2::Formatter::TAP' => '1.302103', + 'Test2::Hub' => '1.302103', + 'Test2::Hub::Interceptor'=> '1.302103', + 'Test2::Hub::Interceptor::Terminator'=> '1.302103', + 'Test2::Hub::Subtest' => '1.302103', + 'Test2::IPC' => '1.302103', + 'Test2::IPC::Driver' => '1.302103', + 'Test2::IPC::Driver::Files'=> '1.302103', + 'Test2::Tools::Tiny' => '1.302103', + 'Test2::Util' => '1.302103', + 'Test2::Util::ExternalMeta'=> '1.302103', + 'Test2::Util::Facets2Legacy'=> '1.302103', + 'Test2::Util::HashBase' => '0.005', + 'Test2::Util::Trace' => '1.302103', + 'Test::Builder' => '1.302103', + 'Test::Builder::Formatter'=> '1.302103', + 'Test::Builder::IO::Scalar'=> '2.114', + 'Test::Builder::Module' => '1.302103', + 'Test::Builder::Tester' => '1.302103', + 'Test::Builder::Tester::Color'=> '1.302103', + 'Test::Builder::TodoDiag'=> '1.302103', + 'Test::More' => '1.302103', + 'Test::Simple' => '1.302103', + 'Test::Tester' => '1.302103', + 'Test::Tester::Capture' => '1.302103', + 'Test::Tester::CaptureRunner'=> '1.302103', + 'Test::Tester::Delegate'=> '1.302103', + 'Test::use::ok' => '1.302103', + 'Time::HiRes' => '1.9746', + 'Time::Piece' => '1.3202', + 'Time::Seconds' => '1.3202', + 'arybase' => '0.14', + 'encoding' => '2.21', + 'ok' => '1.302103', + }, + removed => { + 'Test2::Event::Info' => 1, + } + }, + 5.027006 => { + delta_from => 5.027005, + changed => { + 'Attribute::Handlers' => '1.01', + 'B' => '1.72', + 'B::Concise' => '1.003', + 'B::Deparse' => '1.45', + 'B::Op_private' => '5.027006', + 'Carp' => '1.44', + 'Carp::Heavy' => '1.44', + 'Compress::Raw::Zlib' => '2.075', + 'Config' => '5.027006', + 'Config::Extensions' => '0.02', + 'Cwd' => '3.70', + 'DynaLoader' => '1.44', + 'ExtUtils::CBuilder' => '0.280229', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280229', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280229', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280229', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280229', + 'ExtUtils::CBuilder::Platform::android'=> '0.280229', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280229', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280229', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280229', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280229', + 'ExtUtils::Embed' => '1.35', + 'ExtUtils::Miniperl' => '1.07', + 'ExtUtils::ParseXS' => '3.36', + 'ExtUtils::ParseXS::Constants'=> '3.36', + 'ExtUtils::ParseXS::CountLines'=> '3.36', + 'ExtUtils::ParseXS::Eval'=> '3.36', + 'ExtUtils::ParseXS::Utilities'=> '3.36', + 'ExtUtils::Typemaps' => '3.36', + 'ExtUtils::Typemaps::Cmd'=> '3.36', + 'ExtUtils::Typemaps::InputMap'=> '3.36', + 'ExtUtils::Typemaps::OutputMap'=> '3.36', + 'ExtUtils::Typemaps::Type'=> '3.36', + 'ExtUtils::XSSymSet' => '1.4', + 'File::Copy' => '2.33', + 'File::Spec' => '3.69', + 'File::Spec::AmigaOS' => '3.69', + 'File::Spec::Cygwin' => '3.69', + 'File::Spec::Epoc' => '3.69', + 'File::Spec::Functions' => '3.69', + 'File::Spec::Mac' => '3.69', + 'File::Spec::OS2' => '3.69', + 'File::Spec::Unix' => '3.69', + 'File::Spec::VMS' => '3.69', + 'File::Spec::Win32' => '3.69', + 'File::stat' => '1.08', + 'FileCache' => '1.10', + 'Filter::Simple' => '0.95', + 'Hash::Util::FieldHash' => '1.20', + 'I18N::LangTags' => '0.43', + 'I18N::LangTags::Detect'=> '1.07', + 'I18N::LangTags::List' => '0.40', + 'I18N::Langinfo' => '0.15', + 'IO::Handle' => '1.37', + 'IO::Select' => '1.23', + 'Locale::Maketext' => '1.29', + 'Module::CoreList' => '5.20171120', + 'Module::CoreList::TieHashDelta'=> '5.20171120', + 'Module::CoreList::Utils'=> '5.20171120', + 'Net::Cmd' => '3.11', + 'Net::Config' => '3.11', + 'Net::Domain' => '3.11', + 'Net::FTP' => '3.11', + 'Net::FTP::A' => '3.11', + 'Net::FTP::E' => '3.11', + 'Net::FTP::I' => '3.11', + 'Net::FTP::L' => '3.11', + 'Net::FTP::dataconn' => '3.11', + 'Net::NNTP' => '3.11', + 'Net::Netrc' => '3.11', + 'Net::POP3' => '3.11', + 'Net::Ping' => '2.62', + 'Net::SMTP' => '3.11', + 'Net::Time' => '3.11', + 'Net::hostent' => '1.02', + 'Net::netent' => '1.01', + 'Net::protoent' => '1.01', + 'Net::servent' => '1.02', + 'O' => '1.03', + 'ODBM_File' => '1.15', + 'Opcode' => '1.41', + 'POSIX' => '1.80', + 'Pod::Html' => '1.2203', + 'SelfLoader' => '1.25', + 'Socket' => '2.020_04', + 'Storable' => '2.65', + 'Test' => '1.31', + 'Test2' => '1.302111', + 'Test2::API' => '1.302111', + 'Test2::API::Breakage' => '1.302111', + 'Test2::API::Context' => '1.302111', + 'Test2::API::Instance' => '1.302111', + 'Test2::API::Stack' => '1.302111', + 'Test2::Event' => '1.302111', + 'Test2::Event::Bail' => '1.302111', + 'Test2::Event::Diag' => '1.302111', + 'Test2::Event::Encoding'=> '1.302111', + 'Test2::Event::Exception'=> '1.302111', + 'Test2::Event::Fail' => '1.302111', + 'Test2::Event::Generic' => '1.302111', + 'Test2::Event::Note' => '1.302111', + 'Test2::Event::Ok' => '1.302111', + 'Test2::Event::Pass' => '1.302111', + 'Test2::Event::Plan' => '1.302111', + 'Test2::Event::Skip' => '1.302111', + 'Test2::Event::Subtest' => '1.302111', + 'Test2::Event::TAP::Version'=> '1.302111', + 'Test2::Event::Waiting' => '1.302111', + 'Test2::EventFacet' => '1.302111', + 'Test2::EventFacet::About'=> '1.302111', + 'Test2::EventFacet::Amnesty'=> '1.302111', + 'Test2::EventFacet::Assert'=> '1.302111', + 'Test2::EventFacet::Control'=> '1.302111', + 'Test2::EventFacet::Error'=> '1.302111', + 'Test2::EventFacet::Info'=> '1.302111', + 'Test2::EventFacet::Meta'=> '1.302111', + 'Test2::EventFacet::Parent'=> '1.302111', + 'Test2::EventFacet::Plan'=> '1.302111', + 'Test2::EventFacet::Trace'=> '1.302111', + 'Test2::Formatter' => '1.302111', + 'Test2::Formatter::TAP' => '1.302111', + 'Test2::Hub' => '1.302111', + 'Test2::Hub::Interceptor'=> '1.302111', + 'Test2::Hub::Interceptor::Terminator'=> '1.302111', + 'Test2::Hub::Subtest' => '1.302111', + 'Test2::IPC' => '1.302111', + 'Test2::IPC::Driver' => '1.302111', + 'Test2::IPC::Driver::Files'=> '1.302111', + 'Test2::Tools::Tiny' => '1.302111', + 'Test2::Util' => '1.302111', + 'Test2::Util::ExternalMeta'=> '1.302111', + 'Test2::Util::Facets2Legacy'=> '1.302111', + 'Test2::Util::HashBase' => '1.302111', + 'Test2::Util::Trace' => '1.302111', + 'Test::Builder' => '1.302111', + 'Test::Builder::Formatter'=> '1.302111', + 'Test::Builder::Module' => '1.302111', + 'Test::Builder::Tester' => '1.302111', + 'Test::Builder::Tester::Color'=> '1.302111', + 'Test::Builder::TodoDiag'=> '1.302111', + 'Test::More' => '1.302111', + 'Test::Simple' => '1.302111', + 'Test::Tester' => '1.302111', + 'Test::Tester::Capture' => '1.302111', + 'Test::Tester::CaptureRunner'=> '1.302111', + 'Test::Tester::Delegate'=> '1.302111', + 'Test::use::ok' => '1.302111', + 'Tie::Array' => '1.07', + 'Tie::StdHandle' => '4.5', + 'Time::HiRes' => '1.9747', + 'Time::gmtime' => '1.04', + 'Time::localtime' => '1.03', + 'Unicode::Collate' => '1.23', + 'Unicode::Collate::CJK::Big5'=> '1.23', + 'Unicode::Collate::CJK::GB2312'=> '1.23', + 'Unicode::Collate::CJK::JISX0208'=> '1.23', + 'Unicode::Collate::CJK::Korean'=> '1.23', + 'Unicode::Collate::CJK::Pinyin'=> '1.23', + 'Unicode::Collate::CJK::Stroke'=> '1.23', + 'Unicode::Collate::CJK::Zhuyin'=> '1.23', + 'Unicode::Collate::Locale'=> '1.23', + 'Unicode::Normalize' => '1.26', + 'User::grent' => '1.02', + 'User::pwent' => '1.01', + 'VMS::DCLsym' => '1.09', + 'VMS::Stdio' => '2.44', + 'XS::APItest' => '0.93', + 'XS::Typemap' => '0.16', + 'XSLoader' => '0.28', + 'attributes' => '0.32', + 'base' => '2.27', + 'blib' => '1.07', + 'experimental' => '0.017', + 'fields' => '2.24', + 'ok' => '1.302111', + 're' => '0.36', + 'sort' => '2.04', + 'threads' => '2.19', + 'warnings' => '1.38', + }, + removed => { + } + }, + 5.027007 => { + delta_from => 5.027006, + changed => { + 'App::Cpan' => '1.67', + 'B' => '1.73', + 'B::Debug' => '1.26', + 'B::Deparse' => '1.46', + 'B::Op_private' => '5.027007', + 'CPAN' => '2.20', + 'CPAN::Distribution' => '2.19', + 'CPAN::FTP' => '5.5011', + 'CPAN::FirstTime' => '5.5311', + 'CPAN::Shell' => '5.5007', + 'Carp' => '1.45', + 'Carp::Heavy' => '1.45', + 'Compress::Raw::Zlib' => '2.076', + 'Config' => '5.027007', + 'Cwd' => '3.71', + 'Data::Dumper' => '2.169', + 'Devel::PPPort' => '3.37', + 'Digest::SHA' => '6.00', + 'DynaLoader' => '1.45', + 'ExtUtils::CBuilder' => '0.280230', + 'ExtUtils::CBuilder::Base'=> '0.280230', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280230', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280230', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280230', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280230', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280230', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280230', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280230', + 'ExtUtils::CBuilder::Platform::android'=> '0.280230', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280230', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280230', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280230', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280230', + 'ExtUtils::Typemaps' => '3.37', + 'File::Fetch' => '0.56', + 'File::Spec' => '3.71', + 'File::Spec::AmigaOS' => '3.71', + 'File::Spec::Cygwin' => '3.71', + 'File::Spec::Epoc' => '3.71', + 'File::Spec::Functions' => '3.71', + 'File::Spec::Mac' => '3.71', + 'File::Spec::OS2' => '3.71', + 'File::Spec::Unix' => '3.71', + 'File::Spec::VMS' => '3.71', + 'File::Spec::Win32' => '3.71', + 'Filter::Util::Call' => '1.58', + 'GDBM_File' => '1.17', + 'JSON::PP' => '2.97000', + 'JSON::PP::Boolean' => '2.97000', + 'Locale::Codes' => '3.55', + 'Locale::Codes::Constants'=> '3.55', + 'Locale::Codes::Country'=> '3.55', + 'Locale::Codes::Country_Codes'=> '3.55', + 'Locale::Codes::Country_Retired'=> '3.55', + 'Locale::Codes::Currency'=> '3.55', + 'Locale::Codes::Currency_Codes'=> '3.55', + 'Locale::Codes::Currency_Retired'=> '3.55', + 'Locale::Codes::LangExt'=> '3.55', + 'Locale::Codes::LangExt_Codes'=> '3.55', + 'Locale::Codes::LangExt_Retired'=> '3.55', + 'Locale::Codes::LangFam'=> '3.55', + 'Locale::Codes::LangFam_Codes'=> '3.55', + 'Locale::Codes::LangFam_Retired'=> '3.55', + 'Locale::Codes::LangVar'=> '3.55', + 'Locale::Codes::LangVar_Codes'=> '3.55', + 'Locale::Codes::LangVar_Retired'=> '3.55', + 'Locale::Codes::Language'=> '3.55', + 'Locale::Codes::Language_Codes'=> '3.55', + 'Locale::Codes::Language_Retired'=> '3.55', + 'Locale::Codes::Script' => '3.55', + 'Locale::Codes::Script_Codes'=> '3.55', + 'Locale::Codes::Script_Retired'=> '3.55', + 'Locale::Country' => '3.55', + 'Locale::Currency' => '3.55', + 'Locale::Language' => '3.55', + 'Locale::Script' => '3.55', + 'Module::CoreList' => '5.20171220', + 'Module::CoreList::TieHashDelta'=> '5.20171220', + 'Module::CoreList::Utils'=> '5.20171220', + 'Opcode' => '1.42', + 'POSIX' => '1.81', + 'Pod::Functions' => '1.12', + 'Pod::Functions::Functions'=> '1.12', + 'Pod::Html' => '1.23', + 'Sys::Hostname' => '1.22', + 'Test2' => '1.302120', + 'Test2::API' => '1.302120', + 'Test2::API::Breakage' => '1.302120', + 'Test2::API::Context' => '1.302120', + 'Test2::API::Instance' => '1.302120', + 'Test2::API::Stack' => '1.302120', + 'Test2::Event' => '1.302120', + 'Test2::Event::Bail' => '1.302120', + 'Test2::Event::Diag' => '1.302120', + 'Test2::Event::Encoding'=> '1.302120', + 'Test2::Event::Exception'=> '1.302120', + 'Test2::Event::Fail' => '1.302120', + 'Test2::Event::Generic' => '1.302120', + 'Test2::Event::Note' => '1.302120', + 'Test2::Event::Ok' => '1.302120', + 'Test2::Event::Pass' => '1.302120', + 'Test2::Event::Plan' => '1.302120', + 'Test2::Event::Skip' => '1.302120', + 'Test2::Event::Subtest' => '1.302120', + 'Test2::Event::TAP::Version'=> '1.302120', + 'Test2::Event::Waiting' => '1.302120', + 'Test2::EventFacet' => '1.302120', + 'Test2::EventFacet::About'=> '1.302120', + 'Test2::EventFacet::Amnesty'=> '1.302120', + 'Test2::EventFacet::Assert'=> '1.302120', + 'Test2::EventFacet::Control'=> '1.302120', + 'Test2::EventFacet::Error'=> '1.302120', + 'Test2::EventFacet::Info'=> '1.302120', + 'Test2::EventFacet::Meta'=> '1.302120', + 'Test2::EventFacet::Parent'=> '1.302120', + 'Test2::EventFacet::Plan'=> '1.302120', + 'Test2::EventFacet::Trace'=> '1.302120', + 'Test2::Formatter' => '1.302120', + 'Test2::Formatter::TAP' => '1.302120', + 'Test2::Hub' => '1.302120', + 'Test2::Hub::Interceptor'=> '1.302120', + 'Test2::Hub::Interceptor::Terminator'=> '1.302120', + 'Test2::Hub::Subtest' => '1.302120', + 'Test2::IPC' => '1.302120', + 'Test2::IPC::Driver' => '1.302120', + 'Test2::IPC::Driver::Files'=> '1.302120', + 'Test2::Tools::Tiny' => '1.302120', + 'Test2::Util' => '1.302120', + 'Test2::Util::ExternalMeta'=> '1.302120', + 'Test2::Util::Facets2Legacy'=> '1.302120', + 'Test2::Util::HashBase' => '1.302120', + 'Test2::Util::Trace' => '1.302120', + 'Test::Builder' => '1.302120', + 'Test::Builder::Formatter'=> '1.302120', + 'Test::Builder::Module' => '1.302120', + 'Test::Builder::Tester' => '1.302120', + 'Test::Builder::Tester::Color'=> '1.302120', + 'Test::Builder::TodoDiag'=> '1.302120', + 'Test::More' => '1.302120', + 'Test::Simple' => '1.302120', + 'Test::Tester' => '1.302120', + 'Test::Tester::Capture' => '1.302120', + 'Test::Tester::CaptureRunner'=> '1.302120', + 'Test::Tester::Delegate'=> '1.302120', + 'Test::use::ok' => '1.302120', + 'Time::HiRes' => '1.9748', + 'Time::Piece' => '1.3203', + 'Time::Seconds' => '1.3203', + 'Unicode::Collate' => '1.25', + 'Unicode::Collate::CJK::Big5'=> '1.25', + 'Unicode::Collate::CJK::GB2312'=> '1.25', + 'Unicode::Collate::CJK::JISX0208'=> '1.25', + 'Unicode::Collate::CJK::Korean'=> '1.25', + 'Unicode::Collate::CJK::Pinyin'=> '1.25', + 'Unicode::Collate::CJK::Stroke'=> '1.25', + 'Unicode::Collate::CJK::Zhuyin'=> '1.25', + 'Unicode::Collate::Locale'=> '1.25', + 'Unicode::UCD' => '0.69', + 'XS::APItest' => '0.94', + 'XSLoader' => '0.29', + 'arybase' => '0.15', + 'autodie::exception' => '2.29001', + 'autodie::hints' => '2.29001', + 'experimental' => '0.019', + 'feature' => '1.50', + 'ok' => '1.302120', + 'overload' => '1.29', + 'threads' => '2.21', + 'threads::shared' => '1.58', + 'warnings' => '1.39', + }, + removed => { + } + }, + 5.027008 => { + delta_from => 5.027007, + changed => { + 'B' => '1.74', + 'B::Deparse' => '1.47', + 'B::Op_private' => '5.027008', + 'Config' => '5.027008', + 'Cwd' => '3.72', + 'Data::Dumper' => '2.170', + 'Devel::PPPort' => '3.38', + 'Digest::SHA' => '6.01', + 'Encode' => '2.94', + 'Encode::Alias' => '2.24', + 'ExtUtils::Miniperl' => '1.08', + 'File::Spec' => '3.72', + 'File::Spec::AmigaOS' => '3.72', + 'File::Spec::Cygwin' => '3.72', + 'File::Spec::Epoc' => '3.72', + 'File::Spec::Functions' => '3.72', + 'File::Spec::Mac' => '3.72', + 'File::Spec::OS2' => '3.72', + 'File::Spec::Unix' => '3.72', + 'File::Spec::VMS' => '3.72', + 'File::Spec::Win32' => '3.72', + 'JSON::PP' => '2.97001', + 'JSON::PP::Boolean' => '2.97001', + 'Module::CoreList' => '5.20180120', + 'Module::CoreList::TieHashDelta'=> '5.20180120', + 'Module::CoreList::Utils'=> '5.20180120', + 'Opcode' => '1.43', + 'Pod::Functions' => '1.13', + 'Pod::Functions::Functions'=> '1.13', + 'Pod::Html' => '1.24', + 'Pod::Man' => '4.10', + 'Pod::ParseLink' => '4.10', + 'Pod::Text' => '4.10', + 'Pod::Text::Color' => '4.10', + 'Pod::Text::Overstrike' => '4.10', + 'Pod::Text::Termcap' => '4.10', + 'Socket' => '2.027', + 'Time::HiRes' => '1.9752', + 'Unicode::UCD' => '0.70', + 'XS::APItest' => '0.95', + 'XSLoader' => '0.30', + 'autodie::exception' => '2.29002', + 'feature' => '1.51', + 'overload' => '1.30', + 'utf8' => '1.21', + 'warnings' => '1.40', + }, + removed => { + } + }, + 5.027009 => { + delta_from => 5.027008, + changed => { + 'B::Op_private' => '5.027009', + 'Carp' => '1.46', + 'Carp::Heavy' => '1.46', + 'Config' => '5.027009', + 'Cwd' => '3.74', + 'Devel::PPPort' => '3.39', + 'Encode' => '2.96', + 'Encode::Unicode' => '2.17', + 'Errno' => '1.29', + 'ExtUtils::Command' => '7.32', + 'ExtUtils::Command::MM' => '7.32', + 'ExtUtils::Liblist' => '7.32', + 'ExtUtils::Liblist::Kid'=> '7.32', + 'ExtUtils::MM' => '7.32', + 'ExtUtils::MM_AIX' => '7.32', + 'ExtUtils::MM_Any' => '7.32', + 'ExtUtils::MM_BeOS' => '7.32', + 'ExtUtils::MM_Cygwin' => '7.32', + 'ExtUtils::MM_DOS' => '7.32', + 'ExtUtils::MM_Darwin' => '7.32', + 'ExtUtils::MM_MacOS' => '7.32', + 'ExtUtils::MM_NW5' => '7.32', + 'ExtUtils::MM_OS2' => '7.32', + 'ExtUtils::MM_QNX' => '7.32', + 'ExtUtils::MM_UWIN' => '7.32', + 'ExtUtils::MM_Unix' => '7.32', + 'ExtUtils::MM_VMS' => '7.32', + 'ExtUtils::MM_VOS' => '7.32', + 'ExtUtils::MM_Win32' => '7.32', + 'ExtUtils::MM_Win95' => '7.32', + 'ExtUtils::MY' => '7.32', + 'ExtUtils::MakeMaker' => '7.32', + 'ExtUtils::MakeMaker::Config'=> '7.32', + 'ExtUtils::MakeMaker::Locale'=> '7.32', + 'ExtUtils::MakeMaker::version'=> '7.32', + 'ExtUtils::MakeMaker::version::regex'=> '7.32', + 'ExtUtils::Mkbootstrap' => '7.32', + 'ExtUtils::Mksymlists' => '7.32', + 'ExtUtils::ParseXS' => '3.38', + 'ExtUtils::ParseXS::Constants'=> '3.38', + 'ExtUtils::ParseXS::CountLines'=> '3.38', + 'ExtUtils::ParseXS::Eval'=> '3.38', + 'ExtUtils::ParseXS::Utilities'=> '3.38', + 'ExtUtils::Typemaps' => '3.38', + 'ExtUtils::Typemaps::Cmd'=> '3.38', + 'ExtUtils::Typemaps::InputMap'=> '3.38', + 'ExtUtils::Typemaps::OutputMap'=> '3.38', + 'ExtUtils::Typemaps::Type'=> '3.38', + 'ExtUtils::testlib' => '7.32', + 'File::Spec' => '3.74', + 'File::Spec::AmigaOS' => '3.74', + 'File::Spec::Cygwin' => '3.74', + 'File::Spec::Epoc' => '3.74', + 'File::Spec::Functions' => '3.74', + 'File::Spec::Mac' => '3.74', + 'File::Spec::OS2' => '3.74', + 'File::Spec::Unix' => '3.74', + 'File::Spec::VMS' => '3.74', + 'File::Spec::Win32' => '3.74', + 'IPC::Cmd' => '1.00', + 'Math::BigFloat::Trace' => '0.49', + 'Math::BigInt::Trace' => '0.49', + 'Module::CoreList' => '5.20180220', + 'Module::CoreList::Utils'=> '5.20180220', + 'POSIX' => '1.82', + 'PerlIO::encoding' => '0.26', + 'Storable' => '3.06', + 'Storable::Limit' => undef, + 'Test2' => '1.302122', + 'Test2::API' => '1.302122', + 'Test2::API::Breakage' => '1.302122', + 'Test2::API::Context' => '1.302122', + 'Test2::API::Instance' => '1.302122', + 'Test2::API::Stack' => '1.302122', + 'Test2::Event' => '1.302122', + 'Test2::Event::Bail' => '1.302122', + 'Test2::Event::Diag' => '1.302122', + 'Test2::Event::Encoding'=> '1.302122', + 'Test2::Event::Exception'=> '1.302122', + 'Test2::Event::Fail' => '1.302122', + 'Test2::Event::Generic' => '1.302122', + 'Test2::Event::Note' => '1.302122', + 'Test2::Event::Ok' => '1.302122', + 'Test2::Event::Pass' => '1.302122', + 'Test2::Event::Plan' => '1.302122', + 'Test2::Event::Skip' => '1.302122', + 'Test2::Event::Subtest' => '1.302122', + 'Test2::Event::TAP::Version'=> '1.302122', + 'Test2::Event::Waiting' => '1.302122', + 'Test2::EventFacet' => '1.302122', + 'Test2::EventFacet::About'=> '1.302122', + 'Test2::EventFacet::Amnesty'=> '1.302122', + 'Test2::EventFacet::Assert'=> '1.302122', + 'Test2::EventFacet::Control'=> '1.302122', + 'Test2::EventFacet::Error'=> '1.302122', + 'Test2::EventFacet::Info'=> '1.302122', + 'Test2::EventFacet::Meta'=> '1.302122', + 'Test2::EventFacet::Parent'=> '1.302122', + 'Test2::EventFacet::Plan'=> '1.302122', + 'Test2::EventFacet::Render'=> '1.302122', + 'Test2::EventFacet::Trace'=> '1.302122', + 'Test2::Formatter' => '1.302122', + 'Test2::Formatter::TAP' => '1.302122', + 'Test2::Hub' => '1.302122', + 'Test2::Hub::Interceptor'=> '1.302122', + 'Test2::Hub::Interceptor::Terminator'=> '1.302122', + 'Test2::Hub::Subtest' => '1.302122', + 'Test2::IPC' => '1.302122', + 'Test2::IPC::Driver' => '1.302122', + 'Test2::IPC::Driver::Files'=> '1.302122', + 'Test2::Tools::Tiny' => '1.302122', + 'Test2::Util' => '1.302122', + 'Test2::Util::ExternalMeta'=> '1.302122', + 'Test2::Util::Facets2Legacy'=> '1.302122', + 'Test2::Util::HashBase' => '1.302122', + 'Test2::Util::Trace' => '1.302122', + 'Test::Builder' => '1.302122', + 'Test::Builder::Formatter'=> '1.302122', + 'Test::Builder::Module' => '1.302122', + 'Test::Builder::Tester' => '1.302122', + 'Test::Builder::Tester::Color'=> '1.302122', + 'Test::Builder::TodoDiag'=> '1.302122', + 'Test::More' => '1.302122', + 'Test::Simple' => '1.302122', + 'Test::Tester' => '1.302122', + 'Test::Tester::Capture' => '1.302122', + 'Test::Tester::CaptureRunner'=> '1.302122', + 'Test::Tester::Delegate'=> '1.302122', + 'Test::use::ok' => '1.302122', + 'Time::HiRes' => '1.9753', + 'XS::APItest' => '0.96', + 'bigint' => '0.49', + 'bignum' => '0.49', + 'bigrat' => '0.49', + 'encoding' => '2.22', + 'if' => '0.0608', + 'mro' => '1.22', + 'ok' => '1.302122', + 'threads' => '2.22', + 'warnings' => '1.41', + }, + removed => { + 'Module::CoreList::TieHashDelta'=> 1, + } + }, + 5.027010 => { + delta_from => 5.027009, + changed => { + 'App::Prove' => '3.42', + 'App::Prove::State' => '3.42', + 'App::Prove::State::Result'=> '3.42', + 'App::Prove::State::Result::Test'=> '3.42', + 'B::Deparse' => '1.48', + 'B::Op_private' => '5.027010', + 'Carp' => '1.49', + 'Carp::Heavy' => '1.49', + 'Config' => '5.02701', + 'Encode' => '2.97', + 'ExtUtils::Command' => '7.34', + 'ExtUtils::Command::MM' => '7.34', + 'ExtUtils::Liblist' => '7.34', + 'ExtUtils::Liblist::Kid'=> '7.34', + 'ExtUtils::MM' => '7.34', + 'ExtUtils::MM_AIX' => '7.34', + 'ExtUtils::MM_Any' => '7.34', + 'ExtUtils::MM_BeOS' => '7.34', + 'ExtUtils::MM_Cygwin' => '7.34', + 'ExtUtils::MM_DOS' => '7.34', + 'ExtUtils::MM_Darwin' => '7.34', + 'ExtUtils::MM_MacOS' => '7.34', + 'ExtUtils::MM_NW5' => '7.34', + 'ExtUtils::MM_OS2' => '7.34', + 'ExtUtils::MM_QNX' => '7.34', + 'ExtUtils::MM_UWIN' => '7.34', + 'ExtUtils::MM_Unix' => '7.34', + 'ExtUtils::MM_VMS' => '7.34', + 'ExtUtils::MM_VOS' => '7.34', + 'ExtUtils::MM_Win32' => '7.34', + 'ExtUtils::MM_Win95' => '7.34', + 'ExtUtils::MY' => '7.34', + 'ExtUtils::MakeMaker' => '7.34', + 'ExtUtils::MakeMaker::Config'=> '7.34', + 'ExtUtils::MakeMaker::Locale'=> '7.34', + 'ExtUtils::MakeMaker::version'=> '7.34', + 'ExtUtils::MakeMaker::version::regex'=> '7.34', + 'ExtUtils::Mkbootstrap' => '7.34', + 'ExtUtils::Mksymlists' => '7.34', + 'ExtUtils::ParseXS' => '3.39', + 'ExtUtils::ParseXS::Constants'=> '3.39', + 'ExtUtils::ParseXS::CountLines'=> '3.39', + 'ExtUtils::ParseXS::Eval'=> '3.39', + 'ExtUtils::ParseXS::Utilities'=> '3.39', + 'ExtUtils::testlib' => '7.34', + 'File::Glob' => '1.31', + 'I18N::Langinfo' => '0.16', + 'List::Util' => '1.50', + 'List::Util::XS' => '1.50', + 'Locale::Codes' => '3.56', + 'Locale::Codes::Constants'=> '3.56', + 'Locale::Codes::Country'=> '3.56', + 'Locale::Codes::Country_Codes'=> '3.56', + 'Locale::Codes::Country_Retired'=> '3.56', + 'Locale::Codes::Currency'=> '3.56', + 'Locale::Codes::Currency_Codes'=> '3.56', + 'Locale::Codes::Currency_Retired'=> '3.56', + 'Locale::Codes::LangExt'=> '3.56', + 'Locale::Codes::LangExt_Codes'=> '3.56', + 'Locale::Codes::LangExt_Retired'=> '3.56', + 'Locale::Codes::LangFam'=> '3.56', + 'Locale::Codes::LangFam_Codes'=> '3.56', + 'Locale::Codes::LangFam_Retired'=> '3.56', + 'Locale::Codes::LangVar'=> '3.56', + 'Locale::Codes::LangVar_Codes'=> '3.56', + 'Locale::Codes::LangVar_Retired'=> '3.56', + 'Locale::Codes::Language'=> '3.56', + 'Locale::Codes::Language_Codes'=> '3.56', + 'Locale::Codes::Language_Retired'=> '3.56', + 'Locale::Codes::Script' => '3.56', + 'Locale::Codes::Script_Codes'=> '3.56', + 'Locale::Codes::Script_Retired'=> '3.56', + 'Locale::Country' => '3.56', + 'Locale::Currency' => '3.56', + 'Locale::Language' => '3.56', + 'Locale::Script' => '3.56', + 'Module::CoreList' => '5.20180221', + 'Module::CoreList::Utils'=> '5.20180221', + 'POSIX' => '1.83', + 'Scalar::Util' => '1.50', + 'Sub::Util' => '1.50', + 'TAP::Base' => '3.42', + 'TAP::Formatter::Base' => '3.42', + 'TAP::Formatter::Color' => '3.42', + 'TAP::Formatter::Console'=> '3.42', + 'TAP::Formatter::Console::ParallelSession'=> '3.42', + 'TAP::Formatter::Console::Session'=> '3.42', + 'TAP::Formatter::File' => '3.42', + 'TAP::Formatter::File::Session'=> '3.42', + 'TAP::Formatter::Session'=> '3.42', + 'TAP::Harness' => '3.42', + 'TAP::Harness::Env' => '3.42', + 'TAP::Object' => '3.42', + 'TAP::Parser' => '3.42', + 'TAP::Parser::Aggregator'=> '3.42', + 'TAP::Parser::Grammar' => '3.42', + 'TAP::Parser::Iterator' => '3.42', + 'TAP::Parser::Iterator::Array'=> '3.42', + 'TAP::Parser::Iterator::Process'=> '3.42', + 'TAP::Parser::Iterator::Stream'=> '3.42', + 'TAP::Parser::IteratorFactory'=> '3.42', + 'TAP::Parser::Multiplexer'=> '3.42', + 'TAP::Parser::Result' => '3.42', + 'TAP::Parser::Result::Bailout'=> '3.42', + 'TAP::Parser::Result::Comment'=> '3.42', + 'TAP::Parser::Result::Plan'=> '3.42', + 'TAP::Parser::Result::Pragma'=> '3.42', + 'TAP::Parser::Result::Test'=> '3.42', + 'TAP::Parser::Result::Unknown'=> '3.42', + 'TAP::Parser::Result::Version'=> '3.42', + 'TAP::Parser::Result::YAML'=> '3.42', + 'TAP::Parser::ResultFactory'=> '3.42', + 'TAP::Parser::Scheduler'=> '3.42', + 'TAP::Parser::Scheduler::Job'=> '3.42', + 'TAP::Parser::Scheduler::Spinner'=> '3.42', + 'TAP::Parser::Source' => '3.42', + 'TAP::Parser::SourceHandler'=> '3.42', + 'TAP::Parser::SourceHandler::Executable'=> '3.42', + 'TAP::Parser::SourceHandler::File'=> '3.42', + 'TAP::Parser::SourceHandler::Handle'=> '3.42', + 'TAP::Parser::SourceHandler::Perl'=> '3.42', + 'TAP::Parser::SourceHandler::RawTAP'=> '3.42', + 'TAP::Parser::YAMLish::Reader'=> '3.42', + 'TAP::Parser::YAMLish::Writer'=> '3.42', + 'Test2' => '1.302133', + 'Test2::API' => '1.302133', + 'Test2::API::Breakage' => '1.302133', + 'Test2::API::Context' => '1.302133', + 'Test2::API::Instance' => '1.302133', + 'Test2::API::Stack' => '1.302133', + 'Test2::Event' => '1.302133', + 'Test2::Event::Bail' => '1.302133', + 'Test2::Event::Diag' => '1.302133', + 'Test2::Event::Encoding'=> '1.302133', + 'Test2::Event::Exception'=> '1.302133', + 'Test2::Event::Fail' => '1.302133', + 'Test2::Event::Generic' => '1.302133', + 'Test2::Event::Note' => '1.302133', + 'Test2::Event::Ok' => '1.302133', + 'Test2::Event::Pass' => '1.302133', + 'Test2::Event::Plan' => '1.302133', + 'Test2::Event::Skip' => '1.302133', + 'Test2::Event::Subtest' => '1.302133', + 'Test2::Event::TAP::Version'=> '1.302133', + 'Test2::Event::V2' => '1.302133', + 'Test2::Event::Waiting' => '1.302133', + 'Test2::EventFacet' => '1.302133', + 'Test2::EventFacet::About'=> '1.302133', + 'Test2::EventFacet::Amnesty'=> '1.302133', + 'Test2::EventFacet::Assert'=> '1.302133', + 'Test2::EventFacet::Control'=> '1.302133', + 'Test2::EventFacet::Error'=> '1.302133', + 'Test2::EventFacet::Hub'=> '1.302133', + 'Test2::EventFacet::Info'=> '1.302133', + 'Test2::EventFacet::Meta'=> '1.302133', + 'Test2::EventFacet::Parent'=> '1.302133', + 'Test2::EventFacet::Plan'=> '1.302133', + 'Test2::EventFacet::Render'=> '1.302133', + 'Test2::EventFacet::Trace'=> '1.302133', + 'Test2::Formatter' => '1.302133', + 'Test2::Formatter::TAP' => '1.302133', + 'Test2::Hub' => '1.302133', + 'Test2::Hub::Interceptor'=> '1.302133', + 'Test2::Hub::Interceptor::Terminator'=> '1.302133', + 'Test2::Hub::Subtest' => '1.302133', + 'Test2::IPC' => '1.302133', + 'Test2::IPC::Driver' => '1.302133', + 'Test2::IPC::Driver::Files'=> '1.302133', + 'Test2::Tools::Tiny' => '1.302133', + 'Test2::Util' => '1.302133', + 'Test2::Util::ExternalMeta'=> '1.302133', + 'Test2::Util::Facets2Legacy'=> '1.302133', + 'Test2::Util::HashBase' => '1.302133', + 'Test2::Util::Trace' => '1.302133', + 'Test::Builder' => '1.302133', + 'Test::Builder::Formatter'=> '1.302133', + 'Test::Builder::Module' => '1.302133', + 'Test::Builder::Tester' => '1.302133', + 'Test::Builder::Tester::Color'=> '1.302133', + 'Test::Builder::TodoDiag'=> '1.302133', + 'Test::Harness' => '3.42', + 'Test::More' => '1.302133', + 'Test::Simple' => '1.302133', + 'Test::Tester' => '1.302133', + 'Test::Tester::Capture' => '1.302133', + 'Test::Tester::CaptureRunner'=> '1.302133', + 'Test::Tester::Delegate'=> '1.302133', + 'Test::use::ok' => '1.302133', + 'Time::HiRes' => '1.9757', + 'Time::Piece' => '1.3204', + 'Time::Seconds' => '1.3204', + 'attributes' => '0.33', + 'ok' => '1.302133', + 'warnings' => '1.42', + }, + removed => { + } + }, + 5.024004 => { + delta_from => 5.024003, + changed => { + 'B::Op_private' => '5.024004', + 'Config' => '5.024004', + 'Module::CoreList' => '5.20180414_24', + 'Module::CoreList::TieHashDelta'=> '5.20180414_24', + 'Module::CoreList::Utils'=> '5.20180414_24', + }, + removed => { + } + }, + 5.026002 => { + delta_from => 5.026001, + changed => { + 'B::Op_private' => '5.026002', + 'Config' => '5.026002', + 'Module::CoreList' => '5.20180414_26', + 'Module::CoreList::TieHashDelta'=> '5.20180414_26', + 'Module::CoreList::Utils'=> '5.20180414_26', + 'PerlIO::via' => '0.17', + 'Term::ReadLine' => '1.17', + 'Unicode::UCD' => '0.69', + }, + removed => { + } + }, + 5.027011 => { + delta_from => 5.027010, + changed => { + 'B::Op_private' => '5.027011', + 'Carp' => '1.50', + 'Carp::Heavy' => '1.50', + 'Config' => '5.027011', + 'Devel::PPPort' => '3.40', + 'Exporter' => '5.73', + 'Exporter::Heavy' => '5.73', + 'ExtUtils::Constant' => '0.25', + 'I18N::Langinfo' => '0.17', + 'IO' => '1.39', + 'IO::Dir' => '1.39', + 'IO::File' => '1.39', + 'IO::Handle' => '1.39', + 'IO::Pipe' => '1.39', + 'IO::Poll' => '1.39', + 'IO::Seekable' => '1.39', + 'IO::Select' => '1.39', + 'IO::Socket' => '1.39', + 'IO::Socket::INET' => '1.39', + 'IO::Socket::UNIX' => '1.39', + 'Module::CoreList' => '5.20180420', + 'Module::CoreList::Utils'=> '5.20180420', + 'POSIX' => '1.84', + 'Time::HiRes' => '1.9759', + 'XS::APItest' => '0.97', + 'bytes' => '1.06', + 'subs' => '1.03', + 'vars' => '1.04', + 'version' => '0.9923', + 'version::regex' => '0.9923', + }, + removed => { + } + }, + 5.028000 => { + delta_from => 5.027011, + changed => { + 'Archive::Tar' => '2.30', + 'Archive::Tar::Constant'=> '2.30', + 'Archive::Tar::File' => '2.30', + 'B::Op_private' => '5.028000', + 'Config' => '5.028', + 'Module::CoreList' => '5.20180622', + 'Module::CoreList::Utils'=> '5.20180622', + 'Storable' => '3.08', + 'XS::APItest' => '0.98', + 'feature' => '1.52', + }, + removed => { + } + }, + 5.029000 => { + delta_from => 5.028, + changed => { + 'B::Op_private' => '5.029000', + 'Config' => '5.029', + 'Module::CoreList' => '5.20180626', + 'Module::CoreList::Utils'=> '5.20180626', + 'Unicode::UCD' => '0.71', + 'XS::APItest' => '0.99', + 'feature' => '1.53', + }, + removed => { + } + }, + 5.029001 => { + delta_from => 5.029000, + changed => { + 'B::Op_private' => '5.029001', + 'Compress::Raw::Bzip2' => '2.081', + 'Compress::Raw::Zlib' => '2.081', + 'Compress::Zlib' => '2.081', + 'Config' => '5.029001', + 'Config::Perl::V' => '0.30', + 'DB_File' => '1.842', + 'Devel::PPPort' => '3.42', + 'Digest::SHA' => '6.02', + 'ExtUtils::Manifest' => '1.71', + 'File::GlobMapper' => '1.001', + 'File::Temp' => '0.2308', + 'IO::Compress::Adapter::Bzip2'=> '2.081', + 'IO::Compress::Adapter::Deflate'=> '2.081', + 'IO::Compress::Adapter::Identity'=> '2.081', + 'IO::Compress::Base' => '2.081', + 'IO::Compress::Base::Common'=> '2.081', + 'IO::Compress::Bzip2' => '2.081', + 'IO::Compress::Deflate' => '2.081', + 'IO::Compress::Gzip' => '2.081', + 'IO::Compress::Gzip::Constants'=> '2.081', + 'IO::Compress::RawDeflate'=> '2.081', + 'IO::Compress::Zip' => '2.081', + 'IO::Compress::Zip::Constants'=> '2.081', + 'IO::Compress::Zlib::Constants'=> '2.081', + 'IO::Compress::Zlib::Extra'=> '2.081', + 'IO::Uncompress::Adapter::Bunzip2'=> '2.081', + 'IO::Uncompress::Adapter::Identity'=> '2.081', + 'IO::Uncompress::Adapter::Inflate'=> '2.081', + 'IO::Uncompress::AnyInflate'=> '2.081', + 'IO::Uncompress::AnyUncompress'=> '2.081', + 'IO::Uncompress::Base' => '2.081', + 'IO::Uncompress::Bunzip2'=> '2.081', + 'IO::Uncompress::Gunzip'=> '2.081', + 'IO::Uncompress::Inflate'=> '2.081', + 'IO::Uncompress::RawInflate'=> '2.081', + 'IO::Uncompress::Unzip' => '2.081', + 'IPC::Cmd' => '1.02', + 'Locale::Codes' => '3.57', + 'Locale::Codes::Constants'=> '3.57', + 'Locale::Codes::Country'=> '3.57', + 'Locale::Codes::Country_Codes'=> '3.57', + 'Locale::Codes::Country_Retired'=> '3.57', + 'Locale::Codes::Currency'=> '3.57', + 'Locale::Codes::Currency_Codes'=> '3.57', + 'Locale::Codes::Currency_Retired'=> '3.57', + 'Locale::Codes::LangExt'=> '3.57', + 'Locale::Codes::LangExt_Codes'=> '3.57', + 'Locale::Codes::LangExt_Retired'=> '3.57', + 'Locale::Codes::LangFam'=> '3.57', + 'Locale::Codes::LangFam_Codes'=> '3.57', + 'Locale::Codes::LangFam_Retired'=> '3.57', + 'Locale::Codes::LangVar'=> '3.57', + 'Locale::Codes::LangVar_Codes'=> '3.57', + 'Locale::Codes::LangVar_Retired'=> '3.57', + 'Locale::Codes::Language'=> '3.57', + 'Locale::Codes::Language_Codes'=> '3.57', + 'Locale::Codes::Language_Retired'=> '3.57', + 'Locale::Codes::Script' => '3.57', + 'Locale::Codes::Script_Codes'=> '3.57', + 'Locale::Codes::Script_Retired'=> '3.57', + 'Locale::Country' => '3.57', + 'Locale::Currency' => '3.57', + 'Locale::Language' => '3.57', + 'Locale::Script' => '3.57', + 'Math::BigFloat' => '1.999813', + 'Math::BigFloat::Trace' => '0.50', + 'Math::BigInt' => '1.999813', + 'Math::BigInt::Calc' => '1.999813', + 'Math::BigInt::CalcEmu' => '1.999813', + 'Math::BigInt::FastCalc'=> '0.5007', + 'Math::BigInt::Lib' => '1.999813', + 'Math::BigInt::Trace' => '0.50', + 'Math::BigRat' => '0.2614', + 'Module::CoreList' => '5.20180720', + 'Module::CoreList::Utils'=> '5.20180720', + 'Pod::Man' => '4.11', + 'Pod::ParseLink' => '4.11', + 'Pod::Text' => '4.11', + 'Pod::Text::Color' => '4.11', + 'Pod::Text::Overstrike' => '4.11', + 'Pod::Text::Termcap' => '4.11', + 'Storable' => '3.11', + 'Test2' => '1.302138', + 'Test2::API' => '1.302138', + 'Test2::API::Breakage' => '1.302138', + 'Test2::API::Context' => '1.302138', + 'Test2::API::Instance' => '1.302138', + 'Test2::API::Stack' => '1.302138', + 'Test2::Event' => '1.302138', + 'Test2::Event::Bail' => '1.302138', + 'Test2::Event::Diag' => '1.302138', + 'Test2::Event::Encoding'=> '1.302138', + 'Test2::Event::Exception'=> '1.302138', + 'Test2::Event::Fail' => '1.302138', + 'Test2::Event::Generic' => '1.302138', + 'Test2::Event::Note' => '1.302138', + 'Test2::Event::Ok' => '1.302138', + 'Test2::Event::Pass' => '1.302138', + 'Test2::Event::Plan' => '1.302138', + 'Test2::Event::Skip' => '1.302138', + 'Test2::Event::Subtest' => '1.302138', + 'Test2::Event::TAP::Version'=> '1.302138', + 'Test2::Event::V2' => '1.302138', + 'Test2::Event::Waiting' => '1.302138', + 'Test2::EventFacet' => '1.302138', + 'Test2::EventFacet::About'=> '1.302138', + 'Test2::EventFacet::Amnesty'=> '1.302138', + 'Test2::EventFacet::Assert'=> '1.302138', + 'Test2::EventFacet::Control'=> '1.302138', + 'Test2::EventFacet::Error'=> '1.302138', + 'Test2::EventFacet::Hub'=> '1.302138', + 'Test2::EventFacet::Info'=> '1.302138', + 'Test2::EventFacet::Meta'=> '1.302138', + 'Test2::EventFacet::Parent'=> '1.302138', + 'Test2::EventFacet::Plan'=> '1.302138', + 'Test2::EventFacet::Render'=> '1.302138', + 'Test2::EventFacet::Trace'=> '1.302138', + 'Test2::Formatter' => '1.302138', + 'Test2::Formatter::TAP' => '1.302138', + 'Test2::Hub' => '1.302138', + 'Test2::Hub::Interceptor'=> '1.302138', + 'Test2::Hub::Interceptor::Terminator'=> '1.302138', + 'Test2::Hub::Subtest' => '1.302138', + 'Test2::IPC' => '1.302138', + 'Test2::IPC::Driver' => '1.302138', + 'Test2::IPC::Driver::Files'=> '1.302138', + 'Test2::Tools::Tiny' => '1.302138', + 'Test2::Util' => '1.302138', + 'Test2::Util::ExternalMeta'=> '1.302138', + 'Test2::Util::Facets2Legacy'=> '1.302138', + 'Test2::Util::HashBase' => '1.302138', + 'Test2::Util::Trace' => '1.302138', + 'Test::Builder' => '1.302138', + 'Test::Builder::Formatter'=> '1.302138', + 'Test::Builder::Module' => '1.302138', + 'Test::Builder::Tester' => '1.302138', + 'Test::Builder::Tester::Color'=> '1.302138', + 'Test::Builder::TodoDiag'=> '1.302138', + 'Test::More' => '1.302138', + 'Test::Simple' => '1.302138', + 'Test::Tester' => '1.302138', + 'Test::Tester::Capture' => '1.302138', + 'Test::Tester::CaptureRunner'=> '1.302138', + 'Test::Tester::Delegate'=> '1.302138', + 'Test::use::ok' => '1.302138', + 'Thread::Queue' => '3.13', + 'Time::Local' => '1.28', + 'bigint' => '0.50', + 'bignum' => '0.50', + 'bigrat' => '0.50', + 'experimental' => '0.020', + 'ok' => '1.302138', + 'parent' => '0.237', + 'perlfaq' => '5.20180605', + 'version' => '0.9924', + 'version::regex' => '0.9924', + }, + removed => { + } + }, + 5.029002 => { + delta_from => 5.029001, + changed => { + 'B::Op_private' => '5.029002', + 'Config' => '5.029002', + 'Config::Extensions' => '0.03', + 'Cwd' => '3.75', + 'Data::Dumper' => '2.171', + 'Filter::Util::Call' => '1.59', + 'HTTP::Tiny' => '0.076', + 'Module::CoreList' => '5.20180820', + 'Module::CoreList::Utils'=> '5.20180820', + 'PerlIO::scalar' => '0.30', + 'Storable' => '3.12', + 'Test2' => '1.302140', + 'Test2::API' => '1.302140', + 'Test2::API::Breakage' => '1.302140', + 'Test2::API::Context' => '1.302140', + 'Test2::API::Instance' => '1.302140', + 'Test2::API::Stack' => '1.302140', + 'Test2::Event' => '1.302140', + 'Test2::Event::Bail' => '1.302140', + 'Test2::Event::Diag' => '1.302140', + 'Test2::Event::Encoding'=> '1.302140', + 'Test2::Event::Exception'=> '1.302140', + 'Test2::Event::Fail' => '1.302140', + 'Test2::Event::Generic' => '1.302140', + 'Test2::Event::Note' => '1.302140', + 'Test2::Event::Ok' => '1.302140', + 'Test2::Event::Pass' => '1.302140', + 'Test2::Event::Plan' => '1.302140', + 'Test2::Event::Skip' => '1.302140', + 'Test2::Event::Subtest' => '1.302140', + 'Test2::Event::TAP::Version'=> '1.302140', + 'Test2::Event::V2' => '1.302140', + 'Test2::Event::Waiting' => '1.302140', + 'Test2::EventFacet' => '1.302140', + 'Test2::EventFacet::About'=> '1.302140', + 'Test2::EventFacet::Amnesty'=> '1.302140', + 'Test2::EventFacet::Assert'=> '1.302140', + 'Test2::EventFacet::Control'=> '1.302140', + 'Test2::EventFacet::Error'=> '1.302140', + 'Test2::EventFacet::Hub'=> '1.302140', + 'Test2::EventFacet::Info'=> '1.302140', + 'Test2::EventFacet::Meta'=> '1.302140', + 'Test2::EventFacet::Parent'=> '1.302140', + 'Test2::EventFacet::Plan'=> '1.302140', + 'Test2::EventFacet::Render'=> '1.302140', + 'Test2::EventFacet::Trace'=> '1.302140', + 'Test2::Formatter' => '1.302140', + 'Test2::Formatter::TAP' => '1.302140', + 'Test2::Hub' => '1.302140', + 'Test2::Hub::Interceptor'=> '1.302140', + 'Test2::Hub::Interceptor::Terminator'=> '1.302140', + 'Test2::Hub::Subtest' => '1.302140', + 'Test2::IPC' => '1.302140', + 'Test2::IPC::Driver' => '1.302140', + 'Test2::IPC::Driver::Files'=> '1.302140', + 'Test2::Tools::Tiny' => '1.302140', + 'Test2::Util' => '1.302140', + 'Test2::Util::ExternalMeta'=> '1.302140', + 'Test2::Util::Facets2Legacy'=> '1.302140', + 'Test2::Util::HashBase' => '1.302140', + 'Test2::Util::Trace' => '1.302140', + 'Test::Builder' => '1.302140', + 'Test::Builder::Formatter'=> '1.302140', + 'Test::Builder::Module' => '1.302140', + 'Test::Builder::Tester' => '1.302140', + 'Test::Builder::Tester::Color'=> '1.302140', + 'Test::Builder::TodoDiag'=> '1.302140', + 'Test::More' => '1.302140', + 'Test::Simple' => '1.302140', + 'Test::Tester' => '1.302140', + 'Test::Tester::Capture' => '1.302140', + 'Test::Tester::CaptureRunner'=> '1.302140', + 'Test::Tester::Delegate'=> '1.302140', + 'Test::use::ok' => '1.302140', + 'Time::HiRes' => '1.9760', + 'Time::Piece' => '1.33', + 'Time::Seconds' => '1.33', + 'Unicode' => '11.0.0', + 'ok' => '1.302140', + 'warnings' => '1.43', + }, + removed => { + } + }, + 5.029003 => { + delta_from => 5.029002, + changed => { + 'Archive::Tar' => '2.32', + 'Archive::Tar::Constant'=> '2.32', + 'Archive::Tar::File' => '2.32', + 'B::Op_private' => '5.029003', + 'Config' => '5.029003', + 'Data::Dumper' => '2.172', + 'Devel::PPPort' => '3.43', + 'File::Path' => '2.16', + 'File::Spec' => '3.75', + 'File::Spec::AmigaOS' => '3.75', + 'File::Spec::Cygwin' => '3.75', + 'File::Spec::Epoc' => '3.75', + 'File::Spec::Functions' => '3.75', + 'File::Spec::Mac' => '3.75', + 'File::Spec::OS2' => '3.75', + 'File::Spec::Unix' => '3.75', + 'File::Spec::VMS' => '3.75', + 'File::Spec::Win32' => '3.75', + 'Module::CoreList' => '5.20180920', + 'Module::CoreList::Utils'=> '5.20180920', + 'POSIX' => '1.85', + 'Storable' => '3.13', + 'User::grent' => '1.03', + 'perlfaq' => '5.20180915', + }, + removed => { + 'Locale::Codes' => 1, + 'Locale::Codes::Constants'=> 1, + 'Locale::Codes::Country'=> 1, + 'Locale::Codes::Country_Codes'=> 1, + 'Locale::Codes::Country_Retired'=> 1, + 'Locale::Codes::Currency'=> 1, + 'Locale::Codes::Currency_Codes'=> 1, + 'Locale::Codes::Currency_Retired'=> 1, + 'Locale::Codes::LangExt'=> 1, + 'Locale::Codes::LangExt_Codes'=> 1, + 'Locale::Codes::LangExt_Retired'=> 1, + 'Locale::Codes::LangFam'=> 1, + 'Locale::Codes::LangFam_Codes'=> 1, + 'Locale::Codes::LangFam_Retired'=> 1, + 'Locale::Codes::LangVar'=> 1, + 'Locale::Codes::LangVar_Codes'=> 1, + 'Locale::Codes::LangVar_Retired'=> 1, + 'Locale::Codes::Language'=> 1, + 'Locale::Codes::Language_Codes'=> 1, + 'Locale::Codes::Language_Retired'=> 1, + 'Locale::Codes::Script' => 1, + 'Locale::Codes::Script_Codes'=> 1, + 'Locale::Codes::Script_Retired'=> 1, + 'Locale::Country' => 1, + 'Locale::Currency' => 1, + 'Locale::Language' => 1, + 'Locale::Script' => 1, + } + }, + 5.029004 => { + delta_from => 5.029003, + changed => { + 'App::Cpan' => '1.671', + 'B' => '1.75', + 'B::Concise' => '1.004', + 'B::Deparse' => '1.49', + 'B::Op_private' => '5.029004', + 'B::Terse' => '1.09', + 'CPAN' => '2.21', + 'CPAN::Distribution' => '2.21', + 'CPAN::Mirrors' => '2.21', + 'CPAN::Plugin' => '0.97', + 'CPAN::Shell' => '5.5008', + 'Config' => '5.029004', + 'Devel::Peek' => '1.28', + 'File::Copy' => '2.34', + 'File::Glob' => '1.32', + 'Math::BigFloat::Trace' => '0.51', + 'Math::BigInt::Trace' => '0.51', + 'Module::CoreList' => '5.20181020', + 'Module::CoreList::Utils'=> '5.20181020', + 'Unicode::UCD' => '0.72', + 'bigint' => '0.51', + 'bignum' => '0.51', + 'bigrat' => '0.51', + 'bytes' => '1.07', + 'feature' => '1.54', + 'sigtrap' => '1.09', + 'vars' => '1.05', + }, + removed => { + 'B::Debug' => 1, + 'arybase' => 1, + } + }, + 5.028001 => { + delta_from => 5.028, + changed => { + 'B::Op_private' => '5.028001', + 'Config' => '5.028001', + 'Module::CoreList' => '5.20181129_28', + 'Module::CoreList::Utils'=> '5.20181129_28', + }, + removed => { + } + }, ); sub is_core { + shift if defined $_[1] and $_[1] =~ /^\w/ and _looks_like_invocant $_[0]; my $module = shift; - $module = shift if eval { $module->isa(__PACKAGE__) } && @_ > 0 && defined($_[0]) && $_[0] =~ /^\w/; - my ($module_version, $perl_version); - - $module_version = shift if @_ > 0; - $perl_version = @_ > 0 ? shift : $]; + my $module_version = @_ > 0 ? shift : undef; + my $perl_version = @_ > 0 ? shift : $]; my $first_release = first_release($module); @@ -14462,6 +15849,11 @@ sub is_core # On the way if we pass the required module version, we can # short-circuit and return true if (defined($module_version)) { + my $module_version_object = eval { version->parse($module_version) }; + if (!defined($module_version_object)) { + (my $err = $@) =~ s/^Invalid version format\b/Invalid version '$module_version' specified/; + die $err; + } # The Perl releases aren't a linear sequence, but a tree. We need to build the path # of releases from 5 to the specified release, and follow the module's version(s) # along that path. @@ -14479,7 +15871,7 @@ sub is_core last RELEASE if $prn > $perl_version; next unless defined(my $next_module_version = $delta{$prn}->{changed}->{$module}); - return 1 if version->parse($next_module_version) >= version->parse($module_version); + return 1 if eval { version->parse($next_module_version) >= $module_version_object }; } return 0; } @@ -14489,13 +15881,7 @@ sub is_core return $perl_version <= $final_release; } -for my $version (sort { $a <=> $b } keys %delta) { - my $data = $delta{$version}; - - tie %{$version{$version}}, 'Module::CoreList::TieHashDelta', - $data->{changed}, $data->{removed}, - $data->{delta_from} ? $version{$data->{delta_from}} : undef; -} +%version = _undelta(\%delta); %deprecated = ( 5.011 => { @@ -15258,15 +16644,129 @@ for my $version (sort { $a <=> $b } keys %delta) { removed => { } }, + 5.026001 => { + delta_from => 5.026000, + changed => { + }, + removed => { + } + }, + 5.027005 => { + delta_from => 5.027004, + changed => { + }, + removed => { + } + }, + 5.027006 => { + delta_from => 5.027005, + changed => { + }, + removed => { + } + }, + 5.027007 => { + delta_from => 5.027006, + changed => { + }, + removed => { + } + }, + 5.027008 => { + delta_from => 5.027007, + changed => { + }, + removed => { + } + }, + 5.027009 => { + delta_from => 5.027008, + changed => { + }, + removed => { + } + }, + 5.027010 => { + delta_from => 5.027009, + changed => { + }, + removed => { + } + }, + 5.024004 => { + delta_from => 5.024003, + changed => { + }, + removed => { + } + }, + 5.026002 => { + delta_from => 5.026001, + changed => { + }, + removed => { + } + }, + 5.027011 => { + delta_from => 5.02701, + changed => { + }, + removed => { + } + }, + 5.028000 => { + delta_from => 5.027011, + changed => { + }, + removed => { + } + }, + 5.029000 => { + delta_from => 5.028, + changed => { + }, + removed => { + } + }, + 5.029001 => { + delta_from => 5.029, + changed => { + }, + removed => { + } + }, + 5.029002 => { + delta_from => 5.029001, + changed => { + }, + removed => { + } + }, + 5.029003 => { + delta_from => 5.029002, + changed => { + }, + removed => { + } + }, + 5.029004 => { + delta_from => 5.029003, + changed => { + }, + removed => { + arybase => '1', + } + }, + 5.028001 => { + delta_from => 5.028000, + changed => { + }, + removed => { + } + }, ); -for my $version (sort { $a <=> $b } keys %deprecated) { - my $data = $deprecated{$version}; - - tie %{ $deprecated{$version} }, 'Module::CoreList::TieHashDelta', - $data->{changed}, $data->{removed}, - $data->{delta_from} ? $deprecated{ $data->{delta_from} } : undef; -} +%deprecated = _undelta(\%deprecated); %upstream = ( 'App::Cpan' => 'cpan', @@ -15330,7 +16830,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Compress::Zlib' => 'cpan', 'Config::Perl::V' => 'cpan', 'DB_File' => 'cpan', - 'Devel::PPPort' => 'cpan', 'Digest' => 'cpan', 'Digest::MD5' => 'cpan', 'Digest::SHA' => 'cpan', @@ -15479,6 +16978,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Math::BigInt::Calc' => 'cpan', 'Math::BigInt::CalcEmu' => 'cpan', 'Math::BigInt::FastCalc'=> 'cpan', + 'Math::BigInt::Lib' => 'cpan', 'Math::BigInt::Trace' => 'cpan', 'Math::BigRat' => 'cpan', 'Math::Complex' => 'cpan', @@ -15495,9 +16995,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Module::Load::Conditional'=> 'cpan', 'Module::Loaded' => 'cpan', 'Module::Metadata' => 'cpan', - 'Module::Metadata::corpus::BOMTest::UTF16BE'=> 'cpan', - 'Module::Metadata::corpus::BOMTest::UTF16LE'=> 'cpan', - 'Module::Metadata::corpus::BOMTest::UTF8'=> 'cpan', 'NEXT' => 'cpan', 'Net::Cmd' => 'cpan', 'Net::Config' => 'cpan', @@ -15623,11 +17120,63 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'TAP::Parser::YAMLish::Writer'=> 'cpan', 'Term::ANSIColor' => 'cpan', 'Term::Cap' => 'cpan', + 'Test2' => 'cpan', + 'Test2::API' => 'cpan', + 'Test2::API::Breakage' => 'cpan', + 'Test2::API::Context' => 'cpan', + 'Test2::API::Instance' => 'cpan', + 'Test2::API::Stack' => 'cpan', + 'Test2::Event' => 'cpan', + 'Test2::Event::Bail' => 'cpan', + 'Test2::Event::Diag' => 'cpan', + 'Test2::Event::Encoding'=> 'cpan', + 'Test2::Event::Exception'=> 'cpan', + 'Test2::Event::Fail' => 'cpan', + 'Test2::Event::Generic' => 'cpan', + 'Test2::Event::Note' => 'cpan', + 'Test2::Event::Ok' => 'cpan', + 'Test2::Event::Pass' => 'cpan', + 'Test2::Event::Plan' => 'cpan', + 'Test2::Event::Skip' => 'cpan', + 'Test2::Event::Subtest' => 'cpan', + 'Test2::Event::TAP::Version'=> 'cpan', + 'Test2::Event::V2' => 'cpan', + 'Test2::Event::Waiting' => 'cpan', + 'Test2::EventFacet' => 'cpan', + 'Test2::EventFacet::About'=> 'cpan', + 'Test2::EventFacet::Amnesty'=> 'cpan', + 'Test2::EventFacet::Assert'=> 'cpan', + 'Test2::EventFacet::Control'=> 'cpan', + 'Test2::EventFacet::Error'=> 'cpan', + 'Test2::EventFacet::Hub'=> 'cpan', + 'Test2::EventFacet::Info'=> 'cpan', + 'Test2::EventFacet::Meta'=> 'cpan', + 'Test2::EventFacet::Parent'=> 'cpan', + 'Test2::EventFacet::Plan'=> 'cpan', + 'Test2::EventFacet::Render'=> 'cpan', + 'Test2::EventFacet::Trace'=> 'cpan', + 'Test2::Formatter' => 'cpan', + 'Test2::Formatter::TAP' => 'cpan', + 'Test2::Hub' => 'cpan', + 'Test2::Hub::Interceptor'=> 'cpan', + 'Test2::Hub::Interceptor::Terminator'=> 'cpan', + 'Test2::Hub::Subtest' => 'cpan', + 'Test2::IPC' => 'cpan', + 'Test2::IPC::Driver' => 'cpan', + 'Test2::IPC::Driver::Files'=> 'cpan', + 'Test2::Tools::Tiny' => 'cpan', + 'Test2::Util' => 'cpan', + 'Test2::Util::ExternalMeta'=> 'cpan', + 'Test2::Util::Facets2Legacy'=> 'cpan', + 'Test2::Util::HashBase' => 'cpan', + 'Test2::Util::Trace' => 'cpan', 'Test::Builder' => 'cpan', + 'Test::Builder::Formatter'=> 'cpan', 'Test::Builder::IO::Scalar'=> 'cpan', 'Test::Builder::Module' => 'cpan', 'Test::Builder::Tester' => 'cpan', 'Test::Builder::Tester::Color'=> 'cpan', + 'Test::Builder::TodoDiag'=> 'cpan', 'Test::Harness' => 'cpan', 'Test::More' => 'cpan', 'Test::Simple' => 'cpan', @@ -15653,7 +17202,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Unicode::Collate::CJK::Stroke'=> 'cpan', 'Unicode::Collate::CJK::Zhuyin'=> 'cpan', 'Unicode::Collate::Locale'=> 'cpan', - 'Unicode::Normalize' => 'cpan', 'Win32' => 'cpan', 'Win32API::File' => 'cpan', 'Win32API::File::inc::ExtUtils::Myconst2perl'=> 'cpan', @@ -15737,7 +17285,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Compress::Zlib' => undef, 'Config::Perl::V' => undef, 'DB_File' => undef, - 'Devel::PPPort' => 'https://github.com/mhx/Devel-PPPort/issues/', 'Digest' => undef, 'Digest::MD5' => undef, 'Digest::SHA' => undef, @@ -15810,7 +17357,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'File::Fetch' => undef, 'File::GlobMapper' => undef, 'File::Path' => undef, - 'File::Temp' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=File-Temp', + 'File::Temp' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=File-Temp', 'Filter::Util::Call' => undef, 'Getopt::Long' => undef, 'HTTP::Tiny' => 'https://github.com/chansen/p5-http-tiny/issues', @@ -15886,6 +17433,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Math::BigInt::Calc' => undef, 'Math::BigInt::CalcEmu' => undef, 'Math::BigInt::FastCalc'=> undef, + 'Math::BigInt::Lib' => undef, 'Math::BigInt::Trace' => undef, 'Math::BigRat' => undef, 'Math::Complex' => undef, @@ -15902,9 +17450,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Module::Load::Conditional'=> undef, 'Module::Loaded' => undef, 'Module::Metadata' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata', - 'Module::Metadata::corpus::BOMTest::UTF16BE'=> undef, - 'Module::Metadata::corpus::BOMTest::UTF16LE'=> undef, - 'Module::Metadata::corpus::BOMTest::UTF8'=> undef, 'NEXT' => undef, 'Net::Cmd' => undef, 'Net::Config' => undef, @@ -16030,11 +17575,63 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'TAP::Parser::YAMLish::Writer'=> 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness', 'Term::ANSIColor' => 'https://rt.cpan.org/Dist/Display.html?Name=Term-ANSIColor', 'Term::Cap' => undef, + 'Test2' => 'http://github.com/Test-More/test-more/issues', + 'Test2::API' => 'http://github.com/Test-More/test-more/issues', + 'Test2::API::Breakage' => 'http://github.com/Test-More/test-more/issues', + 'Test2::API::Context' => 'http://github.com/Test-More/test-more/issues', + 'Test2::API::Instance' => 'http://github.com/Test-More/test-more/issues', + 'Test2::API::Stack' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Bail' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Diag' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Encoding'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Exception'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Fail' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Generic' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Note' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Ok' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Pass' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Plan' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Skip' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Subtest' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::TAP::Version'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::V2' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Event::Waiting' => 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet' => 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::About'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Amnesty'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Assert'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Control'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Error'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Hub'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Info'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Meta'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Parent'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Plan'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Render'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::EventFacet::Trace'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Formatter' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Formatter::TAP' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Hub' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Hub::Interceptor'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Hub::Interceptor::Terminator'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Hub::Subtest' => 'http://github.com/Test-More/test-more/issues', + 'Test2::IPC' => 'http://github.com/Test-More/test-more/issues', + 'Test2::IPC::Driver' => 'http://github.com/Test-More/test-more/issues', + 'Test2::IPC::Driver::Files'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Tools::Tiny' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Util' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Util::ExternalMeta'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Util::Facets2Legacy'=> 'http://github.com/Test-More/test-more/issues', + 'Test2::Util::HashBase' => 'http://github.com/Test-More/test-more/issues', + 'Test2::Util::Trace' => 'http://github.com/Test-More/test-more/issues', 'Test::Builder' => 'http://github.com/Test-More/test-more/issues', + 'Test::Builder::Formatter'=> 'http://github.com/Test-More/test-more/issues', 'Test::Builder::IO::Scalar'=> 'http://github.com/Test-More/test-more/issues', 'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues', 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues', 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues', + 'Test::Builder::TodoDiag'=> 'http://github.com/Test-More/test-more/issues', 'Test::Harness' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness', 'Test::More' => 'http://github.com/Test-More/test-more/issues', 'Test::Simple' => 'http://github.com/Test-More/test-more/issues', @@ -16060,7 +17657,6 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Unicode::Collate::CJK::Stroke'=> undef, 'Unicode::Collate::CJK::Zhuyin'=> undef, 'Unicode::Collate::Locale'=> undef, - 'Unicode::Normalize' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Unicode-Normalize', 'Win32' => undef, 'Win32API::File' => undef, 'Win32API::File::inc::ExtUtils::Myconst2perl'=> undef, diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pod b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pod index 0ab1f611d0d..2b563ff9acf 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pod +++ b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList.pod @@ -172,9 +172,6 @@ the Unicode Character Database bundled with Perl. Available in version 3.00 and above. -C<%Module::CoreList::version> is implemented via C<Module::CoreList::TieHashDelta> -using this hash of delta changes. - It is a hash of hashes that is keyed on perl version. Each keyed hash will have the following keys: diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm deleted file mode 100644 index cdb1df78528..00000000000 --- a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm +++ /dev/null @@ -1,79 +0,0 @@ -# For internal Module::CoreList use only. -package Module::CoreList::TieHashDelta; -use strict; -use vars qw($VERSION); - -$VERSION = '5.20170922_24'; - -sub TIEHASH { - my ($class, $changed, $removed, $parent) = @_; - - return bless { - changed => $changed, - removed => $removed, - parent => $parent, - keys_inflated => 0, - }, $class; -} - -sub FETCH { - my ($self, $key) = @_; - - if (exists $self->{changed}{$key}) { - return $self->{changed}{$key}; - } elsif (exists $self->{removed}{$key}) { - return undef; - } elsif (defined $self->{parent}) { - return $self->{parent}{$key}; - } - return undef; -} - -sub EXISTS { - my ($self, $key) = @_; - - restart: - if (exists $self->{changed}{$key}) { - return 1; - } elsif (exists $self->{removed}{$key}) { - return ''; - } elsif (defined $self->{parent}) { - $self = tied %{$self->{parent}}; #avoid extreme magic/tie recursion - goto restart; - } - return ''; -} - -sub FIRSTKEY { - my ($self) = @_; - - if (not $self->{keys_inflated}) { - # exceeds the warning limit of 100 calls since 5.23.2 - no warnings 'recursion'; - - # This inflates the whole set of hashes... Somewhat expensive, but saves - # many tied hash calls later. - my @parent_keys; - if (defined $self->{parent}) { - @parent_keys = keys %{$self->{parent}}; - } - - @parent_keys = grep !exists $self->{removed}{$_}, @parent_keys; - for my $key (@parent_keys) { - next if exists $self->{changed}->{$key}; - $self->{changed}{$key} = $self->{parent}{$key}; - } - - $self->{keys_inflated} = 1; - } - - keys %{$self->{changed}}; # reset each - $self->NEXTKEY; -} - -sub NEXTKEY { - my ($self) = @_; - each %{$self->{changed}}; -} - -1; diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index 5fc8645cf1c..d2d8a4e95a9 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/Utils.pm +++ b/gnu/usr.bin/perl/dist/Module-CoreList/lib/Module/CoreList/Utils.pm @@ -2,11 +2,10 @@ package Module::CoreList::Utils; use strict; use warnings; -use vars qw[$VERSION %utilities]; use Module::CoreList; -use Module::CoreList::TieHashDelta; -$VERSION = '5.20170922_24'; +our $VERSION = '5.20181129_28'; +our %utilities; sub utilities { my $perl = shift; @@ -1320,15 +1319,128 @@ my %delta = ( removed => { } }, + 5.026001 => { + delta_from => 5.026000, + changed => { + }, + removed => { + } + }, + 5.027005 => { + delta_from => 5.027004, + changed => { + }, + removed => { + } + }, + 5.027006 => { + delta_from => 5.027005, + changed => { + }, + removed => { + } + }, + 5.027007 => { + delta_from => 5.027006, + changed => { + }, + removed => { + } + }, + 5.027008 => { + delta_from => 5.027007, + changed => { + }, + removed => { + } + }, + 5.027009 => { + delta_from => 5.027008, + changed => { + }, + removed => { + } + }, + 5.027010 => { + delta_from => 5.027009, + changed => { + }, + removed => { + } + }, + 5.024004 => { + delta_from => 5.024003, + changed => { + }, + removed => { + } + }, + 5.026002 => { + delta_from => 5.026001, + changed => { + }, + removed => { + } + }, + 5.027011 => { + delta_from => 5.027010, + changed => { + }, + removed => { + } + }, + 5.028000 => { + delta_from => 5.027011, + changed => { + }, + removed => { + } + }, + 5.029000 => { + delta_from => 5.028, + changed => { + }, + removed => { + } + }, + 5.029001 => { + delta_from => 5.029000, + changed => { + }, + removed => { + } + }, + 5.029002 => { + delta_from => 5.029001, + changed => { + }, + removed => { + } + }, + 5.029003 => { + delta_from => 5.029002, + changed => { + }, + removed => { + } + }, + 5.029004 => { + delta_from => 5.029003, + changed => { + }, + removed => { + } + }, + 5.028001 => { + delta_from => 5.028000, + changed => { + }, + removed => { + } + }, ); -for my $version (sort { $a <=> $b } keys %delta) { - my $data = $delta{$version}; - - tie %{$utilities{$version}}, 'Module::CoreList::TieHashDelta', - $data->{changed}, $data->{removed}, - $data->{delta_from} ? $utilities{$data->{delta_from}} : undef; -} +%utilities = Module::CoreList::_undelta(\%delta); # Create aliases with trailing zeros for $] use diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/t/is_core.t b/gnu/usr.bin/perl/dist/Module-CoreList/t/is_core.t index 3903703fb8d..70f13a83241 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/t/is_core.t +++ b/gnu/usr.bin/perl/dist/Module-CoreList/t/is_core.t @@ -1,7 +1,7 @@ #!perl -w use strict; use Module::CoreList; -use Test::More tests => 43; +use Test::More tests => 44; BEGIN { require_ok('Module::CoreList'); } @@ -82,3 +82,6 @@ ok(! Module::CoreList->is_core("CGI", undef, 5.021001), "CGI not in 5.021001"); ok( Module::CoreList::is_core("Config", 0, "5.020"), "Config v0+ is in core in 5.020"); ok( Module::CoreList::is_core("Config", undef, "5.020"), "Config v(undef) is in core in 5.020"); + +eval { Module::CoreList::is_core('Config', 'invalid', '5.020'); }; +like( $@, qr/^Invalid version 'invalid' specified\b/, 'invalid version throws'); diff --git a/gnu/usr.bin/perl/dist/Net-Ping/lib/Net/Ping.pm b/gnu/usr.bin/perl/dist/Net-Ping/lib/Net/Ping.pm index 86b0dfd3f51..5aa32429cc1 100644 --- a/gnu/usr.bin/perl/dist/Net-Ping/lib/Net/Ping.pm +++ b/gnu/usr.bin/perl/dist/Net-Ping/lib/Net/Ping.pm @@ -4,31 +4,45 @@ require 5.002; require Exporter; use strict; -use vars qw(@ISA @EXPORT $VERSION - $def_timeout $def_proto $def_factor - $max_datasize $pingstring $hires $source_verify $syn_forking); +our $hires; use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); -use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR IPPROTO_IP IP_TOS IP_TTL - inet_aton getnameinfo NI_NUMERICHOST sockaddr_in ); -use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG ); +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP + SOL_SOCKET SO_ERROR SO_BROADCAST + IPPROTO_IP IP_TOS IP_TTL + inet_ntoa inet_aton getnameinfo sockaddr_in ); +use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN + WNOHANG ); use FileHandle; use Carp; use Time::HiRes; -@ISA = qw(Exporter); -@EXPORT = qw(pingecho); -$VERSION = "2.43_01"; +our @ISA = qw(Exporter); +our @EXPORT = qw(pingecho); +our @EXPORT_OK = qw(wakeonlan); +our $VERSION = "2.62"; -# Constants +# Globals -$def_timeout = 5; # Default timeout to wait for a reply -$def_proto = "tcp"; # Default protocol to use for pinging -$def_factor = 1.2; # Default exponential backoff rate. -$max_datasize = 1024; # Maximum data bytes in a packet +our $def_timeout = 5; # Default timeout to wait for a reply +our $def_proto = "tcp"; # Default protocol to use for pinging +our $def_factor = 1.2; # Default exponential backoff rate. +our $def_family = AF_INET; # Default family. +our $max_datasize = 1024; # Maximum data bytes in a packet # The data we exchange with the server for the stream protocol -$pingstring = "pingschwingping!\n"; -$source_verify = 1; # Default is to verify source endpoint -$syn_forking = 0; +our $pingstring = "pingschwingping!\n"; +our $source_verify = 1; # Default is to verify source endpoint +our $syn_forking = 0; + +# Constants + +my $AF_INET6 = eval { Socket::AF_INET6() } || 30; +my $AF_UNSPEC = eval { Socket::AF_UNSPEC() }; +my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4; +my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2; +my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41; +#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255 +my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; +my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; if ($^O =~ /Win32/i) { # Hack to avoid this Win32 spewage: @@ -50,10 +64,6 @@ if ($^O =~ /Win32/i) { # $syn_forking = 1; # XXX possibly useful in < Win2K ? }; -# h2ph "asm/socket.h" -# require "asm/socket.ph"; -sub SO_BINDTODEVICE {25;} - # Description: The pingecho() subroutine is provided for backward # compatibility with the original Net::Ping. It accepts a host # name/IP and an optional timeout in seconds. Create a tcp ping @@ -86,6 +96,7 @@ sub new $device, # Optional device to use $tos, # Optional ToS to set $ttl, # Optional TTL to set + $family, # Optional address family (AF_INET) ) = @_; my $class = ref($this) || $this; my $self = {}; @@ -94,148 +105,229 @@ sub new ); bless($self, $class); + if (ref $proto eq 'HASH') { # support named args + for my $k (qw(proto timeout data_size device tos ttl family + gateway host port bind retrans pingstring source_verify + econnrefused dontfrag + IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT)) + { + if (exists $proto->{$k}) { + $self->{$k} = $proto->{$k}; + # some are still globals + if ($k eq 'pingstring') { $pingstring = $proto->{$k} } + if ($k eq 'source_verify') { $source_verify = $proto->{$k} } + delete $proto->{$k}; + } + } + if (%$proto) { + croak("Invalid named argument: ",join(" ",keys (%$proto))); + } + $proto = $self->{'proto'}; + } $proto = $def_proto unless $proto; # Determine the protocol - croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"') - unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/; - $self->{"proto"} = $proto; + croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"') + unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/; + $self->{proto} = $proto; $timeout = $def_timeout unless $timeout; # Determine the timeout croak("Default timeout for ping must be greater than 0 seconds") if $timeout <= 0; - $self->{"timeout"} = $timeout; + $self->{timeout} = $timeout; - $self->{"device"} = $device; + $self->{device} = $device; - $self->{"tos"} = $tos; + $self->{tos} = $tos; + + if ($self->{'host'}) { + my $host = $self->{'host'}; + my $ip = _resolv($host) + or croak("could not resolve host $host"); + $self->{host} = $ip; + $self->{family} = $ip->{family}; + } - if ($self->{"proto"} eq 'icmp') { + if ($self->{bind}) { + my $addr = $self->{bind}; + my $ip = _resolv($addr) + or croak("could not resolve local addr $addr"); + $self->{local_addr} = $ip; + } else { + $self->{local_addr} = undef; # Don't bind by default + } + + if ($self->{proto} eq 'icmp') { croak('TTL must be from 0 to 255') if ($ttl && ($ttl < 0 || $ttl > 255)); - $self->{"ttl"} = $ttl; + $self->{ttl} = $ttl; + } + + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family} = AF_INET; + } else { + $self->{family} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family} = $def_family; } $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; croak("Data for ping must be from $min_datasize to $max_datasize bytes") if ($data_size < $min_datasize) || ($data_size > $max_datasize); - $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte - $self->{"data_size"} = $data_size; + $data_size-- if $self->{proto} eq "udp"; # We provide the first byte + $self->{data_size} = $data_size; - $self->{"data"} = ""; # Construct data bytes - for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++) + $self->{data} = ""; # Construct data bytes + for ($cnt = 0; $cnt < $self->{data_size}; $cnt++) { - $self->{"data"} .= chr($cnt % 256); + $self->{data} .= chr($cnt % 256); } - $self->{"local_addr"} = undef; # Don't bind by default - $self->{"retrans"} = $def_factor; # Default exponential backoff rate - $self->{"econnrefused"} = undef; # Default Connection refused behavior + # Default exponential backoff rate + $self->{retrans} = $def_factor unless exists $self->{retrans}; + # Default Connection refused behavior + $self->{econnrefused} = undef unless exists $self->{econnrefused}; - $self->{"seq"} = 0; # For counting packets - if ($self->{"proto"} eq "udp") # Open a socket + $self->{seq} = 0; # For counting packets + if ($self->{proto} eq "udp") # Open a socket { - $self->{"proto_num"} = eval { (getprotobyname('udp'))[2] } || + $self->{proto_num} = eval { (getprotobyname('udp'))[2] } || croak("Can't udp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || - croak("Can't get udp echo port by name"); - $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, PF_INET, SOCK_DGRAM, - $self->{"proto_num"}) || + $self->{port_num} = $self->{port} + || (getservbyname('echo', 'udp'))[2] + || croak("Can't get udp echo port by name"); + $self->{fh} = FileHandle->new(); + socket($self->{fh}, PF_INET, SOCK_DGRAM, + $self->{proto_num}) || croak("udp socket error - $!"); - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak "error binding to device $self->{'device'} $!"; - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } + $self->_setopts(); } - elsif ($self->{"proto"} eq "icmp") + elsif ($self->{proto} eq "icmp") { - croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin'); - $self->{"proto_num"} = eval { (getprotobyname('icmp'))[2] } || + croak("icmp ping requires root privilege") if !_isroot(); + $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } || croak("Can't get icmp protocol by name"); - $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid - $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) || + $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{fh} = FileHandle->new(); + socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) || + croak("icmp socket error - $!"); + $self->_setopts(); + if ($self->{'ttl'}) { + setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) + or croak "error configuring ttl to $self->{'ttl'} $!"; + } + } + elsif ($self->{proto} eq "icmpv6") + { + croak("icmpv6 ping requires root privilege") if !_isroot(); + croak("Wrong family $self->{family} for icmpv6 protocol") + if $self->{family} and $self->{family} != $AF_INET6; + $self->{family} = $AF_INET6; + $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } || + croak("Can't get ipv6-icmp protocol by name"); # 58 + $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{fh} = FileHandle->new(); + socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) || croak("icmp socket error - $!"); - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak "error binding to device $self->{'device'} $!"; + $self->_setopts(); + if ($self->{'gateway'}) { + my $g = $self->{gateway}; + my $ip = _resolv($g) + or croak("nonexistent gateway $g"); + $self->{family} eq $AF_INET6 + or croak("gateway requires the AF_INET6 family"); + $ip->{family} eq $AF_INET6 + or croak("gateway address needs to be IPv6"); + my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21 + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip)) + or croak "error configuring gateway to $g NEXTHOP $!"; + } + if (exists $self->{IPV6_USE_MIN_MTU}) { + my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, + pack("I*", $self->{'IPV6_USE_MIN_MT'})) + or croak "error configuring IPV6_USE_MIN_MT} $!"; + } + if (exists $self->{IPV6_RECVPATHMTU}) { + my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, + pack("I*", $self->{'RECVPATHMTU'})) + or croak "error configuring IPV6_RECVPATHMTU $!"; } if ($self->{'tos'}) { - setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) + my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; + setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } if ($self->{'ttl'}) { - setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) + my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; + setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'})) or croak "error configuring ttl to $self->{'ttl'} $!"; } } - elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream") + elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream") { - $self->{"proto_num"} = eval { (getprotobyname('tcp'))[2] } || + $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || croak("Can't get tcp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || - croak("Can't get tcp echo port by name"); - $self->{"fh"} = FileHandle->new(); + $self->{port_num} = $self->{port} + || (getservbyname('echo', 'tcp'))[2] + || croak("Can't get tcp echo port by name"); + $self->{fh} = FileHandle->new(); } - elsif ($self->{"proto"} eq "syn") + elsif ($self->{proto} eq "syn") { - $self->{"proto_num"} = eval { (getprotobyname('tcp'))[2] } || + $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || croak("Can't get tcp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || + $self->{port_num} = (getservbyname('echo', 'tcp'))[2] || croak("Can't get tcp echo port by name"); if ($syn_forking) { - $self->{"fork_rd"} = FileHandle->new(); - $self->{"fork_wr"} = FileHandle->new(); - pipe($self->{"fork_rd"}, $self->{"fork_wr"}); - $self->{"fh"} = FileHandle->new(); - $self->{"good"} = {}; - $self->{"bad"} = {}; + $self->{fork_rd} = FileHandle->new(); + $self->{fork_wr} = FileHandle->new(); + pipe($self->{fork_rd}, $self->{fork_wr}); + $self->{fh} = FileHandle->new(); + $self->{good} = {}; + $self->{bad} = {}; } else { - $self->{"wbits"} = ""; - $self->{"bad"} = {}; + $self->{wbits} = ""; + $self->{bad} = {}; } - $self->{"syn"} = {}; - $self->{"stop_time"} = 0; - } - elsif ($self->{"proto"} eq "external") - { - # No preliminary work needs to be done. + $self->{syn} = {}; + $self->{stop_time} = 0; } return($self); } # Description: Set the local IP address from which pings will be sent. -# For ICMP and UDP pings, this calls bind() on the already-opened socket; -# for TCP pings, just saves the address to be used when the socket is -# opened. Returns non-zero if successful; croaks on error. +# For ICMP, UDP and TCP pings, just saves the address to be used when +# the socket is opened. Returns non-zero if successful; croaks on error. sub bind { my ($self, $local_addr # Name or IP number of local interface ) = @_; - my ($ip # Packed IP number of $local_addr + my ($ip, # Hash of addr (string), addr_in (packed), family + $h # resolved hash ); croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; - croak("already bound") if defined($self->{"local_addr"}) && - ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp"); + croak("already bound") if defined($self->{local_addr}) && + ($self->{proto} eq "udp" || $self->{proto} eq "icmp"); - $ip = inet_aton($local_addr); + $ip = $self->_resolv($local_addr); croak("nonexistent local address $local_addr") unless defined($ip); - $self->{"local_addr"} = $ip; # Only used if proto is tcp + $self->{local_addr} = $ip; - if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp") - { - CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) || - croak("$self->{'proto'} bind error - $!"); - } - elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn")) + if (($self->{proto} ne "udp") && + ($self->{proto} ne "icmp") && + ($self->{proto} ne "tcp") && + ($self->{proto} ne "syn")) { croak("Unknown protocol \"$self->{proto}\" in bind()"); } @@ -291,8 +383,8 @@ sub source_verify sub service_check { my $self = shift; - $self->{"econnrefused"} = 1 unless defined - ($self->{"econnrefused"} = shift()); + $self->{econnrefused} = 1 unless defined + ($self->{econnrefused} = shift()); } sub tcp_service_check @@ -307,7 +399,95 @@ sub tcp_service_check sub retrans { my $self = shift; - $self->{"retrans"} = shift; + $self->{retrans} = shift; +} + +sub _IsAdminUser { + return unless $^O eq 'MSWin32' or $^O eq "cygwin"; + return unless eval { require Win32 }; + return unless defined &Win32::IsAdminUser; + return Win32::IsAdminUser(); +} + +sub _isroot { + if (($> and $^O ne 'VMS' and $^O ne 'cygwin') + or (($^O eq 'MSWin32' or $^O eq 'cygwin') + and !_IsAdminUser()) + or ($^O eq 'VMS' + and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) { + return 0; + } + else { + return 1; + } +} + +# Description: Sets ipv6 reachability +# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root. + +sub IPV6_REACHCONF +{ + my $self = shift; + my $on = shift; + if ($on) { + my $reachconf = eval { Socket::IPV6_REACHCONF() }; + if (!$reachconf) { + carp "IPV6_REACHCONF not supported on this platform"; + return 0; + } + if (!_isroot()) { + carp "IPV6_REACHCONF requires root permissions"; + return 0; + } + $self->{IPV6_REACHCONF} = 1; + } + else { + return $self->{IPV6_REACHCONF}; + } +} + +# Description: set it on or off. + +sub IPV6_USE_MIN_MTU +{ + my $self = shift; + my $on = shift; + if (defined $on) { + my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43; + #if (!$IPV6_USE_MIN_MTU) { + # carp "IPV6_USE_MIN_MTU not supported on this platform"; + # return 0; + #} + $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, + pack("I*", $self->{'IPV6_USE_MIN_MT'})) + or croak "error configuring IPV6_USE_MIN_MT} $!"; + } + else { + return $self->{IPV6_USE_MIN_MTU}; + } +} + +# Description: notify an according MTU + +sub IPV6_RECVPATHMTU +{ + my $self = shift; + my $on = shift; + if ($on) { + my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; + #if (!$RECVPATHMTU) { + # carp "IPV6_RECVPATHMTU not supported on this platform"; + # return 0; + #} + $self->{IPV6_RECVPATHMTU} = 1; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, + pack("I*", $self->{'IPV6_RECVPATHMTU'})) + or croak "error configuring IPV6_RECVPATHMTU} $!"; + } + else { + return $self->{IPV6_RECVPATHMTU}; + } } # Description: allows the module to use milliseconds as returned by @@ -364,37 +544,56 @@ sub ping my ($self, $host, # Name or IP number of host to ping $timeout, # Seconds after which ping times out + $family, # Address family ) = @_; - my ($ip, # Packed IP number of $host + my ($ip, # Hash of addr (string), addr_in (packed), family $ret, # The return value $ping_time, # When ping began ); - croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3; - $timeout = $self->{"timeout"} unless $timeout; + $host = $self->{host} if !defined $host and $self->{host}; + croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host; + $timeout = $self->{timeout} unless $timeout; croak("Timeout must be greater than 0 seconds") if $timeout <= 0; - $ip = inet_aton($host); + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family_local} = AF_INET; + } else { + $self->{family_local} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family_local} = $self->{family}; + } + + $ip = $self->_resolv($host); return () unless defined($ip); # Does host exist? # Dispatch to the appropriate routine. $ping_time = &time(); - if ($self->{"proto"} eq "external") { + if ($self->{proto} eq "external") { $ret = $self->ping_external($ip, $timeout); } - elsif ($self->{"proto"} eq "udp") { + elsif ($self->{proto} eq "udp") { $ret = $self->ping_udp($ip, $timeout); } - elsif ($self->{"proto"} eq "icmp") { + elsif ($self->{proto} eq "icmp") { $ret = $self->ping_icmp($ip, $timeout); } - elsif ($self->{"proto"} eq "tcp") { + elsif ($self->{proto} eq "icmpv6") { + $ret = $self->ping_icmpv6($ip, $timeout); + } + elsif ($self->{proto} eq "tcp") { $ret = $self->ping_tcp($ip, $timeout); } - elsif ($self->{"proto"} eq "stream") { + elsif ($self->{proto} eq "stream") { $ret = $self->ping_stream($ip, $timeout); } - elsif ($self->{"proto"} eq "syn") { + elsif ($self->{proto} eq "syn") { $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout); } else { croak("Unknown protocol \"$self->{proto}\" in ping()"); @@ -406,33 +605,47 @@ sub ping # Uses Net::Ping::External to do an external ping. sub ping_external { my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out + $ip, # Hash of addr (string), addr_in (packed), family + $timeout, # Seconds after which ping times out + $family ) = @_; + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + my @addr = exists $ip->{addr_in} + ? ('ip' => $ip->{addr_in}) + : ('host' => $ip->{host}); + eval { local @INC = @INC; pop @INC if $INC[-1] eq '.'; require Net::Ping::External; - } - or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); - return Net::Ping::External::ping(ip => $ip, timeout => $timeout); + } or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); + return Net::Ping::External::ping(@addr, timeout => $timeout, + family => $family); } +# h2ph "asm/socket.h" +# require "asm/socket.ph"; +use constant SO_BINDTODEVICE => 25; use constant ICMP_ECHOREPLY => 0; # ICMP packet types +use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types use constant ICMP_UNREACHABLE => 3; # ICMP packet types +use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types use constant ICMP_ECHO => 8; +use constant ICMPv6_ECHO => 128; use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY use constant ICMP_FLAGS => 0; # No special flags for send or recv use constant ICMP_PORT => 0; # No port with ICMP +use constant IP_MTU_DISCOVER => 10; # linux only sub ping_icmp { my ($self, - $ip, # Packed IP number of the host + $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; @@ -457,22 +670,47 @@ sub ping_icmp $from_msg # ICMP message ); - $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + + socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) || + croak("icmp socket error - $!"); + + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("icmp bind error - $!"); + } + $self->_setopts(); + + $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence $checksum = 0; # No checksum for starters - $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, - $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + if ($ip->{family} == AF_INET) { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } else { + # how to get SRC + my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), "\0", 0x003a); + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + $msg = $pseudo_header.$msg + } $checksum = Net::Ping->checksum($msg); - $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, - $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + if ($ip->{family} == AF_INET) { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } else { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } $len_msg = length($msg); - $saddr = sockaddr_in(ICMP_PORT, $ip); - $self->{"from_ip"} = undef; - $self->{"from_type"} = undef; - $self->{"from_subcode"} = undef; - send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message + $saddr = _pack_sockaddr_in(ICMP_PORT, $ip); + $self->{from_ip} = undef; + $self->{from_type} = undef; + $self->{from_subcode} = undef; + send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message $rbits = ""; - vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + vec($rbits, $self->{fh}->fileno(), 1) = 1; $ret = 0; $done = 0; $finish_time = &time() + $timeout; # Must be done by this time @@ -490,26 +728,29 @@ sub ping_icmp $recv_msg = ""; $from_pid = -1; $from_seq = -1; - $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS); - ($from_port, $from_ip) = sockaddr_in($from_saddr); + $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS); + ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2)); if ($from_type == ICMP_ECHOREPLY) { ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) if length $recv_msg >= 28; + } elsif ($from_type == ICMPv6_ECHOREPLY) { + ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) + if length $recv_msg >= 28; } else { ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4)) if length $recv_msg >= 56; } - $self->{"from_ip"} = $from_ip; - $self->{"from_type"} = $from_type; - $self->{"from_subcode"} = $from_subcode; - next if ($from_pid != $self->{"pid"}); - next if ($from_seq != $self->{"seq"}); + $self->{from_ip} = $from_ip; + $self->{from_type} = $from_type; + $self->{from_subcode} = $from_subcode; + next if ($from_pid != $self->{pid}); + next if ($from_seq != $self->{seq}); if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out? - if ($from_type == ICMP_ECHOREPLY) { + if (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY)) { $ret = 1; - $done = 1; - } elsif ($from_type == ICMP_UNREACHABLE) { + $done = 1; + } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) { $done = 1; } elsif ($from_type == ICMP_TIME_EXCEEDED) { $ret = 0; @@ -523,11 +764,16 @@ sub ping_icmp return $ret; } +sub ping_icmpv6 +{ + shift->ping_icmp(@_); +} + sub icmp_result { my ($self) = @_; - my $ip = $self->{"from_ip"} || ""; - $ip = "\0\0\0\0" unless 4 == length $ip; - return ($self->ntop($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0)); + my $addr = $self->{from_ip} || ""; + $addr = "\0\0\0\0" unless 4 == length $addr; + return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0)); } # Description: Do a checksum on the message. Basically sum all of @@ -570,64 +816,63 @@ sub checksum sub ping_tcp { my ($self, - $ip, # Packed IP number of the host + $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; my ($ret # The return value ); + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + $! = 0; $ret = $self -> tcp_connect( $ip, $timeout); - if (!$self->{"econnrefused"} && + if (!$self->{econnrefused} && $! == ECONNREFUSED) { $ret = 1; # "Connection refused" means reachable } - $self->{"fh"}->close(); + $self->{fh}->close(); return $ret; } sub tcp_connect { my ($self, - $ip, # Packed IP number of the host + $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which connect times out ) = @_; my ($saddr); # Packed IP and Port - $saddr = sockaddr_in($self->{"port_num"}, $ip); + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + + $saddr = _pack_sockaddr_in($self->{port_num}, $ip); my $ret = 0; # Default to unreachable my $do_socket = sub { - socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) || + socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) || croak("tcp socket error - $!"); - if (defined $self->{"local_addr"} && - !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } + $self->_setopts(); }; my $do_connect = sub { - $self->{"ip"} = $ip; + $self->{ip} = $ip->{addr_in}; # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?, # we'll get (10061 & 255) = 77, so we cannot check it in the parent process. - return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"})); + return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused})); }; my $do_connect_nb = sub { # Set O_NONBLOCK property on filehandle - $self->socket_blocking_mode($self->{"fh"}, 0); + $self->socket_blocking_mode($self->{fh}, 0); # start the connection attempt - if (!connect($self->{"fh"}, $saddr)) { + if (!connect($self->{fh}, $saddr)) { if ($! == ECONNREFUSED) { - $ret = 1 unless $self->{"econnrefused"}; + $ret = 1 unless $self->{econnrefused}; } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) { # EINPROGRESS is the expected error code after a connect() # on a non-blocking socket. But if the kernel immediately @@ -641,7 +886,7 @@ sub tcp_connect # Just wait for connection completion... my ($wbits, $wout, $wexc); $wout = $wexc = $wbits = ""; - vec($wbits, $self->{"fh"}->fileno, 1) = 1; + vec($wbits, $self->{fh}->fileno, 1) = 1; my $nfound = mselect(undef, ($wout = $wbits), @@ -649,12 +894,12 @@ sub tcp_connect $timeout); warn("select: $!") unless defined $nfound; - if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) { + if ($nfound && vec($wout, $self->{fh}->fileno, 1)) { # the socket is ready for writing so the connection # attempt completed. test whether the connection # attempt was successful or not - if (getpeername($self->{"fh"})) { + if (getpeername($self->{fh})) { # Connection established to remote host $ret = 1; } else { @@ -663,10 +908,10 @@ sub tcp_connect # This should set $! to the correct error. my $char; - sysread($self->{"fh"},$char,1); + sysread($self->{fh},$char,1); $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i); - $ret = 1 if (!$self->{"econnrefused"} + $ret = 1 if (!$self->{econnrefused} && $! == ECONNREFUSED); } } else { @@ -677,8 +922,8 @@ sub tcp_connect # winsock reports ECONNREFUSED as an exception, and we # need to fetch the socket-level error code via getsockopt() # instead of using the thread-level error code that is in $!. - if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) { - $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET, + if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) { + $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET, SO_ERROR)); } } @@ -690,8 +935,8 @@ sub tcp_connect } # Unset O_NONBLOCK property on filehandle - $self->socket_blocking_mode($self->{"fh"}, 1); - $self->{"ip"} = $ip; + $self->socket_blocking_mode($self->{fh}, 1); + $self->{ip} = $ip->{addr_in}; return $ret; }; @@ -715,7 +960,7 @@ sub tcp_connect # Try a slow blocking connect() call # and report the status to the parent. if ( &{ $do_connect }() ) { - $self->{"fh"}->close(); + $self->{fh}->close(); # No error exit 0; } else { @@ -740,7 +985,7 @@ sub tcp_connect } while &time() < $patience && $child != $self->{'tcp_chld'}; if ($child == $self->{'tcp_chld'}) { - if ($self->{"proto"} eq "stream") { + if ($self->{proto} eq "stream") { # We need the socket connected here, in parent # Should be safe to connect because the child finished # within the timeout @@ -784,9 +1029,10 @@ sub DESTROY { # back. It returns 1 on success, 0 on failure. sub tcp_echo { - my $self = shift; - my $timeout = shift; - my $pingstring = shift; + my ($self, $timeout, $pingstring) = @_; + + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring}; my $ret = undef; my $time = &time(); @@ -796,18 +1042,18 @@ sub tcp_echo eval <<'EOM'; do { my $rin = ""; - vec($rin, $self->{"fh"}->fileno(), 1) = 1; + vec($rin, $self->{fh}->fileno(), 1) = 1; my $rout = undef; if($wrstr) { $rout = ""; - vec($rout, $self->{"fh"}->fileno(), 1) = 1; + vec($rout, $self->{fh}->fileno(), 1) = 1; } if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) { - if($rout && vec($rout,$self->{"fh"}->fileno(),1)) { - my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr); + if($rout && vec($rout,$self->{fh}->fileno(),1)) { + my $num = syswrite($self->{fh}, $wrstr, length $wrstr); if($num) { # If it was a partial write, update and try again. $wrstr = substr($wrstr,$num); @@ -817,9 +1063,9 @@ sub tcp_echo } } - if(vec($rin,$self->{"fh"}->fileno(),1)) { + if(vec($rin,$self->{fh}->fileno(),1)) { my $reply; - if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) { + if(sysread($self->{fh},$reply,length($pingstring)-length($rdstr))) { $rdstr .= $reply; $ret = 1 if $rdstr eq $pingstring; } else { @@ -835,9 +1081,6 @@ EOM return $ret; } - - - # Description: Perform a stream ping. If the tcp connection isn't # already open, it opens it. It then sends some data and waits for # a reply. It leaves the stream open on exit. @@ -845,17 +1088,17 @@ EOM sub ping_stream { my ($self, - $ip, # Packed IP number of the host + $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; # Open the stream if it's not already open - if(!defined $self->{"fh"}->fileno()) { + if(!defined $self->{fh}->fileno()) { $self->tcp_connect($ip, $timeout) or return 0; } croak "tried to switch servers while stream pinging" - if $self->{"ip"} ne $ip; + if $self->{ip} ne $ip->{addr_in}; return $self->tcp_echo($timeout, $pingstring); } @@ -867,15 +1110,31 @@ sub open { my ($self, $host, # Host or IP address - $timeout # Seconds after which open times out + $timeout, # Seconds after which open times out + $family ) = @_; + my $ip; # Hash of addr (string), addr_in (packed), family + $host = $self->{host} unless defined $host; - my ($ip); # Packed IP number of the host - $ip = inet_aton($host); - $timeout = $self->{"timeout"} unless $timeout; + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family_local} = AF_INET; + } else { + $self->{family_local} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family_local} = $self->{family}; + } - if($self->{"proto"} eq "stream") { - if(defined($self->{"fh"}->fileno())) { + $ip = $self->_resolv($host); + $timeout = $self->{timeout} unless $timeout; + + if($self->{proto} eq "stream") { + if(defined($self->{fh}->fileno())) { croak("socket is already open"); } else { $self->tcp_connect($ip, $timeout); @@ -883,6 +1142,43 @@ sub open } } +sub _dontfrag { + my $self = shift; + # bsd solaris + my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() }; + if ($IP_DONTFRAG) { + my $i = 1; + setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i)) + or croak "error configuring IP_DONTFRAG $!"; + # Linux needs more: Path MTU Discovery as defined in RFC 1191 + # For non SOCK_STREAM sockets it is the user's responsibility to packetize + # the data in MTU sized chunks and to do the retransmits if necessary. + # The kernel will reject packets that are bigger than the known path + # MTU if this flag is set (with EMSGSIZE). + if ($^O eq 'linux') { + my $i = 2; # IP_PMTUDISC_DO + setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i)) + or croak "error configuring IP_MTU_DISCOVER $!"; + } + } +} + +# SO_BINDTODEVICE + IP_TOS +sub _setopts { + my $self = shift; + if ($self->{'device'}) { + setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'})) + or croak "error binding to device $self->{'device'} $!"; + } + if ($self->{'tos'}) { # need to re-apply ToS (RT #6706) + setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) + or croak "error applying tos to $self->{'tos'} $!"; + } + if ($self->{'dontfrag'}) { + $self->_dontfrag; + } +} + # Description: Perform a udp echo ping. Construct a message of # at least the one-byte sequence number and any additional data bytes. @@ -895,7 +1191,7 @@ use constant UDP_FLAGS => 0; # Nothing special on send or recv sub ping_udp { my ($self, - $ip, # Packed IP number of the host + $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; @@ -914,12 +1210,23 @@ sub ping_udp $from_ip # Packed IP number of sender ); - $saddr = sockaddr_in($self->{"port_num"}, $ip); - $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence - $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any + $saddr = _pack_sockaddr_in($self->{port_num}, $ip); + $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence + $msg = chr($self->{seq}) . $self->{data}; # Add data if any + + socket($self->{fh}, $ip->{family}, SOCK_DGRAM, + $self->{proto_num}) || + croak("udp socket error - $!"); - if ($self->{"connected"}) { - if ($self->{"connected"} ne $saddr) { + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("udp bind error - $!"); + } + + $self->_setopts(); + + if ($self->{connected}) { + if ($self->{connected} ne $saddr) { # Still connected to wrong destination. # Need to flush out the old one. $flush = 1; @@ -938,23 +1245,24 @@ sub ping_udp if ($flush) { # Need to socket() again to flush the descriptor # This will disconnect from the old saddr. - socket($self->{"fh"}, PF_INET, SOCK_DGRAM, - $self->{"proto_num"}); + socket($self->{fh}, $ip->{family}, SOCK_DGRAM, + $self->{proto_num}); + $self->_setopts(); } # Connect the socket if it isn't already connected # to the right destination. if ($flush || $connect) { - connect($self->{"fh"}, $saddr); # Tie destination to socket - $self->{"connected"} = $saddr; + connect($self->{fh}, $saddr); # Tie destination to socket + $self->{connected} = $saddr; } - send($self->{"fh"}, $msg, UDP_FLAGS); # Send it + send($self->{fh}, $msg, UDP_FLAGS); # Send it $rbits = ""; - vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + vec($rbits, $self->{fh}->fileno(), 1) = 1; $ret = 0; # Default to unreachable $done = 0; my $retrans = 0.01; - my $factor = $self->{"retrans"}; + my $factor = $self->{retrans}; $finish_time = &time() + $timeout; # Ping needs to be done by then while (!$done && $timeout > 0) { @@ -975,10 +1283,10 @@ sub ping_udp elsif ($nfound) # A packet is waiting { $from_msg = ""; - $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS); + $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS); if (!$from_saddr) { # For example an unreachable host will make recv() fail. - if (!$self->{"econnrefused"} && + if (!$self->{econnrefused} && ($! == ECONNREFUSED || $! == ECONNRESET)) { # "Connection refused" means reachable @@ -987,10 +1295,11 @@ sub ping_udp } $done = 1; } else { - ($from_port, $from_ip) = sockaddr_in($from_saddr); + ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); + my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; if (!$source_verify || - (($from_ip eq $ip) && # Does the packet check out? - ($from_port == $self->{"port_num"}) && + (($from_ip eq $addr_in) && # Does the packet check out? + ($from_port == $self->{port_num}) && ($from_msg eq $msg))) { $ret = 1; # It's a winner @@ -1005,12 +1314,12 @@ sub ping_udp else { # Send another in case the last one dropped - if (send($self->{"fh"}, $msg, UDP_FLAGS)) { + if (send($self->{fh}, $msg, UDP_FLAGS)) { # Another send worked? The previous udp packet # must have gotten lost or is still in transit. # Hopefully this new packet will arrive safely. } else { - if (!$self->{"econnrefused"} && + if (!$self->{econnrefused} && $! == ECONNREFUSED) { # "Connection refused" means reachable # Good, continue @@ -1037,26 +1346,19 @@ sub ping_syn } my $fh = FileHandle->new(); - my $saddr = sockaddr_in($self->{"port_num"}, $ip); + my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); # Create TCP socket - if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) { + if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { croak("tcp socket error - $!"); } - if (defined $self->{"local_addr"} && - !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) { + if (defined $self->{local_addr} && + !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } - if ($self->{'device'}) { - setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($fh, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } + $self->_setopts(); # Set O_NONBLOCK property on filehandle $self->socket_blocking_mode($fh, 0); @@ -1075,16 +1377,16 @@ sub ping_syn } else { # Just save the error and continue on. # The ack() can check the status later. - $self->{"bad"}->{$host} = $!; + $self->{bad}->{$host} = $!; } } - my $entry = [ $host, $ip, $fh, $start_time, $stop_time ]; - $self->{"syn"}->{$fh->fileno} = $entry; - if ($self->{"stop_time"} < $stop_time) { - $self->{"stop_time"} = $stop_time; + my $entry = [ $host, $ip, $fh, $start_time, $stop_time, $self->{port_num} ]; + $self->{syn}->{$fh->fileno} = $entry; + if ($self->{stop_time} < $stop_time) { + $self->{stop_time} = $stop_time; } - vec($self->{"wbits"}, $fh->fileno, 1) = 1; + vec($self->{wbits}, $fh->fileno, 1) = 1; return 1; } @@ -1100,42 +1402,35 @@ sub ping_syn_fork { if ($pid) { # Parent process my $entry = [ $host, $ip, $pid, $start_time, $stop_time ]; - $self->{"syn"}->{$pid} = $entry; - if ($self->{"stop_time"} < $stop_time) { - $self->{"stop_time"} = $stop_time; + $self->{syn}->{$pid} = $entry; + if ($self->{stop_time} < $stop_time) { + $self->{stop_time} = $stop_time; } } else { # Child process - my $saddr = sockaddr_in($self->{"port_num"}, $ip); + my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); # Create TCP socket - if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) { + if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { croak("tcp socket error - $!"); } - if (defined $self->{"local_addr"} && - !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } + $self->_setopts(); $!=0; # Try to connect (could take a long time) - connect($self->{"fh"}, $saddr); + connect($self->{fh}, $saddr); # Notify parent of connect error status my $err = $!+0; my $wrstr = "$$ $err"; # Force to 16 chars including \n $wrstr .= " "x(15 - length $wrstr). "\n"; - syswrite($self->{"fork_wr"}, $wrstr, length $wrstr); + syswrite($self->{fork_wr}, $wrstr, length $wrstr); exit; } } else { @@ -1152,20 +1447,21 @@ sub ack { my $self = shift; - if ($self->{"proto"} eq "syn") { + if ($self->{proto} eq "syn") { if ($syn_forking) { my @answer = $self->ack_unfork(shift); return wantarray ? @answer : $answer[0]; } my $wbits = ""; my $stop_time = 0; - if (my $host = shift) { - # Host passed as arg - if (exists $self->{"bad"}->{$host}) { - if (!$self->{"econnrefused"} && - $self->{"bad"}->{ $host } && + if (my $host = shift or $self->{host}) { + # Host passed as arg or as option to new + $host = $self->{host} unless defined $host; + if (exists $self->{bad}->{$host}) { + if (!$self->{econnrefused} && + $self->{bad}->{ $host } && (($! = ECONNREFUSED)>0) && - $self->{"bad"}->{ $host } eq "$!") { + $self->{bad}->{ $host } eq "$!") { # "Connection refused" means reachable # Good, continue } else { @@ -1174,8 +1470,8 @@ sub ack } } my $host_fd = undef; - foreach my $fd (keys %{ $self->{"syn"} }) { - my $entry = $self->{"syn"}->{$fd}; + foreach my $fd (keys %{ $self->{syn} }) { + my $entry = $self->{syn}->{$fd}; if ($entry->[0] eq $host) { $host_fd = $fd; $stop_time = $entry->[4] @@ -1189,9 +1485,9 @@ sub ack } else { # No $host passed so scan all hosts # Use the latest stop_time - $stop_time = $self->{"stop_time"}; + $stop_time = $self->{stop_time}; # Use all the bits - $wbits = $self->{"wbits"}; + $wbits = $self->{wbits}; } while ($wbits !~ /^\0*\z/) { @@ -1207,8 +1503,8 @@ sub ack if (vec($wout, $fd, 1)) { # Wipe it from future scanning. vec($wout, $fd, 1) = 0; - if (my $entry = $self->{"syn"}->{$fd}) { - if ($self->{"bad"}->{ $entry->[0] }) { + if (my $entry = $self->{syn}->{$fd}) { + if ($self->{bad}->{ $entry->[0] }) { $winner_fd = $fd; last; } @@ -1229,15 +1525,15 @@ sub ack $fd++; } } - if (my $entry = $self->{"syn"}->{$fd}) { + if (my $entry = $self->{syn}->{$fd}) { # Wipe it from future scanning. - delete $self->{"syn"}->{$fd}; - vec($self->{"wbits"}, $fd, 1) = 0; + delete $self->{syn}->{$fd}; + vec($self->{wbits}, $fd, 1) = 0; vec($wbits, $fd, 1) = 0; - if (!$self->{"econnrefused"} && - $self->{"bad"}->{ $entry->[0] } && + if (!$self->{econnrefused} && + $self->{bad}->{ $entry->[0] } && (($! = ECONNREFUSED)>0) && - $self->{"bad"}->{ $entry->[0] } eq "$!") { + $self->{bad}->{ $entry->[0] } eq "$!") { # "Connection refused" means reachable # Good, continue } elsif (getpeername($entry->[2])) { @@ -1251,8 +1547,8 @@ sub ack my $char; sysread($entry->[2],$char,1); # Store the excuse why the connection failed. - $self->{"bad"}->{$entry->[0]} = $!; - if (!$self->{"econnrefused"} && + $self->{bad}->{$entry->[0]} = $!; + if (!$self->{econnrefused} && (($! == ECONNREFUSED) || ($! == EAGAIN && $^O =~ /cygwin/i))) { # "Connection refused" means reachable @@ -1264,28 +1560,28 @@ sub ack } # Everything passed okay, return the answer return wantarray ? - ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])) + ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]), $entry->[5]) : $entry->[0]; } else { warn "Corrupted SYN entry: unknown fd [$fd] ready!"; vec($wbits, $fd, 1) = 0; - vec($self->{"wbits"}, $fd, 1) = 0; + vec($self->{wbits}, $fd, 1) = 0; } } elsif (defined $nfound) { # Timed out waiting for ACK - foreach my $fd (keys %{ $self->{"syn"} }) { + foreach my $fd (keys %{ $self->{syn} }) { if (vec($wbits, $fd, 1)) { - my $entry = $self->{"syn"}->{$fd}; - $self->{"bad"}->{$entry->[0]} = "Timed out"; + my $entry = $self->{syn}->{$fd}; + $self->{bad}->{$entry->[0]} = "Timed out"; vec($wbits, $fd, 1) = 0; - vec($self->{"wbits"}, $fd, 1) = 0; - delete $self->{"syn"}->{$fd}; + vec($self->{wbits}, $fd, 1) = 0; + delete $self->{syn}->{$fd}; } } } else { # Weird error occurred with select() warn("select: $!"); - $self->{"syn"} = {}; + $self->{syn} = {}; $wbits = ""; } } @@ -1295,11 +1591,11 @@ sub ack sub ack_unfork { my ($self,$host) = @_; - my $stop_time = $self->{"stop_time"}; + my $stop_time = $self->{stop_time}; if ($host) { # Host passed as arg - if (my $entry = $self->{"good"}->{$host}) { - delete $self->{"good"}->{$host}; + if (my $entry = $self->{good}->{$host}) { + delete $self->{good}->{$host}; return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); } } @@ -1307,9 +1603,9 @@ sub ack_unfork { my $rbits = ""; my $timeout; - if (keys %{ $self->{"syn"} }) { + if (keys %{ $self->{syn} }) { # Scan all hosts that are left - vec($rbits, fileno($self->{"fork_rd"}), 1) = 1; + vec($rbits, fileno($self->{fork_rd}), 1) = 1; $timeout = $stop_time - &time(); # Force a minimum of 10 ms timeout. $timeout = 0.01 if $timeout < 0.01; @@ -1320,10 +1616,10 @@ sub ack_unfork { if ($timeout > 0) { my $nfound; - while ( keys %{ $self->{"syn"} } and + while ( keys %{ $self->{syn} } and $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) { # Done waiting for one of the ACKs - if (!sysread($self->{"fork_rd"}, $_, 16)) { + if (!sysread($self->{fork_rd}, $_, 16)) { # Socket closed, which means all children are done. return (); } @@ -1331,16 +1627,16 @@ sub ack_unfork { if ($pid) { # Flush the zombie waitpid($pid, 0); - if (my $entry = $self->{"syn"}->{$pid}) { + if (my $entry = $self->{syn}->{$pid}) { # Connection attempt to remote host is done - delete $self->{"syn"}->{$pid}; + delete $self->{syn}->{$pid}; if (!$how || # If there was no error connecting - (!$self->{"econnrefused"} && + (!$self->{econnrefused} && $how == ECONNREFUSED)) { # "Connection refused" means reachable if ($host && $entry->[0] ne $host) { # A good connection, but not the host we need. # Move it from the "syn" hash to the "good" hash. - $self->{"good"}->{$entry->[0]} = $entry; + $self->{good}->{$entry->[0]} = $entry; # And wait for the next winner next; } @@ -1361,7 +1657,7 @@ sub ack_unfork { warn("select: $!"); } } - if (my @synners = keys %{ $self->{"syn"} }) { + if (my @synners = keys %{ $self->{syn} }) { # Kill all the synners kill 9, @synners; foreach my $pid (@synners) { @@ -1370,7 +1666,7 @@ sub ack_unfork { waitpid($pid, 0); } } - $self->{"syn"} = {}; + $self->{syn} = {}; return (); } @@ -1378,7 +1674,7 @@ sub ack_unfork { sub nack { my $self = shift; my $host = shift || croak('Usage> nack($failed_ack_host)'); - return $self->{"bad"}->{$host} || undef; + return $self->{bad}->{$host} || undef; } # Description: Close the connection. @@ -1387,14 +1683,14 @@ sub close { my ($self) = @_; - if ($self->{"proto"} eq "syn") { - delete $self->{"syn"}; - } elsif ($self->{"proto"} eq "tcp") { + if ($self->{proto} eq "syn") { + delete $self->{syn}; + } elsif ($self->{proto} eq "tcp") { # The connection will already be closed - } elsif ($self->{"proto"} eq "external") { + } elsif ($self->{proto} eq "external") { # Nothing to close } else { - $self->{"fh"}->close(); + $self->{fh}->close(); } } @@ -1417,14 +1713,214 @@ sub ntop { # Any port will work, even undef, but this will work for now. # Socket warns when undef is passed in, but it still works. my $port = getservbyname('echo', 'udp'); - my $sockaddr = sockaddr_in $port, $ip; - my ($error, $address) = getnameinfo($sockaddr, NI_NUMERICHOST); - if($error) { - croak $error; - } + my $sockaddr = _pack_sockaddr_in($port, $ip); + my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST); + croak $error if $error; return $address; } +sub wakeonlan { + my ($mac_addr, $host, $port) = @_; + + # use the discard service if $port not passed in + if (! defined $host) { $host = '255.255.255.255' } + if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 } + + require IO::Socket::INET; + my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef; + + my $ip_addr = inet_aton($host); + my $sock_addr = sockaddr_in($port, $ip_addr); + $mac_addr =~ s/://g; + my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16); + + setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1); + send($sock, $packet, 0, $sock_addr); + $sock->close; + + return 1; +} + +######################################################## +# DNS hostname resolution +# return: +# $h->{name} = host - as passed in +# $h->{host} = host - as passed in without :port +# $h->{port} = OPTIONAL - if :port, then value of port +# $h->{addr} = resolved numeric address +# $h->{addr_in} = aton/pton result +# $h->{family} = AF_INET/6 +############################ +sub _resolv { + my ($self, + $name, + ) = @_; + + my %h; + $h{name} = $name; + my $family = $self->{family}; + + if (defined($self->{family_local})) { + $family = $self->{family_local} + } + +# START - host:port + my $cnt = 0; + + # Count ":" + $cnt++ while ($name =~ m/:/g); + + # 0 = hostname or IPv4 address + if ($cnt == 0) { + $h{host} = $name + # 1 = IPv4 address with port + } elsif ($cnt == 1) { + ($h{host}, $h{port}) = split /:/, $name + # >=2 = IPv6 address + } elsif ($cnt >= 2) { + #IPv6 with port - [2001::1]:port + if ($name =~ /^\[.*\]:\d{1,5}$/) { + ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last : + # IPv6 without port + } else { + $h{host} = $name + } + } + + # Clean up host + $h{host} =~ s/\[//g; + $h{host} =~ s/\]//g; + # Clean up port + if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) { + croak("Invalid port `$h{port}' in `$name'"); + } +# END - host:port + + # address check + # new way + if ($Socket::VERSION >= 1.94) { + my %hints = ( + family => $AF_UNSPEC, + protocol => IPPROTO_TCP, + flags => $AI_NUMERICHOST + ); + + # numeric address, return + my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); + if (defined($getaddr[0])) { + $h{addr} = $h{host}; + $h{family} = $getaddr[0]->{family}; + if ($h{family} == AF_INET) { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; + } else { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; + } + return \%h + } + # old way + } else { + # numeric address, return + my $ret = gethostbyname($h{host}); + if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) { + $h{addr} = $h{host}; + $h{addr_in} = $ret; + $h{family} = AF_INET; + return \%h + } + } + + # resolve + # new way + if ($Socket::VERSION >= 1.94) { + my %hints = ( + family => $family, + protocol => IPPROTO_TCP + ); + + my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); + if (defined($getaddr[0])) { + my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST); + if (defined($address)) { + $h{addr} = $address; + $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6 + $h{family} = $getaddr[0]->{family}; + if ($h{family} == AF_INET) { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; + } else { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; + } + return \%h + } else { + croak("getnameinfo($getaddr[0]->{addr}) failed - $err"); + } + } else { + croak(sprintf("getaddrinfo($h{host},,%s) failed - $err", + $family == AF_INET ? "AF_INET" : "AF_INET6")); + } + # old way + } else { + if ($family == $AF_INET6) { + croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION"); + } + + my @gethost = gethostbyname($h{host}); + if (defined($gethost[4])) { + $h{addr} = inet_ntoa($gethost[4]); + $h{addr_in} = $gethost[4]; + $h{family} = AF_INET; + return \%h + } else { + croak("gethostbyname($h{host}) failed - $^E"); + } + } +} + +sub _pack_sockaddr_in($$) { + my ($port, + $ip, + ) = @_; + + my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; + if (length($addr) <= 4 ) { + return Socket::pack_sockaddr_in($port, $addr); + } else { + return Socket::pack_sockaddr_in6($port, $addr); + } +} + +sub _unpack_sockaddr_in($;$) { + my ($addr, + $family, + ) = @_; + + my ($port, $host); + if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) { + ($port, $host) = Socket::unpack_sockaddr_in($addr); + } else { + ($port, $host) = Socket::unpack_sockaddr_in6($addr); + } + return $port, $host +} + +sub _inet_ntoa { + my ($addr + ) = @_; + + my $ret; + if ($Socket::VERSION >= 1.94) { + my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST); + if (defined($address)) { + $ret = $address; + } else { + croak("getnameinfo($addr) failed - $err"); + } + } else { + $ret = inet_ntoa($addr) + } + + return $ret +} + 1; __END__ @@ -1546,33 +2042,69 @@ This protocol does not require any special privileges. =over 4 -=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]); +=item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family, + host, port, bind, gateway, retrans, pingstring, + source_verify econnrefused dontfrag + IPV6_USE_MIN_MTU IPV6_RECVPATHMTU]) -Create a new ping object. All of the parameters are optional. $proto -specifies the protocol to use when doing a ping. The current choices -are "tcp", "udp", "icmp", "stream", "syn", or "external". -The default is "tcp". +Create a new ping object. All of the parameters are optional and can +be passed as hash ref. All options besides the first 7 must be passed +as hash ref. -If a default timeout ($def_timeout) in seconds is provided, it is used +C<proto> specifies the protocol to use when doing a ping. The current +choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or +"external". The default is "tcp". + +If a C<timeout> in seconds is provided, it is used when a timeout is not given to the ping() method (below). The timeout must be greater than 0 and the default, if not specified, is 5 seconds. -If the number of data bytes ($bytes) is given, that many data bytes +If the number of data bytes (C<bytes>) is given, that many data bytes are included in the ping packet sent to the remote host. The number of data bytes is ignored if the protocol is "tcp". The minimum (and default) number of data bytes is 1 if the protocol is "udp" and 0 otherwise. The maximum number of data bytes that can be specified is 1024. -If $device is given, this device is used to bind the source endpoint +If C<device> is given, this device is used to bind the source endpoint before sending the ping packet. I believe this only works with superuser privileges and with udp and icmp protocols at this time. -If $tos is given, this ToS is configured into the socket. +If <tos> is given, this ToS is configured into the socket. + +For icmp, C<ttl> can be specified to set the TTL of the outgoing packet. + +Valid C<family> values for IPv4: + + 4, v4, ip4, ipv4, AF_INET (constant) -For icmp, $ttl can be specified to set the TTL of the outgoing packet. +Valid C<family> values for IPv6: -=item $p->ping($host [, $timeout]); + 6, v6, ip6, ipv6, AF_INET6 (constant) + +The C<host> argument implicitly specifies the family if the family +argument is not given. + +The C<port> argument is only valid for a udp, tcp or stream ping, and will not +do what you think it does. ping returns true when we get a "Connection refused"! +The default is the echo port. + +The C<bind> argument specifies the local_addr to bind to. +By specifying a bind argument you don't need the bind method. + +The C<gateway> argument is only valid for IPv6, and requires a IPv6 +address. + +The C<retrans> argument the exponential backoff rate, default 1.2. +It matches the $def_factor global. + +The C<dontfrag> argument sets the IP_DONTFRAG bit, but note that +IP_DONTFRAG is not yet defined by Socket, and not available on many +systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to +IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to +set $data_size manually. + +=item $p->ping($host [, $timeout [, $family]]); Ping the remote host and wait for a response. $host can be either the hostname or the IP number of the remote host. The optional timeout @@ -1627,10 +2159,44 @@ Deprecated method, but does the same as service_check() method. =item $p->hires( { 0 | 1 } ); -Causes this module to use Time::HiRes module, allowing milliseconds +With 1 causes this module to use Time::HiRes module, allowing milliseconds to be returned by subsequent calls to ping(). -This is disabled by default. +=item $p->time + +The current time, hires or not. + +=item $p->socket_blocking_mode( $fh, $mode ); + +Sets or clears the O_NONBLOCK flag on a file handle. + +=item $p->IPV6_USE_MIN_MTU + +With argument sets the option. +Without returns the option value. + +=item $p->IPV6_RECVPATHMTU + +Notify an according IPv6 MTU. + +With argument sets the option. +Without returns the option value. + +=item $p->IPV6_HOPLIMIT + +With argument sets the option. +Without returns the option value. + +=item $p->IPV6_REACHCONF I<NYI> + +Sets ipv6 reachability +IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it. +IPV6_REACHCONF requires root/admin permissions. + +With argument sets the option. +Without returns the option value. + +Not yet implemented. =item $p->bind($local_addr); @@ -1646,6 +2212,9 @@ then bind() must be called at most once per object, and (if it is called at all) must be called before the first call to ping() for that object. +The bind() call can be omitted when specifying the C<bind> option to +new(). + =item $p->open($host); When you are using the "stream" protocol, this call pre-opens the @@ -1657,6 +2226,9 @@ automatically opened the first time C<ping()> is called. This call simply does nothing if you are using any protocol other than stream. +The $host argument can be omitted when specifying the C<host> option to +new(). + =item $p->ack( [ $host ] ); When using the "syn" protocol, use this method to determine @@ -1669,19 +2241,82 @@ SYN queued using the ping() method. If the timeout is reached before the TCP ACK is received, or if the remote host is not listening on the port attempted, then the TCP connection will not be established and ack() will return -undef. In list context, the host, the ack time, and the -dotted ip string will be returned instead of just the host. +undef. In list context, the host, the ack time, the dotted ip +string, and the port number will be returned instead of just the host. If the optional $host argument is specified, the return value will be pertaining to that host only. This call simply does nothing if you are using any protocol other than syn. +When new() had a host option, this host will be used. +Without host argument, all hosts are scanned. + =item $p->nack( $failed_ack_host ); The reason that host $failed_ack_host did not receive a valid ACK. Useful to find out why when ack( $fail_ack_host ) returns a false value. +=item $p->ack_unfork($host) + +The variant called by ack() with the syn protocol and $syn_forking +enabled. + +=item $p->ping_icmp([$host, $timeout, $family]) + +The ping() method used with the icmp protocol. + +=item $p->ping_icmpv6([$host, $timeout, $family]) I<NYI> + +The ping() method used with the icmpv6 protocol. + +=item $p->ping_stream([$host, $timeout, $family]) + +The ping() method used with the stream protocol. + +Perform a stream ping. If the tcp connection isn't +already open, it opens it. It then sends some data and waits for +a reply. It leaves the stream open on exit. + +=item $p->ping_syn([$host, $ip, $start_time, $stop_time]) + +The ping() method used with the syn protocol. +Sends a TCP SYN packet to host specified. + +=item $p->ping_syn_fork([$host, $timeout, $family]) + +The ping() method used with the forking syn protocol. + +=item $p->ping_tcp([$host, $timeout, $family]) + +The ping() method used with the tcp protocol. + +=item $p->ping_udp([$host, $timeout, $family]) + +The ping() method used with the udp protocol. + +Perform a udp echo ping. Construct a message of +at least the one-byte sequence number and any additional data bytes. +Send the message out and wait for a message to come back. If we +get a message, make sure all of its parts match. If they do, we are +done. Otherwise go back and wait for the message until we run out +of time. Return the result of our efforts. + +=item $p->ping_external([$host, $timeout, $family]) + +The ping() method used with the external protocol. +Uses Net::Ping::External to do an external ping. + +=item $p->tcp_connect([$ip, $timeout]) + +Initiates a TCP connection, for a tcp ping. + +=item $p->tcp_echo([$ip, $timeout, $pingstring]) + +Performs a TCP echo. +It writes the given string to the socket and then reads it +back. It returns 1 on success, 0 on failure. + =item $p->close(); Close the network connection for this ping object. The network @@ -1697,6 +2332,24 @@ of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful response only if that specific port is accessible. This function returns the value of the port that C<ping()> will connect to. +=item $p->mselect + +A select() wrapper that compensates for platform +peculiarities. + +=item $p->ntop + +Platform abstraction over inet_ntop() + +=item $p->checksum($msg) + +Do a checksum on the message. Basically sum all of +the short words and fold the high order bits into the low order bits. + +=item $p->icmp_result + +Returns a list of addr, type, subcode. + =item pingecho($host [, $timeout]); To provide backward compatibility with the previous version of @@ -1706,6 +2359,17 @@ return values and parameters are the same as described for the ping() method. This subroutine is obsolete and may be removed in a future version of Net::Ping. +=item wakeonlan($mac, [$host, [$port]]) + +Emit the popular wake-on-lan magic udp packet to wake up a local +device. See also L<Net::Wake>, but this has the mac address as 1st arg. +$host should be the local gateway. Without it will broadcast. + +Default host: '255.255.255.255' +Default port: 9 + + perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"' + =back =head1 NOTES @@ -1717,9 +2381,10 @@ either udp or icmp. If many hosts are pinged frequently, you may wish to implement a small wait (e.g. 25ms or more) between each ping to avoid flooding your network with packets. -The icmp protocol requires that the program be run as root or that it -be setuid to root. The other protocols do not require special -privileges, but not all network devices implement tcp or udp echo. +The icmp and icmpv6 protocols requires that the program be run as root +or that it be setuid to root. The other protocols do not require +special privileges, but not all network devices implement tcp or udp +echo. Local hosts should normally respond to pings within milliseconds. However, on a very congested network it may take up to 3 seconds or @@ -1739,57 +2404,44 @@ kinds of ICMP packets. =head1 INSTALL -The latest source tree is available via cvs: +The latest source tree is available via git: - cvs -z3 -q -d \ - :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware \ - checkout Net-Ping + git clone https://github.com/rurban/net-ping.git Net-Ping cd Net-Ping The tarball can be created as follows: perl Makefile.PL ; make ; make dist -The latest Net::Ping release can be found at CPAN: - - $CPAN/modules/by-module/Net/ - -1) Extract the tarball - - gtar -zxvf Net-Ping-xxxx.tar.gz - cd Net-Ping-xxxx - -2) Build: +The latest Net::Ping releases are included in cperl and perl5. - make realclean - perl Makefile.PL - make - make test - -3) Install - - make install +=head1 BUGS -Or install it RPM Style: +For a list of known issues, visit: - rpm -ta SOURCES/Net-Ping-xxxx.tar.gz +L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping> - rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm +To report a new bug, visit: -=head1 BUGS +L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping> (stale) -For a list of known issues, visit: +or call: -https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping + perlbug -To report a new bug, visit: +resp.: -https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping + cperlbug =head1 AUTHORS - Current maintainer: + Current maintainers: + perl11 (for cperl, with IPv6 support and more) + p5p (for perl5) + + Previous maintainers: bbb@cpan.org (Rob Brown) + Steve Peters External protocol: colinm@cpan.org (Colin McMillen) @@ -1797,6 +2449,9 @@ https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping Stream protocol: bronson@trestle.com (Scott Bronson) + Wake-on-lan: + 1999-2003 Clinton Wong + Original pingecho(): karrer@bernina.ethz.ch (Andreas Karrer) pmarquess@bfsec.bt.co.uk (Paul Marquess) @@ -1806,6 +2461,10 @@ https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping =head1 COPYRIGHT +Copyright (c) 2016, cPanel Inc. All rights reserved. + +Copyright (c) 2012, Steve Peters. All rights reserved. + Copyright (c) 2002-2003, Rob Brown. All rights reserved. Copyright (c) 2001, Colin McMillen. All rights reserved. diff --git a/gnu/usr.bin/perl/dist/Net-Ping/t/100_load.t b/gnu/usr.bin/perl/dist/Net-Ping/t/100_load.t deleted file mode 100755 index fa04a0c587e..00000000000 --- a/gnu/usr.bin/perl/dist/Net-Ping/t/100_load.t +++ /dev/null @@ -1,12 +0,0 @@ -use strict; - -BEGIN { - unless (eval "require Socket") { - print "1..0 \# Skip: no Socket\n"; - exit; - } -} - -use Test::More tests => 1; -# Just make sure everything compiles -BEGIN {use_ok 'Net::Ping'}; diff --git a/gnu/usr.bin/perl/dist/PathTools/Cwd.pm b/gnu/usr.bin/perl/dist/PathTools/Cwd.pm index 3b6388938a1..58af9352db3 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Cwd.pm +++ b/gnu/usr.bin/perl/dist/PathTools/Cwd.pm @@ -1,16 +1,16 @@ package Cwd; use strict; use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -$VERSION = '3.63_01'; + +our $VERSION = '3.74'; my $xs_version = $VERSION; $VERSION =~ tr/_//d; -@ISA = qw/ Exporter /; -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +our @ISA = qw/ Exporter /; +our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; -@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command @@ -77,19 +77,9 @@ sub _vms_efs { # If loading the XS stuff doesn't work, we can fall back to pure perl -if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { - eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.50 - #at lib/DynaLoader.pm line 216." by having this eval - if ( $] >= 5.006 ) { - require XSLoader; - XSLoader::load( __PACKAGE__, $xs_version); - } else { - require DynaLoader; - push @ISA, 'DynaLoader'; - __PACKAGE__->bootstrap( $xs_version ); - } - }; +if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { # skipped on miniperl + require XSLoader; + XSLoader::load( __PACKAGE__, $xs_version); } # Big nasty table of function aliases @@ -145,23 +135,6 @@ my %METHOD_MAP = realpath => 'fast_abs_path', }, - epoc => - { - cwd => '_epoc_cwd', - getcwd => '_epoc_cwd', - fastgetcwd => '_epoc_cwd', - fastcwd => '_epoc_cwd', - abs_path => 'fast_abs_path', - }, - - MacOS => - { - getcwd => 'cwd', - fastgetcwd => 'cwd', - fastcwd => 'cwd', - abs_path => 'fast_abs_path', - }, - amigaos => { getcwd => '_backtick_pwd', @@ -254,8 +227,7 @@ unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { } } - # MacOS has some special magic to make `pwd` work. - if( $os eq 'MacOS' || $found_pwd_cmd ) + if( $found_pwd_cmd ) { *cwd = \&_backtick_pwd; } @@ -384,9 +356,6 @@ sub chdir { if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } - elsif ($^O eq 'MacOS') { - return $ENV{'PWD'} = cwd(); - } elsif ($^O eq 'MSWin32') { $ENV{'PWD'} = $newpwd; return 1; @@ -418,8 +387,7 @@ sub _perl_abs_path unless (@cst = stat( $start )) { - _carp("stat($start): $!"); - return ''; + return undef; } unless (-d _) { @@ -453,15 +421,14 @@ sub _perl_abs_path local *PARENT; unless (opendir(PARENT, $dotdots)) { - # probably a permissions issue. Try the native command. - require File::Spec; - return File::Spec->rel2abs( $start, _backtick_pwd() ); + return undef; } unless (@cst = stat($dotdots)) { - _carp("stat($dotdots): $!"); + my $e = $!; closedir(PARENT); - return ''; + $! = $e; + return undef; } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { @@ -473,9 +440,10 @@ sub _perl_abs_path { unless (defined ($dir = readdir(PARENT))) { - _carp("readdir($dotdots): $!"); closedir(PARENT); - return ''; + require Errno; + $! = Errno::ENOENT(); + return undef; } $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) } @@ -494,6 +462,7 @@ my $Curdir; sub fast_abs_path { local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage my $cwd = getcwd(); + defined $cwd or return undef; require File::Spec; my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); @@ -503,7 +472,9 @@ sub fast_abs_path { ($cwd) = $cwd =~ /(.*)/s; unless (-e $path) { - _croak("$path: No such file or directory"); + require Errno; + $! = Errno::ENOENT(); + return undef; } unless (-d _) { @@ -514,7 +485,7 @@ sub fast_abs_path { if (-l $path) { my $link_target = readlink($path); - die "Can't resolve link $path: $!" unless defined $link_target; + defined $link_target or return undef; $link_target = File::Spec->catpath($vol, $dir, $link_target) unless File::Spec->file_name_is_absolute($link_target); @@ -528,7 +499,7 @@ sub fast_abs_path { } if (!CORE::chdir($path)) { - _croak("Cannot chdir to $path: $!"); + return undef; } my $realpath = getcwd(); if (! ((-d $cwd) && (CORE::chdir($cwd)))) { @@ -676,11 +647,6 @@ sub _qnx_abs_path { return $realpath; } -sub _epoc_cwd { - return $ENV{'PWD'} = EPOC::getcwd(); -} - - # Now that all the base-level functions are set up, alias the # user-level functions to the right places @@ -737,7 +703,8 @@ absolute path of the current working directory. my $cwd = getcwd(); -Returns the current working directory. +Returns the current working directory. On error returns C<undef>, +with C<$!> set to indicate the error. Exposes the POSIX function getcwd(3) or re-implements it if it's not available. @@ -800,7 +767,8 @@ given they'll use the current working directory. Uses the same algorithm as getcwd(). Symbolic links and relative-path components ("." and "..") are resolved to return the canonical -pathname, just like realpath(3). +pathname, just like realpath(3). On error returns C<undef>, with C<$!> +set to indicate the error. =item realpath diff --git a/gnu/usr.bin/perl/dist/PathTools/Cwd.xs b/gnu/usr.bin/perl/dist/PathTools/Cwd.xs index 3d018dc43f9..2ca8acd6abb 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Cwd.xs +++ b/gnu/usr.bin/perl/dist/PathTools/Cwd.xs @@ -7,6 +7,8 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define NEED_croak_xs_usage +#define NEED_sv_2pv_flags #define NEED_my_strlcpy #define NEED_my_strlcat #include "ppport.h" @@ -134,9 +136,9 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) } if (next_token[0] == '\0') continue; - else if (strcmp(next_token, ".") == 0) + else if (strEQ(next_token, ".")) continue; - else if (strcmp(next_token, "..") == 0) { + else if (strEQ(next_token, "..")) { /* * Strip the last path component except when we have * single "/" @@ -424,7 +426,7 @@ int Perl_getcwd_sv(pTHX_ SV *sv) #endif #if USE_MY_CXT -# define MY_CXT_KEY "Cwd::_guts"XS_VERSION +# define MY_CXT_KEY "Cwd::_guts" XS_VERSION typedef struct { SV *empty_string_sv, *slash_string_sv; } my_cxt_t; diff --git a/gnu/usr.bin/perl/dist/PathTools/Makefile.PL b/gnu/usr.bin/perl/dist/PathTools/Makefile.PL index bc40baff608..11e04af5230 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Makefile.PL +++ b/gnu/usr.bin/perl/dist/PathTools/Makefile.PL @@ -1,13 +1,34 @@ -BEGIN { @INC = grep {!/blib/} @INC } +# See https://rt.cpan.org/Public/Bug/Display.html?id=4681 +# and https://rt.perl.org/Ticket/Display.html?id=125603 +# When installing a newer Cwd on a system with an existing Cwd, +# under some circumstances the old Cwd.pm and the new Cwd.xs could +# get mixed up and SEGVs ensue. + +BEGIN { @INC = grep { $_ ne "blib/arch" and $_ ne "blib/lib" } @INC } require 5.005; use ExtUtils::MakeMaker; + +my @extra; +push @extra, 'LICENSE' => 'perl_5' + unless $ExtUtils::MakeMaker::VERSION < 6.31; +push @extra, 'META_MERGE' => { + resources => { + repository => 'git://perl5.git.perl.org/perl.git', + bugtracker => 'https://rt.perl.org/rt3/', + homepage => "http://dev.perl.org/", + license => [ 'http://dev.perl.org/licenses/' ], + }, + } unless $ExtUtils::MakeMaker::VERSION < 6.46; + WriteMakefile ( 'DISTNAME' => 'PathTools', 'NAME' => 'Cwd', 'VERSION_FROM' => 'Cwd.pm', + 'ABSTRACT' => 'Tools for working with directory and file names', + 'AUTHOR' => 'Perl 5 Porters', 'DEFINE' => join(" ", "-DDOUBLE_SLASHES_SPECIAL=@{[$^O eq q(qnx) || $^O eq q(nto) ? 1 : 0]}", ((grep { $_ eq 'PERL_CORE=1' } @ARGV) ? '-DNO_PPPORT_H' : ()), @@ -16,12 +37,12 @@ WriteMakefile 'Carp' => '0', 'File::Basename' => '0', 'Scalar::Util' => '0', - 'Test' => '0', # done_testing() is used in dist/Cwd/t/Spec.t 'Test::More' => 0.88, }, ($] > 5.011) ? () : ( INSTALLDIRS => 'perl' ), # CPAN sourced versions should now install to site 'EXE_FILES' => [], - 'PL_FILES' => {} + 'PL_FILES' => {}, + @extra, ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm index 3ef0f339db3..85327ee0da3 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm @@ -1,16 +1,14 @@ package File::Spec; use strict; -use vars qw(@ISA $VERSION); -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -my %module = (MacOS => 'Mac', +my %module = ( MSWin32 => 'Win32', os2 => 'OS2', VMS => 'VMS', - epoc => 'Epoc', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. @@ -21,7 +19,7 @@ my %module = (MacOS => 'Mac', my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; -@ISA = ("File::Spec::$module"); +our @ISA = ("File::Spec::$module"); 1; @@ -158,10 +156,13 @@ Returns a string representation of the parent directory. =item no_upwards -Given a list of file names, strip out those that refer to a parent -directory. (Does not strip symlinks, only '.', '..', and equivalents.) +Given a list of files in a directory (such as from C<readdir()>), +strip out C<'.'> and C<'..'>. - @paths = File::Spec->no_upwards( @paths ); +B<SECURITY NOTE:> This does NOT filter paths containing C<'..'>, like +C<'../../../../etc/passwd'>, only literal matches to C<'.'> and C<'..'>. + + @paths = File::Spec->no_upwards( readdir $dirhandle ); =item case_tolerant diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm index 10b14c4b9a6..ed646a160fd 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -1,13 +1,12 @@ package File::Spec::Cygwin; use strict; -use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); =head1 NAME diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm index 9b9e1fae587..58f74a33ca2 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm @@ -1,13 +1,12 @@ package File::Spec::Epoc; use strict; -use vars qw($VERSION @ISA); -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; require File::Spec::Unix; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); =head1 NAME diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm index a4e1b1bb338..9af6352dd24 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm @@ -3,16 +3,14 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); - -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -@EXPORT = qw( +our @EXPORT = qw( canonpath catdir catfile @@ -24,7 +22,7 @@ require Exporter; path ); -@EXPORT_OK = qw( +our @EXPORT_OK = qw( devnull tmpdir splitpath @@ -35,7 +33,7 @@ require Exporter; case_tolerant ); -%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); +our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); require File::Spec::Unix; my %udeps = ( diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm index 22424f32510..a1b044d152a 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm @@ -1,18 +1,13 @@ package File::Spec::Mac; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); - -my $macfiles; -if ($^O eq 'MacOS') { - $macfiles = eval { require Mac::Files }; -} +our @ISA = qw(File::Spec::Unix); sub case_tolerant { 1 } @@ -121,7 +116,7 @@ doesn't alter the path, i.e. these arguments are ignored. (When a "" is passed as the first argument, it has a special meaning, see (6)). This way, a colon ":" is handled like a "." (curdir) on Unix, while an empty string "" is generally ignored (see -C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +L<File::Spec::Unix/canonpath()> ). Likewise, a "::" is handled like a ".." (updir), and a ":::" is handled like a "../.." etc. E.g. catdir("a",":",":","b") = ":a:b:" @@ -168,7 +163,7 @@ their Unix counterparts: # (e.g. "HD:a:") However, this approach is limited to the first arguments following -"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +"root" (again, see L<File::Spec::Unix/canonpath()>. If there are more arguments that move up the directory tree, an invalid path going beyond root can be created. @@ -343,27 +338,11 @@ sub devnull { =item rootdir -Returns a string representing the root directory. Under MacPerl, -returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. The name has a -trailing ":", because that's the correct specification for a volume -name on Mac OS. - -If Mac::Files could not be loaded, the empty string is returned. +Returns the empty string. Mac OS has no real root directory. =cut -sub rootdir { -# -# There's no real root directory on Mac OS. The name of the startup -# volume is returned, since that's the closest in concept. -# - return '' unless $macfiles; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*\Z(?!\n)/:/s; - return $system; -} +sub rootdir { '' } =item tmpdir @@ -669,7 +648,7 @@ sub abs2rel { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; @@ -737,7 +716,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute($path) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute($base) ) { $base = $self->rel2abs($base) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm index 0119042c9c0..e961ad4e333 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm @@ -1,13 +1,13 @@ package File::Spec::OS2; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); sub devnull { return "/dev/nul"; @@ -30,11 +30,6 @@ sub path { return @path; } -sub _cwd { - # In OS/2 the "require Cwd" is unnecessary bloat. - return Cwd::sys_cwd(); -} - sub tmpdir { my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); return $cached if defined $cached; @@ -148,7 +143,7 @@ sub abs2rel { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; } else { @@ -205,7 +200,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm index 9598dbb3621..a1fa6736a1e 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm @@ -1,26 +1,11 @@ package File::Spec::Unix; use strict; -use vars qw($VERSION); +use Cwd (); -$VERSION = '3.63_01'; -my $xs_version = $VERSION; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl -if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { - eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.50 - #at lib/DynaLoader.pm line 216." by having this eval - if ( $] >= 5.006 ) { - require XSLoader; - XSLoader::load("Cwd", $xs_version); - } else { - require Cwd; - } - }; -} - =head1 NAME File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules @@ -185,7 +170,8 @@ sub _tmpdir { @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; } elsif ($] < 5.007) { # No ${^TAINT} before 5.8 - @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; + @dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } } + @dirlist; } foreach (@dirlist) { @@ -409,7 +395,7 @@ Based on code written by Shigio Yamaguchi. sub abs2rel { my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + $base = Cwd::getcwd() unless defined $base and length $base; ($path, $base) = map $self->canonpath($_), $path, $base; @@ -436,7 +422,7 @@ sub abs2rel { } } else { - my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1]; $path_directories = $self->catdir($wd, $path); $base_directories = $self->catdir($wd, $base); } @@ -519,7 +505,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; @@ -552,15 +538,6 @@ L<File::Spec> =cut -# Internal routine to File::Spec, no point in making this public since -# it is the standard Cwd interface. Most of the platform-specific -# File::Spec subclasses use this. -sub _cwd { - require Cwd; - Cwd::getcwd(); -} - - # Internal method to reduce xx\..\yy -> yy sub _collapse { my($fs, $path) = @_; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm index c0cc1e50434..cbafdce88ab 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm @@ -1,13 +1,13 @@ package File::Spec::VMS; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); use File::Basename; use VMS::Filespec; @@ -97,7 +97,7 @@ sub canonpath { # [-.-. ==> [--. # .-.-] ==> .--] # [-.-] ==> [--] - 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/); # That loop does the following # with any amount (minimum 2) # of dashes: @@ -108,11 +108,11 @@ sub canonpath { # # And then, the remaining cases $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- - $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . - $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ - $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> . + $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ] # [foo.-] ==> [000000] - $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g; + $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g; # [] ==> $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; return $unix_rpt ? unixify($path) : $path; @@ -442,7 +442,7 @@ sub abs2rel { my $self = shift; my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + $base = Cwd::getcwd() unless defined $base and length $base; # If there is no device or directory syntax on $base, make sure it # is treated as a directory. @@ -514,7 +514,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd; + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm index 578d61b37f8..9ccafa7d15f 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm @@ -2,13 +2,13 @@ package File::Spec::Win32; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); # Some regexes we use for path splitting my $DRIVE_RX = '[a-zA-Z]:'; @@ -330,14 +330,13 @@ sub rel2abs { if ($is_abs) { # It's missing a volume, add one - my $vol = ($self->splitpath( $self->_cwd() ))[0]; + my $vol = ($self->splitpath( Cwd::getcwd() ))[0]; return $self->canonpath( $vol . $path ); } if ( !defined( $base ) || $base eq '' ) { - require Cwd ; $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; - $base = $self->_cwd() unless defined $base ; + $base = Cwd::getcwd() unless defined $base ; } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/t/Spec.t b/gnu/usr.bin/perl/dist/PathTools/t/Spec.t index 150c8d48735..84ed6b16fde 100644 --- a/gnu/usr.bin/perl/dist/PathTools/t/Spec.t +++ b/gnu/usr.bin/perl/dist/PathTools/t/Spec.t @@ -61,6 +61,9 @@ my @tests = ( [ "Unix->catfile('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ], ) : ()), [ "Unix->catfile(substr('foo', 2))", 'o' ], +# https://rt.cpan.org/Ticket/Display.html?id=121633 +# https://rt.perl.org/Ticket/Display.html?id=131296 +[ "Unix->catfile('.', 'hints', 'Makefile.PL')", 'hints/Makefile.PL' ], [ "Unix->splitpath('file')", ',,file' ], [ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], @@ -139,6 +142,7 @@ my @tests = ( ($] >= 5.008 ? ( [ "Unix->canonpath(do { my \$x = '///a'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", '/a'.chr(0xaf) ], ) : ()), +[ "Unix->canonpath(1)", '1' ], [ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], [ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], @@ -284,7 +288,7 @@ my @tests = ( [ "Win32->canonpath('/..\\')", '\\' ], [ "Win32->canonpath('d1/../foo')", 'foo' ], -# FakeWin32 subclass (see below) just sets CWD to C:\one\two and getdcwd('D') to D:\alpha\beta +# FakeWin32 subclass (see below) just sets getcwd() to C:\one\two and getdcwd('D') to D:\alpha\beta [ "FakeWin32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], [ "FakeWin32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], @@ -448,6 +452,13 @@ my @tests = ( # During the Perl 5.8 era, FS::Unix stopped eliminating redundant path elements, so mimic that here. [ "VMS->canonpath('a/../../b/c.dat')", $vms_unix_rpt ? 'a/../../b/c.dat' : '[-.b]c.dat' ], [ "VMS->canonpath('^<test^.new.-.caret^ escapes^>')", $vms_unix_rpt ? '/<test.new.-.caret escapes>' : '^<test^.new.-.caret^ escapes^>' ], +# Check that directory specs with caret-dot component is treated correctly +[ "VMS->canonpath('foo:[bar.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ], +[ "VMS->canonpath('foo:[bar^.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo^.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/coo/file.txt' : "foo:[bar.coo]file.txt" ], +[ "VMS->canonpath('foo:[bar^.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar.coo/file.txt' : "foo:[bar^.coo]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo^.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ], [ "VMS->splitdir('')", '' ], [ "VMS->splitdir('[]')", '' ], @@ -790,14 +801,9 @@ my @tests = ( ) ; -can_ok('File::Spec::Win32', '_cwd'); - { package File::Spec::FakeWin32; - use vars qw(@ISA); - @ISA = qw(File::Spec::Win32); - - sub _cwd { 'C:\\one\\two' } + our @ISA = qw(File::Spec::Win32); # Some funky stuff to override Cwd::getdcwd() for testing purposes, # in the limited scope of the rel2abs() method. @@ -806,6 +812,8 @@ can_ok('File::Spec::Win32', '_cwd'); *rel2abs = sub { my $self = shift; local $^W; + local *Cwd::getcwd = sub { 'C:\\one\\two' }; + *Cwd::getcwd = *Cwd::getcwd; # Avoid a 'used only once' warning local *Cwd::getdcwd = sub { return 'D:\alpha\beta' if $_[0] eq 'D:'; return 'C:\one\two' if $_[0] eq 'C:'; @@ -815,6 +823,14 @@ can_ok('File::Spec::Win32', '_cwd'); return $self->SUPER::rel2abs(@_); }; *rel2abs = *rel2abs; # Avoid a 'used only once' warning + *abs2rel = sub { + my $self = shift; + local $^W; + local *Cwd::getcwd = sub { 'C:\\one\\two' }; + *Cwd::getcwd = *Cwd::getcwd; # Avoid a 'used only once' warning + return $self->SUPER::abs2rel(@_); + }; + *abs2rel = *abs2rel; # Avoid a 'used only once' warning } } diff --git a/gnu/usr.bin/perl/dist/PathTools/t/taint.t b/gnu/usr.bin/perl/dist/PathTools/t/taint.t index 48f8c5bc8f6..95154704c00 100644 --- a/gnu/usr.bin/perl/dist/PathTools/t/taint.t +++ b/gnu/usr.bin/perl/dist/PathTools/t/taint.t @@ -11,7 +11,7 @@ use lib File::Spec->catdir('t', 'lib'); use Test::More; BEGIN { plan( - ${^TAINT} + !eval { eval("1".substr($^X,0,0)) } ? (tests => 21) : (skip_all => "A perl without taint support") ); diff --git a/gnu/usr.bin/perl/dist/Safe/Safe.pm b/gnu/usr.bin/perl/dist/Safe/Safe.pm index d78fcc54f68..e9f096713d1 100644 --- a/gnu/usr.bin/perl/dist/Safe/Safe.pm +++ b/gnu/usr.bin/perl/dist/Safe/Safe.pm @@ -3,7 +3,7 @@ package Safe; use 5.003_11; use Scalar::Util qw(reftype refaddr); -$Safe::VERSION = "2.39"; +$Safe::VERSION = "2.40"; # *** Don't declare any lexicals above this point *** # @@ -717,6 +717,9 @@ called from a compartment but not compiled within it. =head2 rdo (FILENAME) This evaluates the contents of file FILENAME inside the compartment. +It uses the same rules as perl's built-in C<do> to locate the file, +poossibly using C<@INC>. + See above documentation on the B<reval> method for further details. =head2 root (NAMESPACE) diff --git a/gnu/usr.bin/perl/dist/Safe/t/safe2.t b/gnu/usr.bin/perl/dist/Safe/t/safe2.t index b55b4a901b8..ee738529c44 100755 --- a/gnu/usr.bin/perl/dist/Safe/t/safe2.t +++ b/gnu/usr.bin/perl/dist/Safe/t/safe2.t @@ -11,8 +11,6 @@ BEGIN { # Tests Todo: # 'main' as root -use vars qw($bar); - use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex opmask_add full_opset empty_opset opcodes opmask define_optag); @@ -23,7 +21,7 @@ my $TB = Test::Builder->new(); # Set up a package namespace of things to be visible to the unsafe code $Root::foo = "visible"; -$bar = "invisible"; +our $bar = "invisible"; # Stop perl from moaning about identifies which are apparently only used once $Root::foo .= ""; @@ -131,7 +129,7 @@ like($@, qr/foo bar/); $! = 0; my $nosuch = '/non/existent/file.name'; -open(NOSUCH, $nosuch); +open(NOSUCH, '<', $nosuch); if ($@) { my $errno = $!; die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!; @@ -143,16 +141,4 @@ if ($@) { } close(NOSUCH); -#my $rdo_file = "tmp_rdo.tpl"; -#if (open X,">$rdo_file") { -# print X "999\n"; -# close X; -# $cpt->permit_only('const', 'leaveeval'); -# $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; -# unlink $rdo_file; -#} -#else { -# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; -#} - done_testing(); diff --git a/gnu/usr.bin/perl/dist/Safe/t/safeops.t b/gnu/usr.bin/perl/dist/Safe/t/safeops.t index 2133bde16b3..ea159316009 100755 --- a/gnu/usr.bin/perl/dist/Safe/t/safeops.t +++ b/gnu/usr.bin/perl/dist/Safe/t/safeops.t @@ -111,7 +111,6 @@ padsv SKIP my $x padav SKIP my @x padhv SKIP my %x padany SKIP (not implemented) -pushre SKIP split /foo/ rv2gv *x rv2sv $x av2arylen $#x @@ -235,6 +234,7 @@ exists exists $h{Key} rv2hv %h helem $h{kEy} hslice @h{kEy} +multiconcat SKIP (set by optimizer) multideref SKIP (set by optimizer) unpack unpack pack pack @@ -287,7 +287,7 @@ return return last last next next redo redo THIS -dump dump +dump CORE::dump goto goto THERE exit exit 0 open open FOO diff --git a/gnu/usr.bin/perl/dist/SelfLoader/lib/SelfLoader.pm b/gnu/usr.bin/perl/dist/SelfLoader/lib/SelfLoader.pm index e36cb923d9e..0034e5be333 100644 --- a/gnu/usr.bin/perl/dist/SelfLoader/lib/SelfLoader.pm +++ b/gnu/usr.bin/perl/dist/SelfLoader/lib/SelfLoader.pm @@ -2,11 +2,11 @@ package SelfLoader; use 5.008; use strict; use IO::Handle; -our $VERSION = "1.23"; +our $VERSION = "1.25"; # The following bit of eval-magic is necessary to make this work on # perls < 5.009005. -use vars qw/$AttrList/; +our $AttrList; BEGIN { if ($] > 5.009004) { eval <<'NEWERPERL'; diff --git a/gnu/usr.bin/perl/dist/Storable/ChangeLog b/gnu/usr.bin/perl/dist/Storable/ChangeLog index cbfdbabb83b..3f3076ac600 100644 --- a/gnu/usr.bin/perl/dist/Storable/ChangeLog +++ b/gnu/usr.bin/perl/dist/Storable/ChangeLog @@ -1,3 +1,192 @@ +2018-02-07 15:08:00 tonyc + Version 3.06 + + * support large object ids. The code in theory supported arrays + with more than 2**32 elements, but references to the elements + emitted at the end of the array with be retrieved as references to + the wrong elements. + * 32-bit object ids over 2**31-1 weren't correctly handled. + * hook object id generation now supports 64-bit ids where needed + * writing 64-bit lengths in network order now works + * reading 64-bit lengths in network order now reads the components + in the correct order. + * retrieving large object tags are now only handled on 64-bit + platforms, large object tags should only be emitted for objects + that are too large for the 32-bit address space, so it was only + wasted code. + * reading 32-bit lengths for LSCALAR and LUTF8STR as unsigned + (perl #131990) + * reading flagged large object hashes didn't read the flags + * treat the 32-bit size of hook data as unsigned, values over 2GB + were treated as large (close to 2**64) parameters to NEWSV(). + (perl #131999) + * added support for hook data over 4GB in size + * zero length data receievd from STORABLE_freeze() no longer + results in an invalid SV being passed to STORABLE_thaw/_attach() + (perl #118551) + * where practical, padding is now cleared when emitting a long + double (perl #131136) + * cache the value of $Storable::DEBUGME (since cperl enabled + Storable TRACEME builds for all -DDEBUGGING builds) + * no longer discard exceptions thrown by + STORABLE_freeze/_thaw/attach() (perl #25933) + * fix dependencies used to build Storable.pm from __Storable__.pm + * add experimental support for freezing/thawing regular + expressions (perl #50608) + * re-work recursion limiting to store the limit in a perl variable + instead of baked into Storable.$so. This allows static Storable + builds to work, and avoids the kind of circular reference on + Storable.$so. + +2017-07-24 13:57:13 rurban + Version 3.05_13 + + * mingw fix: use safe defaults, not segfaulting defaults. + mingw fails on the stacksize binary search, leaving it empty. + +Wed Apr 19 09:11:07 2017 +0200 Reini Urban <rurban@cpan.org> + Version 3.05_12 + + * enhance stack reserve from 8 to 16 + * fix LD_LIBRARY_PATH usage for CORE + * fixed some coverity warnings and leaks + * added a release make target + +Wed Mar 29 21:04:28 2017 +0200 Reini Urban <rurban@cpan.org> + Version 3.05_11 + + * croak on sizes read > I32_MAX + * simplify last_op_in_netorder + * protect from empty retrieve_vstring + * protect store_other error buf, potential static + buffer overflow. + +Tue Mar 14 09:52:20 2017 +0100 Reini Urban <rurban@cpan.org> + Version 3.05_10 + + * CORE-only improvements to stacksize + +Thu Mar 9 19:20:19 2017 +0100 Reini Urban <rurban@cpan.org> + Version 3.05_09 + + * compute the stacksizes, improve cleanup within croak + from stack exhaustion. + * added stack_depth and stack_depth_hash getters. + +Wed Mar 8 21:03:43 CET 2017 Reini Urban <rurban@cpan.org> + Version 3.05_08 + + * finetune the max stack limit, for C++, DEBUGGING and 32bit. + * fix t/blessed.t for cperl5.22 + +Sun Mar 5 13:36:47 2017 +0100 Reini Urban <rurban@cpan.org> + Version 3.05_07 + + * Fixed a podchecker issue + +Sun Mar 5 11:42:04 2017 +0100 Reini Urban <rurban@cpan.org> + Version 3.05_06 + + * Fixed wrong recursion depth error with large arrays containing + another array. + L<[cperl #257]|https://github.com/perl11/cperl/issues/257> + +Thu Feb 2 12:40:44 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05_05 + + * Add leak tests for [cpan #97316], [perl #121928] + * Limit the max recursion depth to 1200 on 32bit systems. + We have no max_depth option yet, as in JSON::XS. + +Thu Feb 2 11:59:21 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05_04 + + * Fix retrieve_tied_array which fails since 5.16 + [cpan #84705] + * Improve t/blessed.t in the creation of sv_yes/sv_no + with threaded perls. + +Tue Jan 31 02:55:30 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05_03 + + * Tune t/recurse.t stack-overflow limit more. + +Mon Jan 30 19:50:29 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05_02 + + * Tune t/recurse.t stack-overflow limit. Small 64bit systems overflow + even with depth 3000, where 32bit are ok. + +Mon Jan 30 15:13:38 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05_01 + + * Protect against stack overflows with nested arrays and hashes + [cpan #97526]. This imposes a new limit to your nested structures, + but JSON::XS has a limit of 512. We use a max_depth of 3000 for the + typical stack limit of 8k. + + +Sun Jan 29 11:36:43 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.05 + + * Protect against classname len overflow on the stack + and 2x on the heap with retrieve_bless and retrieve_hook. + A serious security issue with malcrafted storable files or buffers, + but p5p accepts no CVE on Storable attacks. See RT #130635 + (reported by JD). + * Fix NULL ptr SEGVs with retrieve_code and retrieve_other. + See RT #130098 (reported and fixed by JD) + * Fix wrong huge LOBJECT support, broken since 3.00c. + Repro with `export PERL_TEST_MEMORY=8` + * Fix the few remaining 2-arg open calls. + * Portability and backport fixes back to 5.6.2 + +Sat Jan 7 09:01:29 2017 +0100 Reini Urban <rurban@cpanel.net> + Version 3.04c + + * fix printf types and warnings, esp. for 32bit use64bitint + * Change sv_setpvn(…, "…", …) to sv_setpvs(…, "…") + +Tue Jul 26 11:49:33 2016 +1000 Tony Cook <tony@develop-help.com> + Version 3.03c + + * remove . from @INC when loading optional modules + +Sun Nov 20 18:06:45 2016 +0100 Reini Urban <rurban@cpanel.net> + Version 3.02c + + * Fix -Wc++11-compat warnings, fix -Wchar-subscripts + +Fri Sep 16 01:32:59 2016 +0200 Reini Urban <rurban@cpanel.net> + Version 3.01c + + * Added warn_security("Movable-Type CVE-2015-1592 Storable metasploit attack") + when detecting the third destructive metasploit vector, + thawing bless \"mt-config.cgi", "CGITempFile". + +Thu Mar 31 17:10:27 2016 +0200 Reini Urban <rurban@cpanel.net> + Version 3.00c + + * Added support for u64 strings, arrays and hashes >2G + via a new LOBJECT tag. This is for 32bit systems and lengths + between 2GB and 4GB (I32-U32), and 64bit (>I32). + * Bumped STORABLE_BIN_MINOR and STORABLE_BIN_WRITE_MINOR from 10 to 11 + * fix parallel tests, use unique filenames. + * fixed 2 instances of 2arg open, + * added optional flag arguments to skip tie and bless on retrieve/thaw, + * added SECURITY WARNING and Large data support to docs + * compute CAN_FLOCK at compile-time + * reformat everything consistently + * enable DEBUGME tracing and asserts with -DDEBUGGING + * fix all 64 bit compiler warnings + * added some abstraction methods to avoid code duplication + +?????? p5p <perl5-porters@perl.org> + Version 2.65 + + * Replace multiple 'use vars' by 'our' + * remove Config dependency + Wed Jul 2 16:25:25 IST 2014 Abhijit Menon-Sen <ams@toroid.org> Version 2.51 diff --git a/gnu/usr.bin/perl/dist/Storable/Storable.pm b/gnu/usr.bin/perl/dist/Storable/Storable.pm deleted file mode 100644 index 5823b930b8d..00000000000 --- a/gnu/usr.bin/perl/dist/Storable/Storable.pm +++ /dev/null @@ -1,1237 +0,0 @@ -# -# Copyright (c) 1995-2001, Raphael Manfredi -# Copyright (c) 2002-2014 by the Perl 5 Porters -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -require XSLoader; -require Exporter; -package Storable; @ISA = qw(Exporter); - -@EXPORT = qw(store retrieve); -@EXPORT_OK = qw( - nstore store_fd nstore_fd fd_retrieve - freeze nfreeze thaw - dclone - retrieve_fd - lock_store lock_nstore lock_retrieve - file_magic read_magic -); - -use vars qw($canonical $forgive_me $VERSION); - -$VERSION = '2.56_01'; - -BEGIN { - if (eval { - local $SIG{__DIE__}; - local @INC = @INC; - pop @INC if $INC[-1] eq '.'; - require Log::Agent; - 1; - }) { - Log::Agent->import; - } - # - # Use of Log::Agent is optional. If it hasn't imported these subs then - # provide a fallback implementation. - # - unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) { - require Carp; - *logcroak = sub { - Carp::croak(@_); - }; - } - unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) { - require Carp; - *logcarp = sub { - Carp::carp(@_); - }; - } -} - -# -# They might miss :flock in Fcntl -# - -BEGIN { - if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) { - Fcntl->import(':flock'); - } else { - eval q{ - sub LOCK_SH () {1} - sub LOCK_EX () {2} - }; - } -} - -sub CLONE { - # clone context under threads - Storable::init_perinterp(); -} - -# By default restricted hashes are downgraded on earlier perls. - -$Storable::downgrade_restricted = 1; -$Storable::accept_future_minor = 1; - -XSLoader::load('Storable', $Storable::VERSION); - -# -# Determine whether locking is possible, but only when needed. -# - -sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK { - return $CAN_FLOCK if defined $CAN_FLOCK; - require Config; import Config; - return $CAN_FLOCK = - $Config{'d_flock'} || - $Config{'d_fcntl_can_lock'} || - $Config{'d_lockf'}; -} - -sub show_file_magic { - print <<EOM; -# -# To recognize the data files of the Perl module Storable, -# the following lines need to be added to the local magic(5) file, -# usually either /usr/share/misc/magic or /etc/magic. -# -0 string perl-store perl Storable(v0.6) data ->4 byte >0 (net-order %d) ->>4 byte &01 (network-ordered) ->>4 byte =3 (major 1) ->>4 byte =2 (major 1) - -0 string pst0 perl Storable(v0.7) data ->4 byte >0 ->>4 byte &01 (network-ordered) ->>4 byte =5 (major 2) ->>4 byte =4 (major 2) ->>5 byte >0 (minor %d) -EOM -} - -sub file_magic { - require IO::File; - - my $file = shift; - my $fh = IO::File->new; - open($fh, "<". $file) || die "Can't open '$file': $!"; - binmode($fh); - defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!"; - close($fh); - - $file = "./$file" unless $file; # ensure TRUE value - - return read_magic($buf, $file); -} - -sub read_magic { - my($buf, $file) = @_; - my %info; - - my $buflen = length($buf); - my $magic; - if ($buf =~ s/^(pst0|perl-store)//) { - $magic = $1; - $info{file} = $file || 1; - } - else { - return undef if $file; - $magic = ""; - } - - return undef unless length($buf); - - my $net_order; - if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) { - $info{version} = -1; - $net_order = 0; - } - else { - $buf =~ s/(.)//s; - my $major = (ord $1) >> 1; - return undef if $major > 4; # sanity (assuming we never go that high) - $info{major} = $major; - $net_order = (ord $1) & 0x01; - if ($major > 1) { - return undef unless $buf =~ s/(.)//s; - my $minor = ord $1; - $info{minor} = $minor; - $info{version} = "$major.$minor"; - $info{version_nv} = sprintf "%d.%03d", $major, $minor; - } - else { - $info{version} = $major; - } - } - $info{version_nv} ||= $info{version}; - $info{netorder} = $net_order; - - unless ($net_order) { - return undef unless $buf =~ s/(.)//s; - my $len = ord $1; - return undef unless length($buf) >= $len; - return undef unless $len == 4 || $len == 8; # sanity - @info{qw(byteorder intsize longsize ptrsize)} - = unpack "a${len}CCC", $buf; - (substr $buf, 0, $len + 3) = ''; - if ($info{version_nv} >= 2.002) { - return undef unless $buf =~ s/(.)//s; - $info{nvsize} = ord $1; - } - } - $info{hdrsize} = $buflen - length($buf); - - return \%info; -} - -sub BIN_VERSION_NV { - sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR(); -} - -sub BIN_WRITE_VERSION_NV { - sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR(); -} - -# -# store -# -# Store target object hierarchy, identified by a reference to its root. -# The stored object tree may later be retrieved to memory via retrieve. -# Returns undef if an I/O error occurred, in which case the file is -# removed. -# -sub store { - return _store(\&pstore, @_, 0); -} - -# -# nstore -# -# Same as store, but in network order. -# -sub nstore { - return _store(\&net_pstore, @_, 0); -} - -# -# lock_store -# -# Same as store, but flock the file first (advisory locking). -# -sub lock_store { - return _store(\&pstore, @_, 1); -} - -# -# lock_nstore -# -# Same as nstore, but flock the file first (advisory locking). -# -sub lock_nstore { - return _store(\&net_pstore, @_, 1); -} - -# Internal store to file routine -sub _store { - my $xsptr = shift; - my $self = shift; - my ($file, $use_locking) = @_; - logcroak "not a reference" unless ref($self); - logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist - local *FILE; - if ($use_locking) { - open(FILE, ">>$file") || logcroak "can't write into $file: $!"; - unless (&CAN_FLOCK) { - logcarp - "Storable::lock_store: fcntl/flock emulation broken on $^O"; - return undef; - } - flock(FILE, LOCK_EX) || - logcroak "can't get exclusive lock on $file: $!"; - truncate FILE, 0; - # Unlocking will happen when FILE is closed - } else { - open(FILE, ">$file") || logcroak "can't create $file: $!"; - } - binmode FILE; # Archaic systems... - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine nstore or pstore, depending on network order - eval { $ret = &$xsptr(*FILE, $self) }; - # close will return true on success, so the or short-circuits, the () - # expression is true, and for that case the block will only be entered - # if $@ is true (ie eval failed) - # if close fails, it returns false, $ret is altered, *that* is (also) - # false, so the () expression is false, !() is true, and the block is - # entered. - if (!(close(FILE) or undef $ret) || $@) { - unlink($file) or warn "Can't unlink $file: $!\n"; - } - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $ret; -} - -# -# store_fd -# -# Same as store, but perform on an already opened file descriptor instead. -# Returns undef if an I/O error occurred. -# -sub store_fd { - return _store_fd(\&pstore, @_); -} - -# -# nstore_fd -# -# Same as store_fd, but in network order. -# -sub nstore_fd { - my ($self, $file) = @_; - return _store_fd(\&net_pstore, @_); -} - -# Internal store routine on opened file descriptor -sub _store_fd { - my $xsptr = shift; - my $self = shift; - my ($file) = @_; - logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 1; # No @foo in arglist - my $fd = fileno($file); - logcroak "not a valid file descriptor" unless defined $fd; - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine nstore or pstore, depending on network order - eval { $ret = &$xsptr($file, $self) }; - logcroak $@ if $@ =~ s/\.?\n$/,/; - local $\; print $file ''; # Autoflush the file if wanted - $@ = $da; - return $ret; -} - -# -# freeze -# -# Store object and its hierarchy in memory and return a scalar -# containing the result. -# -sub freeze { - _freeze(\&mstore, @_); -} - -# -# nfreeze -# -# Same as freeze but in network order. -# -sub nfreeze { - _freeze(\&net_mstore, @_); -} - -# Internal freeze routine -sub _freeze { - my $xsptr = shift; - my $self = shift; - logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 0; # No @foo in arglist - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine mstore or net_mstore, depending on network order - eval { $ret = &$xsptr($self) }; - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $ret ? $ret : undef; -} - -# -# retrieve -# -# Retrieve object hierarchy from disk, returning a reference to the root -# object of that tree. -# -sub retrieve { - _retrieve($_[0], 0); -} - -# -# lock_retrieve -# -# Same as retrieve, but with advisory locking. -# -sub lock_retrieve { - _retrieve($_[0], 1); -} - -# Internal retrieve routine -sub _retrieve { - my ($file, $use_locking) = @_; - local *FILE; - open(FILE, $file) || logcroak "can't open $file: $!"; - binmode FILE; # Archaic systems... - my $self; - my $da = $@; # Could be from exception handler - if ($use_locking) { - unless (&CAN_FLOCK) { - logcarp - "Storable::lock_store: fcntl/flock emulation broken on $^O"; - return undef; - } - flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; - # Unlocking will happen when FILE is closed - } - eval { $self = pretrieve(*FILE) }; # Call C routine - close(FILE); - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -# -# fd_retrieve -# -# Same as retrieve, but perform from an already opened file descriptor instead. -# -sub fd_retrieve { - my ($file) = @_; - my $fd = fileno($file); - logcroak "not a valid file descriptor" unless defined $fd; - my $self; - my $da = $@; # Could be from exception handler - eval { $self = pretrieve($file) }; # Call C routine - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -sub retrieve_fd { &fd_retrieve } # Backward compatibility - -# -# thaw -# -# Recreate objects in memory from an existing frozen image created -# by freeze. If the frozen image passed is undef, return undef. -# -sub thaw { - my ($frozen) = @_; - return undef unless defined $frozen; - my $self; - my $da = $@; # Could be from exception handler - eval { $self = mretrieve($frozen) }; # Call C routine - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -1; -__END__ - -=head1 NAME - -Storable - persistence for Perl data structures - -=head1 SYNOPSIS - - use Storable; - store \%table, 'file'; - $hashref = retrieve('file'); - - use Storable qw(nstore store_fd nstore_fd freeze thaw dclone); - - # Network order - nstore \%table, 'file'; - $hashref = retrieve('file'); # There is NO nretrieve() - - # Storing to and retrieving from an already opened file - store_fd \@array, \*STDOUT; - nstore_fd \%table, \*STDOUT; - $aryref = fd_retrieve(\*SOCKET); - $hashref = fd_retrieve(\*SOCKET); - - # Serializing to memory - $serialized = freeze \%table; - %table_clone = %{ thaw($serialized) }; - - # Deep (recursive) cloning - $cloneref = dclone($ref); - - # Advisory locking - use Storable qw(lock_store lock_nstore lock_retrieve) - lock_store \%table, 'file'; - lock_nstore \%table, 'file'; - $hashref = lock_retrieve('file'); - -=head1 DESCRIPTION - -The Storable package brings persistence to your Perl data structures -containing SCALAR, ARRAY, HASH or REF objects, i.e. anything that can be -conveniently stored to disk and retrieved at a later time. - -It can be used in the regular procedural way by calling C<store> with -a reference to the object to be stored, along with the file name where -the image should be written. - -The routine returns C<undef> for I/O problems or other internal error, -a true value otherwise. Serious errors are propagated as a C<die> exception. - -To retrieve data stored to disk, use C<retrieve> with a file name. -The objects stored into that file are recreated into memory for you, -and a I<reference> to the root object is returned. In case an I/O error -occurs while reading, C<undef> is returned instead. Other serious -errors are propagated via C<die>. - -Since storage is performed recursively, you might want to stuff references -to objects that share a lot of common data into a single array or hash -table, and then store that object. That way, when you retrieve back the -whole thing, the objects will continue to share what they originally shared. - -At the cost of a slight header overhead, you may store to an already -opened file descriptor using the C<store_fd> routine, and retrieve -from a file via C<fd_retrieve>. Those names aren't imported by default, -so you will have to do that explicitly if you need those routines. -The file descriptor you supply must be already opened, for read -if you're going to retrieve and for write if you wish to store. - - store_fd(\%table, *STDOUT) || die "can't store to stdout\n"; - $hashref = fd_retrieve(*STDIN); - -You can also store data in network order to allow easy sharing across -multiple platforms, or when storing on a socket known to be remotely -connected. The routines to call have an initial C<n> prefix for I<network>, -as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be -correctly restored so you don't have to know whether you're restoring -from native or network ordered data. Double values are stored stringified -to ensure portability as well, at the slight risk of loosing some precision -in the last decimals. - -When using C<fd_retrieve>, objects are retrieved in sequence, one -object (i.e. one recursive tree) per associated C<store_fd>. - -If you're more from the object-oriented camp, you can inherit from -Storable and directly store your objects by invoking C<store> as -a method. The fact that the root of the to-be-stored tree is a -blessed reference (i.e. an object) is special-cased so that the -retrieve does not provide a reference to that object but rather the -blessed object reference itself. (Otherwise, you'd get a reference -to that blessed object). - -=head1 MEMORY STORE - -The Storable engine can also store data into a Perl scalar instead, to -later retrieve them. This is mainly used to freeze a complex structure in -some safe compact memory place (where it can possibly be sent to another -process via some IPC, since freezing the structure also serializes it in -effect). Later on, and maybe somewhere else, you can thaw the Perl scalar -out and recreate the original complex structure in memory. - -Surprisingly, the routines to be called are named C<freeze> and C<thaw>. -If you wish to send out the frozen scalar to another machine, use -C<nfreeze> instead to get a portable image. - -Note that freezing an object structure and immediately thawing it -actually achieves a deep cloning of that structure: - - dclone(.) = thaw(freeze(.)) - -Storable provides you with a C<dclone> interface which does not create -that intermediary scalar but instead freezes the structure in some -internal memory space and then immediately thaws it out. - -=head1 ADVISORY LOCKING - -The C<lock_store> and C<lock_nstore> routine are equivalent to -C<store> and C<nstore>, except that they get an exclusive lock on -the file before writing. Likewise, C<lock_retrieve> does the same -as C<retrieve>, but also gets a shared lock on the file before reading. - -As with any advisory locking scheme, the protection only works if you -systematically use C<lock_store> and C<lock_retrieve>. If one side of -your application uses C<store> whilst the other uses C<lock_retrieve>, -you will get no protection at all. - -The internal advisory locking is implemented using Perl's flock() -routine. If your system does not support any form of flock(), or if -you share your files across NFS, you might wish to use other forms -of locking by using modules such as LockFile::Simple which lock a -file using a filesystem entry, instead of locking the file descriptor. - -=head1 SPEED - -The heart of Storable is written in C for decent speed. Extra low-level -optimizations have been made when manipulating perl internals, to -sacrifice encapsulation for the benefit of greater speed. - -=head1 CANONICAL REPRESENTATION - -Normally, Storable stores elements of hashes in the order they are -stored internally by Perl, i.e. pseudo-randomly. If you set -C<$Storable::canonical> to some C<TRUE> value, Storable will store -hashes with the elements sorted by their key. This allows you to -compare data structures by comparing their frozen representations (or -even the compressed frozen representations), which can be useful for -creating lookup tables for complicated queries. - -Canonical order does not imply network order; those are two orthogonal -settings. - -=head1 CODE REFERENCES - -Since Storable version 2.05, CODE references may be serialized with -the help of L<B::Deparse>. To enable this feature, set -C<$Storable::Deparse> to a true value. To enable deserialization, -C<$Storable::Eval> should be set to a true value. Be aware that -deserialization is done through C<eval>, which is dangerous if the -Storable file contains malicious data. You can set C<$Storable::Eval> -to a subroutine reference which would be used instead of C<eval>. See -below for an example using a L<Safe> compartment for deserialization -of CODE references. - -If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false -values, then the value of C<$Storable::forgive_me> (see below) is -respected while serializing and deserializing. - -=head1 FORWARD COMPATIBILITY - -This release of Storable can be used on a newer version of Perl to -serialize data which is not supported by earlier Perls. By default, -Storable will attempt to do the right thing, by C<croak()>ing if it -encounters data that it cannot deserialize. However, the defaults -can be changed as follows: - -=over 4 - -=item utf8 data - -Perl 5.6 added support for Unicode characters with code points > 255, -and Perl 5.8 has full support for Unicode characters in hash keys. -Perl internally encodes strings with these characters using utf8, and -Storable serializes them as utf8. By default, if an older version of -Perl encounters a utf8 value it cannot represent, it will C<croak()>. -To change this behaviour so that Storable deserializes utf8 encoded -values as the string of bytes (effectively dropping the I<is_utf8> flag) -set C<$Storable::drop_utf8> to some C<TRUE> value. This is a form of -data loss, because with C<$drop_utf8> true, it becomes impossible to tell -whether the original data was the Unicode string, or a series of bytes -that happen to be valid utf8. - -=item restricted hashes - -Perl 5.8 adds support for restricted hashes, which have keys -restricted to a given set, and can have values locked to be read only. -By default, when Storable encounters a restricted hash on a perl -that doesn't support them, it will deserialize it as a normal hash, -silently discarding any placeholder keys and leaving the keys and -all values unlocked. To make Storable C<croak()> instead, set -C<$Storable::downgrade_restricted> to a C<FALSE> value. To restore -the default set it back to some C<TRUE> value. - -=item files from future versions of Storable - -Earlier versions of Storable would immediately croak if they encountered -a file with a higher internal version number than the reading Storable -knew about. Internal version numbers are increased each time new data -types (such as restricted hashes) are added to the vocabulary of the file -format. This meant that a newer Storable module had no way of writing a -file readable by an older Storable, even if the writer didn't store newer -data types. - -This version of Storable will defer croaking until it encounters a data -type in the file that it does not recognize. This means that it will -continue to read files generated by newer Storable modules which are careful -in what they write out, making it easier to upgrade Storable modules in a -mixed environment. - -The old behaviour of immediate croaking can be re-instated by setting -C<$Storable::accept_future_minor> to some C<FALSE> value. - -=back - -All these variables have no effect on a newer Perl which supports the -relevant feature. - -=head1 ERROR REPORTING - -Storable uses the "exception" paradigm, in that it does not try to workaround -failures: if something bad happens, an exception is generated from the -caller's perspective (see L<Carp> and C<croak()>). Use eval {} to trap -those exceptions. - -When Storable croaks, it tries to report the error via the C<logcroak()> -routine from the C<Log::Agent> package, if it is available. - -Normal errors are reported by having store() or retrieve() return C<undef>. -Such errors are usually I/O errors (or truncated stream errors at retrieval). - -=head1 WIZARDS ONLY - -=head2 Hooks - -Any class may define hooks that will be called during the serialization -and deserialization process on objects that are instances of that class. -Those hooks can redefine the way serialization is performed (and therefore, -how the symmetrical deserialization should be conducted). - -Since we said earlier: - - dclone(.) = thaw(freeze(.)) - -everything we say about hooks should also hold for deep cloning. However, -hooks get to know whether the operation is a mere serialization, or a cloning. - -Therefore, when serializing hooks are involved, - - dclone(.) <> thaw(freeze(.)) - -Well, you could keep them in sync, but there's no guarantee it will always -hold on classes somebody else wrote. Besides, there is little to gain in -doing so: a serializing hook could keep only one attribute of an object, -which is probably not what should happen during a deep cloning of that -same object. - -Here is the hooking interface: - -=over 4 - -=item C<STORABLE_freeze> I<obj>, I<cloning> - -The serializing hook, called on the object during serialization. It can be -inherited, or defined in the class itself, like any other method. - -Arguments: I<obj> is the object to serialize, I<cloning> is a flag indicating -whether we're in a dclone() or a regular serialization via store() or freeze(). - -Returned value: A LIST C<($serialized, $ref1, $ref2, ...)> where $serialized -is the serialized form to be used, and the optional $ref1, $ref2, etc... are -extra references that you wish to let the Storable engine serialize. - -At deserialization time, you will be given back the same LIST, but all the -extra references will be pointing into the deserialized structure. - -The B<first time> the hook is hit in a serialization flow, you may have it -return an empty list. That will signal the Storable engine to further -discard that hook for this class and to therefore revert to the default -serialization of the underlying Perl data. The hook will again be normally -processed in the next serialization. - -Unless you know better, serializing hook should always say: - - sub STORABLE_freeze { - my ($self, $cloning) = @_; - return if $cloning; # Regular default serialization - .... - } - -in order to keep reasonable dclone() semantics. - -=item C<STORABLE_thaw> I<obj>, I<cloning>, I<serialized>, ... - -The deserializing hook called on the object during deserialization. -But wait: if we're deserializing, there's no object yet... right? - -Wrong: the Storable engine creates an empty one for you. If you know Eiffel, -you can view C<STORABLE_thaw> as an alternate creation routine. - -This means the hook can be inherited like any other method, and that -I<obj> is your blessed reference for this particular instance. - -The other arguments should look familiar if you know C<STORABLE_freeze>: -I<cloning> is true when we're part of a deep clone operation, I<serialized> -is the serialized string you returned to the engine in C<STORABLE_freeze>, -and there may be an optional list of references, in the same order you gave -them at serialization time, pointing to the deserialized objects (which -have been processed courtesy of the Storable engine). - -When the Storable engine does not find any C<STORABLE_thaw> hook routine, -it tries to load the class by requiring the package dynamically (using -the blessed package name), and then re-attempts the lookup. If at that -time the hook cannot be located, the engine croaks. Note that this mechanism -will fail if you define several classes in the same file, but L<perlmod> -warned you. - -It is up to you to use this information to populate I<obj> the way you want. - -Returned value: none. - -=item C<STORABLE_attach> I<class>, I<cloning>, I<serialized> - -While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where -each instance is independent, this mechanism has difficulty (or is -incompatible) with objects that exist as common process-level or -system-level resources, such as singleton objects, database pools, caches -or memoized objects. - -The alternative C<STORABLE_attach> method provides a solution for these -shared objects. Instead of C<STORABLE_freeze> --E<gt> C<STORABLE_thaw>, -you implement C<STORABLE_freeze> --E<gt> C<STORABLE_attach> instead. - -Arguments: I<class> is the class we are attaching to, I<cloning> is a flag -indicating whether we're in a dclone() or a regular de-serialization via -thaw(), and I<serialized> is the stored string for the resource object. - -Because these resource objects are considered to be owned by the entire -process/system, and not the "property" of whatever is being serialized, -no references underneath the object should be included in the serialized -string. Thus, in any class that implements C<STORABLE_attach>, the -C<STORABLE_freeze> method cannot return any references, and C<Storable> -will throw an error if C<STORABLE_freeze> tries to return references. - -All information required to "attach" back to the shared resource object -B<must> be contained B<only> in the C<STORABLE_freeze> return string. -Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach> -classes. - -Because C<STORABLE_attach> is passed the class (rather than an object), -it also returns the object directly, rather than modifying the passed -object. - -Returned value: object of type C<class> - -=back - -=head2 Predicates - -Predicates are not exportable. They must be called by explicitly prefixing -them with the Storable package name. - -=over 4 - -=item C<Storable::last_op_in_netorder> - -The C<Storable::last_op_in_netorder()> predicate will tell you whether -network order was used in the last store or retrieve operation. If you -don't know how to use this, just forget about it. - -=item C<Storable::is_storing> - -Returns true if within a store operation (via STORABLE_freeze hook). - -=item C<Storable::is_retrieving> - -Returns true if within a retrieve operation (via STORABLE_thaw hook). - -=back - -=head2 Recursion - -With hooks comes the ability to recurse back to the Storable engine. -Indeed, hooks are regular Perl code, and Storable is convenient when -it comes to serializing and deserializing things, so why not use it -to handle the serialization string? - -There are a few things you need to know, however: - -=over 4 - -=item * - -You can create endless loops if the things you serialize via freeze() -(for instance) point back to the object we're trying to serialize in -the hook. - -=item * - -Shared references among objects will not stay shared: if we're serializing -the list of object [A, C] where both object A and C refer to the SAME object -B, and if there is a serializing hook in A that says freeze(B), then when -deserializing, we'll get [A', C'] where A' refers to B', but C' refers to D, -a deep clone of B'. The topology was not preserved. - -=back - -That's why C<STORABLE_freeze> lets you provide a list of references -to serialize. The engine guarantees that those will be serialized in the -same context as the other objects, and therefore that shared objects will -stay shared. - -In the above [A, C] example, the C<STORABLE_freeze> hook could return: - - ("something", $self->{B}) - -and the B part would be serialized by the engine. In C<STORABLE_thaw>, you -would get back the reference to the B' object, deserialized for you. - -Therefore, recursion should normally be avoided, but is nonetheless supported. - -=head2 Deep Cloning - -There is a Clone module available on CPAN which implements deep cloning -natively, i.e. without freezing to memory and thawing the result. It is -aimed to replace Storable's dclone() some day. However, it does not currently -support Storable hooks to redefine the way deep cloning is performed. - -=head1 Storable magic - -Yes, there's a lot of that :-) But more precisely, in UNIX systems -there's a utility called C<file>, which recognizes data files based on -their contents (usually their first few bytes). For this to work, -a certain file called F<magic> needs to taught about the I<signature> -of the data. Where that configuration file lives depends on the UNIX -flavour; often it's something like F</usr/share/misc/magic> or -F</etc/magic>. Your system administrator needs to do the updating of -the F<magic> file. The necessary signature information is output to -STDOUT by invoking Storable::show_file_magic(). Note that the GNU -implementation of the C<file> utility, version 3.38 or later, -is expected to contain support for recognising Storable files -out-of-the-box, in addition to other kinds of Perl files. - -You can also use the following functions to extract the file header -information from Storable images: - -=over - -=item $info = Storable::file_magic( $filename ) - -If the given file is a Storable image return a hash describing it. If -the file is readable, but not a Storable image return C<undef>. If -the file does not exist or is unreadable then croak. - -The hash returned has the following elements: - -=over - -=item C<version> - -This returns the file format version. It is a string like "2.7". - -Note that this version number is not the same as the version number of -the Storable module itself. For instance Storable v0.7 create files -in format v2.0 and Storable v2.15 create files in format v2.7. The -file format version number only increment when additional features -that would confuse older versions of the module are added. - -Files older than v2.0 will have the one of the version numbers "-1", -"0" or "1". No minor number was used at that time. - -=item C<version_nv> - -This returns the file format version as number. It is a string like -"2.007". This value is suitable for numeric comparisons. - -The constant function C<Storable::BIN_VERSION_NV> returns a comparable -number that represents the highest file version number that this -version of Storable fully supports (but see discussion of -C<$Storable::accept_future_minor> above). The constant -C<Storable::BIN_WRITE_VERSION_NV> function returns what file version -is written and might be less than C<Storable::BIN_VERSION_NV> in some -configurations. - -=item C<major>, C<minor> - -This also returns the file format version. If the version is "2.7" -then major would be 2 and minor would be 7. The minor element is -missing for when major is less than 2. - -=item C<hdrsize> - -The is the number of bytes that the Storable header occupies. - -=item C<netorder> - -This is TRUE if the image store data in network order. This means -that it was created with nstore() or similar. - -=item C<byteorder> - -This is only present when C<netorder> is FALSE. It is the -$Config{byteorder} string of the perl that created this image. It is -a string like "1234" (32 bit little endian) or "87654321" (64 bit big -endian). This must match the current perl for the image to be -readable by Storable. - -=item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize> - -These are only present when C<netorder> is FALSE. These are the sizes of -various C datatypes of the perl that created this image. These must -match the current perl for the image to be readable by Storable. - -The C<nvsize> element is only present for file format v2.2 and -higher. - -=item C<file> - -The name of the file. - -=back - -=item $info = Storable::read_magic( $buffer ) - -=item $info = Storable::read_magic( $buffer, $must_be_file ) - -The $buffer should be a Storable image or the first few bytes of it. -If $buffer starts with a Storable header, then a hash describing the -image is returned, otherwise C<undef> is returned. - -The hash has the same structure as the one returned by -Storable::file_magic(). The C<file> element is true if the image is a -file image. - -If the $must_be_file argument is provided and is TRUE, then return -C<undef> unless the image looks like it belongs to a file dump. - -The maximum size of a Storable header is currently 21 bytes. If the -provided $buffer is only the first part of a Storable image it should -at least be this long to ensure that read_magic() will recognize it as -such. - -=back - -=head1 EXAMPLES - -Here are some code samples showing a possible usage of Storable: - - use Storable qw(store retrieve freeze thaw dclone); - - %color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1); - - store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n"; - - $colref = retrieve('mycolors'); - die "Unable to retrieve from mycolors!\n" unless defined $colref; - printf "Blue is still %lf\n", $colref->{'Blue'}; - - $colref2 = dclone(\%color); - - $str = freeze(\%color); - printf "Serialization of %%color is %d bytes long.\n", length($str); - $colref3 = thaw($str); - -which prints (on my machine): - - Blue is still 0.100000 - Serialization of %color is 102 bytes long. - -Serialization of CODE references and deserialization in a safe -compartment: - -=for example begin - - use Storable qw(freeze thaw); - use Safe; - use strict; - my $safe = new Safe; - # because of opcodes used in "use strict": - $safe->permit(qw(:default require)); - local $Storable::Deparse = 1; - local $Storable::Eval = sub { $safe->reval($_[0]) }; - my $serialized = freeze(sub { 42 }); - my $code = thaw($serialized); - $code->() == 42; - -=for example end - -=for example_testing - is( $code->(), 42 ); - -=head1 SECURITY WARNING - -B<Do not accept Storable documents from untrusted sources!> - -Some features of Storable can lead to security vulnerabilities if you -accept Storable documents from untrusted sources. Most obviously, the -optional (off by default) CODE reference serialization feature allows -transfer of code to the deserializing process. Furthermore, any -serialized object will cause Storable to helpfully load the module -corresponding to the class of the object in the deserializing module. -For manipulated module names, this can load almost arbitrary code. -Finally, the deserialized object's destructors will be invoked when -the objects get destroyed in the deserializing process. Maliciously -crafted Storable documents may put such objects in the value of -a hash key that is overridden by another key/value pair in the -same hash, thus causing immediate destructor execution. - -In a future version of Storable, we intend to provide options to disable -loading modules for classes and to disable deserializing objects -altogether. I<Nonetheless, Storable deserializing documents from -untrusted sources is expected to have other, yet undiscovered, -security concerns such as allowing an attacker to cause the deserializer -to crash hard.> - -B<Therefore, let me repeat: Do not accept Storable documents from -untrusted sources!> - -If your application requires accepting data from untrusted sources, you -are best off with a less powerful and more-likely safe serialization format -and implementation. If your data is sufficiently simple, JSON is a good -choice and offers maximum interoperability. - -=head1 WARNING - -If you're using references as keys within your hash tables, you're bound -to be disappointed when retrieving your data. Indeed, Perl stringifies -references used as hash table keys. If you later wish to access the -items via another reference stringification (i.e. using the same -reference that was used for the key originally to record the value into -the hash table), it will work because both references stringify to the -same string. - -It won't work across a sequence of C<store> and C<retrieve> operations, -however, because the addresses in the retrieved objects, which are -part of the stringified references, will probably differ from the -original addresses. The topology of your structure is preserved, -but not hidden semantics like those. - -On platforms where it matters, be sure to call C<binmode()> on the -descriptors that you pass to Storable functions. - -Storing data canonically that contains large hashes can be -significantly slower than storing the same data normally, as -temporary arrays to hold the keys for each hash have to be allocated, -populated, sorted and freed. Some tests have shown a halving of the -speed of storing -- the exact penalty will depend on the complexity of -your data. There is no slowdown on retrieval. - -=head1 BUGS - -You can't store GLOB, FORMLINE, REGEXP, etc.... If you can define semantics -for those operations, feel free to enhance Storable so that it can -deal with them. - -The store functions will C<croak> if they run into such references -unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that -case, the fatal message is converted to a warning and some meaningless -string is stored instead. - -Setting C<$Storable::canonical> may not yield frozen strings that -compare equal due to possible stringification of numbers. When the -string version of a scalar exists, it is the form stored; therefore, -if you happen to use your numbers as strings between two freezing -operations on the same data structures, you will get different -results. - -When storing doubles in network order, their value is stored as text. -However, you should also not expect non-numeric floating-point values -such as infinity and "not a number" to pass successfully through a -nstore()/retrieve() pair. - -As Storable neither knows nor cares about character sets (although it -does know that characters may be more than eight bits wide), any difference -in the interpretation of character codes between a host and a target -system is your problem. In particular, if host and target use different -code points to represent the characters used in the text representation -of floating-point numbers, you will not be able be able to exchange -floating-point data, even with nstore(). - -C<Storable::drop_utf8> is a blunt tool. There is no facility either to -return B<all> strings as utf8 sequences, or to attempt to convert utf8 -data back to 8 bit and C<croak()> if the conversion fails. - -Prior to Storable 2.01, no distinction was made between signed and -unsigned integers on storing. By default Storable prefers to store a -scalars string representation (if it has one) so this would only cause -problems when storing large unsigned integers that had never been converted -to string or floating point. In other words values that had been generated -by integer operations such as logic ops and then not used in any string or -arithmetic context before storing. - -=head2 64 bit data in perl 5.6.0 and 5.6.1 - -This section only applies to you if you have existing data written out -by Storable 2.02 or earlier on perl 5.6.0 or 5.6.1 on Unix or Linux which -has been configured with 64 bit integer support (not the default) -If you got a precompiled perl, rather than running Configure to build -your own perl from source, then it almost certainly does not affect you, -and you can stop reading now (unless you're curious). If you're using perl -on Windows it does not affect you. - -Storable writes a file header which contains the sizes of various C -language types for the C compiler that built Storable (when not writing in -network order), and will refuse to load files written by a Storable not -on the same (or compatible) architecture. This check and a check on -machine byteorder is needed because the size of various fields in the file -are given by the sizes of the C language types, and so files written on -different architectures are incompatible. This is done for increased speed. -(When writing in network order, all fields are written out as standard -lengths, which allows full interworking, but takes longer to read and write) - -Perl 5.6.x introduced the ability to optional configure the perl interpreter -to use C's C<long long> type to allow scalars to store 64 bit integers on 32 -bit systems. However, due to the way the Perl configuration system -generated the C configuration files on non-Windows platforms, and the way -Storable generates its header, nothing in the Storable file header reflected -whether the perl writing was using 32 or 64 bit integers, despite the fact -that Storable was storing some data differently in the file. Hence Storable -running on perl with 64 bit integers will read the header from a file -written by a 32 bit perl, not realise that the data is actually in a subtly -incompatible format, and then go horribly wrong (possibly crashing) if it -encountered a stored integer. This is a design failure. - -Storable has now been changed to write out and read in a file header with -information about the size of integers. It's impossible to detect whether -an old file being read in was written with 32 or 64 bit integers (they have -the same header) so it's impossible to automatically switch to a correct -backwards compatibility mode. Hence this Storable defaults to the new, -correct behaviour. - -What this means is that if you have data written by Storable 1.x running -on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux -then by default this Storable will refuse to read it, giving the error -I<Byte order is not compatible>. If you have such data then you -should set C<$Storable::interwork_56_64bit> to a true value to make this -Storable read and write files with the old header. You should also -migrate your data, or any older perl you are communicating with, to this -current version of Storable. - -If you don't have data written with specific configuration of perl described -above, then you do not and should not do anything. Don't set the flag - -not only will Storable on an identically configured perl refuse to load them, -but Storable a differently configured perl will load them believing them -to be correct for it, and then may well fail or crash part way through -reading them. - -=head1 CREDITS - -Thank you to (in chronological order): - - Jarkko Hietaniemi <jhi@iki.fi> - Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> - Benjamin A. Holzman <bholzman@earthlink.net> - Andrew Ford <A.Ford@ford-mason.co.uk> - Gisle Aas <gisle@aas.no> - Jeff Gresham <gresham_jeffrey@jpmorgan.com> - Murray Nesbitt <murray@activestate.com> - Marc Lehmann <pcg@opengroup.org> - Justin Banks <justinb@wamnet.com> - Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!) - Salvador Ortiz Garcia <sog@msg.com.mx> - Dominic Dunlop <domo@computer.org> - Erik Haugan <erik@solbors.no> - Benjamin A. Holzman <ben.holzman@grantstreet.com> - Reini Urban <rurban@cpanel.net> - -for their bug reports, suggestions and contributions. - -Benjamin Holzman contributed the tied variable support, Andrew Ford -contributed the canonical order for hashes, and Gisle Aas fixed -a few misunderstandings of mine regarding the perl internals, -and optimized the emission of "tags" in the output streams by -simply counting the objects instead of tagging them (leading to -a binary incompatibility for the Storable image starting at version -0.6--older images are, of course, still properly understood). -Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading -and references to tied items support. Benjamin Holzman added a performance -improvement for overloaded classes; thanks to Grant Street Group for footing -the bill. - -=head1 AUTHOR - -Storable was written by Raphael Manfredi -F<E<lt>Raphael_Manfredi@pobox.comE<gt>> -Maintenance is now done by the perl5-porters -F<E<lt>perl5-porters@perl.orgE<gt>> - -Please e-mail us with problems, bug fixes, comments and complaints, -although if you have compliments you should send them to Raphael. -Please don't e-mail Raphael with problems, as he no longer works on -Storable, and your message will be delayed while he forwards it to us. - -=head1 SEE ALSO - -L<Clone>. - -=cut diff --git a/gnu/usr.bin/perl/dist/Storable/Storable.xs b/gnu/usr.bin/perl/dist/Storable/Storable.xs index 83cd00166db..6a90e248142 100644 --- a/gnu/usr.bin/perl/dist/Storable/Storable.xs +++ b/gnu/usr.bin/perl/dist/Storable/Storable.xs @@ -1,8 +1,11 @@ -/* - * Store and retrieve mechanism. +/* -*- c-basic-offset: 4 -*- + * + * Fast store and retrieve mechanism. * * Copyright (c) 1995-2000, Raphael Manfredi - * + * Copyright (c) 2016, 2017 cPanel Inc + * Copyright (c) 2017 Reini Urban + * * You may redistribute only under the same terms as Perl 5, as specified * in the README file that comes with the distribution. * @@ -18,6 +21,8 @@ #endif #if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1) +#define NEED_PL_parser +#define NEED_sv_2pv_flags #define NEED_load_module #define NEED_vload_module #define NEED_newCONSTSUB @@ -26,7 +31,7 @@ #include "ppport.h" /* handle old perls */ #endif -#if 0 +#ifdef DEBUGGING #define DEBUGME /* Debug mode, turns assertions on as well */ #define DASSERT /* Assertion mode */ #endif @@ -67,19 +72,23 @@ #endif #ifndef HvRITER_get -# define HvRITER_get HvRITER +# define HvRITER_get HvRITER #endif #ifndef HvEITER_get -# define HvEITER_get HvEITER +# define HvEITER_get HvEITER #endif #ifndef HvPLACEHOLDERS_get -# define HvPLACEHOLDERS_get HvPLACEHOLDERS +# define HvPLACEHOLDERS_get HvPLACEHOLDERS #endif #ifndef HvTOTALKEYS # define HvTOTALKEYS(hv) HvKEYS(hv) #endif +/* 5.6 */ +#ifndef HvUSEDKEYS +# define HvUSEDKEYS(hv) HvKEYS(hv) +#endif #ifdef SVf_IsCOW # define SvTRULYREADONLY(sv) SvREADONLY(sv) @@ -87,6 +96,14 @@ # define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv)) #endif +#ifndef SvPVCLEAR +# define SvPVCLEAR(sv) sv_setpvs(sv, "") +#endif + +#ifndef strEQc +# define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c)) +#endif + #ifdef DEBUGME #ifndef DASSERT @@ -94,27 +111,46 @@ #endif /* - * TRACEME() will only output things when the $Storable::DEBUGME is true. + * TRACEME() will only output things when the $Storable::DEBUGME is true, + * using the value traceme cached in the context. + * + * + * TRACEMED() directly looks at the variable, for use before traceme has been + * updated. */ -#define TRACEME(x) \ - STMT_START { \ - if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD))) \ - { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ - } STMT_END +#define TRACEME(x) \ + STMT_START { \ + if (cxt->traceme) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ + } STMT_END + +#define TRACEMED(x) \ + STMT_START { \ + if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ + } STMT_END + +#define INIT_TRACEME \ + STMT_START { \ + cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)); \ + } STMT_END + #else #define TRACEME(x) +#define TRACEMED(x) +#define INIT_TRACEME #endif /* DEBUGME */ #ifdef DASSERT -#define ASSERT(x,y) \ - STMT_START { \ - if (!(x)) { \ - PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ - __FILE__, __LINE__); \ - PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \ - } \ - } STMT_END +#define ASSERT(x,y) \ + STMT_START { \ + if (!(x)) { \ + PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ + __FILE__, (int)__LINE__); \ + PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \ + } \ + } STMT_END #else #define ASSERT(x,y) #endif @@ -157,39 +193,41 @@ #define SX_VSTRING C(29) /* vstring forthcoming (small) */ #define SX_LVSTRING C(30) /* vstring forthcoming (large) */ #define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */ -#define SX_ERROR C(32) /* Error */ +#define SX_REGEXP C(32) /* Regexp */ +#define SX_LOBJECT C(33) /* Large object: string, array or hash (size >2G) */ +#define SX_LAST C(34) /* invalid. marker only */ /* * Those are only used to retrieve "old" pre-0.6 binary images. */ -#define SX_ITEM 'i' /* An array item introducer */ -#define SX_IT_UNDEF 'I' /* Undefined array item */ -#define SX_KEY 'k' /* A hash key introducer */ -#define SX_VALUE 'v' /* A hash value introducer */ -#define SX_VL_UNDEF 'V' /* Undefined hash value */ +#define SX_ITEM 'i' /* An array item introducer */ +#define SX_IT_UNDEF 'I' /* Undefined array item */ +#define SX_KEY 'k' /* A hash key introducer */ +#define SX_VALUE 'v' /* A hash value introducer */ +#define SX_VL_UNDEF 'V' /* Undefined hash value */ /* * Those are only used to retrieve "old" pre-0.7 binary images */ -#define SX_CLASS 'b' /* Object is blessed, class name length <255 */ -#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ -#define SX_STORED 'X' /* End of object */ +#define SX_CLASS 'b' /* Object is blessed, class name length <255 */ +#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ +#define SX_STORED 'X' /* End of object */ /* * Limits between short/long length representation. */ -#define LG_SCALAR 255 /* Large scalar length limit */ -#define LG_BLESS 127 /* Large classname bless limit */ +#define LG_SCALAR 255 /* Large scalar length limit */ +#define LG_BLESS 127 /* Large classname bless limit */ /* * Operation types */ -#define ST_STORE 0x1 /* Store operation */ -#define ST_RETRIEVE 0x2 /* Retrieval operation */ -#define ST_CLONE 0x4 /* Deep cloning operation */ +#define ST_STORE 0x1 /* Store operation */ +#define ST_RETRIEVE 0x2 /* Retrieval operation */ +#define ST_CLONE 0x4 /* Deep cloning operation */ /* * The following structure is used for hash table key retrieval. Since, when @@ -203,10 +241,10 @@ * is required. Hence the aptr pointer. */ struct extendable { - char *arena; /* Will hold hash key strings, resized as needed */ - STRLEN asiz; /* Size of aforementioned buffer */ - char *aptr; /* Arena pointer, for in-place read/write ops */ - char *aend; /* First invalid address */ + char *arena; /* Will hold hash key strings, resized as needed */ + STRLEN asiz; /* Size of aforementioned buffer */ + char *aptr; /* Arena pointer, for in-place read/write ops */ + char *aend; /* First invalid address */ }; /* @@ -228,6 +266,19 @@ struct extendable { typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ /* + * Make the tag type 64-bit on 64-bit platforms. + * + * If the tag number is low enough it's stored as a 32-bit value, but + * with very large arrays and hashes it's possible to go over 2**32 + * scalars. + */ + +typedef STRLEN ntag_t; + +/* used for where_is_undef - marks an unset value */ +#define UNSET_NTAG_T (~(ntag_t)0) + +/* * The following "thread-safe" related defines were contributed by * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who * only renamed things a little bit to ensure consistency with surrounding @@ -287,6 +338,34 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #define USE_PTR_TABLE #endif +/* do we need/want to clear padding on NVs? */ +#if defined(LONG_DOUBLEKIND) && defined(USE_LONG_DOUBLE) +# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN +# define NV_PADDING (NVSIZE - 10) +# else +# define NV_PADDING 0 +# endif +#else +/* This is kind of a guess - it means we'll get an unneeded clear on 128-bit NV + but an upgraded perl will fix that +*/ +# if NVSIZE > 8 +# define NV_CLEAR +# endif +# define NV_PADDING 0 +#endif + +typedef union { + NV nv; + U8 bytes[sizeof(NV)]; +} NV_bytes; + +/* Needed for 32bit with lengths > 2G - 4G, and 64bit */ +#if PTRSIZE > 4 +#define HAS_U64 +#endif + /* * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include * files remap tainted and dirty when threading is enabled. That's bad for @@ -295,53 +374,67 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ struct stcxt; typedef struct stcxt { - int entry; /* flags recursion */ - int optype; /* type of traversal operation */ - /* which objects have been seen, store time. - tags are numbers, which are cast to (SV *) and stored directly */ + int entry; /* flags recursion */ + int optype; /* type of traversal operation */ + /* which objects have been seen, store time. + tags are numbers, which are cast to (SV *) and stored directly */ #ifdef USE_PTR_TABLE - /* use pseen if we have ptr_tables. We have to store tag+1, because - tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table - without it being confused for a fetch lookup failure. */ - struct ptr_tbl *pseen; - /* Still need hseen for the 0.6 file format code. */ -#endif - HV *hseen; - AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ - AV *aseen; /* which objects have been seen, retrieve time */ - IV where_is_undef; /* index in aseen of PL_sv_undef */ - HV *hclass; /* which classnames have been seen, store time */ - AV *aclass; /* which classnames have been seen, retrieve time */ - HV *hook; /* cache for hook methods per class name */ - IV tagnum; /* incremented at store time for each seen object */ - IV classnum; /* incremented at store time for each seen classname */ - int netorder; /* true if network order used */ - int s_tainted; /* true if input source is tainted, at retrieve time */ - int forgive_me; /* whether to be forgiving... */ - int deparse; /* whether to deparse code refs */ - SV *eval; /* whether to eval source code */ - int canonical; /* whether to store hashes sorted by key */ + /* use pseen if we have ptr_tables. We have to store tag+1, because + tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table + without it being confused for a fetch lookup failure. */ + struct ptr_tbl *pseen; + /* Still need hseen for the 0.6 file format code. */ +#endif + HV *hseen; + AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ + AV *aseen; /* which objects have been seen, retrieve time */ + ntag_t where_is_undef; /* index in aseen of PL_sv_undef */ + HV *hclass; /* which classnames have been seen, store time */ + AV *aclass; /* which classnames have been seen, retrieve time */ + HV *hook; /* cache for hook methods per class name */ + IV tagnum; /* incremented at store time for each seen object */ + IV classnum; /* incremented at store time for each seen classname */ + int netorder; /* true if network order used */ + int s_tainted; /* true if input source is tainted, at retrieve time */ + int forgive_me; /* whether to be forgiving... */ + int deparse; /* whether to deparse code refs */ + SV *eval; /* whether to eval source code */ + int canonical; /* whether to store hashes sorted by key */ #ifndef HAS_RESTRICTED_HASHES - int derestrict; /* whether to downgrade restricted hashes */ + int derestrict; /* whether to downgrade restricted hashes */ #endif #ifndef HAS_UTF8_ALL - int use_bytes; /* whether to bytes-ify utf8 */ -#endif - int accept_future_minor; /* croak immediately on future minor versions? */ - int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ - int membuf_ro; /* true means membuf is read-only and msaved is rw */ - struct extendable keybuf; /* for hash key retrieval */ - struct extendable membuf; /* for memory store/retrieve operations */ - struct extendable msaved; /* where potentially valid mbuf is saved */ - PerlIO *fio; /* where I/O are performed, NULL for memory */ - int ver_major; /* major of version for retrieved object */ - int ver_minor; /* minor of version for retrieved object */ - SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */ - SV *prev; /* contexts chained backwards in real recursion */ - SV *my_sv; /* the blessed scalar who's SvPVX() I am */ - int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */ + int use_bytes; /* whether to bytes-ify utf8 */ +#endif + int accept_future_minor; /* croak immediately on future minor versions? */ + int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ + int membuf_ro; /* true means membuf is read-only and msaved is rw */ + struct extendable keybuf; /* for hash key retrieval */ + struct extendable membuf; /* for memory store/retrieve operations */ + struct extendable msaved; /* where potentially valid mbuf is saved */ + PerlIO *fio; /* where I/O are performed, NULL for memory */ + int ver_major; /* major of version for retrieved object */ + int ver_minor; /* minor of version for retrieved object */ + SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */ + SV *prev; /* contexts chained backwards in real recursion */ + SV *my_sv; /* the blessed scalar who's SvPVX() I am */ + SV *recur_sv; /* check only one recursive SV */ + int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */ + int flags; /* controls whether to bless or tie objects */ + IV recur_depth; /* avoid stack overflows RT #97526 */ + IV max_recur_depth; /* limit for recur_depth */ + IV max_recur_depth_hash; /* limit for recur_depth for hashes */ +#ifdef DEBUGME + int traceme; /* TRACEME() produces output */ +#endif } stcxt_t; +#define RECURSION_TOO_DEEP() \ + (cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth) +#define RECURSION_TOO_DEEP_HASH() \ + (cxt->max_recur_depth_hash != -1 && ++cxt->recur_depth > cxt->max_recur_depth_hash) +#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded" + static int storable_free(pTHX_ SV *sv, MAGIC* mg); static MGVTBL vtbl_storable = { @@ -363,15 +456,16 @@ static MGVTBL vtbl_storable = { /* From Digest::MD5. */ #ifndef sv_magicext -# define sv_magicext(sv, obj, type, vtbl, name, namlen) \ +# define sv_magicext(sv, obj, type, vtbl, name, namlen) \ THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen) -static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, - MGVTBL const *vtbl, char const *name, I32 namlen) +static MAGIC *THX_sv_magicext(pTHX_ + SV *sv, SV *obj, int type, + MGVTBL const *vtbl, char const *name, I32 namlen) { MAGIC *mg; if (obj || namlen) - /* exceeded intended usage of this reserve implementation */ - return NULL; + /* exceeded intended usage of this reserve implementation */ + return NULL; Newxz(mg, 1, MAGIC); mg->mg_virtual = (MGVTBL*)vtbl; mg->mg_type = type; @@ -386,55 +480,56 @@ static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, } #endif -#define NEW_STORABLE_CXT_OBJ(cxt) \ - STMT_START { \ - SV *self = newSV(sizeof(stcxt_t) - 1); \ - SV *my_sv = newRV_noinc(self); \ - sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \ - cxt = (stcxt_t *)SvPVX(self); \ - Zero(cxt, 1, stcxt_t); \ - cxt->my_sv = my_sv; \ - } STMT_END +#define NEW_STORABLE_CXT_OBJ(cxt) \ + STMT_START { \ + SV *self = newSV(sizeof(stcxt_t) - 1); \ + SV *my_sv = newRV_noinc(self); \ + sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \ + cxt = (stcxt_t *)SvPVX(self); \ + Zero(cxt, 1, stcxt_t); \ + cxt->my_sv = my_sv; \ + } STMT_END #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI) #if (PATCHLEVEL <= 4) && (SUBVERSION < 68) -#define dSTCXT_SV \ - SV *perinterp_sv = perl_get_sv(MY_VERSION, 0) +#define dSTCXT_SV \ + SV *perinterp_sv = get_sv(MY_VERSION, 0) #else /* >= perl5.004_68 */ -#define dSTCXT_SV \ - SV *perinterp_sv = *hv_fetch(PL_modglobal, \ - MY_VERSION, sizeof(MY_VERSION)-1, TRUE) +#define dSTCXT_SV \ + SV *perinterp_sv = *hv_fetch(PL_modglobal, \ + MY_VERSION, sizeof(MY_VERSION)-1, TRUE) #endif /* < perl5.004_68 */ -#define dSTCXT_PTR(T,name) \ - T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ - ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) -#define dSTCXT \ - dSTCXT_SV; \ - dSTCXT_PTR(stcxt_t *, cxt) - -#define INIT_STCXT \ - dSTCXT; \ - NEW_STORABLE_CXT_OBJ(cxt); \ - assert(perinterp_sv); \ - sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv)) - -#define SET_STCXT(x) \ - STMT_START { \ - dSTCXT_SV; \ - sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \ - } STMT_END +#define dSTCXT_PTR(T,name) \ + T name = ((perinterp_sv \ + && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ + ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) +#define dSTCXT \ + dSTCXT_SV; \ + dSTCXT_PTR(stcxt_t *, cxt) + +#define INIT_STCXT \ + dSTCXT; \ + NEW_STORABLE_CXT_OBJ(cxt); \ + assert(perinterp_sv); \ + sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv)) + +#define SET_STCXT(x) \ + STMT_START { \ + dSTCXT_SV; \ + sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \ + } STMT_END #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ static stcxt_t *Context_ptr = NULL; #define dSTCXT stcxt_t *cxt = Context_ptr #define SET_STCXT(x) Context_ptr = x -#define INIT_STCXT \ - dSTCXT; \ - NEW_STORABLE_CXT_OBJ(cxt); \ - SET_STCXT(cxt) +#define INIT_STCXT \ + dSTCXT; \ + NEW_STORABLE_CXT_OBJ(cxt); \ + SET_STCXT(cxt) #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ @@ -472,10 +567,20 @@ static stcxt_t *Context_ptr = NULL; #if PTRSIZE <= 4 #define LOW_32BITS(x) ((I32) (x)) #else -#define LOW_32BITS(x) ((I32) ((unsigned long) (x) & 0xffffffffUL)) +#define LOW_32BITS(x) ((I32) ((STRLEN) (x) & 0xffffffffUL)) #endif /* + * PTR2TAG(x) + * + * Convert a pointer into an ntag_t. + */ + +#define PTR2TAG(x) ((ntag_t)(x)) + +#define TAG2PTR(x, type) ((y)(x)) + +/* * oI, oS, oC * * Hack for Crays, where sizeof(I32) == 8, and which are big-endians. @@ -485,11 +590,13 @@ static stcxt_t *Context_ptr = NULL; #if INTSIZE > 4 #define oI(x) ((I32 *) ((char *) (x) + 4)) #define oS(x) ((x) - 4) +#define oL(x) (x) #define oC(x) (x = 0) #define CRAY_HACK #else #define oI(x) (x) #define oS(x) (x) +#define oL(x) (x) #define oC(x) #endif @@ -498,22 +605,25 @@ static stcxt_t *Context_ptr = NULL; */ #define kbuf (cxt->keybuf).arena #define ksiz (cxt->keybuf).asiz -#define KBUFINIT() \ - STMT_START { \ - if (!kbuf) { \ - TRACEME(("** allocating kbuf of 128 bytes")); \ - New(10003, kbuf, 128, char); \ - ksiz = 128; \ - } \ - } STMT_END -#define KBUFCHK(x) \ - STMT_START { \ - if (x >= ksiz) { \ - TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \ - Renew(kbuf, x+1, char); \ - ksiz = x+1; \ - } \ - } STMT_END +#define KBUFINIT() \ + STMT_START { \ + if (!kbuf) { \ + TRACEME(("** allocating kbuf of 128 bytes")); \ + New(10003, kbuf, 128, char); \ + ksiz = 128; \ + } \ + } STMT_END +#define KBUFCHK(x) \ + STMT_START { \ + if (x >= ksiz) { \ + if (x >= I32_MAX) \ + CROAK(("Too large size > I32_MAX")); \ + TRACEME(("** extending kbuf to %d bytes (had %d)", \ + (int)(x+1), (int)ksiz)); \ + Renew(kbuf, x+1, char); \ + ksiz = x+1; \ + } \ + } STMT_END /* * memory buffer handling @@ -527,28 +637,28 @@ static stcxt_t *Context_ptr = NULL; #define MMASK (MGROW - 1) #define round_mgrow(x) \ - ((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK)) + ((STRLEN) (((STRLEN) (x) + MMASK) & ~MMASK)) #define trunc_int(x) \ - ((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1))) + ((STRLEN) ((STRLEN) (x) & ~(sizeof(int)-1))) #define int_aligned(x) \ - ((unsigned long) (x) == trunc_int(x)) - -#define MBUF_INIT(x) \ - STMT_START { \ - if (!mbase) { \ - TRACEME(("** allocating mbase of %d bytes", MGROW)); \ - New(10003, mbase, MGROW, char); \ - msiz = (STRLEN)MGROW; \ - } \ - mptr = mbase; \ - if (x) \ - mend = mbase + x; \ - else \ - mend = mbase + msiz; \ - } STMT_END + ((STRLEN)(x) == trunc_int(x)) + +#define MBUF_INIT(x) \ + STMT_START { \ + if (!mbase) { \ + TRACEME(("** allocating mbase of %d bytes", MGROW)); \ + New(10003, mbase, (int)MGROW, char); \ + msiz = (STRLEN)MGROW; \ + } \ + mptr = mbase; \ + if (x) \ + mend = mbase + x; \ + else \ + mend = mbase + msiz; \ + } STMT_END #define MBUF_TRUNC(x) mptr = mbase + x -#define MBUF_SIZE() (mptr - mbase) +#define MBUF_SIZE() (mptr - mbase) /* * MBUF_SAVE_AND_LOAD @@ -558,153 +668,159 @@ static stcxt_t *Context_ptr = NULL; * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve * data from a string. */ -#define MBUF_SAVE_AND_LOAD(in) \ - STMT_START { \ - ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \ - cxt->membuf_ro = 1; \ - TRACEME(("saving mbuf")); \ - StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \ - MBUF_LOAD(in); \ - } STMT_END - -#define MBUF_RESTORE() \ - STMT_START { \ - ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ - cxt->membuf_ro = 0; \ - TRACEME(("restoring mbuf")); \ - StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \ - } STMT_END +#define MBUF_SAVE_AND_LOAD(in) \ + STMT_START { \ + ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \ + cxt->membuf_ro = 1; \ + TRACEME(("saving mbuf")); \ + StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \ + MBUF_LOAD(in); \ + } STMT_END + +#define MBUF_RESTORE() \ + STMT_START { \ + ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ + cxt->membuf_ro = 0; \ + TRACEME(("restoring mbuf")); \ + StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \ + } STMT_END /* * Use SvPOKp(), because SvPOK() fails on tainted scalars. * See store_scalar() for other usage of this workaround. */ -#define MBUF_LOAD(v) \ - STMT_START { \ - ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ - if (!SvPOKp(v)) \ - CROAK(("Not a scalar string")); \ - mptr = mbase = SvPV(v, msiz); \ - mend = mbase + msiz; \ - } STMT_END - -#define MBUF_XTEND(x) \ - STMT_START { \ - int nsz = (int) round_mgrow((x)+msiz); \ - int offset = mptr - mbase; \ - ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ - TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \ - msiz, nsz, (x))); \ - Renew(mbase, nsz, char); \ - msiz = nsz; \ - mptr = mbase + offset; \ - mend = mbase + nsz; \ - } STMT_END - -#define MBUF_CHK(x) \ - STMT_START { \ - if ((mptr + (x)) > mend) \ - MBUF_XTEND(x); \ - } STMT_END - -#define MBUF_GETC(x) \ - STMT_START { \ - if (mptr < mend) \ - x = (int) (unsigned char) *mptr++; \ - else \ - return (SV *) 0; \ - } STMT_END +#define MBUF_LOAD(v) \ + STMT_START { \ + ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ + if (!SvPOKp(v)) \ + CROAK(("Not a scalar string")); \ + mptr = mbase = SvPV(v, msiz); \ + mend = mbase + msiz; \ + } STMT_END + +#define MBUF_XTEND(x) \ + STMT_START { \ + STRLEN nsz = (STRLEN) round_mgrow((x)+msiz); \ + STRLEN offset = mptr - mbase; \ + ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ + TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \ + (long)msiz, nsz, (long)(x))); \ + Renew(mbase, nsz, char); \ + msiz = nsz; \ + mptr = mbase + offset; \ + mend = mbase + nsz; \ + } STMT_END + +#define MBUF_CHK(x) \ + STMT_START { \ + if ((mptr + (x)) > mend) \ + MBUF_XTEND(x); \ + } STMT_END + +#define MBUF_GETC(x) \ + STMT_START { \ + if (mptr < mend) \ + x = (int) (unsigned char) *mptr++; \ + else \ + return (SV *) 0; \ + } STMT_END #ifdef CRAY_HACK -#define MBUF_GETINT(x) \ - STMT_START { \ - oC(x); \ - if ((mptr + 4) <= mend) { \ - memcpy(oI(&x), mptr, 4); \ - mptr += 4; \ - } else \ - return (SV *) 0; \ - } STMT_END +#define MBUF_GETINT(x) \ + STMT_START { \ + oC(x); \ + if ((mptr + 4) <= mend) { \ + memcpy(oI(&x), mptr, 4); \ + mptr += 4; \ + } else \ + return (SV *) 0; \ + } STMT_END #else -#define MBUF_GETINT(x) \ - STMT_START { \ - if ((mptr + sizeof(int)) <= mend) { \ - if (int_aligned(mptr)) \ - x = *(int *) mptr; \ - else \ - memcpy(&x, mptr, sizeof(int)); \ - mptr += sizeof(int); \ - } else \ - return (SV *) 0; \ - } STMT_END -#endif - -#define MBUF_READ(x,s) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else \ - return (SV *) 0; \ - } STMT_END - -#define MBUF_SAFEREAD(x,s,z) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else { \ - sv_free(z); \ - return (SV *) 0; \ - } \ - } STMT_END +#define MBUF_GETINT(x) \ + STMT_START { \ + if ((mptr + sizeof(int)) <= mend) { \ + if (int_aligned(mptr)) \ + x = *(int *) mptr; \ + else \ + memcpy(&x, mptr, sizeof(int)); \ + mptr += sizeof(int); \ + } else \ + return (SV *) 0; \ + } STMT_END +#endif + +#define MBUF_READ(x,s) \ + STMT_START { \ + if ((mptr + (s)) <= mend) { \ + memcpy(x, mptr, s); \ + mptr += s; \ + } else \ + return (SV *) 0; \ + } STMT_END + +#define MBUF_SAFEREAD(x,s,z) \ + STMT_START { \ + if ((mptr + (s)) <= mend) { \ + memcpy(x, mptr, s); \ + mptr += s; \ + } else { \ + sv_free(z); \ + return (SV *) 0; \ + } \ + } STMT_END #define MBUF_SAFEPVREAD(x,s,z) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else { \ - Safefree(z); \ - return (SV *) 0; \ - } \ - } STMT_END - -#define MBUF_PUTC(c) \ - STMT_START { \ - if (mptr < mend) \ - *mptr++ = (char) c; \ - else { \ - MBUF_XTEND(1); \ - *mptr++ = (char) c; \ - } \ - } STMT_END + STMT_START { \ + if ((mptr + (s)) <= mend) { \ + memcpy(x, mptr, s); \ + mptr += s; \ + } else { \ + Safefree(z); \ + return (SV *) 0; \ + } \ + } STMT_END + +#define MBUF_PUTC(c) \ + STMT_START { \ + if (mptr < mend) \ + *mptr++ = (char) c; \ + else { \ + MBUF_XTEND(1); \ + *mptr++ = (char) c; \ + } \ + } STMT_END #ifdef CRAY_HACK -#define MBUF_PUTINT(i) \ - STMT_START { \ - MBUF_CHK(4); \ - memcpy(mptr, oI(&i), 4); \ - mptr += 4; \ - } STMT_END +#define MBUF_PUTINT(i) \ + STMT_START { \ + MBUF_CHK(4); \ + memcpy(mptr, oI(&i), 4); \ + mptr += 4; \ + } STMT_END #else #define MBUF_PUTINT(i) \ - STMT_START { \ - MBUF_CHK(sizeof(int)); \ - if (int_aligned(mptr)) \ - *(int *) mptr = i; \ - else \ - memcpy(mptr, &i, sizeof(int)); \ - mptr += sizeof(int); \ - } STMT_END -#endif - -#define MBUF_WRITE(x,s) \ - STMT_START { \ - MBUF_CHK(s); \ - memcpy(mptr, x, s); \ - mptr += s; \ - } STMT_END + STMT_START { \ + MBUF_CHK(sizeof(int)); \ + if (int_aligned(mptr)) \ + *(int *) mptr = i; \ + else \ + memcpy(mptr, &i, sizeof(int)); \ + mptr += sizeof(int); \ + } STMT_END +#endif + +#define MBUF_PUTLONG(l) \ + STMT_START { \ + MBUF_CHK(8); \ + memcpy(mptr, &l, 8); \ + mptr += 8; \ + } STMT_END +#define MBUF_WRITE(x,s) \ + STMT_START { \ + MBUF_CHK(s); \ + memcpy(mptr, x, s); \ + mptr += s; \ + } STMT_END /* * Possible return values for sv_type(). @@ -715,9 +831,10 @@ static stcxt_t *Context_ptr = NULL; #define svis_ARRAY 2 #define svis_HASH 3 #define svis_TIED 4 -#define svis_TIED_ITEM 5 +#define svis_TIED_ITEM 5 #define svis_CODE 6 -#define svis_OTHER 7 +#define svis_REGEXP 7 +#define svis_OTHER 8 /* * Flags for SX_HOOK. @@ -735,18 +852,18 @@ static stcxt_t *Context_ptr = NULL; * Types for SX_HOOK (last 2 bits in flags). */ -#define SHT_SCALAR 0 -#define SHT_ARRAY 1 -#define SHT_HASH 2 -#define SHT_EXTRA 3 /* Read extra byte for type */ +#define SHT_SCALAR 0 +#define SHT_ARRAY 1 +#define SHT_HASH 2 +#define SHT_EXTRA 3 /* Read extra byte for type */ /* * The following are held in the "extra byte"... */ -#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */ -#define SHT_TARRAY 5 /* 4 + 1 -- tied array */ -#define SHT_THASH 6 /* 4 + 2 -- tied hash */ +#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */ +#define SHT_TARRAY 5 /* 4 + 1 -- tied array */ +#define SHT_THASH 6 /* 4 + 2 -- tied hash */ /* * per hash flags for flagged hashes @@ -765,6 +882,18 @@ static stcxt_t *Context_ptr = NULL; #define SHV_K_PLACEHOLDER 0x10 /* + * flags to allow blessing and/or tieing data the data we load + */ +#define FLAG_BLESS_OK 2 +#define FLAG_TIE_OK 4 + +/* + * Flags for SX_REGEXP. + */ + +#define SHR_U32_RE_LEN 0x01 + +/* * Before 0.6, the magic string was "perl-store" (binary version number 0). * * Since 0.6 introduced many binary incompatibilities, the magic string has @@ -839,13 +968,20 @@ static const char magicstr[] = "pst0"; /* Used as a magic number */ #endif #endif +#ifndef INT32_MAX +# define INT32_MAX 2147483647 +#endif +#if IVSIZE > 4 && !defined(INT64_MAX) +# define INT64_MAX 9223372036854775807LL +#endif + static const char byteorderstr[] = {BYTEORDER_BYTES, 0}; #ifdef USE_56_INTERWORK_KLUDGE static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 10 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 11 /* Binary minor "version" */ #if (PATCHLEVEL <= 5) #define STORABLE_BIN_WRITE_MINOR 4 @@ -856,7 +992,8 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #define STORABLE_BIN_WRITE_MINOR 8 #elif PATCHLEVEL >= 19 /* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */ -#define STORABLE_BIN_WRITE_MINOR 10 +/* With 3.x we added LOBJECT */ +#define STORABLE_BIN_WRITE_MINOR 11 #else #define STORABLE_BIN_WRITE_MINOR 9 #endif /* (PATCHLEVEL <= 5) */ @@ -876,66 +1013,120 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; * tagnum with cxt->tagnum++ along with this macro! * - samv 20Jan04 */ -#define PUTMARK(x) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_PUTC(x); \ - else if (PerlIO_putc(cxt->fio, x) == EOF) \ - return -1; \ - } STMT_END - -#define WRITE_I32(x) \ - STMT_START { \ - ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \ - if (!cxt->fio) \ - MBUF_PUTINT(x); \ - else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return -1; \ - } STMT_END +#define PUTMARK(x) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_PUTC(x); \ + else if (PerlIO_putc(cxt->fio, x) == EOF) \ + return -1; \ + } STMT_END + +#define WRITE_I32(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \ + if (!cxt->fio) \ + MBUF_PUTINT(x); \ + else if (PerlIO_write(cxt->fio, oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } STMT_END + +#define WRITE_U64(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(UV), ("writing an UV")); \ + if (!cxt->fio) \ + MBUF_PUTLONG(x); \ + else if (PerlIO_write(cxt->fio, oL(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } STMT_END #ifdef HAS_HTONL -#define WLEN(x) \ - STMT_START { \ - ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \ - if (cxt->netorder) { \ - int y = (int) htonl(x); \ - if (!cxt->fio) \ - MBUF_PUTINT(y); \ - else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \ - return -1; \ - } else { \ - if (!cxt->fio) \ - MBUF_PUTINT(x); \ - else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \ - return -1; \ - } \ - } STMT_END +#define WLEN(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \ + if (cxt->netorder) { \ + int y = (int) htonl(x); \ + if (!cxt->fio) \ + MBUF_PUTINT(y); \ + else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \ + return -1; \ + } else { \ + if (!cxt->fio) \ + MBUF_PUTINT(x); \ + else if (PerlIO_write(cxt->fio,oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } \ + } STMT_END + +# ifdef HAS_U64 + +#define W64LEN(x) \ + STMT_START { \ + ASSERT(sizeof(x) == 8, ("W64LEN writing a U64")); \ + if (cxt->netorder) { \ + U32 buf[2]; \ + buf[1] = htonl(x & 0xffffffffUL); \ + buf[0] = htonl(x >> 32); \ + if (!cxt->fio) \ + MBUF_PUTLONG(buf); \ + else if (PerlIO_write(cxt->fio, buf, \ + sizeof(buf)) != sizeof(buf)) \ + return -1; \ + } else { \ + if (!cxt->fio) \ + MBUF_PUTLONG(x); \ + else if (PerlIO_write(cxt->fio,oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } \ + } STMT_END + +# else + +#define W64LEN(x) CROAK(("No 64bit UVs")) + +# endif + #else #define WLEN(x) WRITE_I32(x) +#ifdef HAS_U64 +#define W64LEN(x) WRITE_U64(x) +#else +#define W64LEN(x) CROAK(("no 64bit UVs")) +#endif #endif #define WRITE(x,y) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_WRITE(x,y); \ - else if (PerlIO_write(cxt->fio, x, y) != y) \ - return -1; \ - } STMT_END + STMT_START { \ + if (!cxt->fio) \ + MBUF_WRITE(x,y); \ + else if (PerlIO_write(cxt->fio, x, y) != (SSize_t)y) \ + return -1; \ + } STMT_END #define STORE_PV_LEN(pv, len, small, large) \ - STMT_START { \ - if (len <= LG_SCALAR) { \ - unsigned char clen = (unsigned char) len; \ - PUTMARK(small); \ - PUTMARK(clen); \ - if (len) \ - WRITE(pv, len); \ - } else { \ - PUTMARK(large); \ - WLEN(len); \ - WRITE(pv, len); \ - } \ - } STMT_END + STMT_START { \ + if (len <= LG_SCALAR) { \ + int ilen = (int) len; \ + unsigned char clen = (unsigned char) len; \ + PUTMARK(small); \ + PUTMARK(clen); \ + if (len) \ + WRITE(pv, ilen); \ + } else if (sizeof(len) > 4 && len > INT32_MAX) { \ + PUTMARK(SX_LOBJECT); \ + PUTMARK(large); \ + W64LEN(len); \ + WRITE(pv, len); \ + } else { \ + int ilen = (int) len; \ + PUTMARK(large); \ + WLEN(ilen); \ + WRITE(pv, ilen); \ + } \ + } STMT_END #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) @@ -945,78 +1136,109 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; * reasons. */ #define STORE_SV_UNDEF() \ - STMT_START { \ + STMT_START { \ cxt->tagnum++; \ PUTMARK(SX_SV_UNDEF); \ - } STMT_END + } STMT_END /* * Useful retrieve shortcuts... */ #define GETCHAR() \ - (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++)) - -#define GETMARK(x) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_GETC(x); \ - else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ - return (SV *) 0; \ - } STMT_END - -#define READ_I32(x) \ - STMT_START { \ - ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \ - oC(x); \ - if (!cxt->fio) \ - MBUF_GETINT(x); \ - else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return (SV *) 0; \ - } STMT_END + (cxt->fio ? PerlIO_getc(cxt->fio) \ + : (mptr >= mend ? EOF : (int) *mptr++)) + +#define GETMARK(x) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_GETC(x); \ + else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ + return (SV *) 0; \ + } STMT_END + +#define READ_I32(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \ + oC(x); \ + if (!cxt->fio) \ + MBUF_GETINT(x); \ + else if (PerlIO_read(cxt->fio, oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return (SV *) 0; \ + } STMT_END #ifdef HAS_NTOHL -#define RLEN(x) \ - STMT_START { \ - oC(x); \ - if (!cxt->fio) \ - MBUF_GETINT(x); \ - else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return (SV *) 0; \ - if (cxt->netorder) \ - x = (int) ntohl(x); \ - } STMT_END +#define RLEN(x) \ + STMT_START { \ + oC(x); \ + if (!cxt->fio) \ + MBUF_GETINT(x); \ + else if (PerlIO_read(cxt->fio, oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return (SV *) 0; \ + if (cxt->netorder) \ + x = (int) ntohl(x); \ + } STMT_END #else #define RLEN(x) READ_I32(x) #endif #define READ(x,y) \ - STMT_START { \ + STMT_START { \ if (!cxt->fio) \ - MBUF_READ(x, y); \ - else if (PerlIO_read(cxt->fio, x, y) != y) \ - return (SV *) 0; \ - } STMT_END - -#define SAFEREAD(x,y,z) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_SAFEREAD(x,y,z); \ - else if (PerlIO_read(cxt->fio, x, y) != y) { \ - sv_free(z); \ - return (SV *) 0; \ - } \ - } STMT_END + MBUF_READ(x, y); \ + else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) \ + return (SV *) 0; \ + } STMT_END + +#define SAFEREAD(x,y,z) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_SAFEREAD(x,y,z); \ + else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) { \ + sv_free(z); \ + return (SV *) 0; \ + } \ + } STMT_END #define SAFEPVREAD(x,y,z) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_SAFEPVREAD(x,y,z); \ - else if (PerlIO_read(cxt->fio, x, y) != y) { \ - Safefree(z); \ - return (SV *) 0; \ - } \ - } STMT_END + STMT_START { \ + if (!cxt->fio) \ + MBUF_SAFEPVREAD(x,y,z); \ + else if (PerlIO_read(cxt->fio, x, y) != y) { \ + Safefree(z); \ + return (SV *) 0; \ + } \ + } STMT_END + +#ifdef HAS_U64 + +# if defined(HAS_NTOHL) +# define Sntohl(x) ntohl(x) +# elif BYTEORDER == 0x87654321 || BYTEORDER == 0x4321 +# define Sntohl(x) (x) +# else +static U32 Sntohl(U32 x) { + return ((x & 0xFF) << 24) + ((x * 0xFF00) << 8) + + ((x & 0xFF0000) >> 8) + ((x & 0xFF000000) >> 24); +} +# endif + +# define READ_U64(x) \ + STMT_START { \ + ASSERT(sizeof(x) == 8, ("R64LEN reading a U64")); \ + if (cxt->netorder) { \ + U32 buf[2]; \ + READ((void *)buf, sizeof(buf)); \ + (x) = ((UV)Sntohl(buf[0]) << 32) + Sntohl(buf[1]); \ + } \ + else { \ + READ(&(x), sizeof(x)); \ + } \ + } STMT_END + +#endif /* * SEEN() is used at retrieve time, to remember where object 'y', bearing a @@ -1042,33 +1264,35 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; * * The _NN variants dont check for y being null */ -#define SEEN0_NN(y,i) \ +#define SEEN0_NN(y,i) \ STMT_START { \ - if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \ - return (SV *) 0; \ - TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \ - PTR2UV(y), SvREFCNT(y)-1)); \ + if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) \ + : SvREFCNT_inc(y)) == 0) \ + return (SV *) 0; \ + TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)", \ + (int)cxt->tagnum-1, \ + PTR2UV(y), (int)SvREFCNT(y)-1)); \ } STMT_END -#define SEEN0(y,i) \ +#define SEEN0(y,i) \ STMT_START { \ - if (!y) \ - return (SV *) 0; \ - SEEN0_NN(y,i) \ + if (!y) \ + return (SV *) 0; \ + SEEN0_NN(y,i); \ } STMT_END -#define SEEN_NN(y,stash,i) \ +#define SEEN_NN(y,stash,i) \ STMT_START { \ - SEEN0_NN(y,i); \ - if (stash) \ - BLESS((SV *) (y), (HV *)(stash)); \ + SEEN0_NN(y,i); \ + if (stash) \ + BLESS((SV *)(y), (HV *)(stash)); \ } STMT_END -#define SEEN(y,stash,i) \ - STMT_START { \ - if (!y) \ - return (SV *) 0; \ - SEEN_NN(y,stash, i); \ +#define SEEN(y,stash,i) \ + STMT_START { \ + if (!y) \ + return (SV *) 0; \ + SEEN_NN(y,stash, i); \ } STMT_END /* @@ -1076,20 +1300,26 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; * "A" magic is added before the sv_bless for overloaded classes, this avoids * an expensive call to S_reset_amagic in sv_bless. */ -#define BLESS(s,stash) \ - STMT_START { \ - SV *ref; \ - TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (HvNAME_get(stash)))); \ - ref = newRV_noinc(s); \ - if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) \ - { \ - cxt->in_retrieve_overloaded = 0; \ - SvAMAGIC_on(ref); \ - } \ - (void) sv_bless(ref, stash); \ - SvRV_set(ref, NULL); \ - SvREFCNT_dec(ref); \ - } STMT_END +#define BLESS(s,stash) \ + STMT_START { \ + SV *ref; \ + if (cxt->flags & FLAG_BLESS_OK) { \ + TRACEME(("blessing 0x%" UVxf " in %s", PTR2UV(s), \ + HvNAME_get(stash))); \ + ref = newRV_noinc(s); \ + if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) { \ + cxt->in_retrieve_overloaded = 0; \ + SvAMAGIC_on(ref); \ + } \ + (void) sv_bless(ref, stash); \ + SvRV_set(ref, NULL); \ + SvREFCNT_dec(ref); \ + } \ + else { \ + TRACEME(("not blessing 0x%" UVxf " in %s", PTR2UV(s), \ + (HvNAME_get(stash)))); \ + } \ + } STMT_END /* * sort (used in store_hash) - conditionally use qsort when * sortsv is not available ( <= 5.6.1 ). @@ -1099,36 +1329,36 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #if defined(USE_ITHREADS) -#define STORE_HASH_SORT \ - ENTER; { \ - PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \ - SAVESPTR(orig_perl); \ - PERL_SET_CONTEXT(aTHX); \ - qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \ - } LEAVE; +#define STORE_HASH_SORT \ + ENTER; { \ + PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \ + SAVESPTR(orig_perl); \ + PERL_SET_CONTEXT(aTHX); \ + qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);\ + } LEAVE; #else /* ! USE_ITHREADS */ -#define STORE_HASH_SORT \ - qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); +#define STORE_HASH_SORT \ + qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); #endif /* USE_ITHREADS */ #else /* PATCHLEVEL > 6 */ #define STORE_HASH_SORT \ - sortsv(AvARRAY(av), len, Perl_sv_cmp); + sortsv(AvARRAY(av), len, Perl_sv_cmp); #endif /* PATCHLEVEL <= 6 */ static int store(pTHX_ stcxt_t *cxt, SV *sv); static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname); -#define UNSEE() \ - STMT_START { \ - av_pop(cxt->aseen); \ - cxt->tagnum--; \ - } STMT_END +#define UNSEE() \ + STMT_START { \ + av_pop(cxt->aseen); \ + cxt->tagnum--; \ + } STMT_END /* * Dynamic dispatching table for SV store. @@ -1141,20 +1371,22 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv); static int store_tied(pTHX_ stcxt_t *cxt, SV *sv); static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv); static int store_code(pTHX_ stcxt_t *cxt, CV *cv); +static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv); static int store_other(pTHX_ stcxt_t *cxt, SV *sv); static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg); typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv); static const sv_store_t sv_store[] = { - (sv_store_t)store_ref, /* svis_REF */ - (sv_store_t)store_scalar, /* svis_SCALAR */ - (sv_store_t)store_array, /* svis_ARRAY */ - (sv_store_t)store_hash, /* svis_HASH */ - (sv_store_t)store_tied, /* svis_TIED */ - (sv_store_t)store_tied_item, /* svis_TIED_ITEM */ - (sv_store_t)store_code, /* svis_CODE */ - (sv_store_t)store_other, /* svis_OTHER */ + (sv_store_t)store_ref, /* svis_REF */ + (sv_store_t)store_scalar, /* svis_SCALAR */ + (sv_store_t)store_array, /* svis_ARRAY */ + (sv_store_t)store_hash, /* svis_HASH */ + (sv_store_t)store_tied, /* svis_TIED */ + (sv_store_t)store_tied_item,/* svis_TIED_ITEM */ + (sv_store_t)store_code, /* svis_CODE */ + (sv_store_t)store_regexp, /* svis_REGEXP */ + (sv_store_t)store_other, /* svis_OTHER */ }; #define SV_STORE(x) (*sv_store[x]) @@ -1179,45 +1411,61 @@ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname); + +/* helpers for U64 lobjects */ + +static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname); +#ifdef HAS_U64 +static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname); +static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname); +static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags); +#endif +static int store_hentry(pTHX_ stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags); typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name); static const sv_retrieve_t sv_old_retrieve[] = { - 0, /* SX_OBJECT -- entry unused dynamically */ - (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ - (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ - (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ - (sv_retrieve_t)retrieve_ref, /* SX_REF */ - (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ - (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ - (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ - (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ - (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ - (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */ - (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ - (sv_retrieve_t)retrieve_tied_scalar, /* SX_TIED_SCALAR */ - (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */ - (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */ - (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */ - (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */ - (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */ - (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */ - (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */ - (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */ - (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */ - (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */ - (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */ - (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */ - (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ - (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ - (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ - (sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */ - (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */ - (sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */ - (sv_retrieve_t)retrieve_other, /* SX_ERROR */ + 0, /* SX_OBJECT -- entry unused dynamically */ + (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ + (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ + (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ + (sv_retrieve_t)retrieve_ref, /* SX_REF */ + (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ + (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ + (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ + (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ + (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ + (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ + (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */ + (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */ + (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */ + (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */ + (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */ + (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */ + (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */ + (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */ + (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */ + (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */ + (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ + (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ + (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ + (sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */ + (sv_retrieve_t)retrieve_other, /* SX_REGEXP */ + (sv_retrieve_t)retrieve_other, /* SX_LOBJECT not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LAST */ }; +static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large); + static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname); @@ -1238,42 +1486,44 @@ static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname); static const sv_retrieve_t sv_retrieve[] = { - 0, /* SX_OBJECT -- entry unused dynamically */ - (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ - (sv_retrieve_t)retrieve_array, /* SX_ARRAY */ - (sv_retrieve_t)retrieve_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_ref, /* SX_REF */ - (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ - (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ - (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ - (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ - (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ - (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */ - (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ - (sv_retrieve_t)retrieve_tied_scalar, /* SX_TIED_SCALAR */ - (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */ - (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */ - (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */ - (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */ - (sv_retrieve_t)retrieve_idx_blessed, /* SX_IX_BLESS */ - (sv_retrieve_t)retrieve_hook, /* SX_HOOK */ - (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */ - (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */ - (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */ - (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */ - (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */ - (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_code, /* SX_CODE */ - (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ - (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ - (sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */ - (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */ - (sv_retrieve_t)retrieve_svundef_elem, /* SX_SVUNDEF_ELEM */ - (sv_retrieve_t)retrieve_other, /* SX_ERROR */ + 0, /* SX_OBJECT -- entry unused dynamically */ + (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ + (sv_retrieve_t)retrieve_array, /* SX_ARRAY */ + (sv_retrieve_t)retrieve_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_ref, /* SX_REF */ + (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ + (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ + (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ + (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ + (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ + (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ + (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */ + (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */ + (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */ + (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */ + (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */ + (sv_retrieve_t)retrieve_idx_blessed,/* SX_IX_BLESS */ + (sv_retrieve_t)retrieve_hook, /* SX_HOOK */ + (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */ + (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */ + (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */ + (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */ + (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */ + (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_code, /* SX_CODE */ + (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ + (sv_retrieve_t)retrieve_weakoverloaded,/* SX_WEAKOVERLOAD */ + (sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */ + (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */ + (sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */ + (sv_retrieve_t)retrieve_regexp, /* SX_REGEXP */ + (sv_retrieve_t)retrieve_lobject, /* SX_LOBJECT */ + (sv_retrieve_t)retrieve_other, /* SX_LAST */ }; -#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)]) +#define RETRIEVE(c,x) ((x) >= SX_LAST ? retrieve_other : *(c)->retrieve_vtbl[x]) static SV *mbuf2sv(pTHX); @@ -1289,7 +1539,7 @@ static SV *mbuf2sv(pTHX); static void init_perinterp(pTHX) { INIT_STCXT; - + INIT_TRACEME; cxt->netorder = 0; /* true if network order used */ cxt->forgive_me = -1; /* whether to be forgiving... */ cxt->accept_future_minor = -1; /* would otherwise occur too late */ @@ -1303,9 +1553,11 @@ static void init_perinterp(pTHX) */ static void reset_context(stcxt_t *cxt) { - cxt->entry = 0; - cxt->s_dirty = 0; - cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */ + cxt->entry = 0; + cxt->s_dirty = 0; + cxt->recur_sv = NULL; + cxt->recur_depth = 0; + cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */ } /* @@ -1313,101 +1565,105 @@ static void reset_context(stcxt_t *cxt) * * Initialize a new store context for real recursion. */ -static void init_store_context( - pTHX_ +static void init_store_context(pTHX_ stcxt_t *cxt, - PerlIO *f, - int optype, - int network_order) + PerlIO *f, + int optype, + int network_order) { - TRACEME(("init_store_context")); - - cxt->netorder = network_order; - cxt->forgive_me = -1; /* Fetched from perl if needed */ - cxt->deparse = -1; /* Idem */ - cxt->eval = NULL; /* Idem */ - cxt->canonical = -1; /* Idem */ - cxt->tagnum = -1; /* Reset tag numbers */ - cxt->classnum = -1; /* Reset class numbers */ - cxt->fio = f; /* Where I/O are performed */ - cxt->optype = optype; /* A store, or a deep clone */ - cxt->entry = 1; /* No recursion yet */ - - /* - * The 'hseen' table is used to keep track of each SV stored and their - * associated tag numbers is special. It is "abused" because the - * values stored are not real SV, just integers cast to (SV *), - * which explains the freeing below. - * - * It is also one possible bottleneck to achieve good storing speed, - * so the "shared keys" optimization is turned off (unlikely to be - * of any use here), and the hash table is "pre-extended". Together, - * those optimizations increase the throughput by 12%. - */ + INIT_TRACEME; + + TRACEME(("init_store_context")); + + cxt->netorder = network_order; + cxt->forgive_me = -1; /* Fetched from perl if needed */ + cxt->deparse = -1; /* Idem */ + cxt->eval = NULL; /* Idem */ + cxt->canonical = -1; /* Idem */ + cxt->tagnum = -1; /* Reset tag numbers */ + cxt->classnum = -1; /* Reset class numbers */ + cxt->fio = f; /* Where I/O are performed */ + cxt->optype = optype; /* A store, or a deep clone */ + cxt->entry = 1; /* No recursion yet */ + + /* + * The 'hseen' table is used to keep track of each SV stored and their + * associated tag numbers is special. It is "abused" because the + * values stored are not real SV, just integers cast to (SV *), + * which explains the freeing below. + * + * It is also one possible bottleneck to achieve good storing speed, + * so the "shared keys" optimization is turned off (unlikely to be + * of any use here), and the hash table is "pre-extended". Together, + * those optimizations increase the throughput by 12%. + */ #ifdef USE_PTR_TABLE - cxt->pseen = ptr_table_new(); - cxt->hseen = 0; + cxt->pseen = ptr_table_new(); + cxt->hseen = 0; #else - cxt->hseen = newHV(); /* Table where seen objects are stored */ - HvSHAREKEYS_off(cxt->hseen); -#endif - /* - * The following does not work well with perl5.004_04, and causes - * a core dump later on, in a completely unrelated spot, which - * makes me think there is a memory corruption going on. - * - * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking - * it below does not make any difference. It seems to work fine - * with perl5.004_68 but given the probable nature of the bug, - * that does not prove anything. - * - * It's a shame because increasing the amount of buckets raises - * store() throughput by 5%, but until I figure this out, I can't - * allow for this to go into production. - * - * It is reported fixed in 5.005, hence the #if. - */ + cxt->hseen = newHV(); /* Table where seen objects are stored */ + HvSHAREKEYS_off(cxt->hseen); +#endif + /* + * The following does not work well with perl5.004_04, and causes + * a core dump later on, in a completely unrelated spot, which + * makes me think there is a memory corruption going on. + * + * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking + * it below does not make any difference. It seems to work fine + * with perl5.004_68 but given the probable nature of the bug, + * that does not prove anything. + * + * It's a shame because increasing the amount of buckets raises + * store() throughput by 5%, but until I figure this out, I can't + * allow for this to go into production. + * + * It is reported fixed in 5.005, hence the #if. + */ #if PERL_VERSION >= 5 -#define HBUCKETS 4096 /* Buckets for %hseen */ +#define HBUCKETS 4096 /* Buckets for %hseen */ #ifndef USE_PTR_TABLE - HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */ + HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */ #endif #endif - /* - * The 'hclass' hash uses the same settings as 'hseen' above, but it is - * used to assign sequential tags (numbers) to class names for blessed - * objects. - * - * We turn the shared key optimization on. - */ + /* + * The 'hclass' hash uses the same settings as 'hseen' above, but it is + * used to assign sequential tags (numbers) to class names for blessed + * objects. + * + * We turn the shared key optimization on. + */ - cxt->hclass = newHV(); /* Where seen classnames are stored */ + cxt->hclass = newHV(); /* Where seen classnames are stored */ #if PERL_VERSION >= 5 - HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */ + HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */ #endif - /* - * The 'hook' hash table is used to keep track of the references on - * the STORABLE_freeze hook routines, when found in some class name. - * - * It is assumed that the inheritance tree will not be changed during - * storing, and that no new method will be dynamically created by the - * hooks. - */ + /* + * The 'hook' hash table is used to keep track of the references on + * the STORABLE_freeze hook routines, when found in some class name. + * + * It is assumed that the inheritance tree will not be changed during + * storing, and that no new method will be dynamically created by the + * hooks. + */ - cxt->hook = newHV(); /* Table where hooks are cached */ + cxt->hook = newHV(); /* Table where hooks are cached */ - /* - * The 'hook_seen' array keeps track of all the SVs returned by - * STORABLE_freeze hooks for us to serialize, so that they are not - * reclaimed until the end of the serialization process. Each SV is - * only stored once, the first time it is seen. - */ + /* + * The 'hook_seen' array keeps track of all the SVs returned by + * STORABLE_freeze hooks for us to serialize, so that they are not + * reclaimed until the end of the serialization process. Each SV is + * only stored once, the first time it is seen. + */ + + cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ - cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ + cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); + cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); } /* @@ -1417,86 +1673,86 @@ static void init_store_context( */ static void clean_store_context(pTHX_ stcxt_t *cxt) { - HE *he; + HE *he; - TRACEME(("clean_store_context")); + TRACEMED(("clean_store_context")); - ASSERT(cxt->optype & ST_STORE, ("was performing a store()")); + ASSERT(cxt->optype & ST_STORE, ("was performing a store()")); - /* - * Insert real values into hashes where we stored faked pointers. - */ + /* + * Insert real values into hashes where we stored faked pointers. + */ #ifndef USE_PTR_TABLE - if (cxt->hseen) { - hv_iterinit(cxt->hseen); - while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */ - HeVAL(he) = &PL_sv_undef; - } + if (cxt->hseen) { + hv_iterinit(cxt->hseen); + while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall */ + HeVAL(he) = &PL_sv_undef; + } #endif - if (cxt->hclass) { - hv_iterinit(cxt->hclass); - while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */ - HeVAL(he) = &PL_sv_undef; - } + if (cxt->hclass) { + hv_iterinit(cxt->hclass); + while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall */ + HeVAL(he) = &PL_sv_undef; + } - /* - * And now dispose of them... - * - * The surrounding if() protection has been added because there might be - * some cases where this routine is called more than once, during - * exceptional events. This was reported by Marc Lehmann when Storable - * is executed from mod_perl, and the fix was suggested by him. - * -- RAM, 20/12/2000 - */ + /* + * And now dispose of them... + * + * The surrounding if() protection has been added because there might be + * some cases where this routine is called more than once, during + * exceptional events. This was reported by Marc Lehmann when Storable + * is executed from mod_perl, and the fix was suggested by him. + * -- RAM, 20/12/2000 + */ #ifdef USE_PTR_TABLE - if (cxt->pseen) { - struct ptr_tbl *pseen = cxt->pseen; - cxt->pseen = 0; - ptr_table_free(pseen); - } - assert(!cxt->hseen); + if (cxt->pseen) { + struct ptr_tbl *pseen = cxt->pseen; + cxt->pseen = 0; + ptr_table_free(pseen); + } + assert(!cxt->hseen); #else - if (cxt->hseen) { - HV *hseen = cxt->hseen; - cxt->hseen = 0; - hv_undef(hseen); - sv_free((SV *) hseen); - } + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); + } #endif - if (cxt->hclass) { - HV *hclass = cxt->hclass; - cxt->hclass = 0; - hv_undef(hclass); - sv_free((SV *) hclass); - } + if (cxt->hclass) { + HV *hclass = cxt->hclass; + cxt->hclass = 0; + hv_undef(hclass); + sv_free((SV *) hclass); + } - if (cxt->hook) { - HV *hook = cxt->hook; - cxt->hook = 0; - hv_undef(hook); - sv_free((SV *) hook); - } + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - if (cxt->hook_seen) { - AV *hook_seen = cxt->hook_seen; - cxt->hook_seen = 0; - av_undef(hook_seen); - sv_free((SV *) hook_seen); - } + if (cxt->hook_seen) { + AV *hook_seen = cxt->hook_seen; + cxt->hook_seen = 0; + av_undef(hook_seen); + sv_free((SV *) hook_seen); + } - cxt->forgive_me = -1; /* Fetched from perl if needed */ - cxt->deparse = -1; /* Idem */ - if (cxt->eval) { - SvREFCNT_dec(cxt->eval); - } - cxt->eval = NULL; /* Idem */ - cxt->canonical = -1; /* Idem */ + cxt->forgive_me = -1; /* Fetched from perl if needed */ + cxt->deparse = -1; /* Idem */ + if (cxt->eval) { + SvREFCNT_dec(cxt->eval); + } + cxt->eval = NULL; /* Idem */ + cxt->canonical = -1; /* Idem */ - reset_context(cxt); + reset_context(cxt); } /* @@ -1504,51 +1760,57 @@ static void clean_store_context(pTHX_ stcxt_t *cxt) * * Initialize a new retrieve context for real recursion. */ -static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted) +static void init_retrieve_context(pTHX_ + stcxt_t *cxt, int optype, int is_tainted) { - TRACEME(("init_retrieve_context")); + INIT_TRACEME; + + TRACEME(("init_retrieve_context")); - /* - * The hook hash table is used to keep track of the references on - * the STORABLE_thaw hook routines, when found in some class name. - * - * It is assumed that the inheritance tree will not be changed during - * storing, and that no new method will be dynamically created by the - * hooks. - */ + /* + * The hook hash table is used to keep track of the references on + * the STORABLE_thaw hook routines, when found in some class name. + * + * It is assumed that the inheritance tree will not be changed during + * storing, and that no new method will be dynamically created by the + * hooks. + */ - cxt->hook = newHV(); /* Caches STORABLE_thaw */ + cxt->hook = newHV(); /* Caches STORABLE_thaw */ #ifdef USE_PTR_TABLE - cxt->pseen = 0; -#endif - - /* - * If retrieving an old binary version, the cxt->retrieve_vtbl variable - * was set to sv_old_retrieve. We'll need a hash table to keep track of - * the correspondence between the tags and the tag number used by the - * new retrieve routines. - */ - - cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) - ? newHV() : 0); - - cxt->aseen = newAV(); /* Where retrieved objects are kept */ - cxt->where_is_undef = -1; /* Special case for PL_sv_undef */ - cxt->aclass = newAV(); /* Where seen classnames are kept */ - cxt->tagnum = 0; /* Have to count objects... */ - cxt->classnum = 0; /* ...and class names as well */ - cxt->optype = optype; - cxt->s_tainted = is_tainted; - cxt->entry = 1; /* No recursion yet */ + cxt->pseen = 0; +#endif + + /* + * If retrieving an old binary version, the cxt->retrieve_vtbl variable + * was set to sv_old_retrieve. We'll need a hash table to keep track of + * the correspondence between the tags and the tag number used by the + * new retrieve routines. + */ + + cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) + ? newHV() : 0); + + cxt->aseen = newAV(); /* Where retrieved objects are kept */ + cxt->where_is_undef = UNSET_NTAG_T; /* Special case for PL_sv_undef */ + cxt->aclass = newAV(); /* Where seen classnames are kept */ + cxt->tagnum = 0; /* Have to count objects... */ + cxt->classnum = 0; /* ...and class names as well */ + cxt->optype = optype; + cxt->s_tainted = is_tainted; + cxt->entry = 1; /* No recursion yet */ #ifndef HAS_RESTRICTED_HASHES - cxt->derestrict = -1; /* Fetched from perl if needed */ + cxt->derestrict = -1; /* Fetched from perl if needed */ #endif #ifndef HAS_UTF8_ALL - cxt->use_bytes = -1; /* Fetched from perl if needed */ + cxt->use_bytes = -1; /* Fetched from perl if needed */ #endif - cxt->accept_future_minor = -1; /* Fetched from perl if needed */ - cxt->in_retrieve_overloaded = 0; + cxt->accept_future_minor = -1;/* Fetched from perl if needed */ + cxt->in_retrieve_overloaded = 0; + + cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); + cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); } /* @@ -1558,49 +1820,49 @@ static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted */ static void clean_retrieve_context(pTHX_ stcxt_t *cxt) { - TRACEME(("clean_retrieve_context")); + TRACEMED(("clean_retrieve_context")); - ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); + ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); - if (cxt->aseen) { - AV *aseen = cxt->aseen; - cxt->aseen = 0; - av_undef(aseen); - sv_free((SV *) aseen); - } - cxt->where_is_undef = -1; + if (cxt->aseen) { + AV *aseen = cxt->aseen; + cxt->aseen = 0; + av_undef(aseen); + sv_free((SV *) aseen); + } + cxt->where_is_undef = UNSET_NTAG_T; - if (cxt->aclass) { - AV *aclass = cxt->aclass; - cxt->aclass = 0; - av_undef(aclass); - sv_free((SV *) aclass); - } + if (cxt->aclass) { + AV *aclass = cxt->aclass; + cxt->aclass = 0; + av_undef(aclass); + sv_free((SV *) aclass); + } - if (cxt->hook) { - HV *hook = cxt->hook; - cxt->hook = 0; - hv_undef(hook); - sv_free((SV *) hook); - } + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - if (cxt->hseen) { - HV *hseen = cxt->hseen; - cxt->hseen = 0; - hv_undef(hseen); - sv_free((SV *) hseen); /* optional HV, for backward compat. */ - } + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); /* optional HV, for backward compat. */ + } #ifndef HAS_RESTRICTED_HASHES - cxt->derestrict = -1; /* Fetched from perl if needed */ + cxt->derestrict = -1; /* Fetched from perl if needed */ #endif #ifndef HAS_UTF8_ALL - cxt->use_bytes = -1; /* Fetched from perl if needed */ + cxt->use_bytes = -1; /* Fetched from perl if needed */ #endif - cxt->accept_future_minor = -1; /* Fetched from perl if needed */ + cxt->accept_future_minor = -1; /* Fetched from perl if needed */ - cxt->in_retrieve_overloaded = 0; - reset_context(cxt); + cxt->in_retrieve_overloaded = 0; + reset_context(cxt); } /* @@ -1610,24 +1872,24 @@ static void clean_retrieve_context(pTHX_ stcxt_t *cxt) */ static void clean_context(pTHX_ stcxt_t *cxt) { - TRACEME(("clean_context")); + TRACEMED(("clean_context")); - ASSERT(cxt->s_dirty, ("dirty context")); + ASSERT(cxt->s_dirty, ("dirty context")); - if (cxt->membuf_ro) - MBUF_RESTORE(); + if (cxt->membuf_ro) + MBUF_RESTORE(); - ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); + ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); - if (cxt->optype & ST_RETRIEVE) - clean_retrieve_context(aTHX_ cxt); - else if (cxt->optype & ST_STORE) - clean_store_context(aTHX_ cxt); - else - reset_context(cxt); + if (cxt->optype & ST_RETRIEVE) + clean_retrieve_context(aTHX_ cxt); + else if (cxt->optype & ST_STORE) + clean_store_context(aTHX_ cxt); + else + reset_context(cxt); - ASSERT(!cxt->s_dirty, ("context is clean")); - ASSERT(cxt->entry == 0, ("context is reset")); + ASSERT(!cxt->s_dirty, ("context is clean")); + ASSERT(cxt->entry == 0, ("context is reset")); } /* @@ -1638,19 +1900,19 @@ static void clean_context(pTHX_ stcxt_t *cxt) */ static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt) { - stcxt_t *cxt; + stcxt_t *cxt; - TRACEME(("allocate_context")); + ASSERT(!parent_cxt->s_dirty, ("parent context clean")); - ASSERT(!parent_cxt->s_dirty, ("parent context clean")); + NEW_STORABLE_CXT_OBJ(cxt); + TRACEMED(("allocate_context")); - NEW_STORABLE_CXT_OBJ(cxt); - cxt->prev = parent_cxt->my_sv; - SET_STCXT(cxt); + cxt->prev = parent_cxt->my_sv; + SET_STCXT(cxt); - ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(!cxt->s_dirty, ("clean context")); - return cxt; + return cxt; } /* @@ -1661,18 +1923,18 @@ static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt) */ static void free_context(pTHX_ stcxt_t *cxt) { - stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); + stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); - TRACEME(("free_context")); + TRACEMED(("free_context")); - ASSERT(!cxt->s_dirty, ("clean context")); - ASSERT(prev, ("not freeing root context")); - assert(prev); + ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(prev, ("not freeing root context")); + assert(prev); - SvREFCNT_dec(cxt->my_sv); - SET_STCXT(prev); + SvREFCNT_dec(cxt->my_sv); + SET_STCXT(prev); - ASSERT(cxt, ("context not void")); + ASSERT(cxt, ("context not void")); } /*** @@ -1688,9 +1950,9 @@ static void free_context(pTHX_ stcxt_t *cxt) */ static int is_storing(pTHX) { - dSTCXT; + dSTCXT; - return cxt->entry && (cxt->optype & ST_STORE); + return cxt->entry && (cxt->optype & ST_STORE); } /* @@ -1700,9 +1962,9 @@ static int is_storing(pTHX) */ static int is_retrieving(pTHX) { - dSTCXT; + dSTCXT; - return cxt->entry && (cxt->optype & ST_RETRIEVE); + return cxt->entry && (cxt->optype & ST_RETRIEVE); } #endif @@ -1716,10 +1978,10 @@ static int is_retrieving(pTHX) */ static int last_op_in_netorder(pTHX) { - dSTCXT; + dSTCXT; - assert(cxt); - return cxt->netorder; + assert(cxt); + return cxt->netorder; } /*** @@ -1734,39 +1996,40 @@ static int last_op_in_netorder(pTHX) * Returns the routine reference as an SV*, or null if neither the package * nor its ancestors know about the method. */ -static SV *pkg_fetchmeth( - pTHX_ +static SV *pkg_fetchmeth(pTHX_ HV *cache, HV *pkg, const char *method) { - GV *gv; - SV *sv; - const char *hvname = HvNAME_get(pkg); - - - /* - * The following code is the same as the one performed by UNIVERSAL::can - * in the Perl core. - */ - - gv = gv_fetchmethod_autoload(pkg, method, FALSE); - if (gv && isGV(gv)) { - sv = newRV((SV*) GvCV(gv)); - TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); - } else { - sv = newSVsv(&PL_sv_undef); - TRACEME(("%s->%s: not found", hvname, method)); - } + GV *gv; + SV *sv; + const char *hvname = HvNAME_get(pkg); +#ifdef DEBUGME + dSTCXT; +#endif - /* - * Cache the result, ignoring failure: if we can't store the value, - * it just won't be cached. - */ + /* + * The following code is the same as the one performed by UNIVERSAL::can + * in the Perl core. + */ - (void) hv_store(cache, hvname, strlen(hvname), sv, 0); + gv = gv_fetchmethod_autoload(pkg, method, FALSE); + if (gv && isGV(gv)) { + sv = newRV_inc((SV*) GvCV(gv)); + TRACEME(("%s->%s: 0x%" UVxf, hvname, method, PTR2UV(sv))); + } else { + sv = newSVsv(&PL_sv_undef); + TRACEME(("%s->%s: not found", hvname, method)); + } - return SvOK(sv) ? sv : (SV *) 0; + /* + * Cache the result, ignoring failure: if we can't store the value, + * it just won't be cached. + */ + + (void) hv_store(cache, hvname, strlen(hvname), sv, 0); + + return SvOK(sv) ? sv : (SV *) 0; } /* @@ -1774,16 +2037,15 @@ static SV *pkg_fetchmeth( * * Force cached value to be undef: hook ignored even if present. */ -static void pkg_hide( - pTHX_ +static void pkg_hide(pTHX_ HV *cache, HV *pkg, const char *method) { - const char *hvname = HvNAME_get(pkg); - PERL_UNUSED_ARG(method); - (void) hv_store(cache, - hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); + const char *hvname = HvNAME_get(pkg); + PERL_UNUSED_ARG(method); + (void) hv_store(cache, + hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); } /* @@ -1791,15 +2053,14 @@ static void pkg_hide( * * Discard cached value: a whole fetch loop will be retried at next lookup. */ -static void pkg_uncache( - pTHX_ +static void pkg_uncache(pTHX_ HV *cache, HV *pkg, const char *method) { - const char *hvname = HvNAME_get(pkg); - PERL_UNUSED_ARG(method); - (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); + const char *hvname = HvNAME_get(pkg); + PERL_UNUSED_ARG(method); + (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); } /* @@ -1810,41 +2071,43 @@ static void pkg_uncache( * Returns the routine reference as an SV*, or null if the object does not * know about the method. */ -static SV *pkg_can( - pTHX_ +static SV *pkg_can(pTHX_ HV *cache, HV *pkg, const char *method) { - SV **svh; - SV *sv; - const char *hvname = HvNAME_get(pkg); - - TRACEME(("pkg_can for %s->%s", hvname, method)); - - /* - * Look into the cache to see whether we already have determined - * where the routine was, if any. - * - * NOTA BENE: we don't use 'method' at all in our lookup, since we know - * that only one hook (i.e. always the same) is cached in a given cache. - */ - - svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); - if (svh) { - sv = *svh; - if (!SvOK(sv)) { - TRACEME(("cached %s->%s: not found", hvname, method)); - return (SV *) 0; - } else { - TRACEME(("cached %s->%s: 0x%"UVxf, - hvname, method, PTR2UV(sv))); - return sv; - } - } + SV **svh; + SV *sv; + const char *hvname = HvNAME_get(pkg); +#ifdef DEBUGME + dSTCXT; +#endif + + TRACEME(("pkg_can for %s->%s", hvname, method)); + + /* + * Look into the cache to see whether we already have determined + * where the routine was, if any. + * + * NOTA BENE: we don't use 'method' at all in our lookup, since we know + * that only one hook (i.e. always the same) is cached in a given cache. + */ - TRACEME(("not cached yet")); - return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */ + svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); + if (svh) { + sv = *svh; + if (!SvOK(sv)) { + TRACEME(("cached %s->%s: not found", hvname, method)); + return (SV *) 0; + } else { + TRACEME(("cached %s->%s: 0x%" UVxf, + hvname, method, PTR2UV(sv))); + return sv; + } + } + + TRACEME(("not cached yet")); + return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */ } /* @@ -1853,55 +2116,57 @@ static SV *pkg_can( * Call routine as obj->hook(av) in scalar context. * Propagates the single returned value if not called in void context. */ -static SV *scalar_call( - pTHX_ +static SV *scalar_call(pTHX_ SV *obj, SV *hook, int cloning, AV *av, I32 flags) { - dSP; - int count; - SV *sv = 0; - - TRACEME(("scalar_call (cloning=%d)", cloning)); - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - XPUSHs(obj); - XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ - if (av) { - SV **ary = AvARRAY(av); - int cnt = AvFILLp(av) + 1; - int i; - XPUSHs(ary[0]); /* Frozen string */ - for (i = 1; i < cnt; i++) { - TRACEME(("pushing arg #%d (0x%"UVxf")...", - i, PTR2UV(ary[i]))); - XPUSHs(sv_2mortal(newRV(ary[i]))); - } - } - PUTBACK; + dSP; + int count; + SV *sv = 0; +#ifdef DEBUGME + dSTCXT; +#endif + + TRACEME(("scalar_call (cloning=%d)", cloning)); + + ENTER; + SAVETMPS; + + PUSHMARK(sp); + XPUSHs(obj); + XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ + if (av) { + SV **ary = AvARRAY(av); + SSize_t cnt = AvFILLp(av) + 1; + SSize_t i; + XPUSHs(ary[0]); /* Frozen string */ + for (i = 1; i < cnt; i++) { + TRACEME(("pushing arg #%d (0x%" UVxf ")...", + (int)i, PTR2UV(ary[i]))); + XPUSHs(sv_2mortal(newRV_inc(ary[i]))); + } + } + PUTBACK; - TRACEME(("calling...")); - count = perl_call_sv(hook, flags); /* Go back to Perl code */ - TRACEME(("count = %d", count)); + TRACEME(("calling...")); + count = call_sv(hook, flags); /* Go back to Perl code */ + TRACEME(("count = %d", count)); - SPAGAIN; + SPAGAIN; - if (count) { - sv = POPs; - SvREFCNT_inc(sv); /* We're returning it, must stay alive! */ - } + if (count) { + sv = POPs; + SvREFCNT_inc(sv); /* We're returning it, must stay alive! */ + } - PUTBACK; - FREETMPS; - LEAVE; + PUTBACK; + FREETMPS; + LEAVE; - return sv; + return sv; } /* @@ -1910,43 +2175,110 @@ static SV *scalar_call( * Call routine obj->hook(cloning) in list context. * Returns the list of returned values in an array. */ -static AV *array_call( - pTHX_ +static AV *array_call(pTHX_ SV *obj, SV *hook, int cloning) { - dSP; - int count; - AV *av; - int i; + dSP; + int count; + AV *av; + int i; +#ifdef DEBUGME + dSTCXT; +#endif - TRACEME(("array_call (cloning=%d)", cloning)); + TRACEME(("array_call (cloning=%d)", cloning)); - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; - PUSHMARK(sp); - XPUSHs(obj); /* Target object */ - XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ - PUTBACK; + PUSHMARK(sp); + XPUSHs(obj); /* Target object */ + XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ + PUTBACK; - count = perl_call_sv(hook, G_ARRAY); /* Go back to Perl code */ + count = call_sv(hook, G_ARRAY); /* Go back to Perl code */ - SPAGAIN; + SPAGAIN; - av = newAV(); - for (i = count - 1; i >= 0; i--) { - SV *sv = POPs; - av_store(av, i, SvREFCNT_inc(sv)); - } + av = newAV(); + for (i = count - 1; i >= 0; i--) { + SV *sv = POPs; + av_store(av, i, SvREFCNT_inc(sv)); + } + + PUTBACK; + FREETMPS; + LEAVE; + + return av; +} + +#if PERL_VERSION < 15 +static void +cleanup_recursive_av(pTHX_ AV* av) { + SSize_t i = AvFILLp(av); + SV** arr = AvARRAY(av); + if (SvMAGICAL(av)) return; + while (i >= 0) { + if (arr[i]) { +#if PERL_VERSION < 14 + arr[i] = NULL; +#else + SvREFCNT_dec(arr[i]); +#endif + } + i--; + } +} - PUTBACK; - FREETMPS; - LEAVE; +#ifndef SvREFCNT_IMMORTAL +#ifdef DEBUGGING + /* exercise the immortal resurrection code in sv_free2() */ +# define SvREFCNT_IMMORTAL 1000 +#else +# define SvREFCNT_IMMORTAL ((~(U32)0)/2) +#endif +#endif - return av; +static void +cleanup_recursive_hv(pTHX_ HV* hv) { + SSize_t i = HvTOTALKEYS(hv); + HE** arr = HvARRAY(hv); + if (SvMAGICAL(hv)) return; + while (i >= 0) { + if (arr[i]) { + SvREFCNT(HeVAL(arr[i])) = SvREFCNT_IMMORTAL; + arr[i] = NULL; /* let it leak. too dangerous to clean it up here */ + } + i--; + } +#if PERL_VERSION < 8 + ((XPVHV*)SvANY(hv))->xhv_array = NULL; +#else + HvARRAY(hv) = NULL; +#endif + HvTOTALKEYS(hv) = 0; } +static void +cleanup_recursive_rv(pTHX_ SV* sv) { + if (sv && SvROK(sv)) + SvREFCNT_dec(SvRV(sv)); +} +static void +cleanup_recursive_data(pTHX_ SV* sv) { + if (SvTYPE(sv) == SVt_PVAV) { + cleanup_recursive_av(aTHX_ (AV*)sv); + } + else if (SvTYPE(sv) == SVt_PVHV) { + cleanup_recursive_hv(aTHX_ (HV*)sv); + } + else { + cleanup_recursive_rv(aTHX_ sv); + } +} +#endif /* * known_class @@ -1956,39 +2288,38 @@ static AV *array_call( * * Return true if the class was known, false if the ID was just generated. */ -static int known_class( - pTHX_ +static int known_class(pTHX_ stcxt_t *cxt, char *name, /* Class name */ int len, /* Name length */ I32 *classnum) { - SV **svh; - HV *hclass = cxt->hclass; + SV **svh; + HV *hclass = cxt->hclass; - TRACEME(("known_class (%s)", name)); + TRACEME(("known_class (%s)", name)); - /* - * Recall that we don't store pointers in this hash table, but tags. - * Therefore, we need LOW_32BITS() to extract the relevant parts. - */ + /* + * Recall that we don't store pointers in this hash table, but tags. + * Therefore, we need LOW_32BITS() to extract the relevant parts. + */ - svh = hv_fetch(hclass, name, len, FALSE); - if (svh) { - *classnum = LOW_32BITS(*svh); - return TRUE; - } + svh = hv_fetch(hclass, name, len, FALSE); + if (svh) { + *classnum = LOW_32BITS(*svh); + return TRUE; + } - /* - * Unknown classname, we need to record it. - */ + /* + * Unknown classname, we need to record it. + */ - cxt->classnum++; - if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0)) - CROAK(("Unable to record new classname")); + cxt->classnum++; + if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0)) + CROAK(("Unable to record new classname")); - *classnum = cxt->classnum; - return FALSE; + *classnum = cxt->classnum; + return FALSE; } /*** @@ -2003,31 +2334,50 @@ static int known_class( */ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) { - int is_weak = 0; - TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv))); + int retval; + int is_weak = 0; + TRACEME(("store_ref (0x%" UVxf ")", PTR2UV(sv))); - /* - * Follow reference, and check if target is overloaded. - */ + /* + * Follow reference, and check if target is overloaded. + */ #ifdef SvWEAKREF - if (SvWEAKREF(sv)) - is_weak = 1; - TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't")); -#endif - sv = SvRV(sv); - - if (SvOBJECT(sv)) { - HV *stash = (HV *) SvSTASH(sv); - if (stash && Gv_AMG(stash)) { - TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv))); - PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); - } else - PUTMARK(is_weak ? SX_WEAKREF : SX_REF); - } else - PUTMARK(is_weak ? SX_WEAKREF : SX_REF); - - return store(aTHX_ cxt, sv); + if (SvWEAKREF(sv)) + is_weak = 1; + TRACEME(("ref (0x%" UVxf ") is%s weak", PTR2UV(sv), + is_weak ? "" : "n't")); +#endif + sv = SvRV(sv); + + if (SvOBJECT(sv)) { + HV *stash = (HV *) SvSTASH(sv); + if (stash && Gv_AMG(stash)) { + TRACEME(("ref (0x%" UVxf ") is overloaded", PTR2UV(sv))); + PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); + } else + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); + } else + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == sv) { + if (RECURSION_TOO_DEEP()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)sv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = sv; + + retval = store(aTHX_ cxt, sv); + if (cxt->entry && cxt->recur_sv == sv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + return retval; } /* @@ -2045,216 +2395,230 @@ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) * * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>. * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>. + * + * For huge strings use SX_LOBJECT SX_type SX_U64 <type> <data> */ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) { - IV iv; - char *pv; - STRLEN len; - U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */ - - TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv))); - - /* - * For efficiency, break the SV encapsulation by peaking at the flags - * directly without using the Perl macros to avoid dereferencing - * sv->sv_flags each time we wish to check the flags. - */ - - if (!(flags & SVf_OK)) { /* !SvOK(sv) */ - if (sv == &PL_sv_undef) { - TRACEME(("immortal undef")); - PUTMARK(SX_SV_UNDEF); - } else { - TRACEME(("undef at 0x%"UVxf, PTR2UV(sv))); - PUTMARK(SX_UNDEF); - } - return 0; - } + IV iv; + char *pv; + STRLEN len; + U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */ + + TRACEME(("store_scalar (0x%" UVxf ")", PTR2UV(sv))); - /* - * Always store the string representation of a scalar if it exists. - * Gisle Aas provided me with this test case, better than a long speach: - * - * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)' - * SV = PVNV(0x80c8520) - * REFCNT = 1 - * FLAGS = (NOK,POK,pNOK,pPOK) - * IV = 0 - * NV = 0 - * PV = 0x80c83d0 "abc"\0 - * CUR = 3 - * LEN = 4 - * - * Write SX_SCALAR, length, followed by the actual data. - * - * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as - * appropriate, followed by the actual (binary) data. A double - * is written as a string if network order, for portability. - * - * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv). - * The reason is that when the scalar value is tainted, the SvNOK(sv) - * value is false. - * - * The test for a read-only scalar with both POK and NOK set is meant - * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the - * address comparison for each scalar we store. - */ + /* + * For efficiency, break the SV encapsulation by peaking at the flags + * directly without using the Perl macros to avoid dereferencing + * sv->sv_flags each time we wish to check the flags. + */ + + if (!(flags & SVf_OK)) { /* !SvOK(sv) */ + if (sv == &PL_sv_undef) { + TRACEME(("immortal undef")); + PUTMARK(SX_SV_UNDEF); + } else { + TRACEME(("undef at 0x%" UVxf, PTR2UV(sv))); + PUTMARK(SX_UNDEF); + } + return 0; + } + + /* + * Always store the string representation of a scalar if it exists. + * Gisle Aas provided me with this test case, better than a long speach: + * + * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)' + * SV = PVNV(0x80c8520) + * REFCNT = 1 + * FLAGS = (NOK,POK,pNOK,pPOK) + * IV = 0 + * NV = 0 + * PV = 0x80c83d0 "abc"\0 + * CUR = 3 + * LEN = 4 + * + * Write SX_SCALAR, length, followed by the actual data. + * + * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as + * appropriate, followed by the actual (binary) data. A double + * is written as a string if network order, for portability. + * + * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv). + * The reason is that when the scalar value is tainted, the SvNOK(sv) + * value is false. + * + * The test for a read-only scalar with both POK and NOK set is meant + * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the + * address comparison for each scalar we store. + */ #define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK) - if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) { - if (sv == &PL_sv_yes) { - TRACEME(("immortal yes")); - PUTMARK(SX_SV_YES); - } else if (sv == &PL_sv_no) { - TRACEME(("immortal no")); - PUTMARK(SX_SV_NO); - } else { - pv = SvPV(sv, len); /* We know it's SvPOK */ - goto string; /* Share code below */ - } - } else if (flags & SVf_POK) { - /* public string - go direct to string read. */ - goto string_readlen; - } else if ( + if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) { + if (sv == &PL_sv_yes) { + TRACEME(("immortal yes")); + PUTMARK(SX_SV_YES); + } else if (sv == &PL_sv_no) { + TRACEME(("immortal no")); + PUTMARK(SX_SV_NO); + } else { + pv = SvPV(sv, len); /* We know it's SvPOK */ + goto string; /* Share code below */ + } + } else if (flags & SVf_POK) { + /* public string - go direct to string read. */ + goto string_readlen; + } else if ( #if (PATCHLEVEL <= 6) - /* For 5.6 and earlier NV flag trumps IV flag, so only use integer - direct if NV flag is off. */ - (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK + /* For 5.6 and earlier NV flag trumps IV flag, so only use integer + direct if NV flag is off. */ + (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK #else - /* 5.7 rules are that if IV public flag is set, IV value is as - good, if not better, than NV value. */ - flags & SVf_IOK + /* 5.7 rules are that if IV public flag is set, IV value is as + good, if not better, than NV value. */ + flags & SVf_IOK #endif - ) { - iv = SvIV(sv); - /* - * Will come here from below with iv set if double is an integer. - */ - integer: + ) { + iv = SvIV(sv); + /* + * Will come here from below with iv set if double is an integer. + */ + integer: - /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ + /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ #ifdef SVf_IVisUV - /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 - * (for example) and that ends up in the optimised small integer - * case. - */ - if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) { - TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv))); - goto string_readlen; - } + /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 + * (for example) and that ends up in the optimised small integer + * case. + */ + if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) { + TRACEME(("large unsigned integer as string, value = %" UVuf, + SvUV(sv))); + goto string_readlen; + } #endif - /* - * Optimize small integers into a single byte, otherwise store as - * a real integer (converted into network order if they asked). - */ + /* + * Optimize small integers into a single byte, otherwise store as + * a real integer (converted into network order if they asked). + */ - if (iv >= -128 && iv <= 127) { - unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ - PUTMARK(SX_BYTE); - PUTMARK(siv); - TRACEME(("small integer stored as %d", siv)); - } else if (cxt->netorder) { + if (iv >= -128 && iv <= 127) { + unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ + PUTMARK(SX_BYTE); + PUTMARK(siv); + TRACEME(("small integer stored as %d", (int)siv)); + } else if (cxt->netorder) { #ifndef HAS_HTONL - TRACEME(("no htonl, fall back to string for integer")); - goto string_readlen; + TRACEME(("no htonl, fall back to string for integer")); + goto string_readlen; #else - I32 niv; + I32 niv; #if IVSIZE > 4 - if ( + if ( #ifdef SVf_IVisUV - /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ - ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) || + /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ + ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) || #endif - (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) { - /* Bigger than 32 bits. */ - TRACEME(("large network order integer as string, value = %"IVdf, iv)); - goto string_readlen; - } + (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) { + /* Bigger than 32 bits. */ + TRACEME(("large network order integer as string, value = %" IVdf, iv)); + goto string_readlen; + } #endif - niv = (I32) htonl((I32) iv); - TRACEME(("using network order")); - PUTMARK(SX_NETINT); - WRITE_I32(niv); + niv = (I32) htonl((I32) iv); + TRACEME(("using network order")); + PUTMARK(SX_NETINT); + WRITE_I32(niv); +#endif + } else { + PUTMARK(SX_INTEGER); + WRITE(&iv, sizeof(iv)); + } + + TRACEME(("ok (integer 0x%" UVxf ", value = %" IVdf ")", PTR2UV(sv), iv)); + } else if (flags & SVf_NOK) { + NV_bytes nv; +#ifdef NV_CLEAR + /* if we can't tell if there's padding, clear the whole NV and hope the + compiler leaves the padding alone + */ + Zero(&nv, 1, NV_bytes); #endif - } else { - PUTMARK(SX_INTEGER); - WRITE(&iv, sizeof(iv)); - } - - TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); - } else if (flags & SVf_NOK) { - NV nv; #if (PATCHLEVEL <= 6) - nv = SvNV(sv); - /* - * Watch for number being an integer in disguise. - */ - if (nv == (NV) (iv = I_V(nv))) { - TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); - goto integer; /* Share code above */ - } + nv.nv = SvNV(sv); + /* + * Watch for number being an integer in disguise. + */ + if (nv.nv == (NV) (iv = I_V(nv.nv))) { + TRACEME(("double %" NVff " is actually integer %" IVdf, nv, iv)); + goto integer; /* Share code above */ + } #else - SvIV_please(sv); - if (SvIOK_notUV(sv)) { - iv = SvIV(sv); - goto integer; /* Share code above */ - } - nv = SvNV(sv); + SvIV_please(sv); + if (SvIOK_notUV(sv)) { + iv = SvIV(sv); + goto integer; /* Share code above */ + } + nv.nv = SvNV(sv); #endif - if (cxt->netorder) { - TRACEME(("double %"NVff" stored as string", nv)); - goto string_readlen; /* Share code below */ - } + if (cxt->netorder) { + TRACEME(("double %" NVff " stored as string", nv.nv)); + goto string_readlen; /* Share code below */ + } +#if NV_PADDING + Zero(nv.bytes + NVSIZE - NV_PADDING, NV_PADDING, char); +#endif - PUTMARK(SX_DOUBLE); - WRITE(&nv, sizeof(nv)); + PUTMARK(SX_DOUBLE); + WRITE(&nv, sizeof(nv)); - TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); + TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")", PTR2UV(sv), nv.nv)); - } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { + } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { #ifdef SvVOK - MAGIC *mg; + MAGIC *mg; #endif - I32 wlen; /* For 64-bit machines */ + UV wlen; /* For 64-bit machines */ - string_readlen: - pv = SvPV(sv, len); + string_readlen: + pv = SvPV(sv, len); - /* - * Will come here from above if it was readonly, POK and NOK but - * neither &PL_sv_yes nor &PL_sv_no. - */ - string: + /* + * Will come here from above if it was readonly, POK and NOK but + * neither &PL_sv_yes nor &PL_sv_no. + */ + string: #ifdef SvVOK - if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) { - /* The macro passes this by address, not value, and a lot of - called code assumes that it's 32 bits without checking. */ - const int len = mg->mg_len; - STORE_PV_LEN((const char *)mg->mg_ptr, - len, SX_VSTRING, SX_LVSTRING); - } + if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) { + /* The macro passes this by address, not value, and a lot of + called code assumes that it's 32 bits without checking. */ + const SSize_t len = mg->mg_len; + STORE_PV_LEN((const char *)mg->mg_ptr, + len, SX_VSTRING, SX_LVSTRING); + } #endif - wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ - if (SvUTF8 (sv)) - STORE_UTF8STR(pv, wlen); - else - STORE_SCALAR(pv, wlen); - TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", - PTR2UV(sv), SvPVX(sv), (IV)len)); - } else - CROAK(("Can't determine type of %s(0x%"UVxf")", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - return 0; /* Ok, no recursion on scalars */ + wlen = (Size_t)len; + if (SvUTF8 (sv)) + STORE_UTF8STR(pv, wlen); + else + STORE_SCALAR(pv, wlen); + TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")", + PTR2UV(sv), len >= 2048 ? "<string too long>" : SvPVX(sv), + (UV)len)); + } else { + CROAK(("Can't determine type of %s(0x%" UVxf ")", + sv_reftype(sv, FALSE), + PTR2UV(sv))); + } + return 0; /* Ok, no recursion on scalars */ } /* @@ -2267,53 +2631,83 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) */ static int store_array(pTHX_ stcxt_t *cxt, AV *av) { - SV **sav; - I32 len = av_len(av) + 1; - I32 i; - int ret; - - TRACEME(("store_array (0x%"UVxf")", PTR2UV(av))); - - /* - * Signal array by emitting SX_ARRAY, followed by the array length. - */ - - PUTMARK(SX_ARRAY); - WLEN(len); - TRACEME(("size = %d", len)); - - /* - * Now store each item recursively. - */ - - for (i = 0; i < len; i++) { - sav = av_fetch(av, i, 0); - if (!sav) { - TRACEME(("(#%d) nonexistent item", i)); - STORE_SV_UNDEF(); - continue; - } + SV **sav; + UV len = av_len(av) + 1; + UV i; + int ret; + + TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av))); + +#ifdef HAS_U64 + if (len > 0x7fffffffu) { + /* + * Large array by emitting SX_LOBJECT 1 U64 data + */ + PUTMARK(SX_LOBJECT); + PUTMARK(SX_ARRAY); + W64LEN(len); + TRACEME(("lobject size = %lu", (unsigned long)len)); + } else +#endif + { + /* + * Normal array by emitting SX_ARRAY, followed by the array length. + */ + I32 l = (I32)len; + PUTMARK(SX_ARRAY); + WLEN(l); + TRACEME(("size = %d", (int)l)); + } + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)av) { + if (RECURSION_TOO_DEEP()) { + /* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */ +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)av); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)av; + + /* + * Now store each item recursively. + */ + + for (i = 0; i < len; i++) { + sav = av_fetch(av, i, 0); + if (!sav) { + TRACEME(("(#%d) nonexistent item", (int)i)); + STORE_SV_UNDEF(); + continue; + } #if PATCHLEVEL >= 19 - /* In 5.19.3 and up, &PL_sv_undef can actually be stored in - * an array; it no longer represents nonexistent elements. - * Historically, we have used SX_SV_UNDEF in arrays for - * nonexistent elements, so we use SX_SVUNDEF_ELEM for - * &PL_sv_undef itself. */ - if (*sav == &PL_sv_undef) { - TRACEME(("(#%d) undef item", i)); - cxt->tagnum++; - PUTMARK(SX_SVUNDEF_ELEM); - continue; - } -#endif - TRACEME(("(#%d) item", i)); - if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */ - return ret; - } + /* In 5.19.3 and up, &PL_sv_undef can actually be stored in + * an array; it no longer represents nonexistent elements. + * Historically, we have used SX_SV_UNDEF in arrays for + * nonexistent elements, so we use SX_SVUNDEF_ELEM for + * &PL_sv_undef itself. */ + if (*sav == &PL_sv_undef) { + TRACEME(("(#%d) undef item", (int)i)); + cxt->tagnum++; + PUTMARK(SX_SVUNDEF_ELEM); + continue; + } +#endif + TRACEME(("(#%d) item", (int)i)); + if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall */ + return ret; + } - TRACEME(("ok (array)")); + if (cxt->entry && cxt->recur_sv == (SV*)av && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + TRACEME(("ok (array)")); - return 0; + return 0; } @@ -2329,9 +2723,9 @@ static int sortcmp(const void *a, const void *b) { #if defined(USE_ITHREADS) - dTHX; + dTHX; #endif /* USE_ITHREADS */ - return sv_cmp(*(SV * const *) a, *(SV * const *) b); + return sv_cmp(*(SV * const *) a, *(SV * const *) b); } #endif /* PATCHLEVEL <= 6 */ @@ -2360,325 +2754,512 @@ sortcmp(const void *a, const void *b) */ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) { - dVAR; - I32 len = HvTOTALKEYS(hv); - I32 i; - int ret = 0; - I32 riter; - HE *eiter; - int flagged_hash = ((SvREADONLY(hv) + dVAR; + UV len = (UV)HvTOTALKEYS(hv); + Size_t i; + int ret = 0; + I32 riter; + HE *eiter; + int flagged_hash = ((SvREADONLY(hv) #ifdef HAS_HASH_KEY_FLAGS - || HvHASKFLAGS(hv) + || HvHASKFLAGS(hv) #endif - ) ? 1 : 0); - unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); + ) ? 1 : 0); + unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); + + /* + * Signal hash by emitting SX_HASH, followed by the table length. + * Max number of keys per perl version: + * IV - 5.12 + * STRLEN 5.14 - 5.24 (size_t: U32/U64) + * SSize_t 5.22c - 5.24c (I32/I64) + * U32 5.25c - + */ + if (len > 0x7fffffffu) { /* keys > I32_MAX */ + /* + * Large hash: SX_LOBJECT type hashflags? U64 data + * + * Stupid limitation: + * Note that perl5 can store more than 2G keys, but only iterate + * over 2G max. (cperl can) + * We need to manually iterate over it then, unsorted. + * But until perl itself cannot do that, skip that. + */ + TRACEME(("lobject size = %lu", (unsigned long)len)); +#ifdef HAS_U64 + PUTMARK(SX_LOBJECT); if (flagged_hash) { - /* needs int cast for C++ compilers, doesn't it? */ - TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv), - (int) hash_flags)); + PUTMARK(SX_FLAG_HASH); + PUTMARK(hash_flags); } else { - TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv))); + PUTMARK(SX_HASH); } - - /* - * Signal hash by emitting SX_HASH, followed by the table length. - */ - + W64LEN(len); + return store_lhash(aTHX_ cxt, hv, hash_flags); +#else + /* <5.12 you could store larger hashes, but cannot iterate over them. + So we reject them, it's a bug. */ + CROAK(("Cannot store large objects on a 32bit system")); +#endif + } else { + I32 l = (I32)len; if (flagged_hash) { + TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv), + (unsigned int)hash_flags)); PUTMARK(SX_FLAG_HASH); PUTMARK(hash_flags); } else { + TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv))); PUTMARK(SX_HASH); } - WLEN(len); - TRACEME(("size = %d", len)); + WLEN(l); + TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv))); + } + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)hv) { + if (RECURSION_TOO_DEEP_HASH()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)hv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)hv; - /* - * Save possible iteration state via each() on that table. - */ + /* + * Save possible iteration state via each() on that table. + * + * Note that perl as of 5.24 *can* store more than 2G keys, but *not* + * iterate over it. + * Lengths of hash keys are also limited to I32, which is good. + */ - riter = HvRITER_get(hv); - eiter = HvEITER_get(hv); - hv_iterinit(hv); + riter = HvRITER_get(hv); + eiter = HvEITER_get(hv); + hv_iterinit(hv); - /* - * Now store each item recursively. - * + /* + * Now store each item recursively. + * * If canonical is defined to some true value then store each * key/value pair in sorted order otherwise the order is random. - * Canonical order is irrelevant when a deep clone operation is performed. - * - * Fetch the value from perl only once per store() operation, and only - * when needed. - */ - - if ( - !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 || - (cxt->canonical < 0 && (cxt->canonical = - (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0)))) - ) { - /* - * Storing in order, sorted by key. - * Run through the hash, building up an array of keys in a - * mortal array, sort the array and then run through the - * array. - */ - - AV *av = newAV(); + * Canonical order is irrelevant when a deep clone operation is performed. + * + * Fetch the value from perl only once per store() operation, and only + * when needed. + */ - /*av_extend (av, len);*/ + if ( + !(cxt->optype & ST_CLONE) + && (cxt->canonical == 1 + || (cxt->canonical < 0 + && (cxt->canonical = + (SvTRUE(get_sv("Storable::canonical", GV_ADD)) + ? 1 : 0)))) + ) { + /* + * Storing in order, sorted by key. + * Run through the hash, building up an array of keys in a + * mortal array, sort the array and then run through the + * array. + */ + AV *av = newAV(); + av_extend (av, len); - TRACEME(("using canonical order")); + TRACEME(("using canonical order")); - for (i = 0; i < len; i++) { + for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES - HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); + HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); #else - HE *he = hv_iternext(hv); + HE *he = hv_iternext(hv); #endif - SV *key; + av_store(av, i, hv_iterkeysv(he)); + } - if (!he) - CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, (int)len, (int)i)); - key = hv_iterkeysv(he); - av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ - } - - STORE_HASH_SORT; + STORE_HASH_SORT; - for (i = 0; i < len; i++) { + for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES - int placeholders = (int)HvPLACEHOLDERS_get(hv); -#endif - unsigned char flags = 0; - char *keyval; - STRLEN keylen_tmp; - I32 keylen; - SV *key = av_shift(av); - /* This will fail if key is a placeholder. - Track how many placeholders we have, and error if we - "see" too many. */ - HE *he = hv_fetch_ent(hv, key, 0, 0); - SV *val; - - if (he) { - if (!(val = HeVAL(he))) { - /* Internal error, not I/O error */ - return 1; - } - } else { + int placeholders = (int)HvPLACEHOLDERS_get(hv); +#endif + unsigned char flags = 0; + char *keyval; + STRLEN keylen_tmp; + I32 keylen; + SV *key = av_shift(av); + /* This will fail if key is a placeholder. + Track how many placeholders we have, and error if we + "see" too many. */ + HE *he = hv_fetch_ent(hv, key, 0, 0); + SV *val; + + if (he) { + if (!(val = HeVAL(he))) { + /* Internal error, not I/O error */ + return 1; + } + } else { #ifdef HAS_RESTRICTED_HASHES - /* Should be a placeholder. */ - if (placeholders-- < 0) { - /* This should not happen - number of - retrieves should be identical to - number of placeholders. */ - return 1; - } - /* Value is never needed, and PL_sv_undef is - more space efficient to store. */ - val = &PL_sv_undef; - ASSERT (flags == 0, - ("Flags not 0 but %d", flags)); - flags = SHV_K_PLACEHOLDER; + /* Should be a placeholder. */ + if (placeholders-- < 0) { + /* This should not happen - number of + retrieves should be identical to + number of placeholders. */ + return 1; + } + /* Value is never needed, and PL_sv_undef is + more space efficient to store. */ + val = &PL_sv_undef; + ASSERT (flags == 0, + ("Flags not 0 but %d", (int)flags)); + flags = SHV_K_PLACEHOLDER; #else - return 1; -#endif - } - - /* - * Store value first. - */ - - TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - - if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ - goto out; - - /* - * Write key string. - * Keys are written after values to make sure retrieval - * can be optimal in terms of memory usage, where keys are - * read into a fixed unique buffer called kbuf. - * See retrieve_hash() for details. - */ - - /* Implementation of restricted hashes isn't nicely - abstracted: */ - if ((hash_flags & SHV_RESTRICTED) - && SvTRULYREADONLY(val)) { - flags |= SHV_K_LOCKED; - } - - keyval = SvPV(key, keylen_tmp); - keylen = keylen_tmp; + return 1; +#endif + } + + /* + * Store value first. + */ + + TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val))); + + if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ + goto out; + + /* + * Write key string. + * Keys are written after values to make sure retrieval + * can be optimal in terms of memory usage, where keys are + * read into a fixed unique buffer called kbuf. + * See retrieve_hash() for details. + */ + + /* Implementation of restricted hashes isn't nicely + abstracted: */ + if ((hash_flags & SHV_RESTRICTED) + && SvTRULYREADONLY(val)) { + flags |= SHV_K_LOCKED; + } + + keyval = SvPV(key, keylen_tmp); + keylen = keylen_tmp; #ifdef HAS_UTF8_HASHES - /* If you build without optimisation on pre 5.6 - then nothing spots that SvUTF8(key) is always 0, - so the block isn't optimised away, at which point - the linker dislikes the reference to - bytes_from_utf8. */ - if (SvUTF8(key)) { - const char *keysave = keyval; - bool is_utf8 = TRUE; - - /* Just casting the &klen to (STRLEN) won't work - well if STRLEN and I32 are of different widths. - --jhi */ - keyval = (char*)bytes_from_utf8((U8*)keyval, - &keylen_tmp, - &is_utf8); - - /* If we were able to downgrade here, then than - means that we have a key which only had chars - 0-255, but was utf8 encoded. */ - - if (keyval != keysave) { - keylen = keylen_tmp; - flags |= SHV_K_WASUTF8; - } else { - /* keylen_tmp can't have changed, so no need - to assign back to keylen. */ - flags |= SHV_K_UTF8; - } - } -#endif - - if (flagged_hash) { - PUTMARK(flags); - TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); - } else { - /* This is a workaround for a bug in 5.8.0 - that causes the HEK_WASUTF8 flag to be - set on an HEK without the hash being - marked as having key flags. We just - cross our fingers and drop the flag. - AMS 20030901 */ - assert (flags == 0 || flags == SHV_K_WASUTF8); - TRACEME(("(#%d) key '%s'", i, keyval)); - } - WLEN(keylen); - if (keylen) - WRITE(keyval, keylen); - if (flags & SHV_K_WASUTF8) - Safefree (keyval); - } - - /* - * Free up the temporary array - */ - - av_undef(av); - sv_free((SV *) av); - - } else { - - /* - * Storing in "random" order (in the order the keys are stored - * within the hash). This is the default and will be faster! - */ - - for (i = 0; i < len; i++) { - char *key = 0; - I32 len; - unsigned char flags; + /* If you build without optimisation on pre 5.6 + then nothing spots that SvUTF8(key) is always 0, + so the block isn't optimised away, at which point + the linker dislikes the reference to + bytes_from_utf8. */ + if (SvUTF8(key)) { + const char *keysave = keyval; + bool is_utf8 = TRUE; + + /* Just casting the &klen to (STRLEN) won't work + well if STRLEN and I32 are of different widths. + --jhi */ + keyval = (char*)bytes_from_utf8((U8*)keyval, + &keylen_tmp, + &is_utf8); + + /* If we were able to downgrade here, then than + means that we have a key which only had chars + 0-255, but was utf8 encoded. */ + + if (keyval != keysave) { + keylen = keylen_tmp; + flags |= SHV_K_WASUTF8; + } else { + /* keylen_tmp can't have changed, so no need + to assign back to keylen. */ + flags |= SHV_K_UTF8; + } + } +#endif + + if (flagged_hash) { + PUTMARK(flags); + TRACEME(("(#%d) key '%s' flags %x %u", (int)i, keyval, flags, *keyval)); + } else { + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); + TRACEME(("(#%d) key '%s'", (int)i, keyval)); + } + WLEN(keylen); + if (keylen) + WRITE(keyval, keylen); + if (flags & SHV_K_WASUTF8) + Safefree (keyval); + } + + /* + * Free up the temporary array + */ + + av_undef(av); + sv_free((SV *) av); + + } else { + + /* + * Storing in "random" order (in the order the keys are stored + * within the hash). This is the default and will be faster! + */ + + for (i = 0; i < len; i++) { #ifdef HV_ITERNEXT_WANTPLACEHOLDERS - HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); + HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); #else - HE *he = hv_iternext(hv); -#endif - SV *val = (he ? hv_iterval(hv, he) : 0); - SV *key_sv = NULL; - HEK *hek; - - if (val == 0) - return 1; /* Internal error, not I/O error */ - - /* Implementation of restricted hashes isn't nicely - abstracted: */ - flags - = (((hash_flags & SHV_RESTRICTED) - && SvTRULYREADONLY(val)) - ? SHV_K_LOCKED : 0); - - if (val == &PL_sv_placeholder) { - flags |= SHV_K_PLACEHOLDER; - val = &PL_sv_undef; - } - - /* - * Store value first. - */ - - TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - - if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ - goto out; - - - hek = HeKEY_hek(he); - len = HEK_LEN(hek); - if (len == HEf_SVKEY) { - /* This is somewhat sick, but the internal APIs are - * such that XS code could put one of these in in - * a regular hash. - * Maybe we should be capable of storing one if - * found. - */ - key_sv = HeKEY_sv(he); - flags |= SHV_K_ISSV; - } else { - /* Regular string key. */ + HE *he = hv_iternext(hv); +#endif + SV *val = (he ? hv_iterval(hv, he) : 0); + + if (val == 0) + return 1; /* Internal error, not I/O error */ + + if ((ret = store_hentry(aTHX_ cxt, hv, i, he, hash_flags))) + goto out; +#if 0 + /* Implementation of restricted hashes isn't nicely + abstracted: */ + flags = (((hash_flags & SHV_RESTRICTED) + && SvTRULYREADONLY(val)) + ? SHV_K_LOCKED : 0); + + if (val == &PL_sv_placeholder) { + flags |= SHV_K_PLACEHOLDER; + val = &PL_sv_undef; + } + + /* + * Store value first. + */ + + TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val))); + + if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall */ + goto out; + + + hek = HeKEY_hek(he); + len = HEK_LEN(hek); + if (len == HEf_SVKEY) { + /* This is somewhat sick, but the internal APIs are + * such that XS code could put one of these in in + * a regular hash. + * Maybe we should be capable of storing one if + * found. + */ + key_sv = HeKEY_sv(he); + flags |= SHV_K_ISSV; + } else { + /* Regular string key. */ #ifdef HAS_HASH_KEY_FLAGS - if (HEK_UTF8(hek)) - flags |= SHV_K_UTF8; - if (HEK_WASUTF8(hek)) - flags |= SHV_K_WASUTF8; -#endif - key = HEK_KEY(hek); - } - /* - * Write key string. - * Keys are written after values to make sure retrieval - * can be optimal in terms of memory usage, where keys are - * read into a fixed unique buffer called kbuf. - * See retrieve_hash() for details. - */ - - if (flagged_hash) { - PUTMARK(flags); - TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); - } else { - /* This is a workaround for a bug in 5.8.0 - that causes the HEK_WASUTF8 flag to be - set on an HEK without the hash being - marked as having key flags. We just - cross our fingers and drop the flag. - AMS 20030901 */ - assert (flags == 0 || flags == SHV_K_WASUTF8); - TRACEME(("(#%d) key '%s'", i, key)); - } - if (flags & SHV_K_ISSV) { - int ret; - if ((ret = store(aTHX_ cxt, key_sv))) - goto out; - } else { - WLEN(len); - if (len) - WRITE(key, len); - } - } - } - - TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); - -out: - HvRITER_set(hv, riter); /* Restore hash iterator state */ - HvEITER_set(hv, eiter); - - return ret; + if (HEK_UTF8(hek)) + flags |= SHV_K_UTF8; + if (HEK_WASUTF8(hek)) + flags |= SHV_K_WASUTF8; +#endif + key = HEK_KEY(hek); + } + /* + * Write key string. + * Keys are written after values to make sure retrieval + * can be optimal in terms of memory usage, where keys are + * read into a fixed unique buffer called kbuf. + * See retrieve_hash() for details. + */ + + if (flagged_hash) { + PUTMARK(flags); + TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags)); + } else { + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); + TRACEME(("(#%d) key '%s'", (int)i, key)); + } + if (flags & SHV_K_ISSV) { + int ret; + if ((ret = store(aTHX_ cxt, key_sv))) + goto out; + } else { + WLEN(len); + if (len) + WRITE(key, len); + } +#endif + } + } + + TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv))); + + out: + if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf , cxt->recur_depth)); + --cxt->recur_depth; + } + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); + + return ret; +} + +static int store_hentry(pTHX_ + stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags) +{ + int ret = 0; + SV* val = hv_iterval(hv, he); + int flagged_hash = ((SvREADONLY(hv) +#ifdef HAS_HASH_KEY_FLAGS + || HvHASKFLAGS(hv) +#endif + ) ? 1 : 0); + unsigned char flags = (((hash_flags & SHV_RESTRICTED) + && SvTRULYREADONLY(val)) + ? SHV_K_LOCKED : 0); +#ifndef DEBUGME + PERL_UNUSED_ARG(i); +#endif + if (val == &PL_sv_placeholder) { + flags |= SHV_K_PLACEHOLDER; + val = &PL_sv_undef; + } + + /* + * Store value first. + */ + + TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val))); + + { + HEK* hek = HeKEY_hek(he); + I32 len = HEK_LEN(hek); + SV *key_sv = NULL; + char *key = 0; + + if ((ret = store(aTHX_ cxt, val))) + return ret; + if (len == HEf_SVKEY) { + key_sv = HeKEY_sv(he); + flags |= SHV_K_ISSV; + } else { + /* Regular string key. */ +#ifdef HAS_HASH_KEY_FLAGS + if (HEK_UTF8(hek)) + flags |= SHV_K_UTF8; + if (HEK_WASUTF8(hek)) + flags |= SHV_K_WASUTF8; +#endif + key = HEK_KEY(hek); + } + /* + * Write key string. + * Keys are written after values to make sure retrieval + * can be optimal in terms of memory usage, where keys are + * read into a fixed unique buffer called kbuf. + * See retrieve_hash() for details. + */ + + if (flagged_hash) { + PUTMARK(flags); + TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags)); + } else { + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); + TRACEME(("(#%d) key '%s'", (int)i, key)); + } + if (flags & SHV_K_ISSV) { + if ((ret = store(aTHX_ cxt, key_sv))) + return ret; + } else { + WLEN(len); + if (len) + WRITE(key, len); + } + } + return ret; +} + + +#ifdef HAS_U64 +/* + * store_lhash + * + * Store a overlong hash table, with >2G keys, which we cannot iterate + * over with perl5. xhv_eiter is only I32 there. (only cperl can) + * and we also do not want to sort it. + * So we walk the buckets and chains manually. + * + * type, len and flags are already written. + */ + +static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags) +{ + dVAR; + int ret = 0; + Size_t i; + UV ix = 0; + HE** array; +#ifdef DEBUGME + UV len = (UV)HvTOTALKEYS(hv); +#endif + if (hash_flags) { + TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv), + (int) hash_flags)); + } else { + TRACEME(("store_lhash (0x%" UVxf ")", PTR2UV(hv))); + } + TRACEME(("size = %" UVuf ", used = %" UVuf, len, (UV)HvUSEDKEYS(hv))); + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)hv) { + if (RECURSION_TOO_DEEP_HASH()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)hv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)hv; + + array = HvARRAY(hv); + for (i = 0; i <= (Size_t)HvMAX(hv); i++) { + HE* entry = array[i]; + if (!entry) continue; + if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags))) + return ret; + while ((entry = HeNEXT(entry))) { + if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags))) + return ret; + } + } + if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + assert(ix == len); + return ret; } +#endif /* * store_code @@ -2692,100 +3273,181 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv) { #if PERL_VERSION < 6 /* - * retrieve_code does not work with perl 5.005 or less - */ - return store_other(aTHX_ cxt, (SV*)cv); + * retrieve_code does not work with perl 5.005 or less + */ + return store_other(aTHX_ cxt, (SV*)cv); #else - dSP; - I32 len; - int count, reallen; - SV *text, *bdeparse; + dSP; + STRLEN len; + STRLEN count, reallen; + SV *text, *bdeparse; - TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); + TRACEME(("store_code (0x%" UVxf ")", PTR2UV(cv))); - if ( - cxt->deparse == 0 || - (cxt->deparse < 0 && !(cxt->deparse = - SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0)) + if ( + cxt->deparse == 0 || + (cxt->deparse < 0 && + !(cxt->deparse = + SvTRUE(get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0)) ) { - return store_other(aTHX_ cxt, (SV*)cv); - } + return store_other(aTHX_ cxt, (SV*)cv); + } - /* - * Require B::Deparse. At least B::Deparse 0.61 is needed for - * blessed code references. - */ - /* Ownership of both SVs is passed to load_module, which frees them. */ - load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61)); - SPAGAIN; - - ENTER; - SAVETMPS; - - /* - * create the B::Deparse object - */ - - PUSHMARK(sp); - XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP)); - PUTBACK; - count = call_method("new", G_SCALAR); - SPAGAIN; - if (count != 1) - CROAK(("Unexpected return value from B::Deparse::new\n")); - bdeparse = POPs; - - /* - * call the coderef2text method - */ - - PUSHMARK(sp); - XPUSHs(bdeparse); /* XXX is this already mortal? */ - XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); - PUTBACK; - count = call_method("coderef2text", G_SCALAR); - SPAGAIN; - if (count != 1) - CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); - - text = POPs; - len = SvCUR(text); - reallen = strlen(SvPV_nolen(text)); - - /* - * Empty code references or XS functions are deparsed as - * "(prototype) ;" or ";". - */ - - if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { - CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); - } + /* + * Require B::Deparse. At least B::Deparse 0.61 is needed for + * blessed code references. + */ + /* Ownership of both SVs is passed to load_module, which frees them. */ + load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61)); + SPAGAIN; - /* - * Signal code by emitting SX_CODE. - */ + ENTER; + SAVETMPS; - PUTMARK(SX_CODE); - cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ - TRACEME(("size = %d", len)); - TRACEME(("code = %s", SvPV_nolen(text))); + /* + * create the B::Deparse object + */ - /* - * Now store the source code. - */ + PUSHMARK(sp); + XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP)); + PUTBACK; + count = call_method("new", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::new\n")); + bdeparse = POPs; - if(SvUTF8 (text)) - STORE_UTF8STR(SvPV_nolen(text), len); - else - STORE_SCALAR(SvPV_nolen(text), len); + /* + * call the coderef2text method + */ + + PUSHMARK(sp); + XPUSHs(bdeparse); /* XXX is this already mortal? */ + XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); + PUTBACK; + count = call_method("coderef2text", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); + + text = POPs; + len = SvCUR(text); + reallen = strlen(SvPV_nolen(text)); + + /* + * Empty code references or XS functions are deparsed as + * "(prototype) ;" or ";". + */ + + if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { + CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); + } + + /* + * Signal code by emitting SX_CODE. + */ + + PUTMARK(SX_CODE); + cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ + TRACEME(("size = %d", (int)len)); + TRACEME(("code = %s", SvPV_nolen(text))); + + /* + * Now store the source code. + */ + + if(SvUTF8 (text)) + STORE_UTF8STR(SvPV_nolen(text), len); + else + STORE_SCALAR(SvPV_nolen(text), len); - FREETMPS; - LEAVE; + FREETMPS; + LEAVE; - TRACEME(("ok (code)")); + TRACEME(("ok (code)")); + + return 0; +#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 - return 0; +static int get_regexp(pTHX_ stcxt_t *cxt, SV* sv, SV **re, SV **flags) { + dSP; + SV* rv; +#if PERL_VERSION >= 12 + CV *cv = get_cv("re::regexp_pattern", 0); +#else + CV *cv = get_cv("Storable::_regexp_pattern", 0); #endif + I32 count; + + assert(cv); + + ENTER; + SAVETMPS; + rv = sv_2mortal((SV*)newRV_inc(sv)); + PUSHMARK(sp); + XPUSHs(rv); + PUTBACK; + /* optimize to call the XS directly later */ + count = call_sv((SV*)cv, G_ARRAY); + SPAGAIN; + if (count < 2) + CROAK(("re::regexp_pattern returned only %d results", count)); + *flags = POPs; + SvREFCNT_inc(*flags); + *re = POPs; + SvREFCNT_inc(*re); + + PUTBACK; + FREETMPS; + LEAVE; + + return 1; +} + +static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv) { + SV *re = NULL; + SV *flags = NULL; + const char *re_pv; + const char *flags_pv; + STRLEN re_len; + STRLEN flags_len; + U8 op_flags = 0; + + if (!get_regexp(aTHX_ cxt, sv, &re, &flags)) + return -1; + + re_pv = SvPV(re, re_len); + flags_pv = SvPV(flags, flags_len); + + if (re_len > 0xFF) { + op_flags |= SHR_U32_RE_LEN; + } + + PUTMARK(SX_REGEXP); + PUTMARK(op_flags); + if (op_flags & SHR_U32_RE_LEN) { + U32 re_len32 = re_len; + WLEN(re_len32); + } + else + PUTMARK(re_len); + WRITE(re_pv, re_len); + PUTMARK(flags_len); + WRITE(flags_pv, flags_len); + + return 0; } /* @@ -2798,61 +3460,61 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv) */ static int store_tied(pTHX_ stcxt_t *cxt, SV *sv) { - MAGIC *mg; - SV *obj = NULL; - int ret = 0; - int svt = SvTYPE(sv); - char mtype = 'P'; - - TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv))); - - /* - * We have a small run-time penalty here because we chose to factorise - * all tieds objects into the same routine, and not have a store_tied_hash, - * a store_tied_array, etc... - * - * Don't use a switch() statement, as most compilers don't optimize that - * well for 2/3 values. An if() else if() cascade is just fine. We put - * tied hashes first, as they are the most likely beasts. - */ - - if (svt == SVt_PVHV) { - TRACEME(("tied hash")); - PUTMARK(SX_TIED_HASH); /* Introduces tied hash */ - } else if (svt == SVt_PVAV) { - TRACEME(("tied array")); - PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */ - } else { - TRACEME(("tied scalar")); - PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */ - mtype = 'q'; - } + MAGIC *mg; + SV *obj = NULL; + int ret = 0; + int svt = SvTYPE(sv); + char mtype = 'P'; + + TRACEME(("store_tied (0x%" UVxf ")", PTR2UV(sv))); + + /* + * We have a small run-time penalty here because we chose to factorise + * all tieds objects into the same routine, and not have a store_tied_hash, + * a store_tied_array, etc... + * + * Don't use a switch() statement, as most compilers don't optimize that + * well for 2/3 values. An if() else if() cascade is just fine. We put + * tied hashes first, as they are the most likely beasts. + */ - if (!(mg = mg_find(sv, mtype))) - CROAK(("No magic '%c' found while storing tied %s", mtype, - (svt == SVt_PVHV) ? "hash" : - (svt == SVt_PVAV) ? "array" : "scalar")); - - /* - * The mg->mg_obj found by mg_find() above actually points to the - * underlying tied Perl object implementation. For instance, if the - * original SV was that of a tied array, then mg->mg_obj is an AV. - * - * Note that we store the Perl object as-is. We don't call its FETCH - * method along the way. At retrieval time, we won't call its STORE - * method either, but the tieing magic will be re-installed. In itself, - * that ensures that the tieing semantics are preserved since further - * accesses on the retrieved object will indeed call the magic methods... - */ - - /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ - obj = mg->mg_obj ? mg->mg_obj : newSV(0); - if ((ret = store(aTHX_ cxt, obj))) - return ret; - - TRACEME(("ok (tied)")); - - return 0; + if (svt == SVt_PVHV) { + TRACEME(("tied hash")); + PUTMARK(SX_TIED_HASH); /* Introduces tied hash */ + } else if (svt == SVt_PVAV) { + TRACEME(("tied array")); + PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */ + } else { + TRACEME(("tied scalar")); + PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */ + mtype = 'q'; + } + + if (!(mg = mg_find(sv, mtype))) + CROAK(("No magic '%c' found while storing tied %s", mtype, + (svt == SVt_PVHV) ? "hash" : + (svt == SVt_PVAV) ? "array" : "scalar")); + + /* + * The mg->mg_obj found by mg_find() above actually points to the + * underlying tied Perl object implementation. For instance, if the + * original SV was that of a tied array, then mg->mg_obj is an AV. + * + * Note that we store the Perl object as-is. We don't call its FETCH + * method along the way. At retrieval time, we won't call its STORE + * method either, but the tieing magic will be re-installed. In itself, + * that ensures that the tieing semantics are preserved since further + * accesses on the retrieved object will indeed call the magic methods... + */ + + /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ + obj = mg->mg_obj ? mg->mg_obj : newSV(0); + if ((ret = store(aTHX_ cxt, obj))) + return ret; + + TRACEME(("ok (tied)")); + + return 0; } /* @@ -2869,48 +3531,48 @@ static int store_tied(pTHX_ stcxt_t *cxt, SV *sv) */ static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv) { - MAGIC *mg; - int ret; + MAGIC *mg; + int ret; - TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv))); + TRACEME(("store_tied_item (0x%" UVxf ")", PTR2UV(sv))); - if (!(mg = mg_find(sv, 'p'))) - CROAK(("No magic 'p' found while storing reference to tied item")); + if (!(mg = mg_find(sv, 'p'))) + CROAK(("No magic 'p' found while storing reference to tied item")); - /* - * We discriminate between \$h{key} and \$a[idx] via mg_ptr. - */ + /* + * We discriminate between \$h{key} and \$a[idx] via mg_ptr. + */ - if (mg->mg_ptr) { - TRACEME(("store_tied_item: storing a ref to a tied hash item")); - PUTMARK(SX_TIED_KEY); - TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); + if (mg->mg_ptr) { + TRACEME(("store_tied_item: storing a ref to a tied hash item")); + PUTMARK(SX_TIED_KEY); + TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj))); - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ - return ret; + if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + return ret; - TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr))); + TRACEME(("store_tied_item: storing PTR 0x%" UVxf, PTR2UV(mg->mg_ptr))); - if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ - return ret; - } else { - I32 idx = mg->mg_len; + if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ + return ret; + } else { + I32 idx = mg->mg_len; - TRACEME(("store_tied_item: storing a ref to a tied array item ")); - PUTMARK(SX_TIED_IDX); - TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); + TRACEME(("store_tied_item: storing a ref to a tied array item ")); + PUTMARK(SX_TIED_IDX); + TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj))); - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */ - return ret; + if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */ + return ret; - TRACEME(("store_tied_item: storing IDX %d", idx)); + TRACEME(("store_tied_item: storing IDX %d", (int)idx)); - WLEN(idx); - } + WLEN(idx); + } - TRACEME(("ok (tied item)")); + TRACEME(("ok (tied item)")); - return 0; + return 0; } /* @@ -2959,416 +3621,469 @@ static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv) * any other tied variable. */ static int store_hook( - pTHX_ - stcxt_t *cxt, - SV *sv, - int type, - HV *pkg, - SV *hook) + pTHX_ + stcxt_t *cxt, + SV *sv, + int type, + HV *pkg, + SV *hook) { - I32 len; - char *classname; - STRLEN len2; - SV *ref; - AV *av; - SV **ary; - int count; /* really len3 + 1 */ - unsigned char flags; - char *pv; - int i; - int recursed = 0; /* counts recursion */ - int obj_type; /* object type, on 2 bits */ - I32 classnum; - int ret; - int clone = cxt->optype & ST_CLONE; - char mtype = '\0'; /* for blessed ref to tied structures */ - unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ - - TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); - - /* - * Determine object type on 2 bits. - */ - - switch (type) { - case svis_REF: - case svis_SCALAR: - obj_type = SHT_SCALAR; - break; - case svis_ARRAY: - obj_type = SHT_ARRAY; - break; - case svis_HASH: - obj_type = SHT_HASH; - break; - case svis_TIED: - /* - * Produced by a blessed ref to a tied data structure, $o in the - * following Perl code. - * - * my %h; - * tie %h, 'FOO'; - * my $o = bless \%h, 'BAR'; - * - * Signal the tie-ing magic by setting the object type as SHT_EXTRA - * (since we have only 2 bits in <flags> to store the type), and an - * <extra> byte flag will be emitted after the FIRST <flags> in the - * stream, carrying what we put in 'eflags'. - */ - obj_type = SHT_EXTRA; - switch (SvTYPE(sv)) { - case SVt_PVHV: - eflags = (unsigned char) SHT_THASH; - mtype = 'P'; - break; - case SVt_PVAV: - eflags = (unsigned char) SHT_TARRAY; - mtype = 'P'; - break; - default: - eflags = (unsigned char) SHT_TSCALAR; - mtype = 'q'; - break; - } - break; - default: - CROAK(("Unexpected object type (%d) in store_hook()", type)); - } - flags = SHF_NEED_RECURSE | obj_type; - - classname = HvNAME_get(pkg); - len = strlen(classname); - - /* - * To call the hook, we need to fake a call like: - * - * $object->STORABLE_freeze($cloning); - * - * but we don't have the $object here. For instance, if $object is - * a blessed array, what we have in 'sv' is the array, and we can't - * call a method on those. - * - * Therefore, we need to create a temporary reference to the object and - * make the call on that reference. - */ - - TRACEME(("about to call STORABLE_freeze on class %s", classname)); - - ref = newRV_inc(sv); /* Temporary reference */ - av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ - SvREFCNT_dec(ref); /* Reclaim temporary reference */ - - count = AvFILLp(av) + 1; - TRACEME(("store_hook, array holds %d items", count)); - - /* - * If they return an empty list, it means they wish to ignore the - * hook for this class (and not just this instance -- that's for them - * to handle if they so wish). - * - * Simply disable the cached entry for the hook (it won't be recomputed - * since it's present in the cache) and recurse to store_blessed(). - */ - - if (!count) { - /* free empty list returned by the hook */ - av_undef(av); - sv_free((SV *) av); - - /* - * They must not change their mind in the middle of a serialization. - */ - - if (hv_fetch(cxt->hclass, classname, len, FALSE)) - CROAK(("Too late to ignore hooks for %s class \"%s\"", - (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname)); - - pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); - - ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible")); - TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname)); - - return store_blessed(aTHX_ cxt, sv, type, pkg); - } + I32 len; + char *classname; + STRLEN len2; + SV *ref; + AV *av; + SV **ary; + int count; /* really len3 + 1 */ + unsigned char flags; + char *pv; + int i; + int recursed = 0; /* counts recursion */ + int obj_type; /* object type, on 2 bits */ + I32 classnum; + int ret; + int clone = cxt->optype & ST_CLONE; + char mtype = '\0'; /* for blessed ref to tied structures */ + unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ +#ifdef HAS_U64 + int need_large_oids = 0; +#endif - /* - * Get frozen string. - */ - - ary = AvARRAY(av); - pv = SvPV(ary[0], len2); - /* We can't use pkg_can here because it only caches one method per - * package */ - { - GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE); - if (gv && isGV(gv)) { - if (count > 1) - CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname)); - goto check_done; - } - } + TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), (int)cxt->tagnum)); + + /* + * Determine object type on 2 bits. + */ + + switch (type) { + case svis_REF: + case svis_SCALAR: + obj_type = SHT_SCALAR; + break; + case svis_ARRAY: + obj_type = SHT_ARRAY; + break; + case svis_HASH: + obj_type = SHT_HASH; + break; + case svis_TIED: + /* + * Produced by a blessed ref to a tied data structure, $o in the + * following Perl code. + * + * my %h; + * tie %h, 'FOO'; + * my $o = bless \%h, 'BAR'; + * + * Signal the tie-ing magic by setting the object type as SHT_EXTRA + * (since we have only 2 bits in <flags> to store the type), and an + * <extra> byte flag will be emitted after the FIRST <flags> in the + * stream, carrying what we put in 'eflags'. + */ + obj_type = SHT_EXTRA; + switch (SvTYPE(sv)) { + case SVt_PVHV: + eflags = (unsigned char) SHT_THASH; + mtype = 'P'; + break; + case SVt_PVAV: + eflags = (unsigned char) SHT_TARRAY; + mtype = 'P'; + break; + default: + eflags = (unsigned char) SHT_TSCALAR; + mtype = 'q'; + break; + } + break; + default: + CROAK(("Unexpected object type (%d) in store_hook()", type)); + } + flags = SHF_NEED_RECURSE | obj_type; + + classname = HvNAME_get(pkg); + len = strlen(classname); + + /* + * To call the hook, we need to fake a call like: + * + * $object->STORABLE_freeze($cloning); + * + * but we don't have the $object here. For instance, if $object is + * a blessed array, what we have in 'sv' is the array, and we can't + * call a method on those. + * + * Therefore, we need to create a temporary reference to the object and + * make the call on that reference. + */ + + TRACEME(("about to call STORABLE_freeze on class %s", classname)); + + ref = newRV_inc(sv); /* Temporary reference */ + av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ + SvREFCNT_dec(ref); /* Reclaim temporary reference */ + + count = AvFILLp(av) + 1; + TRACEME(("store_hook, array holds %d items", count)); + + /* + * If they return an empty list, it means they wish to ignore the + * hook for this class (and not just this instance -- that's for them + * to handle if they so wish). + * + * Simply disable the cached entry for the hook (it won't be recomputed + * since it's present in the cache) and recurse to store_blessed(). + */ + + if (!count) { + /* free empty list returned by the hook */ + av_undef(av); + sv_free((SV *) av); + + /* + * They must not change their mind in the middle of a serialization. + */ + + if (hv_fetch(cxt->hclass, classname, len, FALSE)) + CROAK(("Too late to ignore hooks for %s class \"%s\"", + (cxt->optype & ST_CLONE) ? "cloning" : "storing", + classname)); + + pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); + + ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), + ("hook invisible")); + TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname)); + + return store_blessed(aTHX_ cxt, sv, type, pkg); + } + + /* + * Get frozen string. + */ - /* - * If they returned more than one item, we need to serialize some - * extra references if not already done. - * - * Loop over the array, starting at position #1, and for each item, - * ensure it is a reference, serialize it if not already done, and - * replace the entry with the tag ID of the corresponding serialized - * object. - * - * We CHEAT by not calling av_fetch() and read directly within the - * array, for speed. - */ - - for (i = 1; i < count; i++) { + ary = AvARRAY(av); + pv = SvPV(ary[0], len2); + /* We can't use pkg_can here because it only caches one method per + * package */ + { + GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE); + if (gv && isGV(gv)) { + if (count > 1) + CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname)); + goto check_done; + } + } + +#ifdef HAS_U64 + if (count > I32_MAX) { + CROAK(("Too many references returned by STORABLE_freeze()")); + } +#endif + + /* + * If they returned more than one item, we need to serialize some + * extra references if not already done. + * + * Loop over the array, starting at position #1, and for each item, + * ensure it is a reference, serialize it if not already done, and + * replace the entry with the tag ID of the corresponding serialized + * object. + * + * We CHEAT by not calling av_fetch() and read directly within the + * array, for speed. + */ + + for (i = 1; i < count; i++) { #ifdef USE_PTR_TABLE - char *fake_tag; + char *fake_tag; #else - SV **svh; -#endif - SV *rsv = ary[i]; - SV *xsv; - SV *tag; - AV *av_hook = cxt->hook_seen; - - if (!SvROK(rsv)) - CROAK(("Item #%d returned by STORABLE_freeze " - "for %s is not a reference", i, classname)); - xsv = SvRV(rsv); /* Follow ref to know what to look for */ - - /* - * Look in hseen and see if we have a tag already. - * Serialize entry if not done already, and get its tag. - */ - + SV **svh; +#endif + SV *rsv = ary[i]; + SV *xsv; + SV *tag; + AV *av_hook = cxt->hook_seen; + + if (!SvROK(rsv)) + CROAK(("Item #%d returned by STORABLE_freeze " + "for %s is not a reference", (int)i, classname)); + xsv = SvRV(rsv); /* Follow ref to know what to look for */ + + /* + * Look in hseen and see if we have a tag already. + * Serialize entry if not done already, and get its tag. + */ + #ifdef USE_PTR_TABLE - /* Fakery needed because ptr_table_fetch returns zero for a - failure, whereas the existing code assumes that it can - safely store a tag zero. So for ptr_tables we store tag+1 - */ - if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv))) - goto sv_seen; /* Avoid moving code too far to the right */ + /* Fakery needed because ptr_table_fetch returns zero for a + failure, whereas the existing code assumes that it can + safely store a tag zero. So for ptr_tables we store tag+1 + */ + if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv))) + goto sv_seen; /* Avoid moving code too far to the right */ #else - if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))) - goto sv_seen; /* Avoid moving code too far to the right */ -#endif - - TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv))); - - /* - * We need to recurse to store that object and get it to be known - * so that we can resolve the list of object-IDs at retrieve time. - * - * The first time we do this, we need to emit the proper header - * indicating that we recursed, and what the type of object is (the - * object we're storing via a user-hook). Indeed, during retrieval, - * we'll have to create the object before recursing to retrieve the - * others, in case those would point back at that object. - */ - - /* [SX_HOOK] <flags> [<extra>] <object>*/ - if (!recursed++) { - PUTMARK(SX_HOOK); - PUTMARK(flags); - if (obj_type == SHT_EXTRA) - PUTMARK(eflags); - } else - PUTMARK(flags); - - if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */ - return ret; + if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))) + goto sv_seen; /* Avoid moving code too far to the right */ +#endif + + TRACEME(("listed object %d at 0x%" UVxf " is unknown", i-1, + PTR2UV(xsv))); + + /* + * We need to recurse to store that object and get it to be known + * so that we can resolve the list of object-IDs at retrieve time. + * + * The first time we do this, we need to emit the proper header + * indicating that we recursed, and what the type of object is (the + * object we're storing via a user-hook). Indeed, during retrieval, + * we'll have to create the object before recursing to retrieve the + * others, in case those would point back at that object. + */ + + /* [SX_HOOK] <flags> [<extra>] <object>*/ + if (!recursed++) { +#ifdef HAS_U64 + if (len2 > INT32_MAX) + PUTMARK(SX_LOBJECT); +#endif + PUTMARK(SX_HOOK); + PUTMARK(flags); + if (obj_type == SHT_EXTRA) + PUTMARK(eflags); + } else + PUTMARK(flags); + + if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */ + return ret; #ifdef USE_PTR_TABLE - fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv); - if (!sv) - CROAK(("Could not serialize item #%d from hook in %s", i, classname)); + fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv); + if (!fake_tag) + CROAK(("Could not serialize item #%d from hook in %s", + (int)i, classname)); #else - svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE); - if (!svh) - CROAK(("Could not serialize item #%d from hook in %s", i, classname)); -#endif - /* - * It was the first time we serialized 'xsv'. - * - * Keep this SV alive until the end of the serialization: if we - * disposed of it right now by decrementing its refcount, and it was - * a temporary value, some next temporary value allocated during - * another STORABLE_freeze might take its place, and we'd wrongly - * assume that new SV was already serialized, based on its presence - * in cxt->hseen. - * - * Therefore, push it away in cxt->hook_seen. - */ - - av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); - - sv_seen: - /* - * Dispose of the REF they returned. If we saved the 'xsv' away - * in the array of returned SVs, that will not cause the underlying - * referenced SV to be reclaimed. - */ - - ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); - SvREFCNT_dec(rsv); /* Dispose of reference */ - - /* - * Replace entry with its tag (not a real SV, so no refcnt increment) - */ + svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE); + if (!svh) + CROAK(("Could not serialize item #%d from hook in %s", + (int)i, classname)); +#endif + /* + * It was the first time we serialized 'xsv'. + * + * Keep this SV alive until the end of the serialization: if we + * disposed of it right now by decrementing its refcount, and it was + * a temporary value, some next temporary value allocated during + * another STORABLE_freeze might take its place, and we'd wrongly + * assume that new SV was already serialized, based on its presence + * in cxt->hseen. + * + * Therefore, push it away in cxt->hook_seen. + */ + + av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); + + sv_seen: + /* + * Dispose of the REF they returned. If we saved the 'xsv' away + * in the array of returned SVs, that will not cause the underlying + * referenced SV to be reclaimed. + */ + + ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); + SvREFCNT_dec(rsv); /* Dispose of reference */ + + /* + * Replace entry with its tag (not a real SV, so no refcnt increment) + */ #ifdef USE_PTR_TABLE - tag = (SV *)--fake_tag; + tag = (SV *)--fake_tag; #else - tag = *svh; + tag = *svh; #endif - ary[i] = tag; - TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, - i-1, PTR2UV(xsv), PTR2UV(tag))); - } + ary[i] = tag; + TRACEME(("listed object %d at 0x%" UVxf " is tag #%" UVuf, + i-1, PTR2UV(xsv), PTR2UV(tag))); +#ifdef HAS_U64 + if ((U32)PTR2TAG(tag) != PTR2TAG(tag)) + need_large_oids = 1; +#endif + } - /* - * Allocate a class ID if not already done. - * - * This needs to be done after the recursion above, since at retrieval - * time, we'll see the inner objects first. Many thanks to - * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and - * proposed the right fix. -- RAM, 15/09/2000 - */ - -check_done: - if (!known_class(aTHX_ cxt, classname, len, &classnum)) { - TRACEME(("first time we see class %s, ID = %d", classname, classnum)); - classnum = -1; /* Mark: we must store classname */ - } else { - TRACEME(("already seen class %s, ID = %d", classname, classnum)); - } + /* + * Allocate a class ID if not already done. + * + * This needs to be done after the recursion above, since at retrieval + * time, we'll see the inner objects first. Many thanks to + * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and + * proposed the right fix. -- RAM, 15/09/2000 + */ - /* - * Compute leading flags. - */ - - flags = obj_type; - if (((classnum == -1) ? len : classnum) > LG_SCALAR) - flags |= SHF_LARGE_CLASSLEN; - if (classnum != -1) - flags |= SHF_IDX_CLASSNAME; - if (len2 > LG_SCALAR) - flags |= SHF_LARGE_STRLEN; - if (count > 1) - flags |= SHF_HAS_LIST; - if (count > (LG_SCALAR + 1)) - flags |= SHF_LARGE_LISTLEN; - - /* - * We're ready to emit either serialized form: - * - * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] - * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>] - * - * If we recursed, the SX_HOOK has already been emitted. - */ - - TRACEME(("SX_HOOK (recursed=%d) flags=0x%x " - "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d", - recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1)); - - /* SX_HOOK <flags> [<extra>] */ - if (!recursed) { - PUTMARK(SX_HOOK); - PUTMARK(flags); - if (obj_type == SHT_EXTRA) - PUTMARK(eflags); - } else - PUTMARK(flags); - - /* <len> <classname> or <index> */ - if (flags & SHF_IDX_CLASSNAME) { - if (flags & SHF_LARGE_CLASSLEN) - WLEN(classnum); - else { - unsigned char cnum = (unsigned char) classnum; - PUTMARK(cnum); - } - } else { - if (flags & SHF_LARGE_CLASSLEN) - WLEN(len); - else { - unsigned char clen = (unsigned char) len; - PUTMARK(clen); - } - WRITE(classname, len); /* Final \0 is omitted */ - } + check_done: + if (!known_class(aTHX_ cxt, classname, len, &classnum)) { + TRACEME(("first time we see class %s, ID = %d", classname, (int)classnum)); + classnum = -1; /* Mark: we must store classname */ + } else { + TRACEME(("already seen class %s, ID = %d", classname, (int)classnum)); + } - /* <len2> <frozen-str> */ - if (flags & SHF_LARGE_STRLEN) { - I32 wlen2 = len2; /* STRLEN might be 8 bytes */ - WLEN(wlen2); /* Must write an I32 for 64-bit machines */ - } else { - unsigned char clen = (unsigned char) len2; - PUTMARK(clen); - } - if (len2) - WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */ - - /* [<len3> <object-IDs>] */ - if (flags & SHF_HAS_LIST) { - int len3 = count - 1; - if (flags & SHF_LARGE_LISTLEN) - WLEN(len3); - else { - unsigned char clen = (unsigned char) len3; - PUTMARK(clen); - } - - /* - * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a - * real pointer, rather a tag number, well under the 32-bit limit. - */ - - for (i = 1; i < count; i++) { - I32 tagval = htonl(LOW_32BITS(ary[i])); - WRITE_I32(tagval); - TRACEME(("object %d, tag #%d", i-1, ntohl(tagval))); - } + /* + * Compute leading flags. + */ + + flags = obj_type; + if (((classnum == -1) ? len : classnum) > LG_SCALAR) + flags |= SHF_LARGE_CLASSLEN; + if (classnum != -1) + flags |= SHF_IDX_CLASSNAME; + if (len2 > LG_SCALAR) + flags |= SHF_LARGE_STRLEN; + if (count > 1) + flags |= SHF_HAS_LIST; + if (count > (LG_SCALAR + 1)) + flags |= SHF_LARGE_LISTLEN; +#ifdef HAS_U64 + if (need_large_oids) + flags |= SHF_LARGE_LISTLEN; +#endif + + /* + * We're ready to emit either serialized form: + * + * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] + * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>] + * + * If we recursed, the SX_HOOK has already been emitted. + */ + + TRACEME(("SX_HOOK (recursed=%d) flags=0x%x " + "class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%d", + recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1)); + + /* SX_HOOK <flags> [<extra>] */ + if (!recursed) { +#ifdef HAS_U64 + if (len2 > INT32_MAX) + PUTMARK(SX_LOBJECT); +#endif + PUTMARK(SX_HOOK); + PUTMARK(flags); + if (obj_type == SHT_EXTRA) + PUTMARK(eflags); + } else + PUTMARK(flags); + + /* <len> <classname> or <index> */ + if (flags & SHF_IDX_CLASSNAME) { + if (flags & SHF_LARGE_CLASSLEN) + WLEN(classnum); + else { + unsigned char cnum = (unsigned char) classnum; + PUTMARK(cnum); + } + } else { + if (flags & SHF_LARGE_CLASSLEN) + WLEN(len); + else { + unsigned char clen = (unsigned char) len; + PUTMARK(clen); + } + WRITE(classname, len); /* Final \0 is omitted */ + } + + /* <len2> <frozen-str> */ +#ifdef HAS_U64 + if (len2 > INT32_MAX) { + W64LEN(len2); + } + else +#endif + if (flags & SHF_LARGE_STRLEN) { + U32 wlen2 = len2; /* STRLEN might be 8 bytes */ + WLEN(wlen2); /* Must write an I32 for 64-bit machines */ + } else { + unsigned char clen = (unsigned char) len2; + PUTMARK(clen); + } + if (len2) + WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */ + + /* [<len3> <object-IDs>] */ + if (flags & SHF_HAS_LIST) { + int len3 = count - 1; + if (flags & SHF_LARGE_LISTLEN) { +#ifdef HAS_U64 + int tlen3 = need_large_oids ? -len3 : len3; + WLEN(tlen3); +#else + WLEN(len3); +#endif } + else { + unsigned char clen = (unsigned char) len3; + PUTMARK(clen); + } + + /* + * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a + * real pointer, rather a tag number, well under the 32-bit limit. + * Which is wrong... if we have more than 2**32 SVs we can get ids over + * the 32-bit limit. + */ - /* - * Free the array. We need extra care for indices after 0, since they - * don't hold real SVs but integers cast. - */ + for (i = 1; i < count; i++) { +#ifdef HAS_U64 + if (need_large_oids) { + ntag_t tag = PTR2TAG(ary[i]); + W64LEN(tag); + TRACEME(("object %d, tag #%" UVuf, i-1, (UV)tag)); + } + else +#endif + { + I32 tagval = htonl(LOW_32BITS(ary[i])); + WRITE_I32(tagval); + TRACEME(("object %d, tag #%d", i-1, ntohl(tagval))); + } + } + } - if (count > 1) - AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */ - av_undef(av); - sv_free((SV *) av); + /* + * Free the array. We need extra care for indices after 0, since they + * don't hold real SVs but integers cast. + */ - /* - * If object was tied, need to insert serialization of the magic object. - */ + if (count > 1) + AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */ + av_undef(av); + sv_free((SV *) av); - if (obj_type == SHT_EXTRA) { - MAGIC *mg; + /* + * If object was tied, need to insert serialization of the magic object. + */ - if (!(mg = mg_find(sv, mtype))) { - int svt = SvTYPE(sv); - CROAK(("No magic '%c' found while storing ref to tied %s with hook", - mtype, (svt == SVt_PVHV) ? "hash" : - (svt == SVt_PVAV) ? "array" : "scalar")); - } + if (obj_type == SHT_EXTRA) { + MAGIC *mg; - TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf, - PTR2UV(mg->mg_obj), PTR2UV(sv))); + if (!(mg = mg_find(sv, mtype))) { + int svt = SvTYPE(sv); + CROAK(("No magic '%c' found while storing ref to tied %s with hook", + mtype, (svt == SVt_PVHV) ? "hash" : + (svt == SVt_PVAV) ? "array" : "scalar")); + } - /* - * [<magic object>] - */ + TRACEME(("handling the magic object 0x%" UVxf " part of 0x%" UVxf, + PTR2UV(mg->mg_obj), PTR2UV(sv))); - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ - return ret; - } + /* + * [<magic object>] + */ + if ((ret = store(aTHX_ cxt, mg->mg_obj))) + return ret; + } - return 0; + return 0; } /* @@ -3396,75 +4111,76 @@ check_done: * on the high-order bit in flag (same encoding as above for <len>). */ static int store_blessed( - pTHX_ - stcxt_t *cxt, - SV *sv, - int type, - HV *pkg) + pTHX_ + stcxt_t *cxt, + SV *sv, + int type, + HV *pkg) { - SV *hook; - I32 len; - char *classname; - I32 classnum; - - TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); - - /* - * Look for a hook for this blessed SV and redirect to store_hook() - * if needed. - */ - - hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); - if (hook) - return store_hook(aTHX_ cxt, sv, type, pkg, hook); - - /* - * This is a blessed SV without any serialization hook. - */ - - classname = HvNAME_get(pkg); - len = strlen(classname); - - TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", - PTR2UV(sv), classname, cxt->tagnum)); - - /* - * Determine whether it is the first time we see that class name (in which - * case it will be stored in the SX_BLESS form), or whether we already - * saw that class name before (in which case the SX_IX_BLESS form will be - * used). - */ - - if (known_class(aTHX_ cxt, classname, len, &classnum)) { - TRACEME(("already seen class %s, ID = %d", classname, classnum)); - PUTMARK(SX_IX_BLESS); - if (classnum <= LG_BLESS) { - unsigned char cnum = (unsigned char) classnum; - PUTMARK(cnum); - } else { - unsigned char flag = (unsigned char) 0x80; - PUTMARK(flag); - WLEN(classnum); - } - } else { - TRACEME(("first time we see class %s, ID = %d", classname, classnum)); - PUTMARK(SX_BLESS); - if (len <= LG_BLESS) { - unsigned char clen = (unsigned char) len; - PUTMARK(clen); - } else { - unsigned char flag = (unsigned char) 0x80; - PUTMARK(flag); - WLEN(len); /* Don't BER-encode, this should be rare */ - } - WRITE(classname, len); /* Final \0 is omitted */ - } + SV *hook; + char *classname; + I32 len; + I32 classnum; + + TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); + + /* + * Look for a hook for this blessed SV and redirect to store_hook() + * if needed. + */ + + hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); + if (hook) + return store_hook(aTHX_ cxt, sv, type, pkg, hook); + + /* + * This is a blessed SV without any serialization hook. + */ - /* - * Now emit the <object> part. - */ + classname = HvNAME_get(pkg); + len = strlen(classname); - return SV_STORE(type)(aTHX_ cxt, sv); + TRACEME(("blessed 0x%" UVxf " in %s, no hook: tagged #%d", + PTR2UV(sv), classname, (int)cxt->tagnum)); + + /* + * Determine whether it is the first time we see that class name (in which + * case it will be stored in the SX_BLESS form), or whether we already + * saw that class name before (in which case the SX_IX_BLESS form will be + * used). + */ + + if (known_class(aTHX_ cxt, classname, len, &classnum)) { + TRACEME(("already seen class %s, ID = %d", classname, (int)classnum)); + PUTMARK(SX_IX_BLESS); + if (classnum <= LG_BLESS) { + unsigned char cnum = (unsigned char) classnum; + PUTMARK(cnum); + } else { + unsigned char flag = (unsigned char) 0x80; + PUTMARK(flag); + WLEN(classnum); + } + } else { + TRACEME(("first time we see class %s, ID = %d", classname, + (int)classnum)); + PUTMARK(SX_BLESS); + if (len <= LG_BLESS) { + unsigned char clen = (unsigned char) len; + PUTMARK(clen); + } else { + unsigned char flag = (unsigned char) 0x80; + PUTMARK(flag); + WLEN(len); /* Don't BER-encode, this should be rare */ + } + WRITE(classname, len); /* Final \0 is omitted */ + } + + /* + * Now emit the <object> part. + */ + + return SV_STORE(type)(aTHX_ cxt, sv); } /* @@ -3479,37 +4195,39 @@ static int store_blessed( */ static int store_other(pTHX_ stcxt_t *cxt, SV *sv) { - I32 len; - char buf[80]; + STRLEN len; + char buf[80]; - TRACEME(("store_other")); + TRACEME(("store_other")); - /* - * Fetch the value from perl only once per store() operation. - */ + /* + * Fetch the value from perl only once per store() operation. + */ - if ( - cxt->forgive_me == 0 || - (cxt->forgive_me < 0 && !(cxt->forgive_me = - SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) + if ( + cxt->forgive_me == 0 || + (cxt->forgive_me < 0 && + !(cxt->forgive_me = SvTRUE + (get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) ) - CROAK(("Can't store %s items", sv_reftype(sv, FALSE))); + CROAK(("Can't store %s items", sv_reftype(sv, FALSE))); - warn("Can't store item %s(0x%"UVxf")", - sv_reftype(sv, FALSE), PTR2UV(sv)); + warn("Can't store item %s(0x%" UVxf ")", + sv_reftype(sv, FALSE), PTR2UV(sv)); - /* - * Store placeholder string as a scalar instead... - */ + /* + * Store placeholder string as a scalar instead... + */ - (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE), - PTR2UV(sv), (char) 0); + (void) sprintf(buf, "You lost %s(0x%" UVxf ")%c", sv_reftype(sv, FALSE), + PTR2UV(sv), (char) 0); - len = strlen(buf); - STORE_SCALAR(buf, len); - TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len)); + len = strlen(buf); + if (len < 80) + STORE_SCALAR(buf, len); + TRACEME(("ok (dummy \"%s\", length = %" IVdf ")", buf, (IV) len)); - return 0; + return 0; } /*** @@ -3526,68 +4244,79 @@ static int store_other(pTHX_ stcxt_t *cxt, SV *sv) */ static int sv_type(pTHX_ SV *sv) { - switch (SvTYPE(sv)) { - case SVt_NULL: + switch (SvTYPE(sv)) { + case SVt_NULL: #if PERL_VERSION <= 10 - case SVt_IV: -#endif - case SVt_NV: - /* - * No need to check for ROK, that can't be set here since there - * is no field capable of hodling the xrv_rv reference. - */ - return svis_SCALAR; - case SVt_PV: + case SVt_IV: +#endif + case SVt_NV: + /* + * No need to check for ROK, that can't be set here since there + * is no field capable of hodling the xrv_rv reference. + */ + return svis_SCALAR; + case SVt_PV: #if PERL_VERSION <= 10 - case SVt_RV: + case SVt_RV: #else - case SVt_IV: -#endif - case SVt_PVIV: - case SVt_PVNV: - /* - * Starting from SVt_PV, it is possible to have the ROK flag - * set, the pointer to the other SV being either stored in - * the xrv_rv (in the case of a pure SVt_RV), or as the - * xpv_pv field of an SVt_PV and its heirs. - * - * However, those SV cannot be magical or they would be an - * SVt_PVMG at least. - */ - return SvROK(sv) ? svis_REF : svis_SCALAR; - case SVt_PVMG: - case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */ - if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == - (SVs_GMG|SVs_SMG|SVs_RMG) && - (mg_find(sv, 'p'))) - return svis_TIED_ITEM; - /* FALL THROUGH */ + case SVt_IV: +#endif + case SVt_PVIV: + case SVt_PVNV: + /* + * Starting from SVt_PV, it is possible to have the ROK flag + * set, the pointer to the other SV being either stored in + * the xrv_rv (in the case of a pure SVt_RV), or as the + * xpv_pv field of an SVt_PV and its heirs. + * + * However, those SV cannot be magical or they would be an + * SVt_PVMG at least. + */ + return SvROK(sv) ? svis_REF : svis_SCALAR; + case SVt_PVMG: +#if PERL_VERSION <= 10 + if ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG) + && mg_find(sv, PERL_MAGIC_qr)) { + return svis_REGEXP; + } +#endif + case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */ + if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + (mg_find(sv, 'p'))) + return svis_TIED_ITEM; + /* FALL THROUGH */ #if PERL_VERSION < 9 - case SVt_PVBM: -#endif - if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == - (SVs_GMG|SVs_SMG|SVs_RMG) && - (mg_find(sv, 'q'))) - return svis_TIED; - return SvROK(sv) ? svis_REF : svis_SCALAR; - case SVt_PVAV: - if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) - return svis_TIED; - return svis_ARRAY; - case SVt_PVHV: - if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) - return svis_TIED; - return svis_HASH; - case SVt_PVCV: - return svis_CODE; + case SVt_PVBM: +#endif + if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + (mg_find(sv, 'q'))) + return svis_TIED; + return SvROK(sv) ? svis_REF : svis_SCALAR; + case SVt_PVAV: + if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) + return svis_TIED; + return svis_ARRAY; + case SVt_PVHV: + if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) + return svis_TIED; + return svis_HASH; + case SVt_PVCV: + return svis_CODE; #if PERL_VERSION > 8 /* case SVt_INVLIST: */ #endif - default: - break; - } +#if PERL_VERSION > 10 + case SVt_REGEXP: + return svis_REGEXP; +#endif + default: + break; + } - return svis_OTHER; + return svis_OTHER; } /* @@ -3601,122 +4330,146 @@ static int sv_type(pTHX_ SV *sv) */ static int store(pTHX_ stcxt_t *cxt, SV *sv) { - SV **svh; - int ret; - int type; + SV **svh; + int ret; + int type; #ifdef USE_PTR_TABLE - struct ptr_tbl *pseen = cxt->pseen; + struct ptr_tbl *pseen = cxt->pseen; #else - HV *hseen = cxt->hseen; + HV *hseen = cxt->hseen; #endif - TRACEME(("store (0x%"UVxf")", PTR2UV(sv))); + TRACEME(("store (0x%" UVxf ")", PTR2UV(sv))); - /* - * If object has already been stored, do not duplicate data. - * Simply emit the SX_OBJECT marker followed by its tag data. - * The tag is always written in network order. - * - * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a - * real pointer, rather a tag number (watch the insertion code below). - * That means it probably safe to assume it is well under the 32-bit limit, - * and makes the truncation safe. - * -- RAM, 14/09/1999 - */ + /* + * If object has already been stored, do not duplicate data. + * Simply emit the SX_OBJECT marker followed by its tag data. + * The tag is always written in network order. + * + * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a + * real pointer, rather a tag number (watch the insertion code below). + * That means it probably safe to assume it is well under the 32-bit + * limit, and makes the truncation safe. + * -- RAM, 14/09/1999 + */ #ifdef USE_PTR_TABLE - svh = (SV **)ptr_table_fetch(pseen, sv); + svh = (SV **)ptr_table_fetch(pseen, sv); #else - svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE); -#endif - if (svh) { - I32 tagval; - - if (sv == &PL_sv_undef) { - /* We have seen PL_sv_undef before, but fake it as - if we have not. - - Not the simplest solution to making restricted - hashes work on 5.8.0, but it does mean that - repeated references to the one true undef will - take up less space in the output file. - */ - /* Need to jump past the next hv_store, because on the - second store of undef the old hash value will be - SvREFCNT_dec()ed, and as Storable cheats horribly - by storing non-SVs in the hash a SEGV will ensure. - Need to increase the tag number so that the - receiver has no idea what games we're up to. This - special casing doesn't affect hooks that store - undef, as the hook routine does its own lookup into - hseen. Also this means that any references back - to PL_sv_undef (from the pathological case of hooks - storing references to it) will find the seen hash - entry for the first time, as if we didn't have this - hackery here. (That hseen lookup works even on 5.8.0 - because it's a key of &PL_sv_undef and a value - which is a tag number, not a value which is - PL_sv_undef.) */ - cxt->tagnum++; - type = svis_SCALAR; - goto undef_special_case; - } - + svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE); +#endif + if (svh) { + ntag_t tagval; + if (sv == &PL_sv_undef) { + /* We have seen PL_sv_undef before, but fake it as + if we have not. + + Not the simplest solution to making restricted + hashes work on 5.8.0, but it does mean that + repeated references to the one true undef will + take up less space in the output file. + */ + /* Need to jump past the next hv_store, because on the + second store of undef the old hash value will be + SvREFCNT_dec()ed, and as Storable cheats horribly + by storing non-SVs in the hash a SEGV will ensure. + Need to increase the tag number so that the + receiver has no idea what games we're up to. This + special casing doesn't affect hooks that store + undef, as the hook routine does its own lookup into + hseen. Also this means that any references back + to PL_sv_undef (from the pathological case of hooks + storing references to it) will find the seen hash + entry for the first time, as if we didn't have this + hackery here. (That hseen lookup works even on 5.8.0 + because it's a key of &PL_sv_undef and a value + which is a tag number, not a value which is + PL_sv_undef.) */ + cxt->tagnum++; + type = svis_SCALAR; + goto undef_special_case; + } + #ifdef USE_PTR_TABLE - tagval = htonl(LOW_32BITS(((char *)svh)-1)); + tagval = PTR2TAG(((char *)svh)-1); #else - tagval = htonl(LOW_32BITS(*svh)); + tagval = PTR2TAG(*svh); +#endif +#ifdef HAS_U64 + + /* older versions of Storable streat the tag as a signed value + used in an array lookup, corrupting the data structure. + Ensure only a newer Storable will be able to parse this tag id + if it's over the 2G mark. + */ + if (tagval > I32_MAX) { + + TRACEME(("object 0x%" UVxf " seen as #%" UVuf, PTR2UV(sv), + (UV)tagval)); + + PUTMARK(SX_LOBJECT); + PUTMARK(SX_OBJECT); + W64LEN(tagval); + return 0; + } + else #endif + { + I32 ltagval; + + ltagval = htonl((I32)tagval); - TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval))); + TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv), + ntohl(ltagval))); - PUTMARK(SX_OBJECT); - WRITE_I32(tagval); - return 0; + PUTMARK(SX_OBJECT); + WRITE_I32(ltagval); + return 0; } + } + + /* + * Allocate a new tag and associate it with the address of the sv being + * stored, before recursing... + * + * In order to avoid creating new SvIVs to hold the tagnum we just + * cast the tagnum to an SV pointer and store that in the hash. This + * means that we must clean up the hash manually afterwards, but gives + * us a 15% throughput increase. + * + */ - /* - * Allocate a new tag and associate it with the address of the sv being - * stored, before recursing... - * - * In order to avoid creating new SvIVs to hold the tagnum we just - * cast the tagnum to an SV pointer and store that in the hash. This - * means that we must clean up the hash manually afterwards, but gives - * us a 15% throughput increase. - * - */ - - cxt->tagnum++; + cxt->tagnum++; #ifdef USE_PTR_TABLE - ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum)); + ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum)); #else - if (!hv_store(hseen, - (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0)) - return -1; + if (!hv_store(hseen, + (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0)) + return -1; #endif - /* - * Store 'sv' and everything beneath it, using appropriate routine. - * Abort immediately if we get a non-zero status back. - */ + /* + * Store 'sv' and everything beneath it, using appropriate routine. + * Abort immediately if we get a non-zero status back. + */ - type = sv_type(aTHX_ sv); + type = sv_type(aTHX_ sv); -undef_special_case: - TRACEME(("storing 0x%"UVxf" tag #%d, type %d...", - PTR2UV(sv), cxt->tagnum, type)); + undef_special_case: + TRACEME(("storing 0x%" UVxf " tag #%d, type %d...", + PTR2UV(sv), (int)cxt->tagnum, (int)type)); - if (SvOBJECT(sv)) { - HV *pkg = SvSTASH(sv); - ret = store_blessed(aTHX_ cxt, sv, type, pkg); - } else - ret = SV_STORE(type)(aTHX_ cxt, sv); + if (SvOBJECT(sv)) { + HV *pkg = SvSTASH(sv); + ret = store_blessed(aTHX_ cxt, sv, type, pkg); + } else + ret = SV_STORE(type)(aTHX_ cxt, sv); - TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)", - ret ? "FAILED" : "ok", PTR2UV(sv), - SvREFCNT(sv), sv_reftype(sv, FALSE))); + TRACEME(("%s (stored 0x%" UVxf ", refcnt=%d, %s)", + ret ? "FAILED" : "ok", PTR2UV(sv), + (int)SvREFCNT(sv), sv_reftype(sv, FALSE))); - return ret; + return ret; } /* @@ -3759,9 +4512,9 @@ static int magic_write(pTHX_ stcxt_t *cxt) (char) sizeof (byteorderstr) - 1, BYTEORDER_BYTES, (unsigned char) sizeof(int), - (unsigned char) sizeof(long), + (unsigned char) sizeof(long), (unsigned char) sizeof(char *), - (unsigned char) sizeof(NV) + (unsigned char) sizeof(NV) }; #ifdef USE_56_INTERWORK_KLUDGE static const unsigned char file_header_56[] = { @@ -3772,9 +4525,9 @@ static int magic_write(pTHX_ stcxt_t *cxt) (char) sizeof (byteorderstr_56) - 1, BYTEORDER_BYTES_56, (unsigned char) sizeof(int), - (unsigned char) sizeof(long), + (unsigned char) sizeof(long), (unsigned char) sizeof(char *), - (unsigned char) sizeof(NV) + (unsigned char) sizeof(NV) }; #endif const unsigned char *header; @@ -3787,30 +4540,30 @@ static int magic_write(pTHX_ stcxt_t *cxt) length = sizeof (network_file_header); } else { #ifdef USE_56_INTERWORK_KLUDGE - if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { + if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) { header = file_header_56; length = sizeof (file_header_56); } else #endif - { - header = file_header; - length = sizeof (file_header); - } - } + { + header = file_header; + length = sizeof (file_header); + } + } if (!cxt->fio) { /* sizeof the array includes the 0 byte at the end. */ header += sizeof (magicstr) - 1; length -= sizeof (magicstr) - 1; - } + } WRITE( (unsigned char*) header, length); if (!cxt->netorder) { - TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", - (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, - (int) sizeof(int), (int) sizeof(long), - (int) sizeof(char *), (int) sizeof(NV))); + TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", + (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, + (int) sizeof(int), (int) sizeof(long), + (int) sizeof(char *), (int) sizeof(NV))); } return 0; } @@ -3826,117 +4579,118 @@ static int magic_write(pTHX_ stcxt_t *cxt) * It is required to provide a non-null 'res' when the operation type is not * dclone() and store() is performed to memory. */ -static int do_store( - pTHX_ +static int do_store(pTHX_ PerlIO *f, - SV *sv, - int optype, - int network_order, - SV **res) + SV *sv, + int optype, + int network_order, + SV **res) { - dSTCXT; - int status; + dSTCXT; + int status; - ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res, - ("must supply result SV pointer for real recursion to memory")); + ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res, + ("must supply result SV pointer for real recursion to memory")); - TRACEME(("do_store (optype=%d, netorder=%d)", - optype, network_order)); + TRACEMED(("do_store (optype=%d, netorder=%d)", + optype, network_order)); - optype |= ST_STORE; + optype |= ST_STORE; - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ + /* + * Workaround for CROAK leak: if they enter with a "dirty" context, + * free up memory for them now. + */ + + assert(cxt); + if (cxt->s_dirty) + clean_context(aTHX_ cxt); - assert(cxt); - if (cxt->s_dirty) - clean_context(aTHX_ cxt); + /* + * Now that STORABLE_xxx hooks exist, it is possible that they try to + * re-enter store() via the hooks. We need to stack contexts. + */ - /* - * Now that STORABLE_xxx hooks exist, it is possible that they try to - * re-enter store() via the hooks. We need to stack contexts. - */ + if (cxt->entry) + cxt = allocate_context(aTHX_ cxt); - if (cxt->entry) - cxt = allocate_context(aTHX_ cxt); + INIT_TRACEME; - cxt->entry++; + cxt->entry++; - ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(cxt->entry == 1, ("starting new recursion")); + ASSERT(!cxt->s_dirty, ("clean context")); - /* - * Ensure sv is actually a reference. From perl, we called something - * like: - * pstore(aTHX_ FILE, \@array); - * so we must get the scalar value behind that reference. - */ + /* + * Ensure sv is actually a reference. From perl, we called something + * like: + * pstore(aTHX_ FILE, \@array); + * so we must get the scalar value behind that reference. + */ - if (!SvROK(sv)) - CROAK(("Not a reference")); - sv = SvRV(sv); /* So follow it to know what to store */ + if (!SvROK(sv)) + CROAK(("Not a reference")); + sv = SvRV(sv); /* So follow it to know what to store */ - /* - * If we're going to store to memory, reset the buffer. - */ + /* + * If we're going to store to memory, reset the buffer. + */ - if (!f) - MBUF_INIT(0); + if (!f) + MBUF_INIT(0); - /* - * Prepare context and emit headers. - */ + /* + * Prepare context and emit headers. + */ - init_store_context(aTHX_ cxt, f, optype, network_order); + init_store_context(aTHX_ cxt, f, optype, network_order); - if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */ - return 0; /* Error */ + if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */ + return 0; /* Error */ - /* - * Recursively store object... - */ + /* + * Recursively store object... + */ - ASSERT(is_storing(aTHX), ("within store operation")); + ASSERT(is_storing(aTHX), ("within store operation")); - status = store(aTHX_ cxt, sv); /* Just do it! */ + status = store(aTHX_ cxt, sv); /* Just do it! */ - /* - * If they asked for a memory store and they provided an SV pointer, - * make an SV string out of the buffer and fill their pointer. - * - * When asking for ST_REAL, it's MANDATORY for the caller to provide - * an SV, since context cleanup might free the buffer if we did recurse. - * (unless caller is dclone(), which is aware of that). - */ + /* + * If they asked for a memory store and they provided an SV pointer, + * make an SV string out of the buffer and fill their pointer. + * + * When asking for ST_REAL, it's MANDATORY for the caller to provide + * an SV, since context cleanup might free the buffer if we did recurse. + * (unless caller is dclone(), which is aware of that). + */ - if (!cxt->fio && res) - *res = mbuf2sv(aTHX); + if (!cxt->fio && res) + *res = mbuf2sv(aTHX); - /* - * Final cleanup. - * - * The "root" context is never freed, since it is meant to be always - * handy for the common case where no recursion occurs at all (i.e. - * we enter store() outside of any Storable code and leave it, period). - * We know it's the "root" context because there's nothing stacked - * underneath it. - * - * OPTIMIZATION: - * - * When deep cloning, we don't free the context: doing so would force - * us to copy the data in the memory buffer. Sicne we know we're - * about to enter do_retrieve... - */ + TRACEME(("do_store returns %d", status)); - clean_store_context(aTHX_ cxt); - if (cxt->prev && !(cxt->optype & ST_CLONE)) - free_context(aTHX_ cxt); + /* + * Final cleanup. + * + * The "root" context is never freed, since it is meant to be always + * handy for the common case where no recursion occurs at all (i.e. + * we enter store() outside of any Storable code and leave it, period). + * We know it's the "root" context because there's nothing stacked + * underneath it. + * + * OPTIMIZATION: + * + * When deep cloning, we don't free the context: doing so would force + * us to copy the data in the memory buffer. Sicne we know we're + * about to enter do_retrieve... + */ - TRACEME(("do_store returns %d", status)); + clean_store_context(aTHX_ cxt); + if (cxt->prev && !(cxt->optype & ST_CLONE)) + free_context(aTHX_ cxt); - return status == 0; + return status == 0; } /*** @@ -3950,10 +4704,10 @@ static int do_store( */ static SV *mbuf2sv(pTHX) { - dSTCXT; + dSTCXT; - assert(cxt); - return newSVpv(mbase, MBUF_SIZE()); + assert(cxt); + return newSVpv(mbase, MBUF_SIZE()); } /*** @@ -3968,22 +4722,22 @@ static SV *mbuf2sv(pTHX) */ static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname) { - PERL_UNUSED_ARG(cname); - if ( - cxt->ver_major != STORABLE_BIN_MAJOR && - cxt->ver_minor != STORABLE_BIN_MINOR + PERL_UNUSED_ARG(cname); + if ( + cxt->ver_major != STORABLE_BIN_MAJOR && + cxt->ver_minor != STORABLE_BIN_MINOR ) { - CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d", - cxt->fio ? "file" : "string", - cxt->ver_major, cxt->ver_minor, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); - } else { - CROAK(("Corrupted storable %s (binary v%d.%d)", - cxt->fio ? "file" : "string", - cxt->ver_major, cxt->ver_minor)); - } + CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d", + cxt->fio ? "file" : "string", + cxt->ver_major, cxt->ver_minor, + STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); + } else { + CROAK(("Corrupted storable %s (binary v%d.%d)", + cxt->fio ? "file" : "string", + cxt->ver_major, cxt->ver_minor)); + } - return (SV *) 0; /* Just in case */ + return (SV *) 0; /* Just in case */ } /* @@ -3994,38 +4748,40 @@ static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname) { - I32 idx; - const char *classname; - SV **sva; - SV *sv; + I32 idx; + const char *classname; + SV **sva; + SV *sv; - PERL_UNUSED_ARG(cname); - TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_idx_blessed (#%d)", (int)cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - GETMARK(idx); /* Index coded on a single char? */ - if (idx & 0x80) - RLEN(idx); + GETMARK(idx); /* Index coded on a single char? */ + if (idx & 0x80) + RLEN(idx); - /* - * Fetch classname in 'aclass' - */ + /* + * Fetch classname in 'aclass' + */ - sva = av_fetch(cxt->aclass, idx, FALSE); - if (!sva) - CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx)); + sva = av_fetch(cxt->aclass, idx, FALSE); + if (!sva) + CROAK(("Class name #%" IVdf " should have been seen already", + (IV) idx)); - classname = SvPVX(*sva); /* We know it's a PV, by construction */ + classname = SvPVX(*sva); /* We know it's a PV, by construction */ - TRACEME(("class ID %d => %s", idx, classname)); + TRACEME(("class ID %d => %s", (int)idx, classname)); - /* - * Retrieve object and bless it. - */ + /* + * Retrieve object and bless it. + */ - sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ + sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN + will be blessed */ - return sv; + return sv; } /* @@ -4036,53 +4792,61 @@ static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - SV *sv; - char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *classname = buf; - char *malloced_classname = NULL; - - PERL_UNUSED_ARG(cname); - TRACEME(("retrieve_blessed (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - - /* - * Decode class name length and read that name. - * - * Short classnames have two advantages: their length is stored on one - * single byte, and the string can be read on the stack. - */ - - GETMARK(len); /* Length coded on a single char? */ - if (len & 0x80) { - RLEN(len); - TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, classname, len+1, char); - malloced_classname = classname; - } - SAFEPVREAD(classname, len, malloced_classname); - classname[len] = '\0'; /* Mark string end */ + U32 len; + SV *sv; + char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ + char *classname = buf; + char *malloced_classname = NULL; - /* - * It's a new classname, otherwise it would have been an SX_IX_BLESS. - */ + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_blessed (#%d)", (int)cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum)); + /* + * Decode class name length and read that name. + * + * Short classnames have two advantages: their length is stored on one + * single byte, and the string can be read on the stack. + */ - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { - Safefree(malloced_classname); - return (SV *) 0; - } + GETMARK(len); /* Length coded on a single char? */ + if (len & 0x80) { + RLEN(len); + TRACEME(("** allocating %ld bytes for class name", (long)len+1)); + if (len > I32_MAX) + CROAK(("Corrupted classname length %lu", (long)len)); + PL_nomemok = TRUE; /* handle error by ourselves */ + New(10003, classname, len+1, char); + PL_nomemok = FALSE; + if (!classname) + CROAK(("Out of memory with len %ld", (long)len)); + PL_nomemok = FALSE; + malloced_classname = classname; + } + SAFEPVREAD(classname, (I32)len, malloced_classname); + classname[len] = '\0'; /* Mark string end */ + + /* + * It's a new classname, otherwise it would have been an SX_IX_BLESS. + */ + + TRACEME(("new class name \"%s\" will bear ID = %d", classname, + (int)cxt->classnum)); + + if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { + Safefree(malloced_classname); + return (SV *) 0; + } - /* - * Retrieve object and bless it. - */ + /* + * Retrieve object and bless it. + */ - sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ - if (malloced_classname) - Safefree(malloced_classname); + sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ + if (malloced_classname) + Safefree(malloced_classname); - return sv; + return sv; } /* @@ -4105,423 +4869,485 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) * processing (since we won't have seen the magic object by the time the hook * is called). See comments below for why it was done that way. */ -static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) +static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large) { - I32 len; - char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *classname = buf; - unsigned int flags; - I32 len2; - SV *frozen; - I32 len3 = 0; - AV *av = 0; - SV *hook; - SV *sv; - SV *rv; - GV *attach; - HV *stash; - int obj_type; - int clone = cxt->optype & ST_CLONE; - char mtype = '\0'; - unsigned int extra_type = 0; - - PERL_UNUSED_ARG(cname); - TRACEME(("retrieve_hook (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - - /* - * Read flags, which tell us about the type, and whether we need to recurse. - */ - - GETMARK(flags); - - /* - * Create the (empty) object, and mark it as seen. - * - * This must be done now, because tags are incremented, and during - * serialization, the object tag was affected before recursion could - * take place. - */ - - obj_type = flags & SHF_TYPE_MASK; - switch (obj_type) { - case SHT_SCALAR: - sv = newSV(0); - break; - case SHT_ARRAY: - sv = (SV *) newAV(); - break; - case SHT_HASH: - sv = (SV *) newHV(); - break; - case SHT_EXTRA: - /* - * Read <extra> flag to know the type of the object. - * Record associated magic type for later. - */ - GETMARK(extra_type); - switch (extra_type) { - case SHT_TSCALAR: - sv = newSV(0); - mtype = 'q'; - break; - case SHT_TARRAY: - sv = (SV *) newAV(); - mtype = 'P'; - break; - case SHT_THASH: - sv = (SV *) newHV(); - mtype = 'P'; - break; - default: - return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ - } - break; - default: - return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ - } - SEEN0_NN(sv, 0); /* Don't bless yet */ - - /* - * Whilst flags tell us to recurse, do so. - * - * We don't need to remember the addresses returned by retrieval, because - * all the references will be obtained through indirection via the object - * tags in the object-ID list. - * - * We need to decrement the reference count for these objects - * because, if the user doesn't save a reference to them in the hook, - * they must be freed when this context is cleaned. - */ - - while (flags & SHF_NEED_RECURSE) { - TRACEME(("retrieve_hook recursing...")); - rv = retrieve(aTHX_ cxt, 0); - if (!rv) - return (SV *) 0; - SvREFCNT_dec(rv); - TRACEME(("retrieve_hook back with rv=0x%"UVxf, - PTR2UV(rv))); - GETMARK(flags); - } + U32 len; + char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ + char *classname = buf; + unsigned int flags; + STRLEN len2; + SV *frozen; + I32 len3 = 0; + AV *av = 0; + SV *hook; + SV *sv; + SV *rv; + GV *attach; + HV *stash; + int obj_type; + int clone = cxt->optype & ST_CLONE; + char mtype = '\0'; + unsigned int extra_type = 0; +#ifdef HAS_U64 + int has_large_oids = 0; +#endif - if (flags & SHF_IDX_CLASSNAME) { - SV **sva; - I32 idx; - - /* - * Fetch index from 'aclass' - */ - - if (flags & SHF_LARGE_CLASSLEN) - RLEN(idx); - else - GETMARK(idx); - - sva = av_fetch(cxt->aclass, idx, FALSE); - if (!sva) - CROAK(("Class name #%"IVdf" should have been seen already", - (IV) idx)); - - classname = SvPVX(*sva); /* We know it's a PV, by construction */ - TRACEME(("class ID %d => %s", idx, classname)); - - } else { - /* - * Decode class name length and read that name. - * - * NOTA BENE: even if the length is stored on one byte, we don't read - * on the stack. Just like retrieve_blessed(), we limit the name to - * LG_BLESS bytes. This is an arbitrary decision. - */ - char *malloced_classname = NULL; - - if (flags & SHF_LARGE_CLASSLEN) - RLEN(len); - else - GETMARK(len); - - if (len > LG_BLESS) { - TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, classname, len+1, char); - malloced_classname = classname; - } - - SAFEPVREAD(classname, len, malloced_classname); - classname[len] = '\0'; /* Mark string end */ - - /* - * Record new classname. - */ - - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { - Safefree(malloced_classname); - return (SV *) 0; - } - } + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_hook (#%d)", (int)cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - TRACEME(("class name: %s", classname)); +#ifndef HAS_U64 + assert(!large); + PERL_UNUSED_ARG(large); +#endif - /* - * Decode user-frozen string length and read it in an SV. - * - * For efficiency reasons, we read data directly into the SV buffer. - * To understand that code, read retrieve_scalar() - */ + /* + * Read flags, which tell us about the type, and whether we need + * to recurse. + */ - if (flags & SHF_LARGE_STRLEN) - RLEN(len2); - else - GETMARK(len2); + GETMARK(flags); - frozen = NEWSV(10002, len2); - if (len2) { - SAFEREAD(SvPVX(frozen), len2, frozen); - SvCUR_set(frozen, len2); - *SvEND(frozen) = '\0'; - } - (void) SvPOK_only(frozen); /* Validates string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(frozen); - - TRACEME(("frozen string: %d bytes", len2)); - - /* - * Decode object-ID list length, if present. - */ - - if (flags & SHF_HAS_LIST) { - if (flags & SHF_LARGE_LISTLEN) - RLEN(len3); - else - GETMARK(len3); - if (len3) { - av = newAV(); - av_extend(av, len3 + 1); /* Leave room for [0] */ - AvFILLp(av) = len3; /* About to be filled anyway */ - } - } + /* + * Create the (empty) object, and mark it as seen. + * + * This must be done now, because tags are incremented, and during + * serialization, the object tag was affected before recursion could + * take place. + */ - TRACEME(("has %d object IDs to link", len3)); - - /* - * Read object-ID list into array. - * Because we pre-extended it, we can cheat and fill it manually. - * - * We read object tags and we can convert them into SV* on the fly - * because we know all the references listed in there (as tags) - * have been already serialized, hence we have a valid correspondence - * between each of those tags and the recreated SV. - */ - - if (av) { - SV **ary = AvARRAY(av); - int i; - for (i = 1; i <= len3; i++) { /* We leave [0] alone */ - I32 tag; - SV **svh; - SV *xsv; - - READ_I32(tag); - tag = ntohl(tag); - svh = av_fetch(cxt->aseen, tag, FALSE); - if (!svh) { - if (tag == cxt->where_is_undef) { - /* av_fetch uses PL_sv_undef internally, hence this - somewhat gruesome hack. */ - xsv = &PL_sv_undef; - svh = &xsv; - } else { - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tag)); - } - } - xsv = *svh; - ary[i] = SvREFCNT_inc(xsv); - } - } + obj_type = flags & SHF_TYPE_MASK; + switch (obj_type) { + case SHT_SCALAR: + sv = newSV(0); + break; + case SHT_ARRAY: + sv = (SV *) newAV(); + break; + case SHT_HASH: + sv = (SV *) newHV(); + break; + case SHT_EXTRA: + /* + * Read <extra> flag to know the type of the object. + * Record associated magic type for later. + */ + GETMARK(extra_type); + switch (extra_type) { + case SHT_TSCALAR: + sv = newSV(0); + mtype = 'q'; + break; + case SHT_TARRAY: + sv = (SV *) newAV(); + mtype = 'P'; + break; + case SHT_THASH: + sv = (SV *) newHV(); + mtype = 'P'; + break; + default: + return retrieve_other(aTHX_ cxt, 0);/* Let it croak */ + } + break; + default: + return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ + } + SEEN0_NN(sv, 0); /* Don't bless yet */ - /* - * Look up the STORABLE_attach hook - */ - stash = gv_stashpv(classname, GV_ADD); - - /* Handle attach case; again can't use pkg_can because it only - * caches one method */ - attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE); - if (attach && isGV(attach)) { - SV* attached; - SV* attach_hook = newRV((SV*) GvCV(attach)); - - if (av) - CROAK(("STORABLE_attach called with unexpected references")); - av = newAV(); - av_extend(av, 1); - AvFILLp(av) = 0; - AvARRAY(av)[0] = SvREFCNT_inc(frozen); - rv = newSVpv(classname, 0); - attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR); - /* Free memory after a call */ - SvREFCNT_dec(rv); - SvREFCNT_dec(frozen); - av_undef(av); - sv_free((SV *) av); - SvREFCNT_dec(attach_hook); - if (attached && - SvROK(attached) && - sv_derived_from(attached, classname) - ) { - UNSEE(); - /* refcnt of unneeded sv is 2 at this point (one from newHV, second from SEEN call) */ - SvREFCNT_dec(sv); - SvREFCNT_dec(sv); - /* we need to free RV but preserve value that RV point to */ - sv = SvRV(attached); - SEEN0_NN(sv, 0); - SvRV_set(attached, NULL); - SvREFCNT_dec(attached); - if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) - Safefree(classname); - return sv; + /* + * Whilst flags tell us to recurse, do so. + * + * We don't need to remember the addresses returned by retrieval, because + * all the references will be obtained through indirection via the object + * tags in the object-ID list. + * + * We need to decrement the reference count for these objects + * because, if the user doesn't save a reference to them in the hook, + * they must be freed when this context is cleaned. + */ + + while (flags & SHF_NEED_RECURSE) { + TRACEME(("retrieve_hook recursing...")); + rv = retrieve(aTHX_ cxt, 0); + if (!rv) + return (SV *) 0; + SvREFCNT_dec(rv); + TRACEME(("retrieve_hook back with rv=0x%" UVxf, + PTR2UV(rv))); + GETMARK(flags); + } + + if (flags & SHF_IDX_CLASSNAME) { + SV **sva; + I32 idx; + + /* + * Fetch index from 'aclass' + */ + + if (flags & SHF_LARGE_CLASSLEN) + RLEN(idx); + else + GETMARK(idx); + + sva = av_fetch(cxt->aclass, idx, FALSE); + if (!sva) + CROAK(("Class name #%" IVdf " should have been seen already", + (IV) idx)); + + classname = SvPVX(*sva); /* We know it's a PV, by construction */ + TRACEME(("class ID %d => %s", (int)idx, classname)); + + } else { + /* + * Decode class name length and read that name. + * + * NOTA BENE: even if the length is stored on one byte, we don't read + * on the stack. Just like retrieve_blessed(), we limit the name to + * LG_BLESS bytes. This is an arbitrary decision. + */ + char *malloced_classname = NULL; + + if (flags & SHF_LARGE_CLASSLEN) + RLEN(len); + else + GETMARK(len); + + TRACEME(("** allocating %ld bytes for class name", (long)len+1)); + if (len > I32_MAX) /* security */ + CROAK(("Corrupted classname length %lu", (long)len)); + else if (len > LG_BLESS) { /* security: signed len */ + PL_nomemok = TRUE; /* handle error by ourselves */ + New(10003, classname, len+1, char); + PL_nomemok = FALSE; + if (!classname) + CROAK(("Out of memory with len %u", (unsigned)len+1)); + malloced_classname = classname; + } + + SAFEPVREAD(classname, (I32)len, malloced_classname); + classname[len] = '\0'; /* Mark string end */ + + /* + * Record new classname. + */ + + if (!av_store(cxt->aclass, cxt->classnum++, + newSVpvn(classname, len))) { + Safefree(malloced_classname); + return (SV *) 0; + } + } + + TRACEME(("class name: %s", classname)); + + /* + * Decode user-frozen string length and read it in an SV. + * + * For efficiency reasons, we read data directly into the SV buffer. + * To understand that code, read retrieve_scalar() + */ + +#ifdef HAS_U64 + if (large) { + READ_U64(len2); + } + else +#endif + if (flags & SHF_LARGE_STRLEN) { + U32 len32; + RLEN(len32); + len2 = len32; + } + else + GETMARK(len2); + + frozen = NEWSV(10002, len2 ? len2 : 1); + if (len2) { + SAFEREAD(SvPVX(frozen), len2, frozen); + } + SvCUR_set(frozen, len2); + *SvEND(frozen) = '\0'; + (void) SvPOK_only(frozen); /* Validates string pointer */ + if (cxt->s_tainted) /* Is input source tainted? */ + SvTAINT(frozen); + + TRACEME(("frozen string: %d bytes", (int)len2)); + + /* + * Decode object-ID list length, if present. + */ + + if (flags & SHF_HAS_LIST) { + if (flags & SHF_LARGE_LISTLEN) { + RLEN(len3); + if (len3 < 0) { +#ifdef HAS_U64 + ++has_large_oids; + len3 = -len3; +#else + CROAK(("Large object ids in hook data not supported on 32-bit platforms")); +#endif + } - CROAK(("STORABLE_attach did not return a %s object", classname)); } + else + GETMARK(len3); + if (len3) { + av = newAV(); + av_extend(av, len3 + 1); /* Leave room for [0] */ + AvFILLp(av) = len3; /* About to be filled anyway */ + } + } - /* - * Bless the object and look up the STORABLE_thaw hook. - */ - - BLESS(sv, stash); - - hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw"); - if (!hook) { - /* - * Hook not found. Maybe they did not require the module where this - * hook is defined yet? - * - * If the load below succeeds, we'll be able to find the hook. - * Still, it only works reliably when each class is defined in a - * file of its own. - */ - - TRACEME(("No STORABLE_thaw defined for objects of class %s", classname)); - TRACEME(("Going to load module '%s'", classname)); - load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv); - - /* - * We cache results of pkg_can, so we need to uncache before attempting - * the lookup again. - */ - - pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - - if (!hook) - CROAK(("No STORABLE_thaw defined for objects of class %s " - "(even after a \"require %s;\")", classname, classname)); - } + TRACEME(("has %d object IDs to link", (int)len3)); - /* - * If we don't have an 'av' yet, prepare one. - * Then insert the frozen string as item [0]. - */ + /* + * Read object-ID list into array. + * Because we pre-extended it, we can cheat and fill it manually. + * + * We read object tags and we can convert them into SV* on the fly + * because we know all the references listed in there (as tags) + * have been already serialized, hence we have a valid correspondence + * between each of those tags and the recreated SV. + */ - if (!av) { - av = newAV(); - av_extend(av, 1); - AvFILLp(av) = 0; - } - AvARRAY(av)[0] = SvREFCNT_inc(frozen); - - /* - * Call the hook as: - * - * $object->STORABLE_thaw($cloning, $frozen, @refs); - * - * where $object is our blessed (empty) object, $cloning is a boolean - * telling whether we're running a deep clone, $frozen is the frozen - * string the user gave us in his serializing hook, and @refs, which may - * be empty, is the list of extra references he returned along for us - * to serialize. - * - * In effect, the hook is an alternate creation routine for the class, - * the object itself being already created by the runtime. - */ - - TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)", - classname, PTR2UV(sv), (IV) AvFILLp(av) + 1)); - - rv = newRV(sv); - (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD); - SvREFCNT_dec(rv); - - /* - * Final cleanup. - */ - - SvREFCNT_dec(frozen); - av_undef(av); - sv_free((SV *) av); - if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) - Safefree(classname); - - /* - * If we had an <extra> type, then the object was not as simple, and - * we need to restore extra magic now. - */ - - if (!extra_type) - return sv; - - TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv))); - - rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */ - - TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf, - PTR2UV(rv), PTR2UV(sv))); - - switch (extra_type) { - case SHT_TSCALAR: - sv_upgrade(sv, SVt_PVMG); - break; - case SHT_TARRAY: - sv_upgrade(sv, SVt_PVAV); - AvREAL_off((AV *)sv); - break; - case SHT_THASH: - sv_upgrade(sv, SVt_PVHV); - break; - default: - CROAK(("Forgot to deal with extra type %d", extra_type)); - break; - } + if (av) { + SV **ary = AvARRAY(av); + int i; + for (i = 1; i <= len3; i++) { /* We leave [0] alone */ + ntag_t tag; + SV **svh; + SV *xsv; + +#ifdef HAS_U64 + if (has_large_oids) { + READ_U64(tag); + } + else { + U32 tmp; + READ_I32(tmp); + tag = ntohl(tmp); + } +#else + READ_I32(tag); + tag = ntohl(tag); +#endif - /* - * Adding the magic only now, well after the STORABLE_thaw hook was called - * means the hook cannot know it deals with an object whose variable is - * tied. But this is happening when retrieving $o in the following case: - * - * my %h; - * tie %h, 'FOO'; - * my $o = bless \%h, 'BAR'; - * - * The 'BAR' class is NOT the one where %h is tied into. Therefore, as - * far as the 'BAR' class is concerned, the fact that %h is not a REAL - * hash but a tied one should not matter at all, and remain transparent. - * This means the magic must be restored by Storable AFTER the hook is - * called. - * - * That looks very reasonable to me, but then I've come up with this - * after a bug report from David Nesting, who was trying to store such - * an object and caused Storable to fail. And unfortunately, it was - * also the easiest way to retrofit support for blessed ref to tied objects - * into the existing design. -- RAM, 17/02/2001 - */ - - sv_magic(sv, rv, mtype, (char *)NULL, 0); - SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ - - return sv; + svh = av_fetch(cxt->aseen, tag, FALSE); + if (!svh) { + if (tag == cxt->where_is_undef) { + /* av_fetch uses PL_sv_undef internally, hence this + somewhat gruesome hack. */ + xsv = &PL_sv_undef; + svh = &xsv; + } else { + CROAK(("Object #%" IVdf + " should have been retrieved already", + (IV) tag)); + } + } + xsv = *svh; + ary[i] = SvREFCNT_inc(xsv); + } + } + + /* + * Look up the STORABLE_attach hook + * If blessing is disabled, just return what we've got. + */ + if (!(cxt->flags & FLAG_BLESS_OK)) { + TRACEME(("skipping bless because flags is %d", cxt->flags)); + return sv; + } + + /* + * Bless the object and look up the STORABLE_thaw hook. + */ + stash = gv_stashpv(classname, GV_ADD); + + /* Handle attach case; again can't use pkg_can because it only + * caches one method */ + attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE); + if (attach && isGV(attach)) { + SV* attached; + SV* attach_hook = newRV_inc((SV*) GvCV(attach)); + + if (av) + CROAK(("STORABLE_attach called with unexpected references")); + av = newAV(); + av_extend(av, 1); + AvFILLp(av) = 0; + AvARRAY(av)[0] = SvREFCNT_inc(frozen); + rv = newSVpv(classname, 0); + attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR); + /* Free memory after a call */ + SvREFCNT_dec(rv); + SvREFCNT_dec(frozen); + av_undef(av); + sv_free((SV *) av); + SvREFCNT_dec(attach_hook); + if (attached && + SvROK(attached) && + sv_derived_from(attached, classname) + ) { + UNSEE(); + /* refcnt of unneeded sv is 2 at this point + (one from newHV, second from SEEN call) */ + SvREFCNT_dec(sv); + SvREFCNT_dec(sv); + /* we need to free RV but preserve value that RV point to */ + sv = SvRV(attached); + SEEN0_NN(sv, 0); + SvRV_set(attached, NULL); + SvREFCNT_dec(attached); + if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) + Safefree(classname); + return sv; + } + CROAK(("STORABLE_attach did not return a %s object", classname)); + } + + /* + * Bless the object and look up the STORABLE_thaw hook. + */ + + BLESS(sv, stash); + + hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw"); + if (!hook) { + /* + * Hook not found. Maybe they did not require the module where this + * hook is defined yet? + * + * If the load below succeeds, we'll be able to find the hook. + * Still, it only works reliably when each class is defined in a + * file of its own. + */ + + TRACEME(("No STORABLE_thaw defined for objects of class %s", classname)); + TRACEME(("Going to load module '%s'", classname)); + load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv); + + /* + * We cache results of pkg_can, so we need to uncache before attempting + * the lookup again. + */ + + pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + + if (!hook) + CROAK(("No STORABLE_thaw defined for objects of class %s " + "(even after a \"require %s;\")", classname, classname)); + } + + /* + * If we don't have an 'av' yet, prepare one. + * Then insert the frozen string as item [0]. + */ + + if (!av) { + av = newAV(); + av_extend(av, 1); + AvFILLp(av) = 0; + } + AvARRAY(av)[0] = SvREFCNT_inc(frozen); + + /* + * Call the hook as: + * + * $object->STORABLE_thaw($cloning, $frozen, @refs); + * + * where $object is our blessed (empty) object, $cloning is a boolean + * telling whether we're running a deep clone, $frozen is the frozen + * string the user gave us in his serializing hook, and @refs, which may + * be empty, is the list of extra references he returned along for us + * to serialize. + * + * In effect, the hook is an alternate creation routine for the class, + * the object itself being already created by the runtime. + */ + + TRACEME(("calling STORABLE_thaw on %s at 0x%" UVxf " (%" IVdf " args)", + classname, PTR2UV(sv), (IV) AvFILLp(av) + 1)); + + rv = newRV_inc(sv); + (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD); + SvREFCNT_dec(rv); + + /* + * Final cleanup. + */ + + SvREFCNT_dec(frozen); + av_undef(av); + sv_free((SV *) av); + if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) + Safefree(classname); + + /* + * If we had an <extra> type, then the object was not as simple, and + * we need to restore extra magic now. + */ + + if (!extra_type) + return sv; + + TRACEME(("retrieving magic object for 0x%" UVxf "...", PTR2UV(sv))); + + rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */ + + TRACEME(("restoring the magic object 0x%" UVxf " part of 0x%" UVxf, + PTR2UV(rv), PTR2UV(sv))); + + switch (extra_type) { + case SHT_TSCALAR: + sv_upgrade(sv, SVt_PVMG); + break; + case SHT_TARRAY: + sv_upgrade(sv, SVt_PVAV); + AvREAL_off((AV *)sv); + break; + case SHT_THASH: + sv_upgrade(sv, SVt_PVHV); + break; + default: + CROAK(("Forgot to deal with extra type %d", extra_type)); + break; + } + + /* + * Adding the magic only now, well after the STORABLE_thaw hook was called + * means the hook cannot know it deals with an object whose variable is + * tied. But this is happening when retrieving $o in the following case: + * + * my %h; + * tie %h, 'FOO'; + * my $o = bless \%h, 'BAR'; + * + * The 'BAR' class is NOT the one where %h is tied into. Therefore, as + * far as the 'BAR' class is concerned, the fact that %h is not a REAL + * hash but a tied one should not matter at all, and remain transparent. + * This means the magic must be restored by Storable AFTER the hook is + * called. + * + * That looks very reasonable to me, but then I've come up with this + * after a bug report from David Nesting, who was trying to store such + * an object and caused Storable to fail. And unfortunately, it was + * also the easiest way to retrofit support for blessed ref to tied objects + * into the existing design. -- RAM, 17/02/2001 + */ + + sv_magic(sv, rv, mtype, (char *)NULL, 0); + SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ + + return sv; +} + +static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) { + return retrieve_hook_common(aTHX_ cxt, cname, FALSE); } /* @@ -4532,61 +5358,64 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) { - SV *rv; - SV *sv; - HV *stash; - - TRACEME(("retrieve_ref (#%d)", cxt->tagnum)); - - /* - * We need to create the SV that holds the reference to the yet-to-retrieve - * object now, so that we may record the address in the seen table. - * Otherwise, if the object to retrieve references us, we won't be able - * to resolve the SX_OBJECT we'll see at that point! Hence we cannot - * do the retrieve first and use rv = newRV(sv) since it will be too late - * for SEEN() recording. - */ - - rv = NEWSV(10002, 0); - if (cname) - stash = gv_stashpv(cname, GV_ADD); - else - stash = 0; - SEEN_NN(rv, stash, 0); /* Will return if rv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * WARNING: breaks RV encapsulation. - * - * Now for the tricky part. We have to upgrade our existing SV, so that - * it is now an RV on sv... Again, we cheat by duplicating the code - * held in newSVrv(), since we already got our SV from retrieve(). - * - * We don't say: - * - * SvRV(rv) = SvREFCNT_inc(sv); - * - * here because the reference count we got from retrieve() above is - * already correct: if the object was retrieved from the file, then - * its reference count is one. Otherwise, if it was retrieved via - * an SX_OBJECT indication, a ref count increment was done. - */ - - if (cname) { - /* No need to do anything, as rv will already be PVMG. */ - assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV); - } else { - sv_upgrade(rv, SVt_RV); - } + SV *rv; + SV *sv; + HV *stash; - SvRV_set(rv, sv); /* $rv = \$sv */ - SvROK_on(rv); + TRACEME(("retrieve_ref (#%d)", (int)cxt->tagnum)); + + /* + * We need to create the SV that holds the reference to the yet-to-retrieve + * object now, so that we may record the address in the seen table. + * Otherwise, if the object to retrieve references us, we won't be able + * to resolve the SX_OBJECT we'll see at that point! Hence we cannot + * do the retrieve first and use rv = newRV(sv) since it will be too late + * for SEEN() recording. + */ - TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv))); + rv = NEWSV(10002, 0); + if (cname) + stash = gv_stashpv(cname, GV_ADD); + else + stash = 0; + SEEN_NN(rv, stash, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0);/* Retrieve <object> */ + if (!sv) + return (SV *) 0; /* Failed */ - return rv; + /* + * WARNING: breaks RV encapsulation. + * + * Now for the tricky part. We have to upgrade our existing SV, so that + * it is now an RV on sv... Again, we cheat by duplicating the code + * held in newSVrv(), since we already got our SV from retrieve(). + * + * We don't say: + * + * SvRV(rv) = SvREFCNT_inc(sv); + * + * here because the reference count we got from retrieve() above is + * already correct: if the object was retrieved from the file, then + * its reference count is one. Otherwise, if it was retrieved via + * an SX_OBJECT indication, a ref count increment was done. + */ + + if (cname) { + /* No need to do anything, as rv will already be PVMG. */ + assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV); + } else { + sv_upgrade(rv, SVt_RV); + } + + SvRV_set(rv, sv); /* $rv = \$sv */ + SvROK_on(rv); + /*if (cxt->entry && ++cxt->ref_cnt > MAX_REF_CNT) { + CROAK(("Max. recursion depth with nested refs exceeded")); + }*/ + + TRACEME(("ok (retrieve_ref at 0x%" UVxf ")", PTR2UV(rv))); + + return rv; } /* @@ -4597,19 +5426,19 @@ static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; + SV *sv; - TRACEME(("retrieve_weakref (#%d)", cxt->tagnum)); + TRACEME(("retrieve_weakref (#%d)", (int)cxt->tagnum)); - sv = retrieve_ref(aTHX_ cxt, cname); - if (sv) { + sv = retrieve_ref(aTHX_ cxt, cname); + if (sv) { #ifdef SvWEAKREF - sv_rvweaken(sv); + sv_rvweaken(sv); #else - WEAKREF_CROAK(); + WEAKREF_CROAK(); #endif - } - return sv; + } + return sv; } /* @@ -4620,63 +5449,63 @@ static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname) { - SV *rv; - SV *sv; - HV *stash; - - TRACEME(("retrieve_overloaded (#%d)", cxt->tagnum)); - - /* - * Same code as retrieve_ref(), duplicated to avoid extra call. - */ - - rv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(rv, stash, 0); /* Will return if rv is null */ - cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - cxt->in_retrieve_overloaded = 0; - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * WARNING: breaks RV encapsulation. - */ - - SvUPGRADE(rv, SVt_RV); - SvRV_set(rv, sv); /* $rv = \$sv */ - SvROK_on(rv); - - /* - * Restore overloading magic. - */ - - stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0; - if (!stash) { - CROAK(("Cannot restore overloading on %s(0x%"UVxf - ") (package <unknown>)", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - } - if (!Gv_AMG(stash)) { - const char *package = HvNAME_get(stash); - TRACEME(("No overloading defined for package %s", package)); - TRACEME(("Going to load module '%s'", package)); - load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv); - if (!Gv_AMG(stash)) { - CROAK(("Cannot restore overloading on %s(0x%"UVxf - ") (package %s) (even after a \"require %s;\")", - sv_reftype(sv, FALSE), - PTR2UV(sv), - package, package)); - } - } + SV *rv; + SV *sv; + HV *stash; + + TRACEME(("retrieve_overloaded (#%d)", (int)cxt->tagnum)); + + /* + * Same code as retrieve_ref(), duplicated to avoid extra call. + */ + + rv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(rv, stash, 0); /* Will return if rv is null */ + cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + cxt->in_retrieve_overloaded = 0; + if (!sv) + return (SV *) 0; /* Failed */ + + /* + * WARNING: breaks RV encapsulation. + */ + + SvUPGRADE(rv, SVt_RV); + SvRV_set(rv, sv); /* $rv = \$sv */ + SvROK_on(rv); + + /* + * Restore overloading magic. + */ - SvAMAGIC_on(rv); + stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0; + if (!stash) { + CROAK(("Cannot restore overloading on %s(0x%" UVxf + ") (package <unknown>)", + sv_reftype(sv, FALSE), + PTR2UV(sv))); + } + if (!Gv_AMG(stash)) { + const char *package = HvNAME_get(stash); + TRACEME(("No overloading defined for package %s", package)); + TRACEME(("Going to load module '%s'", package)); + load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv); + if (!Gv_AMG(stash)) { + CROAK(("Cannot restore overloading on %s(0x%" UVxf + ") (package %s) (even after a \"require %s;\")", + sv_reftype(sv, FALSE), + PTR2UV(sv), + package, package)); + } + } + + SvAMAGIC_on(rv); - TRACEME(("ok (retrieve_overloaded at 0x%"UVxf")", PTR2UV(rv))); + TRACEME(("ok (retrieve_overloaded at 0x%" UVxf ")", PTR2UV(rv))); - return rv; + return rv; } /* @@ -4687,19 +5516,19 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; + SV *sv; - TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum)); + TRACEME(("retrieve_weakoverloaded (#%d)", (int)cxt->tagnum)); - sv = retrieve_overloaded(aTHX_ cxt, cname); - if (sv) { + sv = retrieve_overloaded(aTHX_ cxt, cname); + if (sv) { #ifdef SvWEAKREF - sv_rvweaken(sv); + sv_rvweaken(sv); #else - WEAKREF_CROAK(); + WEAKREF_CROAK(); #endif - } - return sv; + } + return sv; } /* @@ -4710,27 +5539,30 @@ static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) { - SV *tv; - SV *sv; - HV *stash; + SV *tv; + SV *sv; + HV *stash; - TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum)); + TRACEME(("retrieve_tied_array (#%d)", (int)cxt->tagnum)); - tv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(tv, stash, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } - sv_upgrade(tv, SVt_PVAV); - AvREAL_off((AV *)tv); - sv_magic(tv, sv, 'P', (char *)NULL, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + if (!sv) + return (SV *) 0; /* Failed */ + + sv_upgrade(tv, SVt_PVAV); + sv_magic(tv, sv, 'P', (char *)NULL, 0); + SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv))); + TRACEME(("ok (retrieve_tied_array at 0x%" UVxf ")", PTR2UV(tv))); - return tv; + return tv; } /* @@ -4741,26 +5573,30 @@ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) { - SV *tv; - SV *sv; - HV *stash; + SV *tv; + SV *sv; + HV *stash; - TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum)); + TRACEME(("retrieve_tied_hash (#%d)", (int)cxt->tagnum)); - tv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(tv, stash, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } - sv_upgrade(tv, SVt_PVHV); - sv_magic(tv, sv, 'P', (char *)NULL, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + if (!sv) + return (SV *) 0; /* Failed */ - TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv))); + sv_upgrade(tv, SVt_PVHV); + sv_magic(tv, sv, 'P', (char *)NULL, 0); + SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - return tv; + TRACEME(("ok (retrieve_tied_hash at 0x%" UVxf ")", PTR2UV(tv))); + + return tv; } /* @@ -4771,34 +5607,38 @@ static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) { - SV *tv; - SV *sv, *obj = NULL; - HV *stash; - - TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(tv, stash, 0); /* Will return if rv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) { - return (SV *) 0; /* Failed */ - } - else if (SvTYPE(sv) != SVt_NULL) { - obj = sv; - } + SV *tv; + SV *sv, *obj = NULL; + HV *stash; - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, obj, 'q', (char *)NULL, 0); + TRACEME(("retrieve_tied_scalar (#%d)", (int)cxt->tagnum)); - if (obj) { - /* Undo refcnt inc from sv_magic() */ - SvREFCNT_dec(obj); - } + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } - TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv))); + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + if (!sv) { + return (SV *) 0; /* Failed */ + } + else if (SvTYPE(sv) != SVt_NULL) { + obj = sv; + } + + sv_upgrade(tv, SVt_PVMG); + sv_magic(tv, obj, 'q', (char *)NULL, 0); + + if (obj) { + /* Undo refcnt inc from sv_magic() */ + SvREFCNT_dec(obj); + } - return tv; + TRACEME(("ok (retrieve_tied_scalar at 0x%" UVxf ")", PTR2UV(tv))); + + return tv; } /* @@ -4809,30 +5649,34 @@ static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) { - SV *tv; - SV *sv; - SV *key; - HV *stash; - - TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(tv, stash, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */ - if (!key) - return (SV *) 0; /* Failed */ - - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY); - SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */ - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - - return tv; + SV *tv; + SV *sv; + SV *key; + HV *stash; + + TRACEME(("retrieve_tied_key (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + if (!sv) + return (SV *) 0; /* Failed */ + + key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */ + if (!key) + return (SV *) 0; /* Failed */ + + sv_upgrade(tv, SVt_PVMG); + sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY); + SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */ + SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + + return tv; } /* @@ -4843,29 +5687,107 @@ static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) { - SV *tv; - SV *sv; - HV *stash; - I32 idx; + SV *tv; + SV *sv; + HV *stash; + I32 idx; + + TRACEME(("retrieve_tied_idx (#%d)", (int)cxt->tagnum)); - TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum)); + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } - tv = NEWSV(10002, 0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(tv, stash, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ + if (!sv) + return (SV *) 0; /* Failed */ - RLEN(idx); /* Retrieve <idx> */ + RLEN(idx); /* Retrieve <idx> */ - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'p', (char *)NULL, idx); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + sv_upgrade(tv, SVt_PVMG); + sv_magic(tv, sv, 'p', (char *)NULL, idx); + SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - return tv; + return tv; } +/* + * get_lstring + * + * Helper to read a string + */ +static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname) +{ + SV *sv; + HV *stash; + + TRACEME(("get_lstring (#%d), len = %" UVuf, (int)cxt->tagnum, len)); + + /* + * Allocate an empty scalar of the suitable length. + */ + + sv = NEWSV(10002, len); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + + if (len == 0) { + SvPVCLEAR(sv); + return sv; + } + + /* + * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. + * + * Now, for efficiency reasons, read data directly inside the SV buffer, + * and perform the SV final settings directly by duplicating the final + * work done by sv_setpv. Since we're going to allocate lots of scalars + * this way, it's worth the hassle and risk. + */ + + SAFEREAD(SvPVX(sv), len, sv); + SvCUR_set(sv, len); /* Record C string length */ + *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ + (void) SvPOK_only(sv); /* Validate string pointer */ + if (cxt->s_tainted) /* Is input source tainted? */ + SvTAINT(sv); /* External data cannot be trusted */ + + /* Check for CVE-215-1592 */ + if (cname && len == 13 && strEQc(cname, "CGITempFile") + && strEQc(SvPVX(sv), "mt-config.cgi")) { +#if defined(USE_CPERL) && defined(WARN_SECURITY) + Perl_warn_security(aTHX_ + "Movable-Type CVE-2015-1592 Storable metasploit attack"); +#else + Perl_warn(aTHX_ + "SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack"); +#endif + } + + if (isutf8) { + TRACEME(("large utf8 string len %" UVuf " '%s'", len, + len >= 2048 ? "<string too long>" : SvPVX(sv))); +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } else { + TRACEME(("large string len %" UVuf " '%s'", len, + len >= 2048 ? "<string too long>" : SvPVX(sv))); + } + TRACEME(("ok (get_lstring at 0x%" UVxf ")", PTR2UV(sv))); + + return sv; +} /* * retrieve_lscalar @@ -4874,50 +5796,14 @@ static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) * * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read. * The scalar is "long" in that <length> is larger than LG_SCALAR so it - * was not stored on a single byte. + * was not stored on a single byte, but in 4 bytes. For strings longer than + * 4 byte (>2GB) see retrieve_lobject. */ static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - SV *sv; - HV *stash; - - RLEN(len); - TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len)); - - /* - * Allocate an empty scalar of the suitable length. - */ - - sv = NEWSV(10002, len); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ - - if (len == 0) { - sv_setpvn(sv, "", 0); - return sv; - } - - /* - * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. - * - * Now, for efficiency reasons, read data directly inside the SV buffer, - * and perform the SV final settings directly by duplicating the final - * work done by sv_setpv. Since we're going to allocate lots of scalars - * this way, it's worth the hassle and risk. - */ - - SAFEREAD(SvPVX(sv), len, sv); - SvCUR_set(sv, len); /* Record C string length */ - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - (void) SvPOK_only(sv); /* Validate string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(sv); /* External data cannot be trusted */ - - TRACEME(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv))); - TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); - - return sv; + U32 len; + RLEN(len); + return get_lstring(aTHX_ cxt, len, 0, cname); } /* @@ -4931,57 +5817,13 @@ static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) { - int len; - SV *sv; - HV *stash; - - GETMARK(len); - TRACEME(("retrieve_scalar (#%d), len = %d", cxt->tagnum, len)); - - /* - * Allocate an empty scalar of the suitable length. - */ - - sv = NEWSV(10002, len); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ - - /* - * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. - */ - - if (len == 0) { - /* - * newSV did not upgrade to SVt_PV so the scalar is undefined. - * To make it defined with an empty length, upgrade it now... - * Don't upgrade to a PV if the original type contains more - * information than a scalar. - */ - if (SvTYPE(sv) <= SVt_PV) { - sv_upgrade(sv, SVt_PV); - } - SvGROW(sv, 1); - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv))); - } else { - /* - * Now, for efficiency reasons, read data directly inside the SV buffer, - * and perform the SV final settings directly by duplicating the final - * work done by sv_setpv. Since we're going to allocate lots of scalars - * this way, it's worth the hassle and risk. - */ - SAFEREAD(SvPVX(sv), len, sv); - SvCUR_set(sv, len); /* Record C string length */ - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - TRACEME(("small scalar len %d '%s'", len, SvPVX(sv))); - } - - (void) SvPOK_only(sv); /* Validate string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(sv); /* External data cannot be trusted */ + int len; + /*SV *sv; + HV *stash;*/ - TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv))); - return sv; + GETMARK(len); + TRACEME(("retrieve_scalar (#%d), len = %d", (int)cxt->tagnum, len)); + return get_lstring(aTHX_ cxt, (UV)len, 0, cname); } /* @@ -4992,25 +5834,12 @@ static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; + int len; + /*SV *sv;*/ TRACEME(("retrieve_utf8str")); - - sv = retrieve_scalar(aTHX_ cxt, cname); - if (sv) { -#ifdef HAS_UTF8_SCALARS - SvUTF8_on(sv); -#else - if (cxt->use_bytes < 0) - cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) - ? 1 : 0); - if (cxt->use_bytes == 0) - UTF8_CROAK(); -#endif - } - - return sv; + GETMARK(len); + return get_lstring(aTHX_ cxt, (UV)len, 1, cname); } /* @@ -5021,24 +5850,12 @@ static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; + U32 len; TRACEME(("retrieve_lutf8str")); - sv = retrieve_lscalar(aTHX_ cxt, cname); - if (sv) { -#ifdef HAS_UTF8_SCALARS - SvUTF8_on(sv); -#else - if (cxt->use_bytes < 0) - cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) - ? 1 : 0); - if (cxt->use_bytes == 0) - UTF8_CROAK(); -#endif - } - return sv; + RLEN(len); + return get_lstring(aTHX_ cxt, (UV)len, 1, cname); } /* @@ -5054,26 +5871,26 @@ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname) { #ifdef SvVOK - char s[256]; - int len; - SV *sv; - - GETMARK(len); - TRACEME(("retrieve_vstring (#%d), len = %d", cxt->tagnum, len)); - - READ(s, len); + char s[256]; + int len; + SV *sv; - sv = retrieve(aTHX_ cxt, cname); + GETMARK(len); + TRACEME(("retrieve_vstring (#%d), len = %d", (int)cxt->tagnum, len)); - sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); - /* 5.10.0 and earlier seem to need this */ - SvRMAGICAL_on(sv); + READ(s, len); + sv = retrieve(aTHX_ cxt, cname); + if (!sv) + return (SV *) 0; /* Failed */ + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); - TRACEME(("ok (retrieve_vstring at 0x%"UVxf")", PTR2UV(sv))); - return sv; + TRACEME(("ok (retrieve_vstring at 0x%" UVxf ")", PTR2UV(sv))); + return sv; #else - VSTRING_CROAK(); - return Nullsv; + VSTRING_CROAK(); + return Nullsv; #endif } @@ -5085,30 +5902,33 @@ static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname) static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname) { #ifdef SvVOK - char *s; - I32 len; - SV *sv; - - RLEN(len); - TRACEME(("retrieve_lvstring (#%d), len = %"IVdf, - cxt->tagnum, (IV)len)); + char *s; + I32 len; + SV *sv; - New(10003, s, len+1, char); - SAFEPVREAD(s, len, s); + RLEN(len); + TRACEME(("retrieve_lvstring (#%d), len = %" IVdf, + (int)cxt->tagnum, (IV)len)); - sv = retrieve(aTHX_ cxt, cname); + New(10003, s, len+1, char); + SAFEPVREAD(s, len, s); - sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); - /* 5.10.0 and earlier seem to need this */ - SvRMAGICAL_on(sv); + sv = retrieve(aTHX_ cxt, cname); + if (!sv) { + Safefree(s); + return (SV *) 0; /* Failed */ + } + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); - Safefree(s); + Safefree(s); - TRACEME(("ok (retrieve_lvstring at 0x%"UVxf")", PTR2UV(sv))); - return sv; + TRACEME(("ok (retrieve_lvstring at 0x%" UVxf ")", PTR2UV(sv))); + return sv; #else - VSTRING_CROAK(); - return Nullsv; + VSTRING_CROAK(); + return Nullsv; #endif } @@ -5120,21 +5940,104 @@ static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; - HV *stash; - IV iv; + SV *sv; + HV *stash; + IV iv; + + TRACEME(("retrieve_integer (#%d)", (int)cxt->tagnum)); + + READ(&iv, sizeof(iv)); + sv = newSViv(iv); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + + TRACEME(("integer %" IVdf, iv)); + TRACEME(("ok (retrieve_integer at 0x%" UVxf ")", PTR2UV(sv))); + + return sv; +} + +/* + * retrieve_lobject + * + * Retrieve overlong scalar, array or hash. + * Layout is SX_LOBJECT type U64_len ... + */ +static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname) +{ + int type; +#ifdef HAS_U64 + UV len; + SV *sv; + int hash_flags = 0; +#endif - TRACEME(("retrieve_integer (#%d)", cxt->tagnum)); + TRACEME(("retrieve_lobject (#%d)", (int)cxt->tagnum)); - READ(&iv, sizeof(iv)); - sv = newSViv(iv); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + GETMARK(type); + TRACEME(("object type %d", type)); +#ifdef HAS_U64 + + if (type == SX_FLAG_HASH) { + /* we write the flags immediately after the op. I could have + changed the writer, but this may allow someone to recover + data they're already frozen, though such a very large hash + seems unlikely. + */ + GETMARK(hash_flags); + } + else if (type == SX_HOOK) { + return retrieve_hook_common(aTHX_ cxt, cname, TRUE); + } + + READ_U64(len); + TRACEME(("wlen %" UVuf, len)); + switch (type) { + case SX_OBJECT: + { + /* not a large object, just a large index */ + SV **svh = av_fetch(cxt->aseen, len, FALSE); + if (!svh) + CROAK(("Object #%" UVuf " should have been retrieved already", + len)); + sv = *svh; + TRACEME(("had retrieved #%" UVuf " at 0x%" UVxf, len, PTR2UV(sv))); + SvREFCNT_inc(sv); + } + break; + case SX_LSCALAR: + sv = get_lstring(aTHX_ cxt, len, 0, cname); + break; + case SX_LUTF8STR: + sv = get_lstring(aTHX_ cxt, len, 1, cname); + break; + case SX_ARRAY: + sv = get_larray(aTHX_ cxt, len, cname); + break; + /* <5.12 you could store larger hashes, but cannot iterate over them. + So we reject them, it's a bug. */ + case SX_FLAG_HASH: + sv = get_lhash(aTHX_ cxt, len, hash_flags, cname); + break; + case SX_HASH: + sv = get_lhash(aTHX_ cxt, len, 0, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_lobject\n", type)); + } - TRACEME(("integer %"IVdf, iv)); - TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv))); + TRACEME(("ok (retrieve_lobject at 0x%" UVxf ")", PTR2UV(sv))); + return sv; +#else + PERL_UNUSED_ARG(cname); - return sv; + /* previously this (brokenly) checked the length value and only failed if + the length was over 4G. + Since this op should only occur with objects over 4GB (or 2GB) we can just + reject it. + */ + CROAK(("Invalid large object op for this 32bit system")); +#endif } /* @@ -5145,26 +6048,26 @@ static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; - HV *stash; - I32 iv; + SV *sv; + HV *stash; + I32 iv; - TRACEME(("retrieve_netint (#%d)", cxt->tagnum)); + TRACEME(("retrieve_netint (#%d)", (int)cxt->tagnum)); - READ_I32(iv); + READ_I32(iv); #ifdef HAS_NTOHL - sv = newSViv((int) ntohl(iv)); - TRACEME(("network integer %d", (int) ntohl(iv))); + sv = newSViv((int) ntohl(iv)); + TRACEME(("network integer %d", (int) ntohl(iv))); #else - sv = newSViv(iv); - TRACEME(("network integer (as-is) %d", iv)); + sv = newSViv(iv); + TRACEME(("network integer (as-is) %d", iv)); #endif - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ - TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv))); + TRACEME(("ok (retrieve_netint at 0x%" UVxf ")", PTR2UV(sv))); - return sv; + return sv; } /* @@ -5175,21 +6078,21 @@ static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; - HV *stash; - NV nv; + SV *sv; + HV *stash; + NV nv; - TRACEME(("retrieve_double (#%d)", cxt->tagnum)); + TRACEME(("retrieve_double (#%d)", (int)cxt->tagnum)); - READ(&nv, sizeof(nv)); - sv = newSVnv(nv); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + READ(&nv, sizeof(nv)); + sv = newSVnv(nv); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ - TRACEME(("double %"NVff, nv)); - TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv))); + TRACEME(("double %" NVff, nv)); + TRACEME(("ok (retrieve_double at 0x%" UVxf ")", PTR2UV(sv))); - return sv; + return sv; } /* @@ -5200,24 +6103,29 @@ static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; - HV *stash; - int siv; - signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */ + SV *sv; + HV *stash; + int siv; +#ifdef _MSC_VER + /* MSVC 2017 doesn't handle the AIX workaround well */ + int tmp; +#else + signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */ +#endif - TRACEME(("retrieve_byte (#%d)", cxt->tagnum)); + TRACEME(("retrieve_byte (#%d)", (int)cxt->tagnum)); - GETMARK(siv); - TRACEME(("small integer read as %d", (unsigned char) siv)); - tmp = (unsigned char) siv - 128; - sv = newSViv(tmp); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + GETMARK(siv); + TRACEME(("small integer read as %d", (unsigned char) siv)); + tmp = (unsigned char) siv - 128; + sv = newSViv(tmp); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ - TRACEME(("byte %d", tmp)); - TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv))); + TRACEME(("byte %d", tmp)); + TRACEME(("ok (retrieve_byte at 0x%" UVxf ")", PTR2UV(sv))); - return sv; + return sv; } /* @@ -5227,16 +6135,16 @@ static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv; - HV *stash; + SV *sv; + HV *stash; - TRACEME(("retrieve_undef")); + TRACEME(("retrieve_undef")); - sv = newSV(0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); + sv = newSV(0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); - return sv; + return sv; } /* @@ -5246,20 +6154,20 @@ static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv = &PL_sv_undef; - HV *stash; + SV *sv = &PL_sv_undef; + HV *stash; - TRACEME(("retrieve_sv_undef")); + TRACEME(("retrieve_sv_undef")); - /* Special case PL_sv_undef, as av_fetch uses it internally to mark - deleted elements, and will return NULL (fetch failed) whenever it - is fetched. */ - if (cxt->where_is_undef == -1) { - cxt->where_is_undef = cxt->tagnum; - } - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 1); - return sv; + /* Special case PL_sv_undef, as av_fetch uses it internally to mark + deleted elements, and will return NULL (fetch failed) whenever it + is fetched. */ + if (cxt->where_is_undef == UNSET_NTAG_T) { + cxt->where_is_undef = cxt->tagnum; + } + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 1); + return sv; } /* @@ -5269,14 +6177,14 @@ static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv = &PL_sv_yes; - HV *stash; + SV *sv = &PL_sv_yes; + HV *stash; - TRACEME(("retrieve_sv_yes")); + TRACEME(("retrieve_sv_yes")); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 1); - return sv; + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 1); + return sv; } /* @@ -5286,14 +6194,14 @@ static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname) { - SV *sv = &PL_sv_no; - HV *stash; + SV *sv = &PL_sv_no; + HV *stash; - TRACEME(("retrieve_sv_no")); + TRACEME(("retrieve_sv_no")); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 1); - return sv; + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 1); + return sv; } /* @@ -5305,13 +6213,13 @@ static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname) { - TRACEME(("retrieve_svundef_elem")); + TRACEME(("retrieve_svundef_elem")); - /* SEEN reads the contents of its SV argument, which we are not - supposed to do with &PL_sv_placeholder. */ - SEEN_NN(&PL_sv_undef, cname, 1); + /* SEEN reads the contents of its SV argument, which we are not + supposed to do with &PL_sv_placeholder. */ + SEEN_NN(&PL_sv_undef, cname, 1); - return &PL_sv_placeholder; + return &PL_sv_placeholder; } /* @@ -5325,53 +6233,184 @@ static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - I32 i; - AV *av; - SV *sv; - HV *stash; - bool seen_null = FALSE; - - TRACEME(("retrieve_array (#%d)", cxt->tagnum)); - - /* - * Read length, and allocate array, then pre-extend it. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - av = newAV(); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */ - if (len) - av_extend(av, len); - else - return (SV *) av; /* No data follow if array is empty */ - - /* - * Now get each item in turn... - */ - - for (i = 0; i < len; i++) { - TRACEME(("(#%d) item", i)); - sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ - if (!sv) - return (SV *) 0; - if (sv == &PL_sv_undef) { - seen_null = TRUE; - continue; - } - if (sv == &PL_sv_placeholder) - sv = &PL_sv_undef; - if (av_store(av, i, sv) == 0) - return (SV *) 0; - } - if (seen_null) av_fill(av, len-1); + I32 len, i; + AV *av; + SV *sv; + HV *stash; + bool seen_null = FALSE; + + TRACEME(("retrieve_array (#%d)", (int)cxt->tagnum)); + + /* + * Read length, and allocate array, then pre-extend it. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + av = newAV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */ + if (len) + av_extend(av, len); + else + return (SV *) av; /* No data follow if array is empty */ - TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av))); + /* + * Now get each item in turn... + */ - return (SV *) av; + for (i = 0; i < len; i++) { + TRACEME(("(#%d) item", (int)i)); + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ + if (!sv) + return (SV *) 0; + if (sv == &PL_sv_undef) { + seen_null = TRUE; + continue; + } + if (sv == &PL_sv_placeholder) + sv = &PL_sv_undef; + if (av_store(av, i, sv) == 0) + return (SV *) 0; + } + if (seen_null) av_fill(av, len-1); + + TRACEME(("ok (retrieve_array at 0x%" UVxf ")", PTR2UV(av))); + + return (SV *) av; +} + +#ifdef HAS_U64 + +/* internal method with len already read */ + +static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname) +{ + UV i; + AV *av; + SV *sv; + HV *stash; + bool seen_null = FALSE; + + TRACEME(("get_larray (#%d) %lu", (int)cxt->tagnum, (unsigned long)len)); + + /* + * allocate array, then pre-extend it. + */ + + av = newAV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */ + assert(len); + av_extend(av, len); + + /* + * Now get each item in turn... + */ + + for (i = 0; i < len; i++) { + TRACEME(("(#%d) item", (int)i)); + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ + if (!sv) + return (SV *) 0; + if (sv == &PL_sv_undef) { + seen_null = TRUE; + continue; + } + if (sv == &PL_sv_placeholder) + sv = &PL_sv_undef; + if (av_store(av, i, sv) == 0) + return (SV *) 0; + } + if (seen_null) av_fill(av, len-1); + + TRACEME(("ok (get_larray at 0x%" UVxf ")", PTR2UV(av))); + + return (SV *) av; +} + +/* + * get_lhash + * + * Retrieve a overlong hash table. + * <len> is already read. What follows is each key/value pair, in random order. + * Keys are stored as <length> <data>, the <data> section being omitted + * if length is 0. + * Values are stored as <object>. + * + */ +static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname) +{ + UV size; + UV i; + HV *hv; + SV *sv; + HV *stash; + + TRACEME(("get_lhash (#%d)", (int)cxt->tagnum)); + +#ifdef HAS_RESTRICTED_HASHES + PERL_UNUSED_ARG(hash_flags); +#else + if (hash_flags & SHV_RESTRICTED) { + if (cxt->derestrict < 0) + cxt->derestrict = (SvTRUE + (get_sv("Storable::downgrade_restricted", GV_ADD)) + ? 1 : 0); + if (cxt->derestrict == 0) + RESTRICTED_HASH_CROAK(); + } +#endif + + TRACEME(("size = %lu", (unsigned long)len)); + hv = newHV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %lu", (unsigned long)len+1)); + hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */ + + /* + * Now get each key/value pair in turn... + */ + + for (i = 0; i < len; i++) { + /* + * Get value first. + */ + + TRACEME(("(#%d) value", (int)i)); + sv = retrieve(aTHX_ cxt, 0); + if (!sv) + return (SV *) 0; + + /* + * Get key. + * Since we're reading into kbuf, we must ensure we're not + * recursing between the read and the hv_store() where it's used. + * Hence the key comes after the value. + */ + + RLEN(size); /* Get key size */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ + if (size) + READ(kbuf, size); + kbuf[size] = '\0'; /* Mark string end, just in case */ + TRACEME(("(#%d) key '%s'", (int)i, kbuf)); + + /* + * Enter key/value pair into hash table. + */ + + if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) + return (SV *) 0; + } + + TRACEME(("ok (get_lhash at 0x%" UVxf ")", PTR2UV(hv))); + return (SV *) hv; } +#endif /* * retrieve_hash @@ -5386,67 +6425,68 @@ static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - I32 size; - I32 i; - HV *hv; - SV *sv; - HV *stash; - - TRACEME(("retrieve_hash (#%d)", cxt->tagnum)); - - /* - * Read length, allocate table. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - hv = newHV(); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ - if (len == 0) - return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ - - /* - * Now get each key/value pair in turn... - */ - - for (i = 0; i < len; i++) { - /* - * Get value first. - */ - - TRACEME(("(#%d) value", i)); - sv = retrieve(aTHX_ cxt, 0); - if (!sv) - return (SV *) 0; - - /* - * Get key. - * Since we're reading into kbuf, we must ensure we're not - * recursing between the read and the hv_store() where it's used. - * Hence the key comes after the value. - */ - - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ - if (size) - READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s'", i, kbuf)); - - /* - * Enter key/value pair into hash table. - */ - - if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) - return (SV *) 0; - } + I32 len; + I32 size; + I32 i; + HV *hv; + SV *sv; + HV *stash; + + TRACEME(("retrieve_hash (#%d)", (int)cxt->tagnum)); + + /* + * Read length, allocate table. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + hv = newHV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */ - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); + /* + * Now get each key/value pair in turn... + */ - return (SV *) hv; + for (i = 0; i < len; i++) { + /* + * Get value first. + */ + + TRACEME(("(#%d) value", (int)i)); + sv = retrieve(aTHX_ cxt, 0); + if (!sv) + return (SV *) 0; + + /* + * Get key. + * Since we're reading into kbuf, we must ensure we're not + * recursing between the read and the hv_store() where it's used. + * Hence the key comes after the value. + */ + + RLEN(size); /* Get key size */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ + if (size) + READ(kbuf, size); + kbuf[size] = '\0'; /* Mark string end, just in case */ + TRACEME(("(#%d) key '%s'", (int)i, kbuf)); + + /* + * Enter key/value pair into hash table. + */ + + if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) + return (SV *) 0; + } + + TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv))); + + return (SV *) hv; } /* @@ -5472,7 +6512,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) int hash_flags; GETMARK(hash_flags); - TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); + TRACEME(("retrieve_flag_hash (#%d)", (int)cxt->tagnum)); /* * Read length, allocate table. */ @@ -5480,22 +6520,23 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) #ifndef HAS_RESTRICTED_HASHES if (hash_flags & SHV_RESTRICTED) { if (cxt->derestrict < 0) - cxt->derestrict - = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", GV_ADD)) - ? 1 : 0); + cxt->derestrict = (SvTRUE + (get_sv("Storable::downgrade_restricted", GV_ADD)) + ? 1 : 0); if (cxt->derestrict == 0) RESTRICTED_HASH_CROAK(); } #endif RLEN(len); - TRACEME(("size = %d, flags = %d", len, hash_flags)); + TRACEME(("size = %d, flags = %d", (int)len, hash_flags)); hv = newHV(); stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */ /* * Now get each key/value pair in turn... @@ -5508,7 +6549,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) * Get value first. */ - TRACEME(("(#%d) value", i)); + TRACEME(("(#%d) value", (int)i)); sv = retrieve(aTHX_ cxt, 0); if (!sv) return (SV *) 0; @@ -5525,7 +6566,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) Without messing around beyond what the API is supposed to do. */ SV *keysv; - TRACEME(("(#%d) keysv, flags=%d", i, flags)); + TRACEME(("(#%d) keysv, flags=%d", (int)i, flags)); keysv = retrieve(aTHX_ cxt, 0); if (!keysv) return (SV *) 0; @@ -5543,15 +6584,15 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) if (flags & SHV_K_PLACEHOLDER) { SvREFCNT_dec (sv); sv = &PL_sv_placeholder; - store_flags |= HVhek_PLACEHOLD; - } + store_flags |= HVhek_PLACEHOLD; + } if (flags & SHV_K_UTF8) { #ifdef HAS_UTF8_HASHES store_flags |= HVhek_UTF8; #else if (cxt->use_bytes < 0) cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) + = (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD)) ? 1 : 0); if (cxt->use_bytes == 0) UTF8_CROAK(); @@ -5559,16 +6600,16 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) } #ifdef HAS_UTF8_HASHES if (flags & SHV_K_WASUTF8) - store_flags |= HVhek_WASUTF8; + store_flags |= HVhek_WASUTF8; #endif - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ + RLEN(size); /* Get key size */ + KBUFCHK((STRLEN)size);/* Grow hash key read pool if needed */ if (size) READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s' flags %X store_flags %X", i, kbuf, - flags, store_flags)); + kbuf[size] = '\0'; /* Mark string end, just in case */ + TRACEME(("(#%d) key '%s' flags %X store_flags %X", (int)i, kbuf, + flags, store_flags)); /* * Enter key/value pair into hash table. @@ -5582,14 +6623,14 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) if (hv_store(hv, kbuf, size, sv, 0) == 0) return (SV *) 0; #endif - } + } } #ifdef HAS_RESTRICTED_HASHES if (hash_flags & SHV_RESTRICTED) SvREADONLY_on(hv); #endif - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); + TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv))); return (SV *) hv; } @@ -5604,121 +6645,197 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname) #if PERL_VERSION < 6 CROAK(("retrieve_code does not work with perl 5.005 or less\n")); #else - dSP; - int type, count, tagnum; - SV *cv; - SV *sv, *text, *sub, *errsv; - HV *stash; - - TRACEME(("retrieve_code (#%d)", cxt->tagnum)); - - /* - * Insert dummy SV in the aseen array so that we don't screw - * up the tag numbers. We would just make the internal - * scalar an untagged item in the stream, but - * retrieve_scalar() calls SEEN(). So we just increase the - * tag number. - */ - tagnum = cxt->tagnum; - sv = newSViv(0); - stash = cname ? gv_stashpv(cname, GV_ADD) : 0; - SEEN_NN(sv, stash, 0); - - /* - * Retrieve the source of the code reference - * as a small or large scalar - */ - - GETMARK(type); - switch (type) { - case SX_SCALAR: - text = retrieve_scalar(aTHX_ cxt, cname); - break; - case SX_LSCALAR: - text = retrieve_lscalar(aTHX_ cxt, cname); - break; - case SX_UTF8STR: - text = retrieve_utf8str(aTHX_ cxt, cname); - break; - case SX_LUTF8STR: - text = retrieve_lutf8str(aTHX_ cxt, cname); - break; - default: - CROAK(("Unexpected type %d in retrieve_code\n", type)); - } + dSP; + I32 type, count; + IV tagnum; + SV *cv; + SV *sv, *text, *sub, *errsv; + HV *stash; - /* - * prepend "sub " to the source - */ + TRACEME(("retrieve_code (#%d)", (int)cxt->tagnum)); - sub = newSVpvs("sub "); - if (SvUTF8(text)) - SvUTF8_on(sub); - sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ - SvREFCNT_dec(text); + /* + * Insert dummy SV in the aseen array so that we don't screw + * up the tag numbers. We would just make the internal + * scalar an untagged item in the stream, but + * retrieve_scalar() calls SEEN(). So we just increase the + * tag number. + */ + tagnum = cxt->tagnum; + sv = newSViv(0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); - /* - * evaluate the source to a code reference and use the CV value - */ + /* + * Retrieve the source of the code reference + * as a small or large scalar + */ - if (cxt->eval == NULL) { - cxt->eval = perl_get_sv("Storable::Eval", GV_ADD); - SvREFCNT_inc(cxt->eval); - } - if (!SvTRUE(cxt->eval)) { - if ( - cxt->forgive_me == 0 || - (cxt->forgive_me < 0 && !(cxt->forgive_me = - SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) - ) { - CROAK(("Can't eval, please set $Storable::Eval to a true value")); - } else { - sv = newSVsv(sub); - /* fix up the dummy entry... */ - av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); - return sv; - } - } + GETMARK(type); + switch (type) { + case SX_SCALAR: + text = retrieve_scalar(aTHX_ cxt, cname); + break; + case SX_LSCALAR: + text = retrieve_lscalar(aTHX_ cxt, cname); + break; + case SX_UTF8STR: + text = retrieve_utf8str(aTHX_ cxt, cname); + break; + case SX_LUTF8STR: + text = retrieve_lutf8str(aTHX_ cxt, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_code\n", (int)type)); + } - ENTER; - SAVETMPS; - - errsv = get_sv("@", GV_ADD); - sv_setpvn(errsv, "", 0); /* clear $@ */ - if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { - PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVsv(sub))); - PUTBACK; - count = call_sv(cxt->eval, G_SCALAR); - if (count != 1) - CROAK(("Unexpected return value from $Storable::Eval callback\n")); - } else { - eval_sv(sub, G_SCALAR); - } - SPAGAIN; - cv = POPs; - PUTBACK; + if (!text) { + CROAK(("Unable to retrieve code\n")); + } - if (SvTRUE(errsv)) { - CROAK(("code %s caused an error: %s", - SvPV_nolen(sub), SvPV_nolen(errsv))); - } + /* + * prepend "sub " to the source + */ - if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { - sv = SvRV(cv); - } else { - CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); - } + sub = newSVpvs("sub "); + if (SvUTF8(text)) + SvUTF8_on(sub); + sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ + SvREFCNT_dec(text); - SvREFCNT_inc(sv); /* XXX seems to be necessary */ - SvREFCNT_dec(sub); + /* + * evaluate the source to a code reference and use the CV value + */ - FREETMPS; - LEAVE; - /* fix up the dummy entry... */ - av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + if (cxt->eval == NULL) { + cxt->eval = get_sv("Storable::Eval", GV_ADD); + SvREFCNT_inc(cxt->eval); + } + if (!SvTRUE(cxt->eval)) { + if (cxt->forgive_me == 0 || + (cxt->forgive_me < 0 && + !(cxt->forgive_me = SvTRUE + (get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) + ) { + CROAK(("Can't eval, please set $Storable::Eval to a true value")); + } else { + sv = newSVsv(sub); + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + return sv; + } + } - return sv; + ENTER; + SAVETMPS; + + errsv = get_sv("@", GV_ADD); + SvPVCLEAR(errsv); /* clear $@ */ + if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVsv(sub))); + PUTBACK; + count = call_sv(cxt->eval, G_SCALAR); + if (count != 1) + CROAK(("Unexpected return value from $Storable::Eval callback\n")); + } else { + eval_sv(sub, G_SCALAR); + } + SPAGAIN; + cv = POPs; + PUTBACK; + + if (SvTRUE(errsv)) { + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); + } + + if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { + sv = SvRV(cv); + } else { + CROAK(("code %s did not evaluate to a subroutine reference\n", + SvPV_nolen(sub))); + } + + SvREFCNT_inc(sv); /* XXX seems to be necessary */ + SvREFCNT_dec(sub); + + FREETMPS; + LEAVE; + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + + return sv; +#endif +} + +static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) { +#if PERL_VERSION >= 8 + int op_flags; + U32 re_len; + STRLEN flags_len; + SV *re; + SV *flags; + SV *re_ref; + SV *sv; + dSP; + I32 count; + + PERL_UNUSED_ARG(cname); + + ENTER; + SAVETMPS; + + GETMARK(op_flags); + if (op_flags & SHR_U32_RE_LEN) { + RLEN(re_len); + } + else + GETMARK(re_len); + + re = sv_2mortal(NEWSV(10002, re_len ? re_len : 1)); + READ(SvPVX(re), re_len); + SvCUR_set(re, re_len); + *SvEND(re) = '\0'; + SvPOK_only(re); + + GETMARK(flags_len); + flags = sv_2mortal(NEWSV(10002, flags_len ? flags_len : 1)); + READ(SvPVX(flags), flags_len); + SvCUR_set(flags, flags_len); + *SvEND(flags) = '\0'; + SvPOK_only(flags); + + PUSHMARK(SP); + + XPUSHs(re); + XPUSHs(flags); + + PUTBACK; + + count = call_pv("Storable::_make_re", G_SCALAR); + + SPAGAIN; + + if (count != 1) + CROAK(("Bad count %d calling _make_re", count)); + + re_ref = POPs; + + PUTBACK; + + if (!SvROK(re_ref)) + CROAK(("_make_re didn't return a reference")); + + sv = SvRV(re_ref); + SvREFCNT_inc(sv); + + FREETMPS; + LEAVE; + + return sv; +#else + CROAK(("retrieve_regexp does not work with 5.6 or earlier")); #endif } @@ -5734,51 +6851,51 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - I32 i; - AV *av; - SV *sv; - int c; - - PERL_UNUSED_ARG(cname); - TRACEME(("old_retrieve_array (#%d)", cxt->tagnum)); - - /* - * Read length, and allocate array, then pre-extend it. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - av = newAV(); - SEEN0_NN(av, 0); /* Will return if array not allocated nicely */ - if (len) - av_extend(av, len); - else - return (SV *) av; /* No data follow if array is empty */ - - /* - * Now get each item in turn... - */ - - for (i = 0; i < len; i++) { - GETMARK(c); - if (c == SX_IT_UNDEF) { - TRACEME(("(#%d) undef item", i)); - continue; /* av_extend() already filled us with undef */ - } - if (c != SX_ITEM) - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - TRACEME(("(#%d) item", i)); - sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ - if (!sv) - return (SV *) 0; - if (av_store(av, i, sv) == 0) - return (SV *) 0; - } + I32 len; + I32 i; + AV *av; + SV *sv; + int c; - TRACEME(("ok (old_retrieve_array at 0x%"UVxf")", PTR2UV(av))); + PERL_UNUSED_ARG(cname); + TRACEME(("old_retrieve_array (#%d)", (int)cxt->tagnum)); - return (SV *) av; + /* + * Read length, and allocate array, then pre-extend it. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + av = newAV(); + SEEN0_NN(av, 0); /* Will return if array not allocated nicely */ + if (len) + av_extend(av, len); + else + return (SV *) av; /* No data follow if array is empty */ + + /* + * Now get each item in turn... + */ + + for (i = 0; i < len; i++) { + GETMARK(c); + if (c == SX_IT_UNDEF) { + TRACEME(("(#%d) undef item", (int)i)); + continue; /* av_extend() already filled us with undef */ + } + if (c != SX_ITEM) + (void) retrieve_other(aTHX_ cxt, 0);/* Will croak out */ + TRACEME(("(#%d) item", (int)i)); + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ + if (!sv) + return (SV *) 0; + if (av_store(av, i, sv) == 0) + return (SV *) 0; + } + + TRACEME(("ok (old_retrieve_array at 0x%" UVxf ")", PTR2UV(av))); + + return (SV *) av; } /* @@ -5795,85 +6912,86 @@ static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) */ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) { - I32 len; - I32 size; - I32 i; - HV *hv; - SV *sv = (SV *) 0; - int c; - SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ - - PERL_UNUSED_ARG(cname); - TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum)); - - /* - * Read length, allocate table. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - hv = newHV(); - SEEN0_NN(hv, 0); /* Will return if table not allocated properly */ - if (len == 0) - return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ - - /* - * Now get each key/value pair in turn... - */ - - for (i = 0; i < len; i++) { - /* - * Get value first. - */ - - GETMARK(c); - if (c == SX_VL_UNDEF) { - TRACEME(("(#%d) undef value", i)); - /* - * Due to a bug in hv_store(), it's not possible to pass - * &PL_sv_undef to hv_store() as a value, otherwise the - * associated key will not be creatable any more. -- RAM, 14/01/97 - */ - if (!sv_h_undef) - sv_h_undef = newSVsv(&PL_sv_undef); - sv = SvREFCNT_inc(sv_h_undef); - } else if (c == SX_VALUE) { - TRACEME(("(#%d) value", i)); - sv = retrieve(aTHX_ cxt, 0); - if (!sv) - return (SV *) 0; - } else - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - - /* - * Get key. - * Since we're reading into kbuf, we must ensure we're not - * recursing between the read and the hv_store() where it's used. - * Hence the key comes after the value. - */ - - GETMARK(c); - if (c != SX_KEY) - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ - if (size) - READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s'", i, kbuf)); - - /* - * Enter key/value pair into hash table. - */ - - if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) - return (SV *) 0; - } + I32 len; + I32 size; + I32 i; + HV *hv; + SV *sv = (SV *) 0; + int c; + SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ + + PERL_UNUSED_ARG(cname); + TRACEME(("old_retrieve_hash (#%d)", (int)cxt->tagnum)); + + /* + * Read length, allocate table. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + hv = newHV(); + SEEN0_NN(hv, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */ + + /* + * Now get each key/value pair in turn... + */ + + for (i = 0; i < len; i++) { + /* + * Get value first. + */ + + GETMARK(c); + if (c == SX_VL_UNDEF) { + TRACEME(("(#%d) undef value", (int)i)); + /* + * Due to a bug in hv_store(), it's not possible to pass + * &PL_sv_undef to hv_store() as a value, otherwise the + * associated key will not be creatable any more. -- RAM, 14/01/97 + */ + if (!sv_h_undef) + sv_h_undef = newSVsv(&PL_sv_undef); + sv = SvREFCNT_inc(sv_h_undef); + } else if (c == SX_VALUE) { + TRACEME(("(#%d) value", (int)i)); + sv = retrieve(aTHX_ cxt, 0); + if (!sv) + return (SV *) 0; + } else + (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */ + + /* + * Get key. + * Since we're reading into kbuf, we must ensure we're not + * recursing between the read and the hv_store() where it's used. + * Hence the key comes after the value. + */ - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); + GETMARK(c); + if (c != SX_KEY) + (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */ + RLEN(size); /* Get key size */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ + if (size) + READ(kbuf, size); + kbuf[size] = '\0'; /* Mark string end, just in case */ + TRACEME(("(#%d) key '%s'", (int)i, kbuf)); - return (SV *) hv; + /* + * Enter key/value pair into hash table. + */ + + if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) + return (SV *) 0; + } + + TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv))); + + return (SV *) hv; } /*** @@ -5938,24 +7056,25 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) old_len = sizeof(old_magicstr) - 1; READ(current + 1, (SSize_t)(old_len - len)); - + if (memNE(buf, old_magicstr, old_len)) CROAK(("File is not a perl storable")); - old_magic++; + old_magic++; current = buf + old_len; } use_network_order = *current; - } else - GETMARK(use_network_order); - + } else { + GETMARK(use_network_order); + } + /* * Starting with 0.6, the "use_network_order" byte flag is also used to * indicate the version number of the binary, and therefore governs the * setting of sv_retrieve_vtbl. See magic_write(). */ if (old_magic && use_network_order > 1) { - /* 0.1 dump - use_network_order is really byte order length */ - version_major = -1; + /* 0.1 dump - use_network_order is really byte order length */ + version_major = -1; } else { version_major = use_network_order >> 1; @@ -5999,7 +7118,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) cxt->accept_future_minor)); if (cxt->accept_future_minor < 0) cxt->accept_future_minor - = (SvTRUE(perl_get_sv("Storable::accept_future_minor", + = (SvTRUE(get_sv("Storable::accept_future_minor", GV_ADD)) ? 1 : 0); if (cxt->accept_future_minor == 1) @@ -6027,7 +7146,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) GETMARK(c); } else { - c = use_network_order; + c = use_network_order; } length = c + 3 + use_NV_size; READ(buf, length); /* Not null-terminated */ @@ -6037,19 +7156,20 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) #ifdef USE_56_INTERWORK_KLUDGE /* No point in caching this in the context as we only need it once per retrieve, and we need to recheck it each read. */ - if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { + if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) { if ((c != (sizeof (byteorderstr_56) - 1)) || memNE(buf, byteorderstr_56, c)) CROAK(("Byte order is not compatible")); } else #endif { - if ((c != (sizeof (byteorderstr) - 1)) || memNE(buf, byteorderstr, c)) + if ((c != (sizeof (byteorderstr) - 1)) + || memNE(buf, byteorderstr, c)) CROAK(("Byte order is not compatible")); } current = buf + c; - + /* sizeof(int) */ if ((int) *current++ != sizeof(int)) CROAK(("Integer size is not compatible")); @@ -6080,157 +7200,169 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) */ static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname) { - int type; - SV **svh; - SV *sv; - - TRACEME(("retrieve")); - - /* - * Grab address tag which identifies the object if we are retrieving - * an older format. Since the new binary format counts objects and no - * longer explicitly tags them, we must keep track of the correspondence - * ourselves. - * - * The following section will disappear one day when the old format is - * no longer supported, hence the final "goto" in the "if" block. - */ - - if (cxt->hseen) { /* Retrieving old binary */ - stag_t tag; - if (cxt->netorder) { - I32 nettag; - READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */ - tag = (stag_t) nettag; - } else - READ(&tag, sizeof(stag_t)); /* Original address of the SV */ - - GETMARK(type); - if (type == SX_OBJECT) { - I32 tagn; - svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE); - if (!svh) - CROAK(("Old tag 0x%"UVxf" should have been mapped already", - (UV) tag)); - tagn = SvIV(*svh); /* Mapped tag number computed earlier below */ - - /* - * The following code is common with the SX_OBJECT case below. - */ - - svh = av_fetch(cxt->aseen, tagn, FALSE); - if (!svh) - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tagn)); - sv = *svh; - TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv))); - SvREFCNT_inc(sv); /* One more reference to this same sv */ - return sv; /* The SV pointer where object was retrieved */ - } - - /* - * Map new object, but don't increase tagnum. This will be done - * by each of the retrieve_* functions when they call SEEN(). - * - * The mapping associates the "tag" initially present with a unique - * tag number. See test for SX_OBJECT above to see how this is perused. - */ - - if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag), - newSViv(cxt->tagnum), 0)) - return (SV *) 0; - - goto first_time; - } + int type; + SV **svh; + SV *sv; - /* - * Regular post-0.6 binary format. - */ - - GETMARK(type); - - TRACEME(("retrieve type = %d", type)); - - /* - * Are we dealing with an object we should have already retrieved? - */ - - if (type == SX_OBJECT) { - I32 tag; - READ_I32(tag); - tag = ntohl(tag); - svh = av_fetch(cxt->aseen, tag, FALSE); - if (!svh) - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tag)); - sv = *svh; - TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv))); - SvREFCNT_inc(sv); /* One more reference to this same sv */ - return sv; /* The SV pointer where object was retrieved */ - } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) { - if (cxt->accept_future_minor < 0) - cxt->accept_future_minor - = (SvTRUE(perl_get_sv("Storable::accept_future_minor", - GV_ADD)) - ? 1 : 0); - if (cxt->accept_future_minor == 1) { - CROAK(("Storable binary image v%d.%d contains data of type %d. " - "This Storable is v%d.%d and can only handle data types up to %d", - cxt->ver_major, cxt->ver_minor, type, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1)); - } + TRACEME(("retrieve")); + + /* + * Grab address tag which identifies the object if we are retrieving + * an older format. Since the new binary format counts objects and no + * longer explicitly tags them, we must keep track of the correspondence + * ourselves. + * + * The following section will disappear one day when the old format is + * no longer supported, hence the final "goto" in the "if" block. + */ + + if (cxt->hseen) { /* Retrieving old binary */ + stag_t tag; + if (cxt->netorder) { + I32 nettag; + READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */ + tag = (stag_t) nettag; + } else + READ(&tag, sizeof(stag_t)); /* Original address of the SV */ + + GETMARK(type); + if (type == SX_OBJECT) { + I32 tagn; + svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE); + if (!svh) + CROAK(("Old tag 0x%" UVxf " should have been mapped already", + (UV) tag)); + tagn = SvIV(*svh); /* Mapped tag number computed earlier below */ + + /* + * The following code is common with the SX_OBJECT case below. + */ + + svh = av_fetch(cxt->aseen, tagn, FALSE); + if (!svh) + CROAK(("Object #%" IVdf " should have been retrieved already", + (IV) tagn)); + sv = *svh; + TRACEME(("has retrieved #%d at 0x%" UVxf, (int)tagn, PTR2UV(sv))); + SvREFCNT_inc(sv); /* One more reference to this same sv */ + return sv; /* The SV pointer where object was retrieved */ } -first_time: /* Will disappear when support for old format is dropped */ - - /* - * Okay, first time through for this one. - */ - - sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname); - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * Old binary formats (pre-0.7). - * - * Final notifications, ended by SX_STORED may now follow. - * Currently, the only pertinent notification to apply on the - * freshly retrieved object is either: - * SX_CLASS <char-len> <classname> for short classnames. - * SX_LG_CLASS <int-len> <classname> for larger one (rare!). - * Class name is then read into the key buffer pool used by - * hash table key retrieval. - */ - - if (cxt->ver_major < 2) { - while ((type = GETCHAR()) != SX_STORED) { - I32 len; - HV* stash; - switch (type) { - case SX_CLASS: - GETMARK(len); /* Length coded on a single char */ - break; - case SX_LG_CLASS: /* Length coded on a regular integer */ - RLEN(len); - break; - case EOF: - default: - return (SV *) 0; /* Failed */ - } - KBUFCHK((STRLEN)len); /* Grow buffer as necessary */ - if (len) - READ(kbuf, len); - kbuf[len] = '\0'; /* Mark string end */ - stash = gv_stashpvn(kbuf, len, GV_ADD); - BLESS(sv, stash); - } - } + /* + * Map new object, but don't increase tagnum. This will be done + * by each of the retrieve_* functions when they call SEEN(). + * + * The mapping associates the "tag" initially present with a unique + * tag number. See test for SX_OBJECT above to see how this is perused. + */ - TRACEME(("ok (retrieved 0x%"UVxf", refcnt=%d, %s)", PTR2UV(sv), - SvREFCNT(sv) - 1, sv_reftype(sv, FALSE))); + if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag), + newSViv(cxt->tagnum), 0)) + return (SV *) 0; + + goto first_time; + } + + /* + * Regular post-0.6 binary format. + */ - return sv; /* Ok */ + GETMARK(type); + + TRACEME(("retrieve type = %d", type)); + + /* + * Are we dealing with an object we should have already retrieved? + */ + + if (type == SX_OBJECT) { + I32 tag; + READ_I32(tag); + tag = ntohl(tag); +#ifndef HAS_U64 + /* A 32-bit system can't have over 2**31 objects anyway */ + if (tag < 0) + CROAK(("Object #%" IVdf " out of range", (IV)tag)); +#endif + /* Older versions of Storable on with 64-bit support on 64-bit + systems can produce values above the 2G boundary (or wrapped above + the 4G boundary, which we can't do much about), treat those as + unsigned. + This same commit stores tag ids over the 2G boundary as long tags + since older Storables will mis-handle them as short tags. + */ + svh = av_fetch(cxt->aseen, (U32)tag, FALSE); + if (!svh) + CROAK(("Object #%" IVdf " should have been retrieved already", + (IV) tag)); + sv = *svh; + TRACEME(("had retrieved #%d at 0x%" UVxf, (int)tag, PTR2UV(sv))); + SvREFCNT_inc(sv); /* One more reference to this same sv */ + return sv; /* The SV pointer where object was retrieved */ + } else if (type >= SX_LAST && cxt->ver_minor > STORABLE_BIN_MINOR) { + if (cxt->accept_future_minor < 0) + cxt->accept_future_minor + = (SvTRUE(get_sv("Storable::accept_future_minor", + GV_ADD)) + ? 1 : 0); + if (cxt->accept_future_minor == 1) { + CROAK(("Storable binary image v%d.%d contains data of type %d. " + "This Storable is v%d.%d and can only handle data types up to %d", + cxt->ver_major, cxt->ver_minor, type, + STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_LAST - 1)); + } + } + + first_time: /* Will disappear when support for old format is dropped */ + + /* + * Okay, first time through for this one. + */ + + sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname); + if (!sv) + return (SV *) 0; /* Failed */ + + /* + * Old binary formats (pre-0.7). + * + * Final notifications, ended by SX_STORED may now follow. + * Currently, the only pertinent notification to apply on the + * freshly retrieved object is either: + * SX_CLASS <char-len> <classname> for short classnames. + * SX_LG_CLASS <int-len> <classname> for larger one (rare!). + * Class name is then read into the key buffer pool used by + * hash table key retrieval. + */ + + if (cxt->ver_major < 2) { + while ((type = GETCHAR()) != SX_STORED) { + I32 len; + HV* stash; + switch (type) { + case SX_CLASS: + GETMARK(len); /* Length coded on a single char */ + break; + case SX_LG_CLASS: /* Length coded on a regular integer */ + RLEN(len); + break; + case EOF: + default: + return (SV *) 0; /* Failed */ + } + KBUFCHK((STRLEN)len); /* Grow buffer as necessary */ + if (len) + READ(kbuf, len); + kbuf[len] = '\0'; /* Mark string end */ + stash = gv_stashpvn(kbuf, len, GV_ADD); + BLESS(sv, stash); + } + } + + TRACEME(("ok (retrieved 0x%" UVxf ", refcnt=%d, %s)", PTR2UV(sv), + (int)SvREFCNT(sv) - 1, sv_reftype(sv, FALSE))); + + return sv; /* Ok */ } /* @@ -6240,232 +7372,238 @@ first_time: /* Will disappear when support for old format is dropped */ * Common routine for pretrieve and mretrieve. */ static SV *do_retrieve( - pTHX_ - PerlIO *f, - SV *in, - int optype) + pTHX_ + PerlIO *f, + SV *in, + int optype, + int flags) { - dSTCXT; - SV *sv; - int is_tainted; /* Is input source tainted? */ - int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */ + dSTCXT; + SV *sv; + int is_tainted; /* Is input source tainted? */ + int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */ - TRACEME(("do_retrieve (optype = 0x%x)", optype)); + TRACEMED(("do_retrieve (optype = 0x%x, flags=0x%x)", + (unsigned)optype, (unsigned)flags)); - optype |= ST_RETRIEVE; + optype |= ST_RETRIEVE; + cxt->flags = flags; - /* - * Sanity assertions for retrieve dispatch tables. - */ + /* + * Sanity assertions for retrieve dispatch tables. + */ - ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve), - ("old and new retrieve dispatch table have same size")); - ASSERT(sv_old_retrieve[SX_ERROR] == retrieve_other, - ("SX_ERROR entry correctly initialized in old dispatch table")); - ASSERT(sv_retrieve[SX_ERROR] == retrieve_other, - ("SX_ERROR entry correctly initialized in new dispatch table")); + ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve), + ("old and new retrieve dispatch table have same size")); + ASSERT(sv_old_retrieve[(int)SX_LAST] == retrieve_other, + ("SX_LAST entry correctly initialized in old dispatch table")); + ASSERT(sv_retrieve[(int)SX_LAST] == retrieve_other, + ("SX_LAST entry correctly initialized in new dispatch table")); - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ + /* + * Workaround for CROAK leak: if they enter with a "dirty" context, + * free up memory for them now. + */ - assert(cxt); - if (cxt->s_dirty) - clean_context(aTHX_ cxt); + assert(cxt); + if (cxt->s_dirty) + clean_context(aTHX_ cxt); - /* - * Now that STORABLE_xxx hooks exist, it is possible that they try to - * re-enter retrieve() via the hooks. - */ + /* + * Now that STORABLE_xxx hooks exist, it is possible that they try to + * re-enter retrieve() via the hooks. + */ - if (cxt->entry) - cxt = allocate_context(aTHX_ cxt); + if (cxt->entry) { + cxt = allocate_context(aTHX_ cxt); + cxt->flags = flags; + } + INIT_TRACEME; - cxt->entry++; + cxt->entry++; - ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(cxt->entry == 1, ("starting new recursion")); + ASSERT(!cxt->s_dirty, ("clean context")); - /* - * Prepare context. - * - * Data is loaded into the memory buffer when f is NULL, unless 'in' is - * also NULL, in which case we're expecting the data to already lie - * in the buffer (dclone case). - */ + /* + * Prepare context. + * + * Data is loaded into the memory buffer when f is NULL, unless 'in' is + * also NULL, in which case we're expecting the data to already lie + * in the buffer (dclone case). + */ - KBUFINIT(); /* Allocate hash key reading pool once */ + KBUFINIT(); /* Allocate hash key reading pool once */ - if (!f && in) { + if (!f && in) { #ifdef SvUTF8_on - if (SvUTF8(in)) { - STRLEN length; - const char *orig = SvPV(in, length); - char *asbytes; - /* This is quite deliberate. I want the UTF8 routines - to encounter the '\0' which perl adds at the end - of all scalars, so that any new string also has - this. - */ - STRLEN klen_tmp = length + 1; - bool is_utf8 = TRUE; - - /* Just casting the &klen to (STRLEN) won't work - well if STRLEN and I32 are of different widths. - --jhi */ - asbytes = (char*)bytes_from_utf8((U8*)orig, - &klen_tmp, - &is_utf8); - if (is_utf8) { - CROAK(("Frozen string corrupt - contains characters outside 0-255")); - } - if (asbytes != orig) { - /* String has been converted. - There is no need to keep any reference to - the old string. */ - in = sv_newmortal(); - /* We donate the SV the malloc()ed string - bytes_from_utf8 returned us. */ - SvUPGRADE(in, SVt_PV); - SvPOK_on(in); - SvPV_set(in, asbytes); - SvLEN_set(in, klen_tmp); - SvCUR_set(in, klen_tmp - 1); - } - } -#endif - MBUF_SAVE_AND_LOAD(in); - } + if (SvUTF8(in)) { + STRLEN length; + const char *orig = SvPV(in, length); + char *asbytes; + /* This is quite deliberate. I want the UTF8 routines + to encounter the '\0' which perl adds at the end + of all scalars, so that any new string also has + this. + */ + STRLEN klen_tmp = length + 1; + bool is_utf8 = TRUE; + + /* Just casting the &klen to (STRLEN) won't work + well if STRLEN and I32 are of different widths. + --jhi */ + asbytes = (char*)bytes_from_utf8((U8*)orig, + &klen_tmp, + &is_utf8); + if (is_utf8) { + CROAK(("Frozen string corrupt - contains characters outside 0-255")); + } + if (asbytes != orig) { + /* String has been converted. + There is no need to keep any reference to + the old string. */ + in = sv_newmortal(); + /* We donate the SV the malloc()ed string + bytes_from_utf8 returned us. */ + SvUPGRADE(in, SVt_PV); + SvPOK_on(in); + SvPV_set(in, asbytes); + SvLEN_set(in, klen_tmp); + SvCUR_set(in, klen_tmp - 1); + } + } +#endif + MBUF_SAVE_AND_LOAD(in); + } + + /* + * Magic number verifications. + * + * This needs to be done before calling init_retrieve_context() + * since the format indication in the file are necessary to conduct + * some of the initializations. + */ + + cxt->fio = f; /* Where I/O are performed */ + + if (!magic_check(aTHX_ cxt)) + CROAK(("Magic number checking on storable %s failed", + cxt->fio ? "file" : "string")); + + TRACEME(("data stored in %s format", + cxt->netorder ? "net order" : "native")); + + /* + * Check whether input source is tainted, so that we don't wrongly + * taint perfectly good values... + * + * We assume file input is always tainted. If both 'f' and 'in' are + * NULL, then we come from dclone, and tainted is already filled in + * the context. That's a kludge, but the whole dclone() thing is + * already quite a kludge anyway! -- RAM, 15/09/2000. + */ + + is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); + TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); + init_retrieve_context(aTHX_ cxt, optype, is_tainted); - /* - * Magic number verifications. - * - * This needs to be done before calling init_retrieve_context() - * since the format indication in the file are necessary to conduct - * some of the initializations. - */ - - cxt->fio = f; /* Where I/O are performed */ - - if (!magic_check(aTHX_ cxt)) - CROAK(("Magic number checking on storable %s failed", - cxt->fio ? "file" : "string")); - - TRACEME(("data stored in %s format", - cxt->netorder ? "net order" : "native")); - - /* - * Check whether input source is tainted, so that we don't wrongly - * taint perfectly good values... - * - * We assume file input is always tainted. If both 'f' and 'in' are - * NULL, then we come from dclone, and tainted is already filled in - * the context. That's a kludge, but the whole dclone() thing is - * already quite a kludge anyway! -- RAM, 15/09/2000. - */ - - is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); - TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); - init_retrieve_context(aTHX_ cxt, optype, is_tainted); - - ASSERT(is_retrieving(aTHX), ("within retrieve operation")); - - sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */ - - /* - * Final cleanup. - */ - - if (!f && in) - MBUF_RESTORE(); - - pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */ - - /* - * The "root" context is never freed. - */ - - clean_retrieve_context(aTHX_ cxt); - if (cxt->prev) /* This context was stacked */ - free_context(aTHX_ cxt); /* It was not the "root" context */ - - /* - * Prepare returned value. - */ - - if (!sv) { - TRACEME(("retrieve ERROR")); -#if (PATCHLEVEL <= 4) - /* perl 5.00405 seems to screw up at this point with an - 'attempt to modify a read only value' error reported in the - eval { $self = pretrieve(*FILE) } in _retrieve. - I can't see what the cause of this error is, but I suspect a - bug in 5.004, as it seems to be capable of issuing spurious - errors or core dumping with matches on $@. I'm not going to - spend time on what could be a fruitless search for the cause, - so here's a bodge. If you're running 5.004 and don't like - this inefficiency, either upgrade to a newer perl, or you are - welcome to find the problem and send in a patch. - */ - return newSV(0); + ASSERT(is_retrieving(aTHX), ("within retrieve operation")); + + sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */ + + /* + * Final cleanup. + */ + + if (!f && in) + MBUF_RESTORE(); + + pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */ + + /* + * The "root" context is never freed. + */ + + clean_retrieve_context(aTHX_ cxt); + if (cxt->prev) /* This context was stacked */ + free_context(aTHX_ cxt); /* It was not the "root" context */ + + /* + * Prepare returned value. + */ + + if (!sv) { + TRACEMED(("retrieve ERROR")); +#if (PATCHLEVEL <= 4) + /* perl 5.00405 seems to screw up at this point with an + 'attempt to modify a read only value' error reported in the + eval { $self = pretrieve(*FILE) } in _retrieve. + I can't see what the cause of this error is, but I suspect a + bug in 5.004, as it seems to be capable of issuing spurious + errors or core dumping with matches on $@. I'm not going to + spend time on what could be a fruitless search for the cause, + so here's a bodge. If you're running 5.004 and don't like + this inefficiency, either upgrade to a newer perl, or you are + welcome to find the problem and send in a patch. + */ + return newSV(0); #else - return &PL_sv_undef; /* Something went wrong, return undef */ + return &PL_sv_undef; /* Something went wrong, return undef */ #endif - } + } - TRACEME(("retrieve got %s(0x%"UVxf")", - sv_reftype(sv, FALSE), PTR2UV(sv))); - - /* - * Backward compatibility with Storable-0.5@9 (which we know we - * are retrieving if hseen is non-null): don't create an extra RV - * for objects since we special-cased it at store time. - * - * Build a reference to the SV returned by pretrieve even if it is - * already one and not a scalar, for consistency reasons. - */ - - if (pre_06_fmt) { /* Was not handling overloading by then */ - SV *rv; - TRACEME(("fixing for old formats -- pre 0.6")); - if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { - TRACEME(("ended do_retrieve() with an object -- pre 0.6")); - return sv; - } - } + TRACEMED(("retrieve got %s(0x%" UVxf ")", + sv_reftype(sv, FALSE), PTR2UV(sv))); - /* - * If reference is overloaded, restore behaviour. - * - * NB: minor glitch here: normally, overloaded refs are stored specially - * so that we can croak when behaviour cannot be re-installed, and also - * avoid testing for overloading magic at each reference retrieval. - * - * Unfortunately, the root reference is implicitly stored, so we must - * check for possible overloading now. Furthermore, if we don't restore - * overloading, we cannot croak as if the original ref was, because we - * have no way to determine whether it was an overloaded ref or not in - * the first place. - * - * It's a pity that overloading magic is attached to the rv, and not to - * the underlying sv as blessing is. - */ - - if (SvOBJECT(sv)) { - HV *stash = (HV *) SvSTASH(sv); - SV *rv = newRV_noinc(sv); - if (stash && Gv_AMG(stash)) { - SvAMAGIC_on(rv); - TRACEME(("restored overloading on root reference")); - } - TRACEME(("ended do_retrieve() with an object")); - return rv; - } + /* + * Backward compatibility with Storable-0.5@9 (which we know we + * are retrieving if hseen is non-null): don't create an extra RV + * for objects since we special-cased it at store time. + * + * Build a reference to the SV returned by pretrieve even if it is + * already one and not a scalar, for consistency reasons. + */ + + if (pre_06_fmt) { /* Was not handling overloading by then */ + SV *rv; + TRACEMED(("fixing for old formats -- pre 0.6")); + if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { + TRACEME(("ended do_retrieve() with an object -- pre 0.6")); + return sv; + } + } + + /* + * If reference is overloaded, restore behaviour. + * + * NB: minor glitch here: normally, overloaded refs are stored specially + * so that we can croak when behaviour cannot be re-installed, and also + * avoid testing for overloading magic at each reference retrieval. + * + * Unfortunately, the root reference is implicitly stored, so we must + * check for possible overloading now. Furthermore, if we don't restore + * overloading, we cannot croak as if the original ref was, because we + * have no way to determine whether it was an overloaded ref or not in + * the first place. + * + * It's a pity that overloading magic is attached to the rv, and not to + * the underlying sv as blessing is. + */ + + if (SvOBJECT(sv)) { + HV *stash = (HV *) SvSTASH(sv); + SV *rv = newRV_noinc(sv); + if (stash && Gv_AMG(stash)) { + SvAMAGIC_on(rv); + TRACEMED(("restored overloading on root reference")); + } + TRACEMED(("ended do_retrieve() with an object")); + return rv; + } - TRACEME(("regular do_retrieve() end")); + TRACEMED(("regular do_retrieve() end")); - return newRV_noinc(sv); + return newRV_noinc(sv); } /* @@ -6473,10 +7611,10 @@ static SV *do_retrieve( * * Retrieve data held in file and return the root object, undef on error. */ -static SV *pretrieve(pTHX_ PerlIO *f) +static SV *pretrieve(pTHX_ PerlIO *f, IV flag) { - TRACEME(("pretrieve")); - return do_retrieve(aTHX_ f, Nullsv, 0); + TRACEMED(("pretrieve")); + return do_retrieve(aTHX_ f, Nullsv, 0, (int)flag); } /* @@ -6484,10 +7622,10 @@ static SV *pretrieve(pTHX_ PerlIO *f) * * Retrieve data held in scalar and return the root object, undef on error. */ -static SV *mretrieve(pTHX_ SV *sv) +static SV *mretrieve(pTHX_ SV *sv, IV flag) { - TRACEME(("mretrieve")); - return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0); + TRACEMED(("mretrieve")); + return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0, (int)flag); } /*** @@ -6505,78 +7643,78 @@ static SV *mretrieve(pTHX_ SV *sv) */ static SV *dclone(pTHX_ SV *sv) { - dSTCXT; - int size; - stcxt_t *real_context; - SV *out; + dSTCXT; + STRLEN size; + stcxt_t *real_context; + SV *out; - TRACEME(("dclone")); + TRACEMED(("dclone")); - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ + /* + * Workaround for CROAK leak: if they enter with a "dirty" context, + * free up memory for them now. + */ - assert(cxt); - if (cxt->s_dirty) - clean_context(aTHX_ cxt); + assert(cxt); + if (cxt->s_dirty) + clean_context(aTHX_ cxt); - /* - * Tied elements seem to need special handling. - */ + /* + * Tied elements seem to need special handling. + */ - if ((SvTYPE(sv) == SVt_PVLV + if ((SvTYPE(sv) == SVt_PVLV #if PERL_VERSION < 8 - || SvTYPE(sv) == SVt_PVMG + || SvTYPE(sv) == SVt_PVMG #endif - ) && (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == - (SVs_GMG|SVs_SMG|SVs_RMG) && - mg_find(sv, 'p')) { - mg_get(sv); - } + ) && (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + mg_find(sv, 'p')) { + mg_get(sv); + } - /* - * do_store() optimizes for dclone by not freeing its context, should - * we need to allocate one because we're deep cloning from a hook. - */ + /* + * do_store() optimizes for dclone by not freeing its context, should + * we need to allocate one because we're deep cloning from a hook. + */ - if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) - return &PL_sv_undef; /* Error during store */ + if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) + return &PL_sv_undef; /* Error during store */ - /* - * Because of the above optimization, we have to refresh the context, - * since a new one could have been allocated and stacked by do_store(). - */ + /* + * Because of the above optimization, we have to refresh the context, + * since a new one could have been allocated and stacked by do_store(). + */ - { dSTCXT; real_context = cxt; } /* Sub-block needed for macro */ - cxt = real_context; /* And we need this temporary... */ + { dSTCXT; real_context = cxt; } /* Sub-block needed for macro */ + cxt = real_context; /* And we need this temporary... */ - /* - * Now, 'cxt' may refer to a new context. - */ + /* + * Now, 'cxt' may refer to a new context. + */ - assert(cxt); - ASSERT(!cxt->s_dirty, ("clean context")); - ASSERT(!cxt->entry, ("entry will not cause new context allocation")); + assert(cxt); + ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(!cxt->entry, ("entry will not cause new context allocation")); - size = MBUF_SIZE(); - TRACEME(("dclone stored %d bytes", size)); - MBUF_INIT(size); + size = MBUF_SIZE(); + TRACEME(("dclone stored %ld bytes", (long)size)); + MBUF_INIT(size); - /* - * Since we're passing do_retrieve() both a NULL file and sv, we need - * to pre-compute the taintedness of the input by setting cxt->tainted - * to whatever state our own input string was. -- RAM, 15/09/2000 - * - * do_retrieve() will free non-root context. - */ + /* + * Since we're passing do_retrieve() both a NULL file and sv, we need + * to pre-compute the taintedness of the input by setting cxt->tainted + * to whatever state our own input string was. -- RAM, 15/09/2000 + * + * do_retrieve() will free non-root context. + */ - cxt->s_tainted = SvTAINTED(sv); - out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE); + cxt->s_tainted = SvTAINTED(sv); + out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE, FLAG_BLESS_OK | FLAG_TIE_OK); - TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out))); + TRACEMED(("dclone returns 0x%" UVxf, PTR2UV(out))); - return out; + return out; } /*** @@ -6595,21 +7733,21 @@ static SV *dclone(pTHX_ SV *sv) #ifndef OutputStream #define OutputStream PerlIO * -#define InputStream PerlIO * +#define InputStream PerlIO * #endif /* !OutputStream */ static int storable_free(pTHX_ SV *sv, MAGIC* mg) { - stcxt_t *cxt = (stcxt_t *)SvPVX(sv); - - PERL_UNUSED_ARG(mg); - if (kbuf) - Safefree(kbuf); - if (!cxt->membuf_ro && mbase) - Safefree(mbase); - if (cxt->membuf_ro && (cxt->msaved).arena) - Safefree((cxt->msaved).arena); - return 0; + stcxt_t *cxt = (stcxt_t *)SvPVX(sv); + + PERL_UNUSED_ARG(mg); + if (kbuf) + Safefree(kbuf); + if (!cxt->membuf_ro && mbase) + Safefree(mbase); + if (cxt->membuf_ro && (cxt->msaved).arena) + Safefree((cxt->msaved).arena); + return 0; } MODULE = Storable PACKAGE = Storable @@ -6632,12 +7770,12 @@ BOOT: #ifdef USE_56_INTERWORK_KLUDGE gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); #endif -} + } void init_perinterp() - CODE: - init_perinterp(aTHX); +CODE: + init_perinterp(aTHX); # pstore # @@ -6651,16 +7789,16 @@ init_perinterp() SV * pstore(f,obj) -OutputStream f -SV * obj - ALIAS: - net_pstore = 1 - PPCODE: - RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; - /* do_store() can reallocate the stack, so need a sequence point to ensure - that ST(0) knows about it. Hence using two statements. */ - ST(0) = RETVAL; - XSRETURN(1); + OutputStream f + SV* obj +ALIAS: + net_pstore = 1 +PPCODE: + RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; + /* do_store() can reallocate the stack, so need a sequence point to ensure + that ST(0) knows about it. Hence using two statements. */ + ST(0) = RETVAL; + XSRETURN(1); # mstore # @@ -6674,55 +7812,70 @@ SV * obj SV * mstore(obj) -SV * obj - ALIAS: - net_mstore = 1 - CODE: - RETVAL = &PL_sv_undef; - if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL)) + SV* obj +ALIAS: + net_mstore = 1 +CODE: RETVAL = &PL_sv_undef; - OUTPUT: - RETVAL + if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL)) + RETVAL = &PL_sv_undef; +OUTPUT: + RETVAL SV * -pretrieve(f) -InputStream f - CODE: - RETVAL = pretrieve(aTHX_ f); - OUTPUT: - RETVAL +pretrieve(f, flag = 6) + InputStream f + IV flag +CODE: + RETVAL = pretrieve(aTHX_ f, flag); +OUTPUT: + RETVAL SV * -mretrieve(sv) -SV * sv - CODE: - RETVAL = mretrieve(aTHX_ sv); - OUTPUT: - RETVAL +mretrieve(sv, flag = 6) + SV* sv + IV flag +CODE: + RETVAL = mretrieve(aTHX_ sv, flag); +OUTPUT: + RETVAL SV * dclone(sv) -SV * sv - CODE: - RETVAL = dclone(aTHX_ sv); - OUTPUT: - RETVAL + SV* sv +CODE: + RETVAL = dclone(aTHX_ sv); +OUTPUT: + RETVAL void last_op_in_netorder() - ALIAS: - is_storing = ST_STORE - is_retrieving = ST_RETRIEVE - PREINIT: - bool result; - PPCODE: - if (ix) { - dSTCXT; - - assert(cxt); - result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE; - } else { - result = !!last_op_in_netorder(aTHX); - } - ST(0) = boolSV(result); - XSRETURN(1); +ALIAS: + is_storing = ST_STORE + is_retrieving = ST_RETRIEVE +PREINIT: + bool result; +CODE: + if (ix) { + dSTCXT; + assert(cxt); + result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE; + } else { + result = !!last_op_in_netorder(aTHX); + } + ST(0) = boolSV(result); + + +IV +stack_depth() +CODE: + RETVAL = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); +OUTPUT: + RETVAL + +IV +stack_depth_hash() +CODE: + RETVAL = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); +OUTPUT: + RETVAL diff --git a/gnu/usr.bin/perl/dist/Storable/t/attach_errors.t b/gnu/usr.bin/perl/dist/Storable/t/attach_errors.t index 6cebd9735d2..0ed7c8d39f7 100755 --- a/gnu/usr.bin/perl/dist/Storable/t/attach_errors.t +++ b/gnu/usr.bin/perl/dist/Storable/t/attach_errors.t @@ -25,10 +25,6 @@ sub BEGIN { use Test::More tests => 40; use Storable (); - - - - ##################################################################### # Error 1 # diff --git a/gnu/usr.bin/perl/dist/Storable/t/canonical.t b/gnu/usr.bin/perl/dist/Storable/t/canonical.t index 35046dec677..f7791ce879f 100755 --- a/gnu/usr.bin/perl/dist/Storable/t/canonical.t +++ b/gnu/usr.bin/perl/dist/Storable/t/canonical.t @@ -18,7 +18,7 @@ sub BEGIN { use Storable qw(freeze thaw dclone); -use vars qw($debugging $verbose); +our ($debugging, $verbose); use Test::More tests => 8; @@ -34,7 +34,7 @@ $maxarraysize = 100; eval { require Digest::MD5; }; $gotmd5 = !$@; -note "Will use Digest::MD5" if $gotmd5; +diag "Will use Digest::MD5" if $gotmd5; # Use Data::Dumper if debugging and it is available to create an ASCII dump diff --git a/gnu/usr.bin/perl/dist/Storable/t/code.t b/gnu/usr.bin/perl/dist/Storable/t/code.t index 7fc40ba5a7d..b4e70812882 100755 --- a/gnu/usr.bin/perl/dist/Storable/t/code.t +++ b/gnu/usr.bin/perl/dist/Storable/t/code.t @@ -41,7 +41,7 @@ use Safe; #$Storable::DEBUGME = 1; -use vars qw($freezed $thawed @obj @res $blessed_code); +our ($freezed, $thawed, @obj, @res, $blessed_code); $blessed_code = bless sub { "blessed" }, "Some::Package"; { package Another::Package; sub foo { __PACKAGE__ } } @@ -71,7 +71,7 @@ local *FOO; \&dclone, # XS function - sub { open FOO, "/" }, + sub { open FOO, '<', "/" }, ); $Storable::Deparse = 1; @@ -125,8 +125,9 @@ is($new_sub->(), $obj[2]->()); ###################################################################### # Test retrieve & store -store $obj[0], 'store'; -$thawed = retrieve 'store'; +store $obj[0], "store$$"; +# $Storable::DEBUGME = 1; +$thawed = retrieve "store$$"; is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); @@ -136,9 +137,9 @@ is(prototype($thawed->[4]), prototype($obj[0]->[4])); ###################################################################### -nstore $obj[0], 'store'; -$thawed = retrieve 'store'; -unlink 'store'; +nstore $obj[0], "store$$"; +$thawed = retrieve "store$$"; +unlink "store$$"; is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); @@ -191,7 +192,7 @@ is(prototype($thawed->[4]), prototype($obj[0]->[4])); my $devnull = File::Spec->devnull; open(SAVEERR, ">&STDERR"); - open(STDERR, ">$devnull") or + open(STDERR, '>', $devnull) or ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); eval { $freezed = freeze $obj[0]->[0] }; diff --git a/gnu/usr.bin/perl/dist/Term-ReadLine/lib/Term/ReadLine.pm b/gnu/usr.bin/perl/dist/Term-ReadLine/lib/Term/ReadLine.pm index db08947972d..78c1ebf5b63 100644 --- a/gnu/usr.bin/perl/dist/Term-ReadLine/lib/Term/ReadLine.pm +++ b/gnu/usr.bin/perl/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -75,6 +75,8 @@ history. Returns the old value. returns an array with two strings that give most appropriate names for files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">. +The strings returned may not be useful for 3-argument open(). + =item Attribs returns a reference to a hash which describes internal configuration @@ -229,12 +231,17 @@ sub readline { } sub addhistory {} +# used for testing purpose +sub devtty { return '/dev/tty' } + sub findConsole { my $console; my $consoleOUT; - if ($^O ne 'MSWin32' and -e "/dev/tty") { - $console = "/dev/tty"; + my $devtty = devtty(); + + if ($^O ne 'MSWin32' and -e $devtty) { + $console = $devtty; } elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") { $console = 'CONIN$'; $consoleOUT = 'CONOUT$'; @@ -248,7 +255,7 @@ sub findConsole { $consoleOUT = $console unless defined $consoleOUT; $console = "&STDIN" unless defined $console; - if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) { + if ($console eq $devtty && !open(my $fh, "<", $console)) { $console = "&STDIN"; undef($consoleOUT); } @@ -266,11 +273,10 @@ sub new { if (@_==2) { my($console, $consoleOUT) = $_[0]->findConsole; - # the Windows CONIN$ needs GENERIC_WRITE mode to allow # a SetConsoleMode() if we end up using Term::ReadKey - open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" : - "<$console"; + open FIN, (( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? '+<' : '<' ), $console; + # RT #132008: Still need 2-arg open here open FOUT,">$consoleOUT"; #OUT->autoflush(1); # Conflicts with debugger? @@ -320,7 +326,7 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? -our $VERSION = '1.15'; +our $VERSION = '1.17'; my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { diff --git a/gnu/usr.bin/perl/dist/Thread-Queue/lib/Thread/Queue.pm b/gnu/usr.bin/perl/dist/Thread-Queue/lib/Thread/Queue.pm index 2f87eed9c73..c0d21806536 100644 --- a/gnu/usr.bin/perl/dist/Thread-Queue/lib/Thread/Queue.pm +++ b/gnu/usr.bin/perl/dist/Thread-Queue/lib/Thread/Queue.pm @@ -3,7 +3,7 @@ package Thread::Queue; use strict; use warnings; -our $VERSION = '3.09'; +our $VERSION = '3.12'; $VERSION = eval $VERSION; use threads::shared 1.21; @@ -65,8 +65,8 @@ sub end lock(%$self); # No more data is coming $$self{'ENDED'} = 1; - # Try to release at least one blocked thread - cond_signal(%$self); + + cond_signal(%$self); # Unblock possibly waiting threads } # Return 1 or more items from the head of a queue, blocking if needed @@ -80,17 +80,21 @@ sub dequeue # Wait for requisite number of items cond_wait(%$self) while ((@$queue < $count) && ! $$self{'ENDED'}); - cond_signal(%$self) if ((@$queue >= $count) || $$self{'ENDED'}); # If no longer blocking, try getting whatever is left on the queue return $self->dequeue_nb($count) if ($$self{'ENDED'}); # Return single item - return shift(@$queue) if ($count == 1); + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } # Return multiple items my @items; push(@items, shift(@$queue)) for (1..$count); + cond_signal(%$self); # Unblock possibly waiting threads return @items; } @@ -104,7 +108,11 @@ sub dequeue_nb my $count = @_ ? $self->_validate_count(shift) : 1; # Return single item - return shift(@$queue) if ($count == 1); + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } # Return multiple items my @items; @@ -112,6 +120,7 @@ sub dequeue_nb last if (! @$queue); push(@items, shift(@$queue)); } + cond_signal(%$self); # Unblock possibly waiting threads return @items; } @@ -135,7 +144,6 @@ sub dequeue_timed while ((@$queue < $count) && ! $$self{'ENDED'}) { last if (! cond_timedwait(%$self, $timeout)); } - cond_signal(%$self) if ((@$queue >= $count) || $$self{'ENDED'}); # Get whatever we need off the queue if available return $self->dequeue_nb($count); @@ -187,8 +195,7 @@ sub insert # Add previous items back onto the queue push(@$queue, @tmp); - # Soup's up - cond_signal(%$self); + cond_signal(%$self); # Unblock possibly waiting threads } # Remove items from anywhere in a queue @@ -206,7 +213,7 @@ sub extract $index += @$queue; if ($index < 0) { $count += $index; - return if ($count <= 0); # Beyond the head of the queue + return if ($count <= 0); # Beyond the head of the queue return $self->dequeue_nb($count); # Extract from the head } } @@ -224,6 +231,8 @@ sub extract # Add back any removed items push(@$queue, @tmp); + cond_signal(%$self); # Unblock possibly waiting threads + # Return single item return $items[0] if ($count == 1); @@ -263,14 +272,19 @@ sub _validate_count if (! defined($count) || ! looks_like_number($count) || (int($count) != $count) || - ($count < 1)) + ($count < 1) || + ($$self{'LIMIT'} && $count > $$self{'LIMIT'})) { require Carp; my ($method) = (caller(1))[3]; my $class_name = ref($self); $method =~ s/$class_name\:://; $count = 'undef' if (! defined($count)); - Carp::croak("Invalid 'count' argument ($count) to '$method' method"); + if ($$self{'LIMIT'} && $count > $$self{'LIMIT'}) { + Carp::croak("'count' argument ($count) to '$method' method exceeds queue size limit ($$self{'LIMIT'})"); + } else { + Carp::croak("Invalid 'count' argument ($count) to '$method' method"); + } } return $count; @@ -304,7 +318,7 @@ Thread::Queue - Thread-safe queues =head1 VERSION -This document describes Thread::Queue version 3.09 +This document describes Thread::Queue version 3.12 =head1 SYNOPSIS @@ -494,6 +508,9 @@ C<limit> does not prevent enqueuing items beyond that count: # 'undef') $q->limit = 0; # Queue size is now unlimited +Calling any of the dequeue methods with C<COUNT> greater than a queue's +C<limit> will generate an error. + =item ->end() Declares that no more items will be added to the queue. @@ -618,8 +635,11 @@ Passing array/hash refs that contain objects may not work for Perl prior to =head1 SEE ALSO -Thread::Queue Discussion Forum on CPAN: -L<http://www.cpanforum.com/dist/Thread-Queue> +Thread::Queue on MetaCPAN: +L<https://metacpan.org/release/Thread-Queue> + +Code repository for CPAN distribution: +L<https://github.com/Dual-Life/Thread-Queue> L<threads>, L<threads::shared> diff --git a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/01_basic.t b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/01_basic.t index b10f7254fb9..cfdadb90471 100755 --- a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/01_basic.t +++ b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/01_basic.t @@ -14,7 +14,7 @@ use threads::shared; use Thread::Semaphore; if ($] == 5.008) { - require 't/test.pl'; # Test::More work-alike for Perl 5.8.0 + require './t/test.pl'; # Test::More work-alike for Perl 5.8.0 } else { require Test::More; } @@ -35,7 +35,6 @@ my @threads; push @threads, threads->create(sub { $st->down(); is($token++, 1, 'Thread 1 got semaphore'); - $st->up(); $sm->up(); $st->down(4); @@ -46,7 +45,6 @@ push @threads, threads->create(sub { push @threads, threads->create(sub { $st->down(2); is($token++, 3, 'Thread 2 got semaphore'); - $st->up(); $sm->up(); $st->down(4); @@ -68,11 +66,11 @@ $st->up(9); $sm->down(2); $st->down(); -ok(1, 'Main done'); -threads::yield(); $_->join for @threads; +ok(1, 'Main done'); + exit(0); # EOF diff --git a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/04_nonblocking.t b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/04_nonblocking.t index d1538e81150..bef964eaf0d 100644 --- a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/04_nonblocking.t +++ b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/04_nonblocking.t @@ -14,7 +14,7 @@ use threads::shared; use Thread::Semaphore; if ($] == 5.008) { - require 't/test.pl'; # Test::More work-alike for Perl 5.8.0 + require './t/test.pl'; # Test::More work-alike for Perl 5.8.0 } else { require Test::More; } diff --git a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/05_force.t b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/05_force.t index 8803cfa1607..ee7090b6452 100644 --- a/gnu/usr.bin/perl/dist/Thread-Semaphore/t/05_force.t +++ b/gnu/usr.bin/perl/dist/Thread-Semaphore/t/05_force.t @@ -14,7 +14,7 @@ use threads::shared; use Thread::Semaphore; if ($] == 5.008) { - require 't/test.pl'; # Test::More work-alike for Perl 5.8.0 + require './t/test.pl'; # Test::More work-alike for Perl 5.8.0 } else { require Test::More; } @@ -51,11 +51,10 @@ $st->up(); $sm->down(); is($token, 4, 'Main re-got semaphore'); -ok(1, 'Main done'); -threads::yield(); - $thread->join; +ok(1, 'Main done'); + exit(0); # EOF diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/Changes b/gnu/usr.bin/perl/dist/Time-HiRes/Changes index c2ad5a53029..bad6b565df4 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/Changes +++ b/gnu/usr.bin/perl/dist/Time-HiRes/Changes @@ -1,5 +1,107 @@ Revision history for the Perl extension Time::HiRes. +1.9759 [2018-03-23] + - This version reverts the changes on CPAN that were included in 1.9754 - 1.9758. + Several of these changes caused instability on some windows platforms. We can + revisit these fixes if necessary in Perl 5.29.0 + +1.9753 [2018-01-11] + - in t/clock.t in a fast system we need to burn more CPU, + reported and fix suggested by Joel C. Maslak <jmaslak@antelope.net> + [rt.cpan.org #124025] + - for t/utime.t in netbsd we need /sbin in PATH to find the mount command, + this is needed for the fix in 1.9751 to actually help netbsd with noatime + mounts. + (thanks to Nigel Horne) + +1.9752 [2018-01-04] + - fix an error in the error message of utimensat() not available: + it said futimens() not available + - add --force alias for Makefile.PL --configure + +1.9751 [2018-01-02] + - in macOS/OSX/Darwin, use __has_builtin() check also for utimensat(), + can cause errors like + "HiRes.xs:1474:16: error: unrecognized platform name macOS" + [rt.cpan.org #123994] + (oversight from 1.9749) + - do not define TIME_HIRES_STAT/d_hires_stat if none was found, instead + of defining it to be zero, which case has no implementation in hrstatns() + (thanks to Nigel Horne) + - in t/utime.t try to divine if the filesystem of the tempfiles has been + mounted with the 'noatime' option, which can prohibit updating the + access time timestamp. Also document this in HiRes.pm. + (thanks to Nigel Horne, original analysis by Slaven Rezic) + - synchronize the constant lists in HiRes.pm:@EXPORT_OK + and Makefile.PL:doConstants and regenerate fallback/const-c.inc + and fallback/const-xs.inc, this fixes Perl 5.6.2 issue with + d_futimens not allegedly being a valid macro in t/utime.t + (using Perl 5.26.1 for the regenerating, not 5.6.2) + (thanks to Nigel Horne) + - in t/utime.t define a nop sub done_testing for ancient Perls + (like Perl 5.6.2) + - in Perl 5.6.2 a bogus warning + "Use of uninitialized value in subroutine entry" + is issued from t/alarm.t: add a comment documenting that + +1.9750 [2017-12-22] + - update META.yml and META.json for XSLoader instead of DynaLoader + [rt.cpan.org #123933] + +1.9749 [2017-12-21] + - CPAN release + - Quieten Time-HiRes test noise: blead 0f009486 + - Switch some core modules to XSLoader: blead b9a5a78f [rt.cpan.org #129789] + - disable a flapping test for CI: blead cd2a978d + - Avoid newGVgen in blead-upstream modules: blead 732d3893 + - Declaration after statement in typemap: blead d269f586 + - semicolon-friendly diagnostic control: blead 7347ee54 + - in macOS (OS X) check properly in runtime whether futimens() + and utimensat() are available + +1.9748 [2017-12-16] + - bleadperl only + - semicolon-friendly diagnostic control: blead 7347ee54 + +1.9747 [2017-09-13] + - bleadperl only + - Switch some core modules to XSLoader: blead b9a5a78f [rt.cpan.org #129789] + +1.9746 [2017-08-17] + - Unreliable t/usleep.t and t/utime.t tests [rt.cpan.org #122819] + Avoid testing for $dt = $t2 - $t1 and assuming $dt is less than + some value since a heavily loaded machine can delay the $t2. + Testing for greater than is fine. + - Tweak the configuring messages about subsecond stat/utime. + +1.9745 [2017-08-14] + - Properly check for futimens/utimensat actually doing something. + This should handle 'gnukfreebsd' (which has only stubs, so far + we have been skipping the test) and as a new thing 'gnu' (Hurd) + (also only stubs). Thanks to Nigel Horne. + - Scan in t/utime.t whether the filesystem (wherever File::Temp + puts it tempfiles) supports subsecond timestamps. This removes + the fragile Linux/ext3 specific hack. As a side effect, the + setting of subsecond timestamps is tested only if reading of + them is supported. Thanks to Carsten Gaebler for the test idea, + and Ryan Voots for testing. + +1.9744 [2017-07-27] + - add more potential clock constants, like CLOCK_MONOTONIC_FAST + (available in FreeBSD), and not all potentially found clock + constants were properly exported to be available from Perl, + see your system's clock_gettime() documentation for the available ones + +1.9743 [2017-07-20] + - correct declared minimum Perl version (should be 5.6, was declared + as 5.8 since 1.9727_03): blead af94b3ac + - fix the fix for 'do file' to load hints in Makefile.PL: blead 3172fdbc + +1.9742 [2017-04-16] + - prefer 3-argument open: blead 1ae6ead9 + - fix dist/Time-HiRes/t/*.t that assumed '.' in @INC: blead 465db51d + - fix cases where 'do file' should be 'do ./file'.: blead 8b69401c + 1.9741 [2016-11-20] - C++11 compatibility: blead a914236c - El Capitan compatibility: blead 45bbc013 diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm index a3ddd595b74..59f0f3aad98 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm +++ b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm @@ -4,31 +4,53 @@ package Time::HiRes; use strict; require Exporter; -require DynaLoader; +use XSLoader (); -our @ISA = qw(Exporter DynaLoader); +our @ISA = qw(Exporter); our @EXPORT = qw( ); +# More or less this same list is in Makefile.PL. Should unify. our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval getitimer setitimer nanosleep clock_gettime clock_getres clock clock_nanosleep - CLOCK_BOOTTIME CLOCK_HIGHRES - CLOCK_MONOTONIC CLOCK_MONOTONIC_COARSE - CLOCK_MONOTONIC_PRECISE CLOCK_MONOTONIC_RAW + CLOCKS_PER_SEC + CLOCK_BOOTTIME + CLOCK_HIGHRES + CLOCK_MONOTONIC + CLOCK_MONOTONIC_COARSE + CLOCK_MONOTONIC_FAST + CLOCK_MONOTONIC_PRECISE + CLOCK_MONOTONIC_RAW CLOCK_PROCESS_CPUTIME_ID - CLOCK_REALTIME CLOCK_REALTIME_COARSE - CLOCK_REALTIME_FAST CLOCK_REALTIME_PRECISE - CLOCK_SECOND CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID - CLOCK_TIMEOFDAY CLOCKS_PER_SEC - ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF + CLOCK_PROF + CLOCK_REALTIME + CLOCK_REALTIME_COARSE + CLOCK_REALTIME_FAST + CLOCK_REALTIME_PRECISE + CLOCK_REALTIME_RAW + CLOCK_SECOND + CLOCK_SOFTTIME + CLOCK_THREAD_CPUTIME_ID + CLOCK_TIMEOFDAY + CLOCK_UPTIME + CLOCK_UPTIME_COARSE + CLOCK_UPTIME_FAST + CLOCK_UPTIME_PRECISE + CLOCK_UPTIME_RAW + CLOCK_VIRTUAL + ITIMER_PROF + ITIMER_REAL + ITIMER_REALPROF + ITIMER_VIRTUAL TIMER_ABSTIME d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer - d_nanosleep d_clock_gettime d_clock_getres d_hires_utime - d_clock d_clock_nanosleep + d_nanosleep d_clock_gettime d_clock_getres + d_clock d_clock_nanosleep d_hires_stat + d_futimens d_utimensat d_hires_utime stat lstat utime ); -our $VERSION = '1.9741'; +our $VERSION = '1.9759'; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -69,7 +91,7 @@ sub import { Time::HiRes->export_to_level(1, $this, @_); } -bootstrap Time::HiRes; +XSLoader::load( 'Time::HiRes', $XS_VERSION ); # Preloaded methods go here. @@ -454,8 +476,10 @@ time stamp from t1: it may be equal or I<less>. As L<perlfunc/utime> but with the ability to set the access/modify file timestamps -in subsecond resolution, if the operating system and the filesystem -both support such timestamps. To override the standard utime(): +in subsecond resolution, if the operating system and the filesystem, +and the mount options of the filesystem, all support such timestamps. + +To override the standard utime(): use Time::HiRes qw(utime); @@ -468,6 +492,10 @@ call the syscall with a NULL argument. The actual achievable subsecond resolution depends on the combination of the operating system and the filesystem. +Modifying the timestamps may not be possible at all: for example, the +C<noatime> filesystem mount option may prohibit you from changing the +access time timestamp. + Returns the number of files successfully changed. =back diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs index 6b0dba8e686..b9eaa17cde2 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs +++ b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs @@ -46,6 +46,15 @@ extern "C" { #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) +#ifndef GCC_DIAG_IGNORE +# define GCC_DIAG_IGNORE(x) +# define GCC_DIAG_RESTORE +#endif +#ifndef GCC_DIAG_IGNORE_STMT +# define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP +# define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP +#endif + /* At least ppport.h 3.13 gets this wrong: one really cannot * have NVgf as anything else than "g" under Perl 5.6.x. */ #if PERL_REVISION == 5 && PERL_VERSION == 6 @@ -913,6 +922,40 @@ static int th_clock_nanosleep(clockid_t clock_id, int flags, #endif /* PERL_DARWIN */ +/* The macOS headers warn about using certain interfaces in + * OS-release-ignorant manner, for example: + * + * warning: 'futimens' is only available on macOS 10.13 or newer + * [-Wunguarded-availability-new] + * + * (ditto for utimensat) + * + * There is clang __builtin_available() *runtime* check for this. + * The gotchas are that neither __builtin_available() nor __has_builtin() + * are always available. + */ +#ifndef __has_builtin +# define __has_builtin(x) 0 /* non-clang */ +#endif +#ifdef HAS_FUTIMENS +# if defined(PERL_DARWIN) && __has_builtin(__builtin_available) +# define FUTIMENS_AVAILABLE __builtin_available(macOS 10.13, *) +# else +# define FUTIMENS_AVAILABLE 1 +# endif +#else +# define FUTIMENS_AVAILABLE 0 +#endif +#ifdef HAS_UTIMENSAT +# if defined(PERL_DARWIN) && __has_builtin(__builtin_available) +# define UTIMENSAT_AVAILABLE __builtin_available(macOS 10.13, *) +# else +# define UTIMENSAT_AVAILABLE 1 +# endif +#else +# define UTIMENSAT_AVAILABLE 0 +#endif + #include "const-c.inc" #if (defined(TIME_HIRES_NANOSLEEP)) || \ @@ -1338,9 +1381,7 @@ setitimer(which, seconds, interval = 0) /* on some platforms the 1st arg to setitimer is an enum, which * causes -Wc++-compat to complain about passing an int instead */ -#ifdef GCC_DIAG_IGNORE - GCC_DIAG_IGNORE(-Wc++-compat); -#endif + GCC_DIAG_IGNORE_STMT(-Wc++-compat); if (setitimer(which, &newit, &oldit) == 0) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value)))); @@ -1349,9 +1390,7 @@ setitimer(which, seconds, interval = 0) PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval)))); } } -#ifdef GCC_DIAG_RESTORE - GCC_DIAG_RESTORE; -#endif + GCC_DIAG_RESTORE_STMT; void getitimer(which) @@ -1362,9 +1401,7 @@ getitimer(which) /* on some platforms the 1st arg to getitimer is an enum, which * causes -Wc++-compat to complain about passing an int instead */ -#ifdef GCC_DIAG_IGNORE - GCC_DIAG_IGNORE(-Wc++-compat); -#endif + GCC_DIAG_IGNORE_STMT(-Wc++-compat); if (getitimer(which, &nowit) == 0) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value)))); @@ -1373,9 +1410,7 @@ getitimer(which) PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval)))); } } -#ifdef GCC_DIAG_RESTORE - GCC_DIAG_RESTORE; -#endif + GCC_DIAG_RESTORE_STMT; #endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */ @@ -1418,25 +1453,36 @@ PROTOTYPE: $$@ if (SvROK(file) && GvIO(SvRV(file)) && IoIFP(sv_2io(SvRV(file)))) { int fd = PerlIO_fileno(IoIFP(sv_2io(file))); - if (fd < 0) + if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - else + } else { #ifdef HAS_FUTIMENS - if (futimens(fd, utbufp) == 0) - tot++; -#else /* HAS_FUTIMES */ - croak("futimens unimplemented in this platform"); -#endif /* HAS_FUTIMES */ + if (FUTIMENS_AVAILABLE) { + if (futimens(fd, utbufp) == 0) { + tot++; + } + } else { + croak("futimens unimplemented in this platform"); + } +#else /* HAS_FUTIMENS */ + croak("futimens unimplemented in this platform"); +#endif /* HAS_FUTIMENS */ + } } else { #ifdef HAS_UTIMENSAT - STRLEN len; - char * name = SvPV(file, len); - if (IS_SAFE_PATHNAME(name, len, "utime") && - utimensat(AT_FDCWD, name, utbufp, 0) == 0) - tot++; + if (UTIMENSAT_AVAILABLE) { + STRLEN len; + char * name = SvPV(file, len); + if (IS_SAFE_PATHNAME(name, len, "utime") && + utimensat(AT_FDCWD, name, utbufp, 0) == 0) { + tot++; + } + } else { + croak("utimensat unimplemented in this platform"); + } #else /* HAS_UTIMENSAT */ - croak("utimensat unimplemented in this platform"); + croak("utimensat unimplemented in this platform"); #endif /* HAS_UTIMENSAT */ } } /* while items */ diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL b/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL index 9060fa20f35..daca5b4f60c 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL +++ b/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL @@ -88,7 +88,7 @@ sub try_compile_and_link { my $obj_ext = $Config{obj_ext} || ".o"; unlink("$tmp.c", "$tmp$obj_ext"); - if (open(TMPC, ">$tmp.c")) { + if (open(TMPC, '>', "$tmp.c")) { print TMPC $c; close(TMPC); @@ -132,7 +132,7 @@ __EOD__ unless defined $cccmd; if ($^O eq 'VMS') { - open( CMDFILE, ">$tmp.com" ); + open( CMDFILE, '>', "$tmp.com" ); print CMDFILE "\$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENT/NOTEXT\n"; print CMDFILE "\$ $cccmd\n"; print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate @@ -367,10 +367,14 @@ sub has_futimens { #include <sys/stat.h> int main(int argc, char** argv) { - int ret; - struct timespec ts[2]; - ret = futimens(0, ts); - ret == 0 ? exit(0) : exit(errno ? errno : -1); + int ret1, ret2; + struct timespec ts1[2], ts2[2]; + ret1 = futimens(0, ts1); + char buf[1]; + read(0, buf, 0); /* Assuming reading nothing updates atime (the [0]) */ + ret2 = futimens(0, ts2); + ret1 == 0 && ret2 == 0 && (ts1[0].tv_nsec != 0 || ts2[0].tv_nsec != 0) ? + exit(0) : exit(errno ? errno : -1); } EOM } @@ -385,10 +389,16 @@ sub has_utimensat{ #include <fcntl.h> int main(int argc, char** argv) { - int ret; - struct timespec ts[2]; - ret = utimensat(AT_FDCWD, 0, ts, 0); - ret == 0 ? exit(0) : exit(errno ? errno : -1); + int ret1, ret2; + struct timespec ts1[2], ts2[2]; + /* We make the brave but probably foolish assumption that systems + * modern enough to have utimensat also have the /dev/stdin. */ + ret1 = utimensat(AT_FDCWD, "/dev/stdin", ts1, 0); + char buf[1]; + read(0, buf, 0); /* Assuming reading nothing updates atime (the [0]) */ + ret2 = utimensat(AT_FDCWD, "/dev/stdin", ts2, 0); + ret1 == 0 && ret2 == 0 && (ts1[0].tv_nsec != 0 || ts2[0].tv_nsec != 0) ? + exit(0) : exit(errno ? errno : -1); } EOM } @@ -421,7 +431,7 @@ sub init { if (-f $hints) { print "Using hints $hints...\n"; local $self; - do $hints; + do "./$hints"; if (exists $self->{LIBS}) { $LIBS = $self->{LIBS}; print "Extra libraries: @$LIBS...\n"; @@ -507,7 +517,7 @@ EOD if ($has_setitimer && $has_getitimer) { print "You have interval timers (both setitimer and getitimer).\n"; } else { - print "You do not have interval timers.\n"; + print "You do NOT have interval timers.\n"; } print "Looking for ualarm()... "; @@ -695,7 +705,7 @@ EOD print "NOT found.\n"; } - print "Looking for futimens()... "; + print "Looking for working futimens()... "; my $has_futimens; if (has_futimens()) { $has_futimens++; @@ -708,7 +718,7 @@ EOD print "NOT found.\n"; } - print "Looking for utimensat()... "; + print "Looking for working utimensat()... "; my $has_utimensat; if (has_utimensat()) { $has_utimensat++; @@ -721,8 +731,12 @@ EOD print "NOT found.\n"; } - if ($has_futimens or $has_utimensat) { + my $has_hires_utime = ($has_futimens && $has_utimensat); + if ($has_hires_utime) { $DEFINE .= ' -DTIME_HIRES_UTIME'; + print "You seem to have subsecond timestamp setting.\n"; + } else { + print "You do NOT seem to have subsecond timestamp setting.\n"; } print "Looking for stat() subsecond timestamps...\n"; @@ -838,14 +852,18 @@ EOM DEFINE('TIME_HIRES_STAT', 4); } elsif ($has_stat_st_uxtime) { DEFINE('TIME_HIRES_STAT', 5); - } + } - if ($DEFINE =~ /-DTIME_HIRES_STAT=\d+/) { - print "You seem to have stat() subsecond timestamps.\n"; - print "(Your struct stat has them, but the filesystems must help.)\n"; - } else { - print "You do not seem to have stat subsecond timestamps.\n"; - } + my $has_hires_stat = ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/) ? $1 : 0; + if ($has_hires_stat) { + print "You seem to have subsecond timestamp reading.\n"; + print "(Your struct stat has them, but the filesystems must help.)\n"; + unless ($has_hires_utime) { + print "However, you do NOT seem to have subsecond timestamp setting.\n"; + } + } else { + print "You do NOT seem to have subsecond timestamp reading.\n"; + } my $has_w32api_windows_h; @@ -864,7 +882,7 @@ EOM if ($DEFINE) { $DEFINE =~ s/^\s+//; - if (open(XDEFINE, ">xdefine")) { + if (open(XDEFINE, '>', 'xdefine')) { print XDEFINE $DEFINE, "\n"; close(XDEFINE); } @@ -895,10 +913,10 @@ sub doMakefile { 'PREREQ_PM' => { 'Carp' => 0, 'Config' => 0, - 'DynaLoader' => 0, 'Exporter' => 0, 'ExtUtils::MakeMaker' => 0, 'Test::More' => 0, + 'XSLoader' => 0, 'strict' => 0, }, 'dist' => { @@ -936,7 +954,7 @@ sub doMakefile { } if ($ExtUtils::MakeMaker::VERSION >= 6.48) { - push @makefileopts, (MIN_PERL_VERSION => '5.008',); + push @makefileopts, (MIN_PERL_VERSION => '5.006',); } if ($ExtUtils::MakeMaker::VERSION >= 6.31) { @@ -948,31 +966,38 @@ sub doMakefile { sub doConstants { if (eval {require ExtUtils::Constant; 1}) { + # More or less this same list is in HiRes.pm. Should unify. my @names = qw( - CLOCKS_PER_SEC - CLOCK_BOOTTIME - CLOCK_HIGHRES - CLOCK_MONOTONIC - CLOCK_MONOTONIC_COARSE - CLOCK_MONOTONIC_PRECISE - CLOCK_MONOTONIC_RAW - CLOCK_PROCESS_CPUTIME_ID - CLOCK_REALTIME - CLOCK_REALTIME_COARSE - CLOCK_REALTIME_FAST - CLOCK_REALTIME_PRECISE - CLOCK_SECOND - CLOCK_SOFTTIME - CLOCK_THREAD_CPUTIME_ID - CLOCK_TIMEOFDAY - CLOCK_UPTIME - CLOCK_UPTIME_FAST - CLOCK_UPTIME_PRECISE - ITIMER_PROF - ITIMER_REAL - ITIMER_REALPROF - ITIMER_VIRTUAL - TIMER_ABSTIME + CLOCKS_PER_SEC + CLOCK_BOOTTIME + CLOCK_HIGHRES + CLOCK_MONOTONIC + CLOCK_MONOTONIC_COARSE + CLOCK_MONOTONIC_FAST + CLOCK_MONOTONIC_PRECISE + CLOCK_MONOTONIC_RAW + CLOCK_PROF + CLOCK_PROCESS_CPUTIME_ID + CLOCK_REALTIME + CLOCK_REALTIME_COARSE + CLOCK_REALTIME_FAST + CLOCK_REALTIME_PRECISE + CLOCK_REALTIME_RAW + CLOCK_SECOND + CLOCK_SOFTTIME + CLOCK_THREAD_CPUTIME_ID + CLOCK_TIMEOFDAY + CLOCK_UPTIME + CLOCK_UPTIME_COARSE + CLOCK_UPTIME_FAST + CLOCK_UPTIME_PRECISE + CLOCK_UPTIME_RAW + CLOCK_VIRTUAL + ITIMER_PROF + ITIMER_REAL + ITIMER_REALPROF + ITIMER_VIRTUAL + TIMER_ABSTIME ); foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer d_nanosleep d_clock_gettime d_clock_getres @@ -982,15 +1007,16 @@ sub doConstants { if ($macro =~ /^(d_nanosleep|d_clock)$/) { $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/; } elsif ($macro =~ /^(d_hires_stat)$/) { - my $d_hires_stat = 0; - $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/); - push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat, - default => ["IV", "0"]}; - next; + my $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/); + if (defined $d_hires_stat) { + push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat, + default => ["IV", "0"]}; + next; + } } elsif ($macro =~ /^(d_hires_utime)$/) { my $d_hires_utime = - ($DEFINE =~ /-DHAS_FUTIMENS/ || - $DEFINE =~ /-DHAS_UTIMENSAT/) ? 1 : 0; + ($DEFINE =~ /-DHAS_FUTIMENS/ || + $DEFINE =~ /-DHAS_UTIMENSAT/); push @names, {name => $_, macro => "TIME_HIRES_UTIME", value => $d_hires_utime, default => ["IV", "0"]}; next; @@ -1015,8 +1041,8 @@ sub doConstants { foreach $file ('const-c.inc', 'const-xs.inc') { my $fallback = File::Spec->catfile('fallback', $file); local $/; - open IN, "<$fallback" or die "Can't open $fallback: $!"; - open OUT, ">$file" or die "Can't open $file: $!"; + open IN, '<', $fallback or die "Can't open $fallback: $!"; + open OUT, '>', $file or die "Can't open $file: $!"; print OUT <IN> or die $!; close OUT or die "Can't close $file: $!"; close IN or die "Can't close $fallback: $!"; @@ -1025,9 +1051,11 @@ sub doConstants { } sub main { - if (-f "xdefine" && !(@ARGV && $ARGV[0] eq '--configure')) { + if (-f "xdefine" && !(@ARGV && $ARGV[0] =~ /^--(?:configure|force)$/)) { print qq[$0: The "xdefine" exists, skipping the configure step.\n]; - print qq[("$^X $0 --configure" to force the configure step)\n]; + print qq[Use "$^X $0 --configure"\n]; + print qq[or: "$^X $0 --force\n]; + print qq[to force the configure step.\n]; } else { print "Configuring Time::HiRes...\n"; 1 while unlink("define"); @@ -1035,7 +1063,7 @@ sub main { DEFINE('SELECT_IS_BROKEN'); $LIBS = []; print "System is $^O, skipping full configure...\n"; - open(XDEFINE, ">xdefine") or die "$0: Cannot create xdefine: $!\n"; + open(XDEFINE, '>', 'xdefine') or die "$0: Cannot create xdefine: $!\n"; close(XDEFINE); } else { init(); diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc b/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc index 524db169a9f..2c29a0b1414 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc +++ b/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc @@ -24,7 +24,7 @@ static int constant_11 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - ITIMER_PROF ITIMER_REAL d_getitimer d_nanosleep d_setitimer */ + ITIMER_PROF ITIMER_REAL d_getitimer d_nanosleep d_setitimer d_utimensat */ /* Offset 7 gives the best switch position. */ switch (name[7]) { case 'P': @@ -83,6 +83,63 @@ constant_11 (pTHX_ const char *name, IV *iv_return) { #endif } break; + case 'n': + if (memEQ(name, "d_utimensat", 11)) { + /* ^ */ +#ifdef HAS_UTIMENSAT + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_12 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CLOCK_SECOND CLOCK_UPTIME d_hires_stat */ + /* Offset 10 gives the best switch position. */ + switch (name[10]) { + case 'M': + if (memEQ(name, "CLOCK_UPTIME", 12)) { + /* ^ */ +#ifdef CLOCK_UPTIME + *iv_return = CLOCK_UPTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "CLOCK_SECOND", 12)) { + /* ^ */ +#ifdef CLOCK_SECOND + *iv_return = CLOCK_SECOND; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'a': + if (memEQ(name, "d_hires_stat", 12)) { + /* ^ */ +#ifdef TIME_HIRES_STAT + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; } return PERL_constant_NOTFOUND; } @@ -91,12 +148,12 @@ static int constant_13 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - CLOCK_HIGHRES TIMER_ABSTIME d_hires_utime */ - /* Offset 1 gives the best switch position. */ - switch (name[1]) { - case 'I': - if (memEQ(name, "TIMER_ABSTIME", 13)) { - /* ^ */ + CLOCK_HIGHRES CLOCK_VIRTUAL TIMER_ABSTIME d_hires_utime */ + /* Offset 12 gives the best switch position. */ + switch (name[12]) { + case 'E': + if (memEQ(name, "TIMER_ABSTIM", 12)) { + /* E */ #ifdef TIMER_ABSTIME *iv_return = TIMER_ABSTIME; return PERL_constant_ISIV; @@ -106,8 +163,19 @@ constant_13 (pTHX_ const char *name, IV *iv_return) { } break; case 'L': - if (memEQ(name, "CLOCK_HIGHRES", 13)) { - /* ^ */ + if (memEQ(name, "CLOCK_VIRTUA", 12)) { + /* L */ +#ifdef CLOCK_VIRTUAL + *iv_return = CLOCK_VIRTUAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "CLOCK_HIGHRE", 12)) { + /* S */ #ifdef CLOCK_HIGHRES *iv_return = CLOCK_HIGHRES; return PERL_constant_ISIV; @@ -116,9 +184,9 @@ constant_13 (pTHX_ const char *name, IV *iv_return) { #endif } break; - case '_': - if (memEQ(name, "d_hires_utime", 13)) { - /* ^ */ + case 'e': + if (memEQ(name, "d_hires_utim", 12)) { + /* e */ #ifdef TIME_HIRES_UTIME *iv_return = 1; return PERL_constant_ISIV; @@ -136,8 +204,8 @@ static int constant_14 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - CLOCKS_PER_SEC CLOCK_REALTIME CLOCK_SOFTTIME ITIMER_VIRTUAL d_clock_getres - d_gettimeofday */ + CLOCKS_PER_SEC CLOCK_BOOTTIME CLOCK_REALTIME CLOCK_SOFTTIME ITIMER_VIRTUAL + d_clock_getres d_gettimeofday */ /* Offset 8 gives the best switch position. */ switch (name[8]) { case 'A': @@ -184,6 +252,17 @@ constant_14 (pTHX_ const char *name, IV *iv_return) { #endif } break; + case 'O': + if (memEQ(name, "CLOCK_BOOTTIME", 14)) { + /* ^ */ +#ifdef CLOCK_BOOTTIME + *iv_return = CLOCK_BOOTTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; case 'e': if (memEQ(name, "d_gettimeofday", 14)) { /* ^ */ @@ -269,6 +348,50 @@ constant_15 (pTHX_ const char *name, IV *iv_return) { } static int +constant_19 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CLOCK_MONOTONIC_RAW CLOCK_REALTIME_FAST CLOCK_UPTIME_COARSE */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'I': + if (memEQ(name, "CLOCK_UPTIME_COARSE", 19)) { + /* ^ */ +#ifdef CLOCK_UPTIME_COARSE + *iv_return = CLOCK_UPTIME_COARSE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "CLOCK_REALTIME_FAST", 19)) { + /* ^ */ +#ifdef CLOCK_REALTIME_FAST + *iv_return = CLOCK_REALTIME_FAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "CLOCK_MONOTONIC_RAW", 19)) { + /* ^ */ +#ifdef CLOCK_MONOTONIC_RAW + *iv_return = CLOCK_MONOTONIC_RAW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { /* Initially switch on the length of the name. */ /* When generated this function returned values for the list of names given @@ -281,18 +404,25 @@ constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { Regenerate these constant functions by feeding this entire source file to perl -x -#!perl -w +#!/opt/local/perl-5.25.6/bin/perl -w use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV)}; -my @names = (qw(CLOCKS_PER_SEC CLOCK_HIGHRES CLOCK_MONOTONIC - CLOCK_PROCESS_CPUTIME_ID CLOCK_REALTIME CLOCK_SOFTTIME - CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY ITIMER_PROF ITIMER_REAL +my @names = (qw(CLOCKS_PER_SEC CLOCK_BOOTTIME CLOCK_HIGHRES CLOCK_MONOTONIC + CLOCK_MONOTONIC_COARSE CLOCK_MONOTONIC_FAST + CLOCK_MONOTONIC_PRECISE CLOCK_MONOTONIC_RAW + CLOCK_PROCESS_CPUTIME_ID CLOCK_PROF CLOCK_REALTIME + CLOCK_REALTIME_COARSE CLOCK_REALTIME_FAST CLOCK_REALTIME_PRECISE + CLOCK_REALTIME_RAW CLOCK_SECOND CLOCK_SOFTTIME + CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY CLOCK_UPTIME + CLOCK_UPTIME_COARSE CLOCK_UPTIME_FAST CLOCK_UPTIME_PRECISE + CLOCK_UPTIME_RAW CLOCK_VIRTUAL ITIMER_PROF ITIMER_REAL ITIMER_REALPROF ITIMER_VIRTUAL TIMER_ABSTIME), {name=>"d_clock", type=>"IV", macro=>"TIME_HIRES_CLOCK", value=>"1", default=>["IV", "0"]}, {name=>"d_clock_getres", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETRES", value=>"1", default=>["IV", "0"]}, {name=>"d_clock_gettime", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETTIME", value=>"1", default=>["IV", "0"]}, {name=>"d_clock_nanosleep", type=>"IV", macro=>"TIME_HIRES_CLOCK_NANOSLEEP", value=>"1", default=>["IV", "0"]}, + {name=>"d_futimens", type=>"IV", macro=>"HAS_FUTIMENS", value=>"1", default=>["IV", "0"]}, {name=>"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]}, {name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]}, {name=>"d_hires_stat", type=>"IV", macro=>"TIME_HIRES_STAT", value=>"1", default=>["IV", "0"]}, @@ -300,7 +430,8 @@ my @names = (qw(CLOCKS_PER_SEC CLOCK_HIGHRES CLOCK_MONOTONIC {name=>"d_nanosleep", type=>"IV", macro=>"TIME_HIRES_NANOSLEEP", value=>"1", default=>["IV", "0"]}, {name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]}, {name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]}, - {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]}); + {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]}, + {name=>"d_utimensat", type=>"IV", macro=>"HAS_UTIMENSAT", value=>"1", default=>["IV", "0"]}); print constant_types(), "\n"; # macro defs foreach (C_constant ("Time::HiRes", 'constant', 'IV', $types, undef, 3, @names) ) { @@ -354,19 +485,41 @@ __END__ break; } break; + case 10: + /* Names all of length 10. */ + /* CLOCK_PROF d_futimens */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case '_': + if (memEQ(name, "CLOCK_PROF", 10)) { + /* ^ */ +#ifdef CLOCK_PROF + *iv_return = CLOCK_PROF; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'i': + if (memEQ(name, "d_futimens", 10)) { + /* ^ */ +#ifdef HAS_FUTIMENS + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + break; case 11: return constant_11 (aTHX_ name, iv_return); break; case 12: - if (memEQ(name, "d_hires_stat", 12)) { -#ifdef TIME_HIRES_STAT - *iv_return = 1; - return PERL_constant_ISIV; -#else - *iv_return = 0; - return PERL_constant_ISIV; -#endif - } + return constant_12 (aTHX_ name, iv_return); break; case 13: return constant_13 (aTHX_ name, iv_return); @@ -377,25 +530,154 @@ __END__ case 15: return constant_15 (aTHX_ name, iv_return); break; + case 16: + if (memEQ(name, "CLOCK_UPTIME_RAW", 16)) { +#ifdef CLOCK_UPTIME_RAW + *iv_return = CLOCK_UPTIME_RAW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; case 17: - if (memEQ(name, "d_clock_nanosleep", 17)) { + /* Names all of length 17. */ + /* CLOCK_UPTIME_FAST d_clock_nanosleep */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case '_': + if (memEQ(name, "CLOCK_UPTIME_FAST", 17)) { + /* ^ */ +#ifdef CLOCK_UPTIME_FAST + *iv_return = CLOCK_UPTIME_FAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'c': + if (memEQ(name, "d_clock_nanosleep", 17)) { + /* ^ */ #ifdef TIME_HIRES_CLOCK_NANOSLEEP - *iv_return = 1; + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + break; + case 18: + if (memEQ(name, "CLOCK_REALTIME_RAW", 18)) { +#ifdef CLOCK_REALTIME_RAW + *iv_return = CLOCK_REALTIME_RAW; return PERL_constant_ISIV; #else - *iv_return = 0; + return PERL_constant_NOTDEF; +#endif + } + break; + case 19: + return constant_19 (aTHX_ name, iv_return); + break; + case 20: + /* Names all of length 20. */ + /* CLOCK_MONOTONIC_FAST CLOCK_UPTIME_PRECISE */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'O': + if (memEQ(name, "CLOCK_MONOTONIC_FAST", 20)) { + /* ^ */ +#ifdef CLOCK_MONOTONIC_FAST + *iv_return = CLOCK_MONOTONIC_FAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "CLOCK_UPTIME_PRECISE", 20)) { + /* ^ */ +#ifdef CLOCK_UPTIME_PRECISE + *iv_return = CLOCK_UPTIME_PRECISE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + case 21: + if (memEQ(name, "CLOCK_REALTIME_COARSE", 21)) { +#ifdef CLOCK_REALTIME_COARSE + *iv_return = CLOCK_REALTIME_COARSE; return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; #endif } break; + case 22: + /* Names all of length 22. */ + /* CLOCK_MONOTONIC_COARSE CLOCK_REALTIME_PRECISE */ + /* Offset 12 gives the best switch position. */ + switch (name[12]) { + case 'M': + if (memEQ(name, "CLOCK_REALTIME_PRECISE", 22)) { + /* ^ */ +#ifdef CLOCK_REALTIME_PRECISE + *iv_return = CLOCK_REALTIME_PRECISE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "CLOCK_MONOTONIC_COARSE", 22)) { + /* ^ */ +#ifdef CLOCK_MONOTONIC_COARSE + *iv_return = CLOCK_MONOTONIC_COARSE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; case 23: - if (memEQ(name, "CLOCK_THREAD_CPUTIME_ID", 23)) { + /* Names all of length 23. */ + /* CLOCK_MONOTONIC_PRECISE CLOCK_THREAD_CPUTIME_ID */ + /* Offset 22 gives the best switch position. */ + switch (name[22]) { + case 'D': + if (memEQ(name, "CLOCK_THREAD_CPUTIME_I", 22)) { + /* D */ #ifdef CLOCK_THREAD_CPUTIME_ID - *iv_return = CLOCK_THREAD_CPUTIME_ID; - return PERL_constant_ISIV; + *iv_return = CLOCK_THREAD_CPUTIME_ID; + return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "CLOCK_MONOTONIC_PRECIS", 22)) { + /* E */ +#ifdef CLOCK_MONOTONIC_PRECISE + *iv_return = CLOCK_MONOTONIC_PRECISE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; #endif + } + break; } break; case 24: diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t index f600f99256c..af34d2a5619 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t @@ -1,6 +1,7 @@ use strict; use Test::More tests => 10; +BEGIN { push @INC, '.' } use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -10,7 +11,7 @@ use Config; my $limit = 0.25; # 25% is acceptable slosh for testing timers my $xdefine = ''; -if (open(XDEFINE, "xdefine")) { +if (open(XDEFINE, "<", "xdefine")) { chomp($xdefine = <XDEFINE> || ""); close(XDEFINE); } @@ -41,6 +42,9 @@ SKIP: { # Perl's deferred signals may be too wimpy to break through # a restartable select(), so use POSIX::sigaction if available. + # In perl 5.6.2 you will get a likely bogus warning of + # "Use of uninitialized value in subroutine entry" from + # the following line. POSIX::sigaction(&POSIX::SIGALRM, POSIX::SigAction->new("tick"), $oldaction) diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t index 346ca57fbf5..64478b015c5 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t @@ -1,6 +1,7 @@ use strict; use Test::More tests => 5; +BEGIN { push @INC, '.' } use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -78,10 +79,16 @@ SKIP: { SKIP: { skip "no clock", 1 unless &Time::HiRes::d_clock; + skip "no CLOCKS_PER_SEC", 1 unless has_symbol("CLOCKS_PER_SEC"); my @clock = Time::HiRes::clock(); + # If we have a relatively low precision clock() and we haven't seen much + # CPU usage thus far with clock(), we will want to have a bit longer delay. + my $delay = $clock[0] < (5 / &Time::HiRes::CLOCKS_PER_SEC) ? 1e7 : 1e6; + printf("# CLOCKS_PER_SEC = %d\n", &Time::HiRes::CLOCKS_PER_SEC); + printf("# delay = %d\n", $delay); print("# clock = @clock\n"); for my $i (1..3) { - for (my $j = 0; $j < 1e6; $j++) { } + for (my $j = 0; $j < $delay; $j++) { } push @clock, Time::HiRes::clock(); print("# clock = @clock\n"); } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t index 69defe8672e..9f2fd7e9f7b 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t @@ -9,6 +9,7 @@ BEGIN { } use Test::More tests => 6; +BEGIN { push @INC, '.' } use t::Watchdog; my @one = Time::HiRes::gettimeofday(); diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t index 31cdd674ae7..e196b1648c1 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t @@ -26,6 +26,7 @@ BEGIN { } use Test::More tests => 2; +BEGIN { push @INC, '.' } use t::Watchdog; my $limit = 0.25; # 25% is acceptable slosh for testing timers diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t index c17a7e4790e..98cc8d96708 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t @@ -8,7 +8,8 @@ BEGIN { } } -use Test::More tests => 3; +use Test::More tests => 4; +BEGIN { push @INC, '.' } use t::Watchdog; eval { Time::HiRes::nanosleep(-5) }; @@ -24,12 +25,14 @@ ok $one == $two || $two == $three or print("# slept too long, $one $two $three\n"); SKIP: { - skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; + skip "no gettimeofday", 2 unless &Time::HiRes::d_gettimeofday; my $f = Time::HiRes::time(); Time::HiRes::nanosleep(500_000_000); my $f2 = Time::HiRes::time(); my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n"); + cmp_ok $d, '>', 0.4, "nanosleep for more than 0.4 sec"; + skip "flapping test - more than 0.9 sec could be necessary...", 1 if $ENV{CI}; + cmp_ok $d, '<', 0.9 or diag("# slept $d secs $f to $f2\n"); } 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t index c4d802be402..0ab634072de 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t @@ -1,6 +1,7 @@ use strict; use Test::More tests => 4; +BEGIN { push @INC, '.' } use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -8,7 +9,7 @@ BEGIN { require_ok "Time::HiRes"; } use Config; my $xdefine = ''; -if (open(XDEFINE, "xdefine")) { +if (open(XDEFINE, "<", "xdefine")) { chomp($xdefine = <XDEFINE> || ""); close(XDEFINE); } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t index e7552b5e256..d5e22acb46f 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t @@ -14,13 +14,14 @@ BEGIN { } use Test::More tests => 43; +BEGIN { push @INC, '.' } use t::Watchdog; my @atime; my @mtime; for (1..5) { Time::HiRes::sleep(rand(0.1) + 0.1); - open(X, ">$$"); + open(X, '>', $$); print X $$; close(X); my($a, $stat, $b) = ("a", [Time::HiRes::stat($$)], "b"); @@ -33,7 +34,7 @@ for (1..5) { is $b, "b"; is_deeply $lstat, $stat; Time::HiRes::sleep(rand(0.1) + 0.1); - open(X, "<$$"); + open(X, '<', $$); <X>; close(X); $stat = [Time::HiRes::stat($$)]; @@ -75,7 +76,7 @@ SKIP: { my $targetname = "tgt$$"; my $linkname = "link$$"; SKIP: { - open(X, ">$targetname"); + open(X, '>', $targetname); print X $$; close(X); eval { symlink $targetname, $linkname or die "can't symlink: $!"; }; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t index 6f219f9e0c4..5db016f4cf2 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t @@ -1,6 +1,7 @@ use strict; use Test::More tests => 2; +BEGIN { push @INC, '.' } use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t index b50a175f449..0f9a829a1ad 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t @@ -9,6 +9,7 @@ BEGIN { } use Test::More tests => 12; +BEGIN { push @INC, '.' } use t::Watchdog; use Config; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t index bdf372bd163..bb66cbe62cb 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t @@ -9,6 +9,7 @@ BEGIN { } use Test::More tests => 6; +BEGIN { push @INC, '.' } use t::Watchdog; eval { Time::HiRes::usleep(-2) }; @@ -31,7 +32,7 @@ SKIP: { Time::HiRes::usleep(500_000); my $f2 = Time::HiRes::time(); my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n"); + ok $d > 0.49 or print("# slept $d secs $f to $f2\n"); } SKIP: { @@ -39,7 +40,7 @@ SKIP: { my $r = [ Time::HiRes::gettimeofday() ]; Time::HiRes::sleep( 0.5 ); my $f = Time::HiRes::tv_interval $r; - ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n"); + ok $f > 0.49 or print("# slept $f instead of 0.5 secs.\n"); } SKIP: { diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/utime.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/utime.t index e64f99bfbe2..7fd4604b352 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/utime.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/utime.t @@ -1,5 +1,94 @@ use strict; +sub has_subsecond_file_times { + require File::Temp; + require Time::HiRes; + my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" ); + use File::Basename qw[dirname]; + my $dirname = dirname($filename); + require Cwd; + $dirname = &Cwd::getcwd if $dirname eq '.'; + print("\n# Testing for subsecond file timestamps (mtime) in $dirname\n"); + close $fh; + my @mtimes; + for (1..2) { + open $fh, '>', $filename; + print $fh "foo"; + close $fh; + push @mtimes, (Time::HiRes::stat($filename))[9]; + Time::HiRes::sleep(.1) if $_ == 1; + } + my $delta = $mtimes[1] - $mtimes[0]; + # print STDERR "mtimes = @mtimes, delta = $delta\n"; + unlink $filename; + my $ok = $delta > 0 && $delta < 1; + printf("# Subsecond file timestamps in $dirname: %s\n", + $ok ? "OK" : "NO"); + return $ok; +} + +sub get_filesys_of_tempfile { + require File::Temp; + require Time::HiRes; + my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" ); + my $filesys; + if (open(my $df, "df $filename |")) { + my @fs; + while (<$df>) { + next if /^Filesystem/; + chomp; + push @fs, $_; + } + if (@fs == 1) { + if (defined $fs[0] && length($fs[0])) { + $filesys = $fs[0]; + } else { + printf("# Got empty result from 'df'\n"); + } + } else { + printf("# Expected one result from 'df', got %d\n", scalar(@fs)); + } + } else { + # Too noisy to show by default. + # Can fail for too many reasons. + print "# Failed to run 'df $filename |': $!\n"; + } + return $filesys; +} + +sub get_mount_of_filesys { + my ($filesys) = @_; + # netbsd has /sbin/mount + local $ENV{PATH} = "$ENV{PATH}:/sbin" if $^O =~ /^(?:netbsd)$/; + if (defined $filesys) { + my @fs = split(' ', $filesys); + if (open(my $mount, "mount |")) { + while (<$mount>) { + chomp; + my @mnt = split(' '); + if ($mnt[0] eq $fs[0]) { + return $_; + } + } + } else { + # Too noisy to show by default. + # The mount(8) might not be in the PATH, for example. + # Or this might be a completely non-UNIX system. + # print "# Failed to run 'mount |': $!\n"; + } + } + return; +} + +sub get_mount_of_tempfile { + return get_mount_of_filesys(get_filesys_of_tempfile()); +} + +sub tempfile_has_noatime_mount { + my ($mount) = get_mount_of_tempfile(); + return $mount =~ /\bnoatime\b/; +} + BEGIN { require Time::HiRes; require Test::More; @@ -7,50 +96,31 @@ BEGIN { unless(&Time::HiRes::d_hires_utime) { Test::More::plan(skip_all => "no hires_utime"); } + unless(&Time::HiRes::d_hires_stat) { + # Being able to read subsecond timestamps is a reasonable + # prerequisite for being able to write them. + Test::More::plan(skip_all => "no hires_stat"); + } unless (&Time::HiRes::d_futimens) { Test::More::plan(skip_all => "no futimens()"); } unless (&Time::HiRes::d_utimensat) { Test::More::plan(skip_all => "no utimensat()"); } - if ($^O eq 'gnukfreebsd') { - Test::More::plan(skip_all => "futimens() and utimensat() not working in $^O"); - } - if ($^O eq 'linux' && -e '/proc/mounts') { - # The linux might be wrong when ext3 - # is available in other operating systems, - # but then we need other methods for detecting - # the filesystem type of the tempfiles. - my ($fh, $fn) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1); - sub getfstype { - my ($fn) = @_; - my $cmd = "df $fn"; - open(my $df, "$cmd |") or die "$cmd: $!"; - my @df = <$df>; # Assume $df[0] is header line. - my $dev = +(split(" ", $df[1]))[0]; - open(my $mounts, "/proc/mounts") or die "/proc/mounts: $!"; - while (<$mounts>) { - my @m = split(" "); - if ($m[0] eq $dev) { return $m[2] } - } - return; - } - my $fstype = getfstype($fn); - unless (defined $fstype) { - warn "Unknown fstype for $fn\n"; - } else { - print "# fstype = $fstype\n"; - if ($fstype eq 'ext3' || $fstype eq 'ext2') { - Test::More::plan(skip_all => "fstype $fstype has no subsecond timestamps in $^O"); - } - } + unless (has_subsecond_file_times()) { + Test::More::plan(skip_all => "No subsecond file timestamps"); } } use Test::More tests => 18; +BEGIN { push @INC, '.' } use t::Watchdog; use File::Temp qw( tempfile ); +BEGIN { + *done_testing = sub {} unless defined &done_testing; +} + use Config; # Hope initially for nanosecond accuracy. @@ -64,12 +134,21 @@ if ($^O eq 'cygwin') { } print "# \$^O = $^O, atime = $atime, mtime = $mtime\n"; +my $skip_atime = $^O eq 'netbsd' && tempfile_has_noatime_mount(); + +if ($skip_atime) { + printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'"); +} + print "# utime \$fh\n"; { my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed"; my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9]; - is $got_atime, $atime, "atime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + is $got_atime, $atime, "atime set correctly"; + } is $got_mtime, $mtime, "mtime set correctly"; }; @@ -78,7 +157,10 @@ print "#utime \$filename\n"; my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed"; my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9]; - is $got_atime, $atime, "atime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + is $got_atime, $atime, "atime set correctly"; + } is $got_mtime, $mtime, "mtime set correctly"; }; @@ -89,12 +171,18 @@ print "utime \$filename and \$fh\n"; is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed"; { my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9]; - is $got_atime, $atime, "File 1 atime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + is $got_atime, $atime, "File 1 atime set correctly"; + } is $got_mtime, $mtime, "File 1 mtime set correctly"; } { my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9]; - is $got_atime, $atime, "File 2 atime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + is $got_atime, $atime, "File 2 atime set correctly"; + } is $got_mtime, $mtime, "File 2 mtime set correctly"; } }; @@ -105,17 +193,24 @@ print "# utime undef sets time to now\n"; my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); my $now = Time::HiRes::time; + sleep(1); is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed"; { my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9]; - cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly"; - cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly"; + } + cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly"; } { my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9]; - cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly"; - cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly"; + SKIP: { + skip("noatime mount", 1) if $skip_atime; + cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly"; + } + cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly"; } }; @@ -133,6 +228,6 @@ print "# negative mtime dies;\n"; "negative time error"; }; -done_testing; +done_testing(); 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/typemap b/gnu/usr.bin/perl/dist/Time-HiRes/typemap index 3fa91f3a0b3..ffe60e3694a 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/typemap +++ b/gnu/usr.bin/perl/dist/Time-HiRes/typemap @@ -282,8 +282,9 @@ T_ARRAY } T_STDIO { - GV *gv = newGVgen("$Package"); + GV *gv = (GV *)sv_newmortal(); PerlIO *fp = PerlIO_importFILE($var,0); + gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else @@ -291,7 +292,8 @@ T_STDIO } T_IN { - GV *gv = newGVgen("$Package"); + GV *gv = (GV *)sv_newmortal(); + gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else @@ -299,7 +301,8 @@ T_IN } T_INOUT { - GV *gv = newGVgen("$Package"); + GV *gv = (GV *)sv_newmortal(); + gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else @@ -307,7 +310,8 @@ T_INOUT } T_OUT { - GV *gv = newGVgen("$Package"); + GV *gv = (GV *)sv_newmortal(); + gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else diff --git a/gnu/usr.bin/perl/dist/XSLoader/Makefile.PL b/gnu/usr.bin/perl/dist/XSLoader/Makefile.PL index 899cc89a314..69b52340bdf 100644 --- a/gnu/usr.bin/perl/dist/XSLoader/Makefile.PL +++ b/gnu/usr.bin/perl/dist/XSLoader/Makefile.PL @@ -6,16 +6,20 @@ # Alternatively, you can say the hell with this and use h2xs. use ExtUtils::MakeMaker; +use ExtUtils::MM_Unix; eval 'use ExtUtils::MakeMaker::Coverage'; $PACKAGE = 'XSLoader'; ($PACKAGE_FILE = $PACKAGE) =~ s|::|/|g; $LAST_API_CHANGE = 0; +$CURRENT_VERSION = ${$PACKAGE.'::VERSION'}; +$NEW_VERSION = ExtUtils::MM_Unix->parse_version("XSLoader_pm.PL"); + eval "require $PACKAGE"; unless ($@) { # Make sure we did find the module. - print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE; + print <<"CHANGE_WARN" if $CURRENT_VERSION < $LAST_API_CHANGE; NOTE: There have been API changes between this version and any older than version $LAST_API_CHANGE! Please read the Changes file if you @@ -42,16 +46,35 @@ WriteMakefile( PL_FILES => { 'XSLoader_pm.PL' => 'XSLoader.pm' }, PM => { 'XSLoader.pm' => '$(INST_ARCHLIB)/XSLoader.pm' }, PREREQ_PM => { + # NOTE: If we should require a Test::More version higher than 0.98 + # (that included with perl 5.14), we need to remove the meta-spec + # entry below for EUMM 6.57_02 to 6.57_06 (the buggy versions + # included with perl 5.14). Otherwise installation will break. + # See https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues/118 + # for details. 'Test::More' => '0.47', }, META_MERGE => { - resources => { - repository => 'git://perl5.git.perl.org/perl.git', - license => 'http://dev.perl.org/licenses/', + 'meta-spec' => { version => 2 }, + dynamic_config => 0, + resources => { + repository => { + type => 'git', + url => 'git://perl5.git.perl.org/perl.git', + }, homepage => 'https://metacpan.org/module/XSLoader', - irc => 'irc://irc.perl.org/#p5p', - mailinglist => 'http://lists.perl.org/list/perl5-porters.html', - bugtracker => "https://rt.perl.org/rt3/Search/Results.html?Query=Queue='perl5' AND Content LIKE 'module=XSLoader' AND (Status='open' OR Status='new' OR Status='stalled')", + x_IRC => 'irc://irc.perl.org/#p5p', + x_MailingList => 'http://lists.perl.org/list/perl5-porters.html', + bugtracker => { + mailto => 'perlbug@perl.org', + web => "https://rt.perl.org/rt3/Search/Results.html?Query=Queue='perl5' AND Content LIKE 'module=XSLoader' AND (Status='open' OR Status='new' OR Status='stalled')", + }, + }, + provides => { + 'XSLoader' => { + file => 'XSLoader_pm.PL', + version => $NEW_VERSION, + }, }, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, diff --git a/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL b/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL index 09f9d4b11e1..66e4c2d6315 100644 --- a/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL +++ b/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL @@ -4,14 +4,14 @@ use Config; eval { require DynaLoader }; 1 while unlink "XSLoader.pm"; -open OUT, ">XSLoader.pm" or die $!; +open OUT, '>', 'XSLoader.pm' or die $!; print OUT <<'EOT'; -# Generated from XSLoader.pm.PL (resolved %Config::Config value) +# Generated from XSLoader_pm.PL (resolved %Config::Config value) # This file is unique for every OS package XSLoader; -$VERSION = "0.22"; +$VERSION = "0.30"; # remember to update version in POD! #use strict; @@ -66,6 +66,7 @@ sub load { my @modparts = split(/::/,$module); my $modfname = $modparts[-1]; + my $modfname_orig = $modfname; # For .bs file search EOT @@ -140,17 +141,13 @@ print OUT <<'EOT'; # print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; - my $bs = $file; - $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + # N.B. The .bs file does not following the naming convention used + # by mod2fname, so use the unedited version of the name. - if (-s $bs) { # only read file if it's not empty -# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; - eval { do $bs; }; - warn "$bs: $@\n" if $@; - goto \&XSLoader::bootstrap_inherit; - } + my $bs = "$modlibname/auto/$modpname/$modfname_orig.bs"; - goto \&XSLoader::bootstrap_inherit if not -f $file; + # This calls DynaLoader::bootstrap, which will load the .bs file if present + goto \&XSLoader::bootstrap_inherit if not -f $file or -s $bs; my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @@ -255,14 +252,14 @@ XSLoader - Dynamically load C libraries into Perl code =head1 VERSION -Version 0.22 +Version 0.30 =head1 SYNOPSIS package YourPackage; require XSLoader; - XSLoader::load(); + XSLoader::load(__PACKAGE__, $VERSION); =head1 DESCRIPTION @@ -283,7 +280,7 @@ A typical module using L<DynaLoader|DynaLoader> starts like this: our @ISA = qw( OnePackage OtherPackage DynaLoader ); our $VERSION = '0.01'; - bootstrap YourPackage $VERSION; + __PACKAGE__->bootstrap($VERSION); Change this to @@ -292,7 +289,7 @@ Change this to our @ISA = qw( OnePackage OtherPackage ); our $VERSION = '0.01'; - XSLoader::load 'YourPackage', $VERSION; + XSLoader::load(__PACKAGE__, $VERSION); In other words: replace C<require DynaLoader> by C<use XSLoader>, remove C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not @@ -309,10 +306,9 @@ one can remove this reference to C<@ISA> together with the C<@ISA> assignment. If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes - XSLoader::load 'YourPackage'; + XSLoader::load(__PACKAGE__); -If the call to C<load> is from C<YourPackage>, then that can be further -simplified to +in which case it can be further simplified to XSLoader::load(); @@ -324,18 +320,17 @@ If you want to have your cake and eat it too, you need a more complicated boilerplate. package YourPackage; - use vars qw($VERSION @ISA); - @ISA = qw( OnePackage OtherPackage ); - $VERSION = '0.01'; + our @ISA = qw( OnePackage OtherPackage ); + our $VERSION = '0.01'; eval { require XSLoader; - XSLoader::load('YourPackage', $VERSION); + XSLoader::load(__PACKAGE__, $VERSION); 1; } or do { require DynaLoader; push @ISA, 'DynaLoader'; - bootstrap YourPackage $VERSION; + __PACKAGE__->bootstrap($VERSION); }; The parentheses about C<XSLoader::load()> arguments are needed since we replaced @@ -393,7 +388,7 @@ boilerplate as package YourPackage; use XSLoader; - use vars qw($VERSION @ISA); + our ($VERSION, @ISA); BEGIN { @ISA = qw( OnePackage OtherPackage ); @@ -401,7 +396,7 @@ boilerplate as # Put Perl code used in the BOOT: section here - XSLoader::load 'YourPackage', $VERSION; + XSLoader::load(__PACKAGE__, $VERSION); } # Put Perl code making calls into XSUBs here @@ -416,12 +411,12 @@ this: package YourPackage; use XSLoader; - use vars qw($VERSION @ISA); + our ($VERSION, @ISA); BEGIN { @ISA = qw( OnePackage OtherPackage ); $VERSION = '0.01'; - XSLoader::load 'YourPackage', $VERSION; + XSLoader::load(__PACKAGE__, $VERSION); } # Put Perl code used in onBOOT() function here; calls to XSUBs are diff --git a/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t b/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t index 1e86faa9ede..d3538b849cb 100755 --- a/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t +++ b/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t @@ -130,7 +130,7 @@ SKIP: { skip "File::Path not available", 1 unless eval { require File::Path }; my $name = "phooo$$"; - File::Path::make_path("$name/auto/Foo/Bar"); + File::Path::mkpath("$name/auto/Foo/Bar"); open my $fh, ">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}"; close $fh; @@ -148,5 +148,5 @@ END the_test: ok $fell_back, 'XSLoader will not load relative paths based on (caller)[1]'; - File::Path::remove_tree($name); + File::Path::rmtree($name); } diff --git a/gnu/usr.bin/perl/dist/autouse/t/autouse.t b/gnu/usr.bin/perl/dist/autouse/t/autouse.t index a790403f0f9..20ad9eb8d4d 100644 --- a/gnu/usr.bin/perl/dist/autouse/t/autouse.t +++ b/gnu/usr.bin/perl/dist/autouse/t/autouse.t @@ -98,13 +98,14 @@ SKIP: { SKIP: { skip "Fails in 5.15.5 and below (perl bug)", 1 if $] < 5.0150051; use Config; - skip "no B", 1 unless $Config{extensions} =~ /\bB\b/; + skip "no Hash::Util", 1 unless $Config{extensions} =~ /\bHash::Util\b/; use warnings; local $^W = 1; no warnings 'once'; my $w; local $SIG{__WARN__} = sub { $w .= shift }; - use autouse B => "sv_undef"; - *B::sv_undef = \&sv_undef; - require B; + # any old XS sub from any old module which uses Exporter + use autouse 'Hash::Util' => "all_keys"; + *Hash::Util::all_keys = \&all_keys; + require Hash::Util; is $w, undef, 'no redefinition warning when clobbering autouse stub with new XSUB'; } diff --git a/gnu/usr.bin/perl/dist/base/Changes b/gnu/usr.bin/perl/dist/base/Changes index 44d579f7680..07755298acb 100644 --- a/gnu/usr.bin/perl/dist/base/Changes +++ b/gnu/usr.bin/perl/dist/base/Changes @@ -70,7 +70,7 @@ pseudohashes * Fixing inheritance from classes which have only private fields * Fixing inheritance when an intermediate class has no fields. - [perlbug 20020326.004] + [perlbug 20020326.004 (#8884)] - Removing uses of 'our' from tests for backwards compat. 2.02 Wed Sep 3 20:40:13 PDT 2003 diff --git a/gnu/usr.bin/perl/dist/base/lib/base.pm b/gnu/usr.bin/perl/dist/base/lib/base.pm index edb35494762..fb48fc295b2 100644 --- a/gnu/usr.bin/perl/dist/base/lib/base.pm +++ b/gnu/usr.bin/perl/dist/base/lib/base.pm @@ -2,8 +2,7 @@ use 5.008; package base; use strict 'vars'; -use vars qw($VERSION); -$VERSION = '2.23_01'; +our $VERSION = '2.27'; $VERSION =~ tr/_//d; # simplest way to avoid indexing of the package: no package statement diff --git a/gnu/usr.bin/perl/dist/base/lib/fields.pm b/gnu/usr.bin/perl/dist/base/lib/fields.pm index c40978bd90e..93eba95bf9b 100644 --- a/gnu/usr.bin/perl/dist/base/lib/fields.pm +++ b/gnu/usr.bin/perl/dist/base/lib/fields.pm @@ -10,9 +10,9 @@ unless( eval q{require warnings::register; warnings::register->import; 1} ) { Carp::carp(@_); } } -use vars qw(%attr $VERSION); +our %attr; -$VERSION = '2.23'; +our $VERSION = '2.24'; $VERSION =~ tr/_//d; # constant.pm is slow diff --git a/gnu/usr.bin/perl/dist/constant/t/constant.t b/gnu/usr.bin/perl/dist/constant/t/constant.t index 00eddfb6579..80147c6a2d7 100755 --- a/gnu/usr.bin/perl/dist/constant/t/constant.t +++ b/gnu/usr.bin/perl/dist/constant/t/constant.t @@ -1,7 +1,7 @@ #!./perl -T use warnings; -use vars qw{ @warnings $fagwoosh $putt $kloong}; +our ( @warnings, $fagwoosh, $putt, $kloong ); BEGIN { # ...and save 'em for later $SIG{'__WARN__'} = sub { push @warnings, @_ } } @@ -92,11 +92,13 @@ is ZERO3, '0.0'; cmp_ok(abs(PI - 3.1416), '<', 0.0001); is Other::PI, 3.141; -use constant E2BIG => $! = 7; -cmp_ok E2BIG, '==', 7; -# This is something like "Arg list too long", but the actual message -# text may vary, so we can't test much better than this. -cmp_ok length(E2BIG), '>', 6; +# Test that constant.pm can create a dualvar out of $! +use constant A_DUALVAR_CONSTANT => $! = 7; +cmp_ok A_DUALVAR_CONSTANT, '==', 7; +# Make sure we have an error message string. It does not +# matter that 7 means different things on different platforms. +# If this test fails, then either constant.pm or $! is broken: +cmp_ok length(A_DUALVAR_CONSTANT), '>', 6; is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings; @warnings = (); # just in case diff --git a/gnu/usr.bin/perl/dist/if/if.pm b/gnu/usr.bin/perl/dist/if/if.pm index 1985df4db18..166de7bb10c 100644 --- a/gnu/usr.bin/perl/dist/if/if.pm +++ b/gnu/usr.bin/perl/dist/if/if.pm @@ -1,6 +1,6 @@ package if; -$VERSION = '0.0606'; +$VERSION = '0.0608'; sub work { my $method = shift() ? 'import' : 'unimport'; @@ -25,67 +25,70 @@ __END__ =head1 NAME -if - C<use> a Perl module if a condition holds (also can C<no> a module) +if - C<use> a Perl module if a condition holds =head1 SYNOPSIS - use if CONDITION, MODULE => ARGUMENTS; - no if CONDITION, MODULE => ARGUMENTS; + use if CONDITION, "MODULE", ARGUMENTS; + no if CONDITION, "MODULE", ARGUMENTS; =head1 DESCRIPTION -The C<if> module is used to conditionally load or unload another module. -The construct +=head2 C<use if> - use if CONDITION, MODULE => ARGUMENTS; +The C<if> module is used to conditionally load another module. The construct: -will load MODULE only if CONDITION evaluates to true. -The above statement has no effect unless C<CONDITION> is true. -If the CONDITION does evaluate to true, then the above line has -the same effect as: + use if CONDITION, "MODULE", ARGUMENTS; - use MODULE ARGUMENTS; +... will load C<MODULE> only if C<CONDITION> evaluates to true; it has no +effect if C<CONDITION> evaluates to false. (The module name, assuming it +contains at least one C<::>, must be quoted when C<'use strict "subs";'> is in +effect.) If the CONDITION does evaluate to true, then the above line has the +same effect as: -The use of C<< => >> above provides necessary quoting of C<MODULE>. -If you don't use the fat comma (eg you don't have any ARGUMENTS), -then you'll need to quote the MODULE. + use MODULE ARGUMENTS; -=head2 EXAMPLES +For example, the F<Unicode::UCD> module's F<charinfo> function will use two functions from F<Unicode::Normalize> only if a certain condition is met: -The following line is taken from the testsuite for L<File::Map>: + use if defined &DynaLoader::boot_DynaLoader, + "Unicode::Normalize" => qw(getCombinClass NFD); - use if $^O ne 'MSWin32', POSIX => qw/setlocale LC_ALL/; +Suppose you wanted C<ARGUMENTS> to be an empty list, I<i.e.>, to have the +effect of: -If run on any operating system other than Windows, -this will import the functions C<setlocale> and C<LC_ALL> from L<POSIX>. -On Windows it does nothing. + use MODULE (); -The following is used to L<deprecate> core modules beyond a certain version of Perl: +You can't do this with the C<if> pragma; however, you can achieve +exactly this effect, at compile time, with: - use if $] > 5.016, 'deprecate'; + BEGIN { require MODULE if CONDITION } -This line is taken from L<Text::Soundex> 3.04, -and marks it as deprecated beyond Perl 5.16. -If you C<use Text::Soundex> in Perl 5.18, for example, -and you have used L<warnings>, -then you'll get a warning message -(the deprecate module looks to see whether the -calling module was C<use>'d from a core library directory, -and if so, generates a warning), -unless you've installed a more recent version of L<Text::Soundex> from CPAN. +=head2 C<no if> -You can also specify to NOT use something: +The C<no if> construct is mainly used to deactivate categories of warnings +when those categories would produce superfluous output under specified +versions of F<perl>. - no if $] ge 5.021_006, warnings => "locale"; +For example, the C<redundant> category of warnings was introduced in +Perl-5.22. This warning flags certain instances of superfluous arguments to +C<printf> and C<sprintf>. But if your code was running warnings-free on +earlier versions of F<perl> and you don't care about C<redundant> warnings in +more recent versions, you can call: -This warning category was added in the specified Perl version (a development -release). Without the C<'if'>, trying to use it in an earlier release would -generate an unknown warning category error. + use warnings; + no if $] >= 5.022, q|warnings|, qw(redundant); + + my $test = { fmt => "%s", args => [ qw( x y ) ] }; + my $result = sprintf $test->{fmt}, @{$test->{args}}; + +The C<no if> construct assumes that a module or pragma has correctly +implemented an C<unimport()> method -- but most modules and pragmata have not. +That explains why the C<no if> construct is of limited applicability. =head1 BUGS -The current implementation does not allow specification of the -required version of the module. +The current implementation does not allow specification of the required +version of the module. =head1 SEE ALSO @@ -96,8 +99,8 @@ Unlike C<if> though, L<Module::Requires> is not a core module. L<Module::Load::Conditional> provides a number of functions you can use to query what modules are available, and then load one or more of them at runtime. -L<provide> can be used to select one of several possible modules to load, -based on what version of Perl is running. +The L<provide> module from CPAN can be used to select one of several possible +modules to load based on the version of Perl that is running. =head1 AUTHOR diff --git a/gnu/usr.bin/perl/dist/if/t/if.t b/gnu/usr.bin/perl/dist/if/t/if.t index 4a2b351aaf4..999a30f301c 100644 --- a/gnu/usr.bin/perl/dist/if/t/if.t +++ b/gnu/usr.bin/perl/dist/if/t/if.t @@ -1,9 +1,9 @@ #!./perl use strict; -use Test::More tests => 10; +use Test::More tests => 18; -my $v_plus = $] + 1; +my $v_plus = $] + 1; my $v_minus = $] - 1; unless (eval 'use open ":std"; 1') { @@ -12,29 +12,85 @@ unless (eval 'use open ":std"; 1') { eval 'sub open::foo{}'; # Just in case... } -no strict; +{ + no strict; -is( eval "use if ($v_minus > \$]), strict => 'subs'; \${'f'} = 12", 12, - '"use if" with a false condition, fake pragma'); -is( eval "use if ($v_minus > \$]), strict => 'refs'; \${'f'} = 12", 12, - '"use if" with a false condition and a pragma'); + is( eval "use if ($v_minus > \$]), strict => 'subs'; \${'f'} = 12", 12, + '"use if" with a false condition, fake pragma'); + is( eval "use if ($v_minus > \$]), strict => 'refs'; \${'f'} = 12", 12, + '"use if" with a false condition and a pragma'); -is( eval "use if ($v_plus > \$]), strict => 'subs'; \${'f'} = 12", 12, - '"use if" with a true condition, fake pragma'); + is( eval "use if ($v_plus > \$]), strict => 'subs'; \${'f'} = 12", 12, + '"use if" with a true condition, fake pragma'); -is( eval "use if ($v_plus > \$]), strict => 'refs'; \${'f'} = 12", undef, - '"use if" with a true condition and a pragma'); -like( $@, qr/while "strict refs" in use/, 'expected error message'), + is( eval "use if ($v_plus > \$]), strict => 'refs'; \${'f'} = 12", undef, + '"use if" with a true condition and a pragma'); + like( $@, qr/while "strict refs" in use/, 'expected error message'), -# Old version had problems with the module name 'open', which is a keyword too -# Use 'open' =>, since pre-5.6.0 could interpret differently -is( (eval "use if ($v_plus > \$]), 'open' => IN => ':crlf'; 12" || 0), 12, - '"use if" with open'); + # Old version had problems with the module name 'open', which is a keyword too + # Use 'open' =>, since pre-5.6.0 could interpret differently + is( (eval "use if ($v_plus > \$]), 'open' => IN => ':crlf'; 12" || 0), 12, + '"use if" with open'); -is(eval "use if ($v_plus > \$])", undef, - "Too few args to 'use if' returns <undef>"); -like($@, qr/Too few arguments to 'use if'/, " ... and returns correct error"); + is(eval "use if ($v_plus > \$])", undef, + "Too few args to 'use if' returns <undef>"); + like($@, qr/Too few arguments to 'use if'/, " ... and returns correct error"); -is(eval "no if ($v_plus > \$])", undef, - "Too few args to 'no if' returns <undef>"); -like($@, qr/Too few arguments to 'no if'/, " ... and returns correct error"); + is(eval "no if ($v_plus > \$])", undef, + "Too few args to 'no if' returns <undef>"); + like($@, qr/Too few arguments to 'no if'/, " ... and returns correct error"); +} + +{ + note(q|RT 132732: strict 'subs'|); + use strict "subs"; + + { + SKIP: { + unless ($] >= 5.018) { + skip "bigrat apparently not testable prior to perl-5.18", 4; + } + note(q|strict "subs" : 'use if' : condition false|); + eval "use if (0 > 1), q|bigrat|, qw(hex oct);"; + ok (! main->can('hex'), "Cannot call bigrat::hex() in importing package"); + ok (! main->can('oct'), "Cannot call bigrat::oct() in importing package"); + + note(q|strict "subs" : 'use if' : condition true|); + eval "use if (1 > 0), q|bigrat|, qw(hex oct);"; + ok ( main->can('hex'), "Can call bigrat::hex() in importing package"); + ok ( main->can('oct'), "Can call bigrat::oct() in importing package"); + } + } + + { + note(q|strict "subs" : 'no if' : condition variable|); + note(($] >= 5.022) ? "Recent enough Perl: $]" : "Older Perl: $]"); + use warnings; + SKIP: { + unless ($] >= 5.022) { + skip "Redundant argument warning not available in pre-5.22 perls", 4; + } + + { + no if $] >= 5.022, q|warnings|, qw(redundant); + my ($test, $result, $warn); + local $SIG{__WARN__} = sub { $warn = shift }; + $test = { fmt => "%s", args => [ qw( x y ) ] }; + $result = sprintf $test->{fmt}, @{$test->{args}}; + is($result, $test->{args}->[0], "Got expected string"); + ok(! $warn, "Redundant argument warning suppressed"); + } + + { + use if $] >= 5.022, q|warnings|, qw(redundant); + my ($test, $result, $warn); + local $SIG{__WARN__} = sub { $warn = shift }; + $test = { fmt => "%s", args => [ qw( x y ) ] }; + $result = sprintf $test->{fmt}, @{$test->{args}}; + is($result, $test->{args}->[0], "Got expected string"); + like($warn, qr/Redundant argument in sprintf/, + "Redundant argument warning generated and captured"); + } + } + } +} diff --git a/gnu/usr.bin/perl/dist/lib/t/01lib.t b/gnu/usr.bin/perl/dist/lib/t/01lib.t index 7cf644d4284..a1b023d138a 100755 --- a/gnu/usr.bin/perl/dist/lib/t/01lib.t +++ b/gnu/usr.bin/perl/dist/lib/t/01lib.t @@ -27,7 +27,7 @@ BEGIN { mkpath [$Auto_Dir]; - open(MOD, ">$Module") || DIE $!; + open(MOD, '>', $Module) || DIE $!; print MOD <<'MODULE'; package Yup; $Plan = 9; diff --git a/gnu/usr.bin/perl/dist/threads-shared/lib/threads/shared.pm b/gnu/usr.bin/perl/dist/threads-shared/lib/threads/shared.pm index 89a79a4864d..b9ba66e85b7 100644 --- a/gnu/usr.bin/perl/dist/threads-shared/lib/threads/shared.pm +++ b/gnu/usr.bin/perl/dist/threads-shared/lib/threads/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.51'; # Please update the pod, too. +our $VERSION = '1.58'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -195,7 +195,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.51 +This document describes threads::shared version 1.58 =head1 SYNOPSIS @@ -570,16 +570,18 @@ not propagate the blessing to the shared reference: Therefore, you should bless objects before sharing them. It is often not wise to share an object unless the class itself has been -written to support sharing. For example, an object's destructor may get -called multiple times, once for each thread's scope exit. Another danger is -that the contents of hash-based objects will be lost due to the above -mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of -this module) for how to create a class that supports object sharing. +written to support sharing. For example, a shared object's destructor may +get called multiple times, once for each thread's scope exit, or may not +get called at all if it is embedded inside another shared object. Another +issue is that the contents of hash-based objects will be lost due to the +above mentioned limitation. See F<examples/class.pl> (in the CPAN +distribution of this module) for how to create a class that supports object +sharing. Destructors may not be called on objects if those objects still exist at global destruction time. If the destructors must be called, make sure there are no circular references and that nothing is referencing the -objects, before the program ends. +objects before the program ends. Does not support C<splice> on arrays. Does not support explicitly changing array lengths via $#array -- use C<push> and C<pop> instead. @@ -646,8 +648,11 @@ to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared> =head1 SEE ALSO -L<threads::shared> Discussion Forum on CPAN: -L<http://www.cpanforum.com/dist/threads-shared> +threads::shared on MetaCPAN: +L<https://metacpan.org/release/threads-shared> + +Code repository for CPAN distribution: +L<https://github.com/Dual-Life/threads-shared> L<threads>, L<perlthrtut> @@ -657,6 +662,8 @@ L<http://www.perl.com/pub/a/2002/09/04/threads.html> Perl threads mailing list: L<http://lists.perl.org/list/ithreads.html> +Sample code in the I<examples> directory of this distribution on CPAN. + =head1 AUTHOR Artur Bergman E<lt>sky AT crucially DOT netE<gt> diff --git a/gnu/usr.bin/perl/dist/threads-shared/shared.xs b/gnu/usr.bin/perl/dist/threads-shared/shared.xs index a019732af87..d0f7d1e070c 100644 --- a/gnu/usr.bin/perl/dist/threads-shared/shared.xs +++ b/gnu/usr.bin/perl/dist/threads-shared/shared.xs @@ -128,6 +128,15 @@ # include "shared.h" #endif +#ifndef CLANG_DIAG_IGNORE +# define CLANG_DIAG_IGNORE(x) +# define CLANG_DIAG_RESTORE +#endif +#ifndef CLANG_DIAG_IGNORE_STMT +# define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP +# define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP +#endif + #ifdef USE_ITHREADS /* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */ @@ -656,7 +665,11 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) abs -= (NV)ts.tv_sec; ts.tv_nsec = (long)(abs * 1000000000.0); + CLANG_DIAG_IGNORE_STMT(-Wthread-safety); + /* warning: calling function 'pthread_cond_timedwait' requires holding mutex 'mut' exclusively [-Wthread-safety-analysis] */ switch (pthread_cond_timedwait(cond, mut, &ts)) { + CLANG_DIAG_RESTORE_STMT; + case 0: got_it = 1; break; case ETIMEDOUT: break; #ifdef OEMVS @@ -1094,8 +1107,9 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) if (!sv) continue; if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) && SvREFCNT(sv) == 1 ) { - SV *tmp = Perl_sv_newmortal(caller_perl); + SV *tmp; PERL_SET_CONTEXT((aTHX = caller_perl)); + tmp = sv_newmortal(); sv_upgrade(tmp, SVt_RV); get_RV(tmp, sv); PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); @@ -1374,8 +1388,9 @@ STORESIZE(SV *obj,IV count) if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) && SvREFCNT(sv) == 1 ) { - SV *tmp = Perl_sv_newmortal(caller_perl); + SV *tmp; PERL_SET_CONTEXT((aTHX = caller_perl)); + tmp = sv_newmortal(); sv_upgrade(tmp, SVt_RV); get_RV(tmp, sv); PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); diff --git a/gnu/usr.bin/perl/dist/threads-shared/t/object2.t b/gnu/usr.bin/perl/dist/threads-shared/t/object2.t index 3d795b92084..31c37974313 100644 --- a/gnu/usr.bin/perl/dist/threads-shared/t/object2.t +++ b/gnu/usr.bin/perl/dist/threads-shared/t/object2.t @@ -17,7 +17,7 @@ use ExtUtils::testlib; BEGIN { $| = 1; - print("1..131\n"); ### Number of tests that will be run ### + print("1..133\n"); ### Number of tests that will be run ### }; use threads; @@ -445,6 +445,28 @@ ok($destroyed[$ID], 'Scalar object removed from shared scalar'); ::ok($count == $n, "remove array object by undef"); } +# RT #131124 +# Emptying a shared array creates new temp SVs. If there are no spare +# SVs, a new arena is allocated. shared.xs was mallocing a new arena +# with the wrong perl context set, meaning that when the arena was later +# freed, it would "panic: realloc from wrong pool" +# + +{ + threads->new(sub { + my @a :shared; + push @a, bless &threads::shared::share({}) for 1..1000; + undef @a; # this creates lots of temp SVs + })->join; + ok(1, "#131124 undef array doesnt panic"); + + threads->new(sub { + my @a :shared; + push @a, bless &threads::shared::share({}) for 1..1000; + @a = (); # this creates lots of temp SVs + })->join; + ok(1, "#131124 clear array doesnt panic"); +} # EOF diff --git a/gnu/usr.bin/perl/dist/threads-shared/t/stress.t b/gnu/usr.bin/perl/dist/threads-shared/t/stress.t index e3c1441288e..1dd95e39595 100755 --- a/gnu/usr.bin/perl/dist/threads-shared/t/stress.t +++ b/gnu/usr.bin/perl/dist/threads-shared/t/stress.t @@ -83,7 +83,7 @@ use threads::shared; print "# Looping for $busycount iterations should take about 0.025s\n"; } - my $TIMEOUT = 600; + my $TIMEOUT = 60; my $mutex = 1; share($mutex); diff --git a/gnu/usr.bin/perl/dist/threads/lib/threads.pm b/gnu/usr.bin/perl/dist/threads/lib/threads.pm index 39761be3dd4..1b99567ef23 100644 --- a/gnu/usr.bin/perl/dist/threads/lib/threads.pm +++ b/gnu/usr.bin/perl/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '2.07'; +our $VERSION = '2.22'; # remember to update version in POD! my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 2.07 +This document describes threads version 2.21 =head1 WARNING @@ -937,6 +937,33 @@ C<chdir()>) will affect all the threads in the application. On MSWin32, each thread maintains its own the current working directory setting. +=item Locales + +Prior to Perl 5.28, locales could not be used with threads, due to various +race conditions. Starting in that release, on systems that implement +thread-safe locale functions, threads can be used, with some caveats. +This includes Windows starting with Visual Studio 2005, and systems compatible +with POSIX 2008. See L<perllocale/Multi-threaded operation>. + +Each thread (except the main thread) is started using the C locale. The main +thread is started like all other Perl programs; see L<perllocale/ENVIRONMENT>. +You can switch locales in any thread as often as you like. + +If you want to inherit the parent thread's locale, you can, in the parent, set +a variable like so: + + $foo = POSIX::setlocale(LC_ALL, NULL); + +and then pass to threads->create() a sub that closes over C<$foo>. Then, in +the child, you say + + POSIX::setlocale(LC_ALL, $foo); + +Or you can use the facilities in L<threads::shared> to pass C<$foo>; +or if the environment hasn't changed, in the child, do + + POSIX::setlocale(LC_ALL, ""); + =item Environment variables Currently, on all platforms except MSWin32, all I<system> calls (e.g., using @@ -987,13 +1014,6 @@ L</"THREAD SIGNALLING"> to relay the signal to the thread: On some platforms, it might not be possible to destroy I<parent> threads while there are still existing I<child> threads. -=item Creating threads inside special blocks - -Creating threads inside C<BEGIN>, C<CHECK> or C<INIT> blocks should not be -relied upon. Depending on the Perl version and the application code, results -may range from success, to (apparently harmless) warnings of leaked scalar, or -all the way up to crashing of the Perl interpreter. - =item Unsafe signals Since Perl 5.8.0, signals have been made safer in Perl by postponing their @@ -1018,16 +1038,27 @@ signalling behavior is only in effect in the following situations: If unsafe signals is in effect, then signal handling is not thread-safe, and the C<-E<gt>kill()> signalling method cannot be used. -=item Returning closures from threads +=item Identity of objects returned from threads -Returning closures from threads should not be relied upon. Depending on the -Perl version and the application code, results may range from success, to -(apparently harmless) warnings of leaked scalar, or all the way up to crashing -of the Perl interpreter. +When a value is returned from a thread through a C<join> operation, +the value and everything that it references is copied across to the +joining thread, in much the same way that values are copied upon thread +creation. This works fine for most kinds of value, including arrays, +hashes, and subroutines. The copying recurses through array elements, +reference scalars, variables closed over by subroutines, and other kinds +of reference. -=item Returning objects from threads +However, everything referenced by the returned value is a fresh copy in +the joining thread, even if a returned object had in the child thread +been a copy of something that previously existed in the parent thread. +After joining, the parent will therefore have a duplicate of each such +object. This sometimes matters, especially if the object gets mutated; +this can especially matter for private data to which a returned subroutine +provides access. -Returning objects from threads does not work. Depending on the classes +=item Returning blessed objects from threads + +Returning blessed objects from threads does not work. Depending on the classes involved, you may be able to work around this by returning a serialized version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then reconstituting it in the joining thread. If you're using Perl 5.10.0 or @@ -1061,6 +1092,18 @@ In prior perl versions, spawning threads with open directory handles would crash the interpreter. L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154> +=item Detached threads and global destruction + +If the main thread exits while there are detached threads which are still +running, then Perl's global destruction phase is not executed because +otherwise certain global structures that control the operation of threads and +that are allocated in the main thread's memory may get destroyed before the +detached thread is destroyed. + +If you are using any code that requires the execution of the global +destruction phase for clean up (e.g., removing temp files), then do not use +detached threads, but rather join all threads before exiting the program. + =item Perl Bugs and the CPAN Version of L<threads> Support for threads extends beyond the code in this module (i.e., @@ -1086,8 +1129,11 @@ Perl 5.8.0 or later =head1 SEE ALSO -L<threads> Discussion Forum on CPAN: -L<http://www.cpanforum.com/dist/threads> +threads on MetaCPAN: +L<https://metacpan.org/release/threads> + +Code repository for CPAN distribution: +L<https://github.com/Dual-Life/threads> L<threads::shared>, L<perlthrtut> @@ -1100,6 +1146,8 @@ L<http://lists.perl.org/list/ithreads.html> Stack size discussion: L<http://www.perlmonks.org/?node_id=532956> +Sample code in the I<examples> directory of this distribution on CPAN. + =head1 AUTHOR Artur Bergman E<lt>sky AT crucially DOT netE<gt> diff --git a/gnu/usr.bin/perl/dist/threads/t/exit.t b/gnu/usr.bin/perl/dist/threads/t/exit.t index 16d7a7ac174..2edc2625462 100755 --- a/gnu/usr.bin/perl/dist/threads/t/exit.t +++ b/gnu/usr.bin/perl/dist/threads/t/exit.t @@ -48,7 +48,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 2.07;' . +run_perl(prog => 'use threads 2.21;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -98,7 +98,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 2.07 qw(exit thread_only);' . +run_perl(prog => 'use threads 2.21 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -108,7 +108,7 @@ run_perl(prog => 'use threads 2.07 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); } -my $out = run_perl(prog => 'use threads 2.07;' . +my $out = run_perl(prog => 'use threads 2.21;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 2.07;' . like($out, qr/1 finished and unjoined/, "exit(status) in thread"); -$out = run_perl(prog => 'use threads 2.07 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 2.21 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 2.07 qw(exit thread_only);' . like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 2.07;' . +run_perl(prog => 'use threads 2.21;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/gnu/usr.bin/perl/dist/threads/t/thread.t b/gnu/usr.bin/perl/dist/threads/t/thread.t index 4628b276c96..4dc1a292d84 100755 --- a/gnu/usr.bin/perl/dist/threads/t/thread.t +++ b/gnu/usr.bin/perl/dist/threads/t/thread.t @@ -161,7 +161,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 2.07;' . +run_perl(prog => 'use threads 2.21;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/gnu/usr.bin/perl/dist/threads/threads.xs b/gnu/usr.bin/perl/dist/threads/threads.xs index 5f521928a15..3da9165c274 100644 --- a/gnu/usr.bin/perl/dist/threads/threads.xs +++ b/gnu/usr.bin/perl/dist/threads/threads.xs @@ -35,6 +35,17 @@ # endif #endif +#ifndef CLANG_DIAG_IGNORE +# define CLANG_DIAG_IGNORE(x) +# define CLANG_DIAG_RESTORE +#endif +#ifndef CLANG_DIAG_IGNORE_STMT +# define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP +# define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP +# define CLANG_DIAG_IGNORE_DECL(x) CLANG_DIAG_IGNORE(x) dNOOP +# define CLANG_DIAG_RESTORE_DECL CLANG_DIAG_RESTORE dNOOP +#endif + #ifdef USE_ITHREADS #ifdef __amigaos4__ @@ -569,6 +580,8 @@ S_ithread_run(void * arg) S_set_sigmask(&thread->initial_sigmask); #endif + thread_locale_init(); + PL_perl_destruct_level = 2; { @@ -654,6 +667,8 @@ S_ithread_run(void * arg) MUTEX_UNLOCK(&thread->mutex); MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + thread_locale_term(); + /* Exit application if required */ if (exit_app) { (void)S_jmpenv_run(aTHX_ 2, thread, NULL, &exit_app, &exit_code); @@ -870,15 +885,18 @@ S_ithread_create( reallocated (and hence move) as a side effect of calls to perl_clone() and sv_dup_inc(). Hence copy the parameters somewhere under our control first, before duplicating. */ + if (num_params) { #if (PERL_VERSION > 8) - Copy(parent_perl->Istack_base + params_start, array, num_params, SV *); + Copy(parent_perl->Istack_base + params_start, array, num_params, SV *); #else - Copy(parent_perl->Tstack_base + params_start, array, num_params, SV *); + Copy(parent_perl->Tstack_base + params_start, array, num_params, SV *); #endif - while (num_params--) { - *array = sv_dup_inc(*array, clone_param); - ++array; + while (num_params--) { + *array = sv_dup_inc(*array, clone_param); + ++array; + } } + #if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1) Perl_clone_params_del(clone_param); #endif @@ -1016,12 +1034,10 @@ S_ithread_create( MUTEX_UNLOCK(&my_pool->create_destruct_mutex); return (thread); - CLANG_DIAG_IGNORE(-Wthread-safety); + CLANG_DIAG_IGNORE_STMT(-Wthread-safety); /* warning: mutex 'thread->mutex' is not held on every path through here [-Wthread-safety-analysis] */ } -#if defined(__clang__) || defined(__clang) -CLANG_DIAG_RESTORE; -#endif +CLANG_DIAG_RESTORE_DECL; #endif /* USE_ITHREADS */ @@ -1083,16 +1099,16 @@ ithread_create(...) if (specs) { SV **svp; /* stack_size */ - if ((svp = hv_fetch(specs, "stack", 5, 0))) { + if ((svp = hv_fetchs(specs, "stack", 0))) { stack_size = SvIV(*svp); - } else if ((svp = hv_fetch(specs, "stacksize", 9, 0))) { + } else if ((svp = hv_fetchs(specs, "stacksize", 0))) { stack_size = SvIV(*svp); - } else if ((svp = hv_fetch(specs, "stack_size", 10, 0))) { + } else if ((svp = hv_fetchs(specs, "stack_size", 0))) { stack_size = SvIV(*svp); } /* context */ - if ((svp = hv_fetch(specs, "context", 7, 0))) { + if ((svp = hv_fetchs(specs, "context", 0))) { str = (char *)SvPV_nolen(*svp); switch (*str) { case 'a': @@ -1112,26 +1128,26 @@ ithread_create(...) default: Perl_croak(aTHX_ "Invalid context: %s", str); } - } else if ((svp = hv_fetch(specs, "array", 5, 0))) { + } else if ((svp = hv_fetchs(specs, "array", 0))) { if (SvTRUE(*svp)) { context = G_ARRAY; } - } else if ((svp = hv_fetch(specs, "list", 4, 0))) { + } else if ((svp = hv_fetchs(specs, "list", 0))) { if (SvTRUE(*svp)) { context = G_ARRAY; } - } else if ((svp = hv_fetch(specs, "scalar", 6, 0))) { + } else if ((svp = hv_fetchs(specs, "scalar", 0))) { if (SvTRUE(*svp)) { context = G_SCALAR; } - } else if ((svp = hv_fetch(specs, "void", 4, 0))) { + } else if ((svp = hv_fetchs(specs, "void", 0))) { if (SvTRUE(*svp)) { context = G_VOID; } } /* exit => thread_only */ - if ((svp = hv_fetch(specs, "exit", 4, 0))) { + if ((svp = hv_fetchs(specs, "exit", 0))) { str = (char *)SvPV_nolen(*svp); exit_opt = (*str == 't' || *str == 'T') ? PERL_ITHR_THREAD_EXIT_ONLY : 0; @@ -1159,10 +1175,10 @@ ithread_create(...) /* Let thread run. */ /* See S_ithread_run() for more detail. */ - CLANG_DIAG_IGNORE(-Wthread-safety); + CLANG_DIAG_IGNORE_STMT(-Wthread-safety); /* warning: releasing mutex 'thread->mutex' that was not held [-Wthread-safety-analysis] */ MUTEX_UNLOCK(&thread->mutex); - CLANG_DIAG_RESTORE; + CLANG_DIAG_RESTORE_STMT; /* XSRETURN(1); - implied */ @@ -1357,6 +1373,9 @@ ithread_join(...) ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); +# ifdef PL_sv_zero + ptr_table_store(PL_ptr_table, &other_perl->Isv_zero, &PL_sv_zero); +# endif params = (AV *)sv_dup((SV*)params_copy, clone_params); S_ithread_set(aTHX_ current_thread); Perl_clone_params_del(clone_params); @@ -1491,7 +1510,9 @@ ithread_kill(...) MUTEX_UNLOCK(&thread->mutex); if (no_handler) { - Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid); + Perl_croak(aTHX_ "Signal %s received in thread %" UVuf + ", but no signal handler set.", + sig_name, thread->tid); } /* Return the thread to allow for method chaining */ @@ -1783,6 +1804,9 @@ ithread_error(...) ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); +# ifdef PL_sv_zero + ptr_table_store(PL_ptr_table, &other_perl->Isv_zero, &PL_sv_zero); +# endif err = sv_dup(thread->err, clone_params); S_ithread_set(aTHX_ current_thread); Perl_clone_params_del(clone_params); |