In perl.git, the branch smoke-me/jkeenan/updated-pod-simple has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/34b229ccc4629273934b834c7c085f247f6c77c2?hp=b2acdd1fd7e61d6918dc41a947b4a91d3f3b6ac0> - Log ----------------------------------------------------------------- commit 34b229ccc4629273934b834c7c085f247f6c77c2 Merge: 61e20d8 b2acdd1 Author: James E Keenan <[email protected]> Date: Mon Jan 12 20:02:19 2015 -0500 Merge branch 'smoke-me/jkeenan/updated-pod-simple' of git://perl5.git.perl.org/perl into updated-pod-simple commit 61e20d8a18f33f1792cc8db2b36941dff64f8bba Author: James E Keenan <[email protected]> Date: Mon Jan 12 19:57:12 2015 -0500 Patch supplied by theory. But we're still getting test failures. M ext/Pod-Html/t/pod2html-lib.pl commit 94d88814fdcf7a9c97851d0871bd7aa14938f49a Author: James E Keenan <[email protected]> Date: Sun Jan 11 10:20:31 2015 -0500 Update to recent Pod-Simple. Collateral damage to 3 tests under ext/Pod-Html/. M MANIFEST M cpan/Pod-Simple/lib/Pod/Simple.pm M cpan/Pod-Simple/lib/Pod/Simple.pod M cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm M cpan/Pod-Simple/lib/Pod/Simple/Checker.pm M cpan/Pod-Simple/lib/Pod/Simple/Debug.pm M cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm M cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm M cpan/Pod-Simple/lib/Pod/Simple/HTML.pm M cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm M cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm M cpan/Pod-Simple/lib/Pod/Simple/Methody.pm M cpan/Pod-Simple/lib/Pod/Simple/Progress.pm M cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm M cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm M cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm M cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm M cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm M cpan/Pod-Simple/lib/Pod/Simple/RTF.pm M cpan/Pod-Simple/lib/Pod/Simple/Search.pm M cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm M cpan/Pod-Simple/lib/Pod/Simple/Subclassing.pod M cpan/Pod-Simple/lib/Pod/Simple/Text.pm M cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm M cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm M cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm M cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm M cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm M cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm M cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm A cpan/Pod-Simple/t/corpus/enc_char_directive.txt A cpan/Pod-Simple/t/corpus/enc_char_directive.xml A cpan/Pod-Simple/t/corpus/enc_char_wrong_directive.txt A cpan/Pod-Simple/t/corpus/enc_char_wrong_directive.xml M cpan/Pod-Simple/t/enc-chars.t M cpan/Pod-Simple/t/html01.t M cpan/Pod-Simple/t/render.t M cpan/Pod-Simple/t/search50.t M cpan/Pod-Simple/t/xhtml01.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 +- Porting/Maintainers.pl | 10 ++--- cpan/Digest-MD5/MD5.pm | 12 ++++- cpan/Digest-MD5/MD5.xs | 79 ++++++++++++++++++++++++++------- cpan/Digest-MD5/Makefile.PL | 2 +- cpan/Digest-MD5/t/files.t | 4 +- cpan/Digest-MD5/t/threads.t | 2 + cpan/Digest-SHA/lib/Digest/SHA.pm | 2 +- cpan/Digest-SHA/shasum | 6 +-- cpan/Digest-SHA/src/sha.c | 4 +- cpan/Digest-SHA/src/sha.h | 4 +- cpan/Digest-SHA/src/sha64bit.c | 4 +- cpan/Digest-SHA/src/sha64bit.h | 4 +- cpan/Digest-SHA/t/bit-order.t | 15 ------- cpan/Digest-SHA/t/bitorder.t | 29 +++++++++++++ cpan/IO-Socket-IP/lib/IO/Socket/IP.pm | 10 ++++- cpan/MIME-Base64/Base64.pm | 2 +- cpan/MIME-Base64/Base64.xs | 4 +- dist/Safe/Changes | 2 +- embed.fnc | 4 +- embed.h | 4 +- ext/Pod-Html/t/pod2html-lib.pl | 4 ++ op.c | 37 ++++++++-------- pad.c | 82 ++++++++++++++++++++++++++++++----- perl.c | 2 +- pod/perldelta.pod | 72 ++++++++++++++++++++++++++++++ pod/perldiag.pod | 6 +++ pp.c | 25 +++++++---- pp_ctl.c | 72 ++++++++++++++++++++---------- proto.h | 12 ++--- t/lib/warnings/op | 17 ++++++++ t/op/infnan.t | 29 +++++++++++++ t/op/lexsub.t | 41 +++++++++++++++++- t/porting/customized.dat | 1 - 34 files changed, 472 insertions(+), 133 deletions(-) delete mode 100644 cpan/Digest-SHA/t/bit-order.t create mode 100644 cpan/Digest-SHA/t/bitorder.t diff --git a/MANIFEST b/MANIFEST index cd6da21..83019f0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -713,7 +713,7 @@ cpan/Digest-SHA/src/sha.h Digest::SHA extension cpan/Digest-SHA/t/allfcns.t See if Digest::SHA works cpan/Digest-SHA/t/base64.t See if Digest::SHA works cpan/Digest-SHA/t/bitbuf.t See if Digest::SHA works -cpan/Digest-SHA/t/bit-order.t +cpan/Digest-SHA/t/bitorder.t cpan/Digest-SHA/t/fips180-4.t See if Digest::SHA works cpan/Digest-SHA/t/fips198.t See if Digest::SHA works cpan/Digest-SHA/t/gglong.t See if Digest::SHA works diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index db8e83e..71204e4 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -357,15 +357,13 @@ use File::Glob qw(:case); }, 'Digest::MD5' => { - 'DISTRIBUTION' => 'GAAS/Digest-MD5-2.53.tar.gz', + 'DISTRIBUTION' => 'GAAS/Digest-MD5-2.54.tar.gz', 'FILES' => q[cpan/Digest-MD5], 'EXCLUDED' => ['rfc1321.txt'], - # Waiting to be merged upstream: see CPAN RT#89612 - 'CUSTOMIZED' => ['t/files.t'], }, 'Digest::SHA' => { - 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.94.tar.gz', + 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.95.tar.gz', 'FILES' => q[cpan/Digest-SHA], 'EXCLUDED' => [ qw( t/pod.t @@ -632,7 +630,7 @@ use File::Glob qw(:case); }, 'IO::Socket::IP' => { - 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.35.tar.gz', + 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.36.tar.gz', 'FILES' => q[cpan/IO-Socket-IP], 'EXCLUDED' => [ qr{^examples/}, @@ -788,7 +786,7 @@ use File::Glob qw(:case); }, 'MIME::Base64' => { - 'DISTRIBUTION' => 'GAAS/MIME-Base64-3.14.tar.gz', + 'DISTRIBUTION' => 'GAAS/MIME-Base64-3.15.tar.gz', 'FILES' => q[cpan/MIME-Base64], 'EXCLUDED' => ['t/bad-sv.t'], }, diff --git a/cpan/Digest-MD5/MD5.pm b/cpan/Digest-MD5/MD5.pm index 679036f..bb92ddb 100644 --- a/cpan/Digest-MD5/MD5.pm +++ b/cpan/Digest-MD5/MD5.pm @@ -3,7 +3,7 @@ package Digest::MD5; use strict; use vars qw($VERSION @ISA @EXPORT_OK); -$VERSION = '2.53'; +$VERSION = '2.54'; require Exporter; *import = \&Exporter::import; @@ -227,6 +227,16 @@ The base64 encoded string returned is not padded to be a multiple of 4 bytes long. If you want interoperability with other base64 encoded md5 digests you might want to append the string "==" to the result. +=item @ctx = $md5->context + +=item $md5->context(@ctx) + +Saves or restores the internal state. When called with no arguments, +returns a 3-element list: number of blocks processed, a 16-byte +internal state buffer, then up to 63 bytes of unprocessed data. When +passed those same arguments, restores the state. This is only useful +for specialised operations. + =back diff --git a/cpan/Digest-MD5/MD5.xs b/cpan/Digest-MD5/MD5.xs index f3b58f7..acefc30 100644 --- a/cpan/Digest-MD5/MD5.xs +++ b/cpan/Digest-MD5/MD5.xs @@ -155,26 +155,29 @@ STATIC int dup_md5_ctx(pTHX_ MAGIC *mg, CLONE_PARAMS *params) } #endif -STATIC MGVTBL vtbl_md5 = { +#if defined(MGf_DUP) && defined(USE_ITHREADS) +const STATIC MGVTBL vtbl_md5 = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ NULL, /* free */ -#ifdef MGf_COPY NULL, /* copy */ -#endif -#ifdef MGf_DUP -# ifdef USE_ITHREADS - dup_md5_ctx, -# else - NULL, /* dup */ -# endif -#endif -#ifdef MGf_LOCAL + dup_md5_ctx, /* dup */ NULL /* local */ -#endif }; +#else +/* declare as 5 member, not normal 8 to save image space*/ +const STATIC struct { + int (*svt_get)(SV* sv, MAGIC* mg); + int (*svt_set)(SV* sv, MAGIC* mg); + U32 (*svt_len)(SV* sv, MAGIC* mg); + int (*svt_clear)(SV* sv, MAGIC* mg); + int (*svt_free)(SV* sv, MAGIC* mg); +} vtbl_md5 = { + NULL, NULL, NULL, NULL, NULL +}; +#endif /* Padding is added at the end of the message in order to fill a @@ -503,7 +506,8 @@ static MD5_CTX* get_md5_ctx(pTHX_ SV* sv) croak("Not a reference to a Digest::MD5 object"); for (mg = SvMAGIC(SvRV(sv)); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &vtbl_md5) { + if (mg->mg_type == PERL_MAGIC_ext + && mg->mg_virtual == (const MGVTBL * const)&vtbl_md5) { return (MD5_CTX *)mg->mg_ptr; } } @@ -525,7 +529,7 @@ static SV * new_md5_ctx(pTHX_ MD5_CTX *context, const char *klass) #ifdef USE_ITHREADS mg = #endif - sv_magicext(sv, NULL, PERL_MAGIC_ext, &vtbl_md5, (const char *)context, 0); + sv_magicext(sv, NULL, PERL_MAGIC_ext, (const MGVTBL * const)&vtbl_md5, (const char *)context, 0); #if defined(USE_ITHREADS) && defined(MGf_DUP) mg->mg_flags |= MGf_DUP; @@ -731,6 +735,45 @@ digest(context) XSRETURN(1); void +context(ctx, ...) + MD5_CTX* ctx + PREINIT: + char out[16]; + U32 w; + PPCODE: + if (items > 2) { + STRLEN len; + unsigned long blocks = SvUV(ST(1)); + unsigned char *buf = (unsigned char *)(SvPV(ST(2), len)); + ctx->A = buf[ 0] | (buf[ 1]<<8) | (buf[ 2]<<16) | (buf[ 3]<<24); + ctx->B = buf[ 4] | (buf[ 5]<<8) | (buf[ 6]<<16) | (buf[ 7]<<24); + ctx->C = buf[ 8] | (buf[ 9]<<8) | (buf[10]<<16) | (buf[11]<<24); + ctx->D = buf[12] | (buf[13]<<8) | (buf[14]<<16) | (buf[15]<<24); + ctx->bytes_low = blocks << 6; + ctx->bytes_high = blocks >> 26; + if (items == 4) { + buf = (unsigned char *)(SvPV(ST(3), len)); + MD5Update(ctx, buf, len); + } + XSRETURN(1); /* ctx */ + } else if (items != 1) { + XSRETURN(0); + } + + w=ctx->A; out[ 0]=w; out[ 1]=(w>>8); out[ 2]=(w>>16); out[ 3]=(w>>24); + w=ctx->B; out[ 4]=w; out[ 5]=(w>>8); out[ 6]=(w>>16); out[ 7]=(w>>24); + w=ctx->C; out[ 8]=w; out[ 9]=(w>>8); out[10]=(w>>16); out[11]=(w>>24); + w=ctx->D; out[12]=w; out[13]=(w>>8); out[14]=(w>>16); out[15]=(w>>24); + + EXTEND(SP, 3); + ST(0) = sv_2mortal(newSVuv(ctx->bytes_high << 26 | + ctx->bytes_low >> 6)); + ST(1) = sv_2mortal(newSVpv(out, 16)); + ST(2) = sv_2mortal(newSVpv((char *)ctx->buffer, + ctx->bytes_low & 0x3F)); + XSRETURN(3); + +void md5(...) ALIAS: Digest::MD5::md5 = F_BIN @@ -750,7 +793,9 @@ md5(...) if (items == 1) { if (SvROK(ST(0))) { SV* sv = SvRV(ST(0)); - if (SvOBJECT(sv) && strEQ(HvNAME(SvSTASH(sv)), "Digest::MD5")) + char *name; + if (SvOBJECT(sv) && (name = HvNAME(SvSTASH(sv))) + && strEQ(name, "Digest::MD5")) msg = "probably called as method"; else msg = "called with reference argument"; @@ -763,7 +808,9 @@ md5(...) } else if (SvROK(ST(0))) { SV* sv = SvRV(ST(0)); - if (SvOBJECT(sv) && strEQ(HvNAME(SvSTASH(sv)), "Digest::MD5")) + char *name; + if (SvOBJECT(sv) && (name = HvNAME(SvSTASH(sv))) + && strEQ(name, "Digest::MD5")) msg = "probably called as method"; } } diff --git a/cpan/Digest-MD5/Makefile.PL b/cpan/Digest-MD5/Makefile.PL index 1d9337b..1015058 100644 --- a/cpan/Digest-MD5/Makefile.PL +++ b/cpan/Digest-MD5/Makefile.PL @@ -31,7 +31,7 @@ WriteMakefile( }, 'META_MERGE' => { resources => { - repository => 'http://github.com/gisle/digest-md5', + repository => 'https://github.com/gisle/digest-md5', } }, @extra, diff --git a/cpan/Digest-MD5/t/files.t b/cpan/Digest-MD5/t/files.t index 60d2847..d6b4fcb 100644 --- a/cpan/Digest-MD5/t/files.t +++ b/cpan/Digest-MD5/t/files.t @@ -14,14 +14,14 @@ my $EXPECT; if (ord "A" == 193) { # EBCDIC $EXPECT = <<EOT; 0956ffb4f6416082b27d6680b4cf73fc README -b349234bb1005785bb6e377990209dc7 MD5.xs +2a61dd5022b11faa35eed27d1c6c98c2 MD5.xs 276da0aa4e9a08b7fe09430c9c5690aa rfc1321.txt EOT } else { # This is the output of: 'md5sum README MD5.xs rfc1321.txt' $EXPECT = <<EOT; 2f93400875dbb56f36691d5f69f3eba5 README -f908acbcf6bd32042f282b0deed61264 MD5.xs +0a0cf2512d18d24c6881d7d755e2b609 MD5.xs 754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt EOT } diff --git a/cpan/Digest-MD5/t/threads.t b/cpan/Digest-MD5/t/threads.t index 968fd0c..64c2529 100644 --- a/cpan/Digest-MD5/t/threads.t +++ b/cpan/Digest-MD5/t/threads.t @@ -6,6 +6,8 @@ use Config; BEGIN { plan skip_all => 'Perl compiled without ithreads' unless $Config{useithreads}; + plan skip_all => 'no threads.pm' + unless eval { require threads }; plan tests => 2; } diff --git a/cpan/Digest-SHA/lib/Digest/SHA.pm b/cpan/Digest-SHA/lib/Digest/SHA.pm index bbc1e22..3abca3d 100644 --- a/cpan/Digest-SHA/lib/Digest/SHA.pm +++ b/cpan/Digest-SHA/lib/Digest/SHA.pm @@ -8,7 +8,7 @@ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Fcntl; use integer; -$VERSION = '5.94'; +$VERSION = '5.95'; require Exporter; require DynaLoader; diff --git a/cpan/Digest-SHA/shasum b/cpan/Digest-SHA/shasum index 0a12562..14ddd60 100644 --- a/cpan/Digest-SHA/shasum +++ b/cpan/Digest-SHA/shasum @@ -4,8 +4,8 @@ ## ## Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved ## - ## Version: 5.94 - ## Sat Jan 10 00:45:28 MST 2015 + ## Version: 5.95 + ## Sat Jan 10 12:15:36 MST 2015 ## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add ## "-a" option for algorithm selection, @@ -101,7 +101,7 @@ L<Digest::SHA::PurePerl>. END_OF_POD -my $VERSION = "5.94"; +my $VERSION = "5.95"; sub usage { my($err, $msg) = @_; diff --git a/cpan/Digest-SHA/src/sha.c b/cpan/Digest-SHA/src/sha.c index c0daaaa..ea0d41b 100644 --- a/cpan/Digest-SHA/src/sha.c +++ b/cpan/Digest-SHA/src/sha.c @@ -5,8 +5,8 @@ * * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved * - * Version: 5.94 - * Sat Jan 10 00:45:28 MST 2015 + * Version: 5.95 + * Sat Jan 10 12:15:36 MST 2015 * */ diff --git a/cpan/Digest-SHA/src/sha.h b/cpan/Digest-SHA/src/sha.h index 5901811..e63d4b7 100644 --- a/cpan/Digest-SHA/src/sha.h +++ b/cpan/Digest-SHA/src/sha.h @@ -5,8 +5,8 @@ * * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved * - * Version: 5.94 - * Sat Jan 10 00:45:28 MST 2015 + * Version: 5.95 + * Sat Jan 10 12:15:36 MST 2015 * */ diff --git a/cpan/Digest-SHA/src/sha64bit.c b/cpan/Digest-SHA/src/sha64bit.c index d5a6a6f..2fa0dda 100644 --- a/cpan/Digest-SHA/src/sha64bit.c +++ b/cpan/Digest-SHA/src/sha64bit.c @@ -5,8 +5,8 @@ * * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved * - * Version: 5.94 - * Sat Jan 10 00:45:28 MST 2015 + * Version: 5.95 + * Sat Jan 10 12:15:36 MST 2015 * */ diff --git a/cpan/Digest-SHA/src/sha64bit.h b/cpan/Digest-SHA/src/sha64bit.h index 573594b..ce89548 100644 --- a/cpan/Digest-SHA/src/sha64bit.h +++ b/cpan/Digest-SHA/src/sha64bit.h @@ -5,8 +5,8 @@ * * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved * - * Version: 5.94 - * Sat Jan 10 00:45:28 MST 2015 + * Version: 5.95 + * Sat Jan 10 12:15:36 MST 2015 * * The following macros supply placeholder values that enable the * sha.c module to successfully compile when 64-bit integer types diff --git a/cpan/Digest-SHA/t/bit-order.t b/cpan/Digest-SHA/t/bit-order.t deleted file mode 100644 index 5dd2ebc..0000000 --- a/cpan/Digest-SHA/t/bit-order.t +++ /dev/null @@ -1,15 +0,0 @@ -use strict; -use Digest::SHA; - -my $s1 = Digest::SHA->new; -my $s2 = Digest::SHA->new; -my $d1 = $s1->add_bits("110")->hexdigest; -my $d2 = $s2->add_bits("1")->add_bits("1")->add_bits("0")->hexdigest; - -my $numtests = 1; -print "1..$numtests\n"; - -for (1 .. $numtests) { - print "not " unless $d1 eq $d2; - print "ok ", $_, "\n"; -} diff --git a/cpan/Digest-SHA/t/bitorder.t b/cpan/Digest-SHA/t/bitorder.t new file mode 100644 index 0000000..2cd2dbf --- /dev/null +++ b/cpan/Digest-SHA/t/bitorder.t @@ -0,0 +1,29 @@ +use strict; + +my $MODULE; + +BEGIN { + $MODULE = (-d "src") ? "Digest::SHA" : "Digest::SHA::PurePerl"; + eval "require $MODULE" || die $@; + $MODULE->import(qw()); +} + +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +my $s1 = $MODULE->new; +my $s2 = $MODULE->new; +my $d1 = $s1->add_bits("110")->hexdigest; +my $d2 = $s2->add_bits("1")->add_bits("1")->add_bits("0")->hexdigest; + +my $numtests = 1; +print "1..$numtests\n"; + +for (1 .. $numtests) { + print "not " unless $d1 eq $d2; + print "ok ", $_, "\n"; +} diff --git a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm index 8141761..5435f4f 100644 --- a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm +++ b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm @@ -7,7 +7,7 @@ package IO::Socket::IP; # $VERSION needs to be set before use base 'IO::Socket' # - https://rt.cpan.org/Ticket/Display.html?id=92107 BEGIN { - $VERSION = '0.35'; + $VERSION = '0.36'; } use strict; @@ -441,11 +441,17 @@ sub _io_socket_ip__configure ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref"; @localinfos = @$info; } - elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) { + elsif( defined $arg->{LocalHost} or + defined $arg->{LocalService} or + HAVE_MSWIN32 and $arg->{Listen} ) { # Either may be undef my $host = $arg->{LocalHost}; my $service = $arg->{LocalService}; + unless ( defined $host or defined $service ) { + $service = 0; + } + local $1; # Placate a taint-related bug; [perl #67962] defined $service and $service =~ s/\((\d+)\)$// and my $fallback_port = $1; diff --git a/cpan/MIME-Base64/Base64.pm b/cpan/MIME-Base64/Base64.pm index 4e59b62..120cd72 100644 --- a/cpan/MIME-Base64/Base64.pm +++ b/cpan/MIME-Base64/Base64.pm @@ -8,7 +8,7 @@ require Exporter; @EXPORT = qw(encode_base64 decode_base64); @EXPORT_OK = qw(encode_base64url decode_base64url encoded_base64_length decoded_base64_length); -$VERSION = '3.14'; +$VERSION = '3.15'; require XSLoader; XSLoader::load('MIME::Base64', $VERSION); diff --git a/cpan/MIME-Base64/Base64.xs b/cpan/MIME-Base64/Base64.xs index b6959bc..903aa21 100644 --- a/cpan/MIME-Base64/Base64.xs +++ b/cpan/MIME-Base64/Base64.xs @@ -391,9 +391,9 @@ encode_qp(sv,...) break; } else if (*p == '\n' && eol_len && !binary) { - if (linelen == 1 && SvCUR(RETVAL) > eol_len + 1 && SvEND(RETVAL)[-eol_len - 2] == '=') { + if (linelen == 1 && SvCUR(RETVAL) > eol_len + 1 && (SvEND(RETVAL)-eol_len)[-2] == '=') { /* fixup useless soft linebreak */ - SvEND(RETVAL)[-eol_len - 2] = SvEND(RETVAL)[-1]; + (SvEND(RETVAL)-eol_len)[-2] = SvEND(RETVAL)[-1]; SvCUR_set(RETVAL, SvCUR(RETVAL) - 1); } else { diff --git a/dist/Safe/Changes b/dist/Safe/Changes index c0c7315..a707195 100644 --- a/dist/Safe/Changes +++ b/dist/Safe/Changes @@ -1,6 +1,6 @@ 2.39 xxxxx - reval was not propagating void context properly. - The fix is partly in Opcode, so it requires 5.21.7 or higher. + The fix is partly in Opcode, so it requires 5.21.8 or higher. 2.38 Mon Aug 04 2014 - critical bugfix: outside packages could be replaced (fix in Opcode) diff --git a/embed.fnc b/embed.fnc index 020872c..187d113 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1938,8 +1938,8 @@ s |OP * |my_kid |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp s |OP * |dup_attrlist |NN OP *o s |void |apply_attrs |NN HV *stash|NN SV *target|NULLOK OP *attrs s |void |apply_attrs_my |NN HV *stash|NN OP *target|NULLOK OP *attrs|NN OP **imopsp -s |void |bad_type_pv |I32 n|NN const char *t|NN const char *name|U32 flags|NN const OP *kid -s |void |bad_type_gv |I32 n|NN const char *t|NN GV *gv|U32 flags|NN const OP *kid +s |void |bad_type_pv |I32 n|NN const char *t|NN const OP *o|NN const OP *kid +s |void |bad_type_gv |I32 n|NN GV *gv|NN const OP *kid|NN const char *t s |void |no_bareword_allowed|NN OP *o sR |OP* |no_fh_allowed|NN OP *o sR |OP* |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags diff --git a/embed.h b/embed.h index c484be0..70cab3e 100644 --- a/embed.h +++ b/embed.h @@ -1518,8 +1518,8 @@ #define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c) #define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d) #define assignment_type(a) S_assignment_type(aTHX_ a) -#define bad_type_gv(a,b,c,d,e) S_bad_type_gv(aTHX_ a,b,c,d,e) -#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e) +#define bad_type_gv(a,b,c,d) S_bad_type_gv(aTHX_ a,b,c,d) +#define bad_type_pv(a,b,c,d) S_bad_type_pv(aTHX_ a,b,c,d) #define clear_special_blocks(a,b,c) S_clear_special_blocks(aTHX_ a,b,c) #define cop_free(a) S_cop_free(aTHX_ a) #define dup_attrlist(a) S_dup_attrlist(aTHX_ a) diff --git a/ext/Pod-Html/t/pod2html-lib.pl b/ext/Pod-Html/t/pod2html-lib.pl index 42cf1c9..16cc797 100644 --- a/ext/Pod-Html/t/pod2html-lib.pl +++ b/ext/Pod-Html/t/pod2html-lib.pl @@ -64,6 +64,10 @@ sub convert_n_test { if (ord("A") == 193) { # EBCDIC. $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/; } + if (Pod::Simple->VERSION > 3.28) { + $expect =~ s/\n\nsome html/$1/m; + $expect =~ s{(TESTING FOR AND BEGIN</h1>)\n\n}{$1}m; + } # result open my $in, $outfile or die "cannot open $outfile: $!"; diff --git a/op.c b/op.c index 28cca42..637a60e 100644 --- a/op.c +++ b/op.c @@ -541,22 +541,24 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) } STATIC void -S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) +S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) { PERL_ARGS_ASSERT_BAD_TYPE_PV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, OP_DESC(kid)), flags); + (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); } +/* remove flags var, its unused in all callers, move to to right end since gv + and kid are always the same */ STATIC void -S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) +S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) { SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", - (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } STATIC void @@ -9969,7 +9971,7 @@ Perl_ck_fun(pTHX_ OP *o) && ( !SvROK(cSVOPx_sv(kid)) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) - bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid); + bad_type_pv(numargs, "array", o, kid); /* Defer checks to run-time if we have a scalar arg */ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) op_lvalue(kid, type); @@ -9984,7 +9986,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_HVREF: if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); + bad_type_pv(numargs, "hash", o, kid); op_lvalue(kid, type); break; case OA_CVREF: @@ -10010,7 +10012,7 @@ Perl_ck_fun(pTHX_ OP *o) } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(<FH>), close(<FH>) etc. */ - bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid); + bad_type_pv(numargs, "HANDLE", o, kid); } else { I32 flags = OPf_SPECIAL; @@ -11417,9 +11419,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) != OP_ANONCODE && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_RV2CV)) - bad_type_gv(arg, - arg == 1 ? "block or sub {}" : "sub {}", - namegv, 0, o3); + bad_type_gv(arg, namegv, o3, + arg == 1 ? "block or sub {}" : "sub {}"); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -11474,9 +11475,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s", - (int)(end - p), p), - namegv, 0, o3); + bad_type_gv(arg, namegv, o3, + Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); } else goto oops; break; @@ -11484,15 +11484,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type_gv(arg, "symbol", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "symbol"); break; case '&': if (o3->op_type == OP_ENTERSUB && !(o3->op_flags & OPf_STACKED)) goto wrapref; if (!contextclass) - bad_type_gv(arg, "subroutine", namegv, 0, - o3); + bad_type_gv(arg, namegv, o3, "subroutine"); break; case '$': if (o3->op_type == OP_RV2SV || @@ -11507,7 +11506,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_gv(arg, "scalar", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "scalar"); } break; case '@': @@ -11518,7 +11517,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; } if (!contextclass) - bad_type_gv(arg, "array", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "array"); break; case '%': if (o3->op_type == OP_RV2HV || @@ -11528,7 +11527,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; } if (!contextclass) - bad_type_gv(arg, "hash", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "hash"); break; wrapref: aop = S_op_sibling_newUNOP(aTHX_ parent, prev, diff --git a/pad.c b/pad.c index 4e675fa..aa63fde 100644 --- a/pad.c +++ b/pad.c @@ -1940,10 +1940,11 @@ the immediately surrounding code. =cut */ -static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); +static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned); static CV * -S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) +S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, + bool newcv) { I32 ix; PADLIST* const protopadlist = CvPADLIST(proto); @@ -1955,7 +1956,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) const I32 fpad = AvFILLp(protopad); SV** outpad; long depth; - bool subclones = FALSE; + U32 subclones = 0; + bool trouble = FALSE; assert(!CvUNIQUE(proto)); @@ -2042,7 +2044,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) second pass. */ if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { assert(SvTYPE(ppad[ix]) == SVt_PVCV); - subclones = 1; + subclones ++; + if (CvOUTSIDE(ppad[ix]) != proto) + trouble = TRUE; sv = newSV_type(SVt_PVCV); CvLEXICAL_on(sv); } @@ -2088,12 +2092,70 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) } if (subclones) - for (ix = fpad; ix > 0; ix--) { + { + if (trouble || cloned) { + /* Uh-oh, we have trouble! At least one of the state subs here + has its CvOUTSIDE pointer pointing somewhere unexpected. It + could be pointing to another state protosub that we are + about to clone. So we have to track which sub clones come + from which protosubs. If the CvOUTSIDE pointer for a parti- + cular sub points to something we have not cloned yet, we + delay cloning it. We must loop through the pad entries, + until we get a full pass with no cloning. If any uncloned + subs remain (probably nested inside anonymous or âmyâ subs), + then they get cloned in a final pass. + */ + bool cloned_in_this_pass; + if (!cloned) + cloned = (HV *)sv_2mortal((SV *)newHV()); + do { + cloned_in_this_pass = FALSE; + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + { + CV * const protokey = CvOUTSIDE(ppad[ix]); + CV ** const cvp = protokey == proto + ? &cv + : (CV **)hv_fetch(cloned, (char *)&protokey, + sizeof(CV *), 0); + if (cvp && *cvp) { + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + *cvp, cloned); + hv_store(cloned, (char *)&ppad[ix], + sizeof(CV *), + SvREFCNT_inc_simple_NN(PL_curpad[ix]), + 0); + subclones--; + cloned_in_this_pass = TRUE; + } + } + } + } while (cloned_in_this_pass); + if (subclones) + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + CvOUTSIDE(ppad[ix]), cloned); + } + } + else for (ix = fpad; ix > 0; ix--) { PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) - S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv); + S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, + NULL); } + } if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; @@ -2186,7 +2248,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) } static CV * -S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) +S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) { #ifdef USE_ITHREADS dVAR; @@ -2221,7 +2283,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) mg_copy((SV *)proto, (SV *)cv, 0, 0); if (CvPADLIST(proto)) - cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv); + cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); @@ -2239,7 +2301,7 @@ Perl_cv_clone(pTHX_ CV *proto) PERL_ARGS_ASSERT_CV_CLONE; if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone"); - return S_cv_clone(aTHX_ proto, NULL, NULL); + return S_cv_clone(aTHX_ proto, NULL, NULL, NULL); } /* Called only by pp_clonecv */ @@ -2248,7 +2310,7 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target) { PERL_ARGS_ASSERT_CV_CLONE_INTO; cv_undef(target); - return S_cv_clone(aTHX_ proto, target, NULL); + return S_cv_clone(aTHX_ proto, target, NULL, NULL); } /* diff --git a/perl.c b/perl.c index 2ebc4f7..bb4a342 100644 --- a/perl.c +++ b/perl.c @@ -3626,7 +3626,7 @@ S_init_main_stash(pTHX) GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ #ifdef PERL_DONT_CREATE_GVSV - gv_SVadd(PL_errgv); + (void)gv_SVadd(PL_errgv); #endif sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ CLEAR_ERRSV(); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3ce47f6..11d0273 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -53,6 +53,10 @@ This is equivalent to putting C<?:> at the beginning of every capturing group. See L<perlre/"n"> for more information. +=head2 C<prototype> with no arguments + +C<prototype()> with no arguments now infers C<$_>. [perl #123514] + =head1 Security XXX Any security-related notices go here. In particular, any security @@ -161,6 +165,25 @@ A bug where, after an ithread creation or psuedofork, special/immortal SVs in the child ithread/psuedoprocess did not have the correct class of C<B::SPECIAL>, has been fixed. +The C<id> and C<outid> PADLIST methods have been added. + +=item * + +L<B::Deparse> has been upgraded from version 1.31 to 1.32. + +Deparsing C<BEGIN { undef &foo }> with the B<-w> switch enabled started to +emit 'uninitialized' warnings in Perl 5.14. This has been fixed. + +Deparsing calls to subs with a C<(;+)> prototype resulted in an infinite +loop. The C<(;$>) C<(_)> and C<(;_)> prototypes were given the wrong +precedence, causing C<foo($a<$b)> to be deparsed without the parentheses. + +=item * + +L<Safe> has been upgraded from version 2.38 to 2.39. + +C<reval> was not propagating void context properly. + =back =head2 Removed Modules and Pragmata @@ -376,6 +399,11 @@ Support for building without PerlIO has been removed from the Windows makefiles. Non-PerlIO builds were all but deprecated in Perl 5.18.0 and are already not supported by F<Configure> on POSIX systems. +=item * + +Between 2 and 6 ms and 7 I/O calls have been saved per attempt to open a perl +module for each path in C<@INC>. + =back =back @@ -435,6 +463,50 @@ means they have to be compiled within the scope of C<S<"use locale">>), and there must be a string of at least 128 consecutive bytes to match. [perl #123539] +=item * + +C<s///> now works on very long strings instead of dying with 'Substitution +loop'. [perl #103260] [perl #123071] + +=item * + +C<gmtime> no longer crashes with not-a-number values. [perl #123495] + +=item * + +C<\()> (reference to an empty list) and C<y///> with lexical $_ in scope +could do a bad write past the end of the stack. They have been fixed +to extend the stack first. + +=item * + +C<prototype()> with no arguments used to read the previous item on the +stack, so C<print "foo", prototype()> would print foo's prototype. It has +been fixed to infer $_ instead. [perl #123514] + +=item * + +Some cases of lexical state subs inside predeclared subs could crash but no +longer do. + +=item * + +Some cases of nested lexical state subs inside anonymous subs could cause +'Bizarre copy' errors or possibly even crash. + +=item * + +When trying to emit warnings, perl's default debugger (F<perl5db.pl>) was +sometimes giving 'Undefined subroutine &DB::db_warn called' instead. This +bug, which started to occur in Perl 5.18, has been fixed. [perl #123553] + +=item * + +Certain syntax errors in substitutions, such as C<< s/${<>{})// >>, would +crash, and had done so since Perl 5.10. (In some cases the crash did not +start happening till 5.16.) The crash has, of course, been fixed. +[perl #123542] + =back =head1 Known Problems diff --git a/pod/perldiag.pod b/pod/perldiag.pod index c7c32e3..84577ae 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3704,6 +3704,12 @@ in the remaining packages of the MRO of this class. If you don't want it throwing an exception, use C<maybe::next::method> or C<next::can>. See L<mro>. +=item Non-finite repeat count does nothing + +(W numeric) You tried to execute the +L<C<x>|perlop/Multiplicative Operators> repetition operator C<Inf> (or +C<-Inf>) or C<NaN> times, which doesn't make sense. + =item Non-hex character in regex; marked by S<<-- HERE> in m/%s/ (F) In a regular expression, there was a non-hexadecimal character where diff --git a/pp.c b/pp.c index 753385b..8c66286 100644 --- a/pp.c +++ b/pp.c @@ -1649,6 +1649,7 @@ PP(pp_repeat) dSP; dATARGET; IV count; SV *sv; + bool infnan = FALSE; if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { /* TODO: think of some way of doing list-repeat overloading ??? */ @@ -1691,19 +1692,27 @@ PP(pp_repeat) } } else if (SvNOKp(sv)) { - const NV nv = SvNV_nomg(sv); - if (nv < 0.0) - count = -1; /* An arbitrary negative integer */ - else - count = (IV)nv; + const NV nv = SvNV_nomg(sv); + infnan = Perl_isinfnan(nv); + if (UNLIKELY(infnan)) { + count = 0; + } else { + if (nv < 0.0) + count = -1; /* An arbitrary negative integer */ + else + count = (IV)nv; + } } else - count = SvIV_nomg(sv); + count = SvIV_nomg(sv); - if (count < 0) { + if (infnan) { + Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), + "Non-finite repeat count does nothing"); + } else if (count < 0) { count = 0; Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), - "Negative repeat count does nothing"); + "Negative repeat count does nothing"); } if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { diff --git a/pp_ctl.c b/pp_ctl.c index f2c9856..37b822c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2090,6 +2090,28 @@ PP(pp_leave) RETURN; } +static bool +S_outside_integer(pTHX_ SV *sv) +{ + if (SvOK(sv)) { + const NV nv = SvNV_nomg(sv); + if (Perl_isinfnan(nv)) + return TRUE; +#ifdef NV_PRESERVES_UV + if (nv < (NV)IV_MIN || nv > (NV)IV_MAX) + return TRUE; +#else + if (nv <= (NV)IV_MIN) + return TRUE; + if ((nv > 0) && + ((nv > (NV)UV_MAX || + SvUV_nomg(sv) > (UV)IV_MAX))) + return TRUE; +#endif + } + return FALSE; +} + PP(pp_enteriter) { dSP; dMARK; @@ -2148,32 +2170,13 @@ PP(pp_enteriter) SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - NV nv; cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; /* Make sure that no-one re-orders cop.h and breaks our assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); -#ifdef NV_PRESERVES_UV - if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) || - (nv > (NV)IV_MAX))) - || - (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) || - (nv < (NV)IV_MIN)))) -#else - if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN) - || - ((nv > 0) && - ((nv > (NV)UV_MAX) || - (SvUV_nomg(sv) > (UV)IV_MAX))))) - || - (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN) - || - ((nv > 0) && - ((nv > (NV)UV_MAX) || - (SvUV_nomg(right) > (UV)IV_MAX)) - )))) -#endif + if (S_outside_integer(aTHX_ sv) || + S_outside_integer(aTHX_ right)) DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); @@ -3578,6 +3581,7 @@ S_check_type_and_open(pTHX_ SV *name) { Stat_t st; STRLEN len; + PerlIO * retio; const char *p = SvPV_const(name, len); int st_rc; @@ -3592,6 +3596,11 @@ S_check_type_and_open(pTHX_ SV *name) if (!IS_SAFE_PATHNAME(p, len, "require")) return NULL; + /* on Win32 stat is expensive (it does an open() and close() twice and + a couple other IO calls), the open will fail with a dir on its own with + errno EACCES, so only do a stat to separate a dir from a real EACCES + caused by user perms */ +#ifndef WIN32 /* we use the value of errno later to see how stat() or open() failed. * We don't want it set if the stat succeeded but we still failed, * such as if the name exists, but is a directory */ @@ -3602,12 +3611,29 @@ S_check_type_and_open(pTHX_ SV *name) if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } +#endif #if !defined(PERLIO_IS_STDIO) - return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); + retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); #else - return PerlIO_open(p, PERL_SCRIPT_MODE); + retio = PerlIO_open(p, PERL_SCRIPT_MODE); +#endif +#ifdef WIN32 + /* EACCES stops the INC search early in pp_require to implement + feature RT #113422 */ + if(!retio && errno == EACCES) { /* exists but probably a directory */ + int eno; + st_rc = PerlLIO_stat(p, &st); + if (st_rc >= 0) { + if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) + eno = 0; + else + eno = EACCES; + errno = eno; + } + } #endif + return retio; } #ifndef PERL_DISABLE_PMC diff --git a/proto.h b/proto.h index b72c283..58724ac 100644 --- a/proto.h +++ b/proto.h @@ -6305,19 +6305,19 @@ STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp STATIC I32 S_assignment_type(pTHX_ const OP *o) __attribute__warn_unused_result__; -STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) +STATIC void S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) - __attribute__nonnull__(pTHX_5); + __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_BAD_TYPE_GV \ - assert(t); assert(gv); assert(kid) + assert(gv); assert(kid); assert(t) -STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) +STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) - __attribute__nonnull__(pTHX_5); + __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_BAD_TYPE_PV \ - assert(t); assert(name); assert(kid) + assert(t); assert(o); assert(kid) STATIC void S_clear_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv) __attribute__nonnull__(pTHX_1) diff --git a/t/lib/warnings/op b/t/lib/warnings/op index a468ebe..009a102 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -1942,3 +1942,20 @@ no warnings 'numeric'; EXPECT Negative repeat count does nothing at - line 3. Negative repeat count does nothing at - line 4. +######## +my $a = "inf" + 0; +my $b = -$a; +my $c = "nan" + 0; +use warnings 'numeric'; +my $x = "x" x $a; +my $y = "y" x $b; +my $z = "z" x $c; +no warnings 'numeric'; +my $x = "x" x $a; +my $y = "y" x $b; +my $z = "z" x $c; +no warnings 'numeric'; +EXPECT +Non-finite repeat count does nothing at - line 5. +Non-finite repeat count does nothing at - line 6. +Non-finite repeat count does nothing at - line 7. diff --git a/t/op/infnan.t b/t/op/infnan.t index 86135a0..bb03fd4 100644 --- a/t/op/infnan.t +++ b/t/op/infnan.t @@ -241,6 +241,21 @@ SKIP: { } } +{ + # Silence "Non-finite repeat count", that is tested elsewhere. + local $^W = 0; + is("a" x $PInf, "", "x +Inf"); + is("a" x $NInf, "", "x -Inf"); +} + +{ + eval 'for my $x (0..$PInf) { last }'; + like($@, qr/Range iterator outside integer range/, "0..+Inf fails"); + + eval 'for my $x ($NInf..0) { last }'; + like($@, qr/Range iterator outside integer range/, "-Inf..0 fails"); +} + # === NaN === cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)"); @@ -358,6 +373,12 @@ SKIP: { } } +{ + # Silence "Non-finite repeat count", that is tested elsewhere. + local $^W = 0; + is("a" x $NaN, "", "x NaN"); +} + # === Tests combining Inf and NaN === # is() okay with $NaN because it uses eq. @@ -378,6 +399,14 @@ ok(!($NaN > $NInf), "NaN is not gt -Inf"); is(sin($PInf), $NaN, "sin(+Inf) is NaN"); +{ + eval 'for my $x (0..$NaN) { last }'; + like($@, qr/Range iterator outside integer range/, "0..NaN fails"); + + eval 'for my $x ($NaN..0) { last }'; + like($@, qr/Range iterator outside integer range/, "NaN..0 fails"); +} + # === Overflows and Underflows === # 1e9999 (and 1e-9999) are large (and small) enough for even diff --git a/t/op/lexsub.t b/t/op/lexsub.t index 2ba7635..b1b76e8 100644 --- a/t/op/lexsub.t +++ b/t/op/lexsub.t @@ -7,7 +7,7 @@ BEGIN { *bar::is = *is; *bar::like = *like; } -plan 148; +plan 151; # -------------------- Errors with feature disabled -------------------- # @@ -291,6 +291,45 @@ sub make_anon_with_state_sub{ 'state subs in anon subs are cloned'; is &$s(0), &$s(0), 'but only when the anon sub is cloned'; } +# Check that nested state subs close over variables properly +{ + is sub { + state sub a; + state sub b { + state sub c { + state $x = 42; + sub a { $x } + } + c(); + } + b(); + a(); + }->(), 42, 'state sub with body defined in doubly-nested state subs'; + is sub { + state sub a; + state sub b; + state sub c { + sub b { + state $x = 42; + sub a { $x } + } + } + b(); + a(); + }->(), 42, 'nested state subs declared in same scope'; + state $w; + local $SIG{__WARN__} = sub { $w .= shift }; + use warnings 'closure'; + my $sub = sub { + state sub a; + sub { + my $x; + sub a { $x } + } + }; + like $w, qr/Variable \"\$x\" is not available at /, + "unavailability warning when state closure is defined in anon sub"; +} { state sub BEGIN { exit }; pass 'state subs are never special blocks'; diff --git a/t/porting/customized.dat b/t/porting/customized.dat index d05c87f..9bde2de 100644 --- a/t/porting/customized.dat +++ b/t/porting/customized.dat @@ -1,4 +1,3 @@ -Digest::MD5 cpan/Digest-MD5/t/files.t bdbe05b705d9da305fedce7a9f4b6ba63250c7cf Encode cpan/Encode/encoding.pm 506ec84f1fbbff189c3f4f47b92aff5afc95b98e ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/pm_to_blib.t 71ebcee355691ce374fcad251b12d8b2412462b3 PerlIO::via::QuotedPrint cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t ca39f0146e89de02c746e199c45dcb3e5edad691 -- Perl5 Master Repository
