summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorH.Merijn Brand <h.m.brand@xs4all.nl>2010-04-16 14:03:05 +0200
committerH.Merijn Brand <h.m.brand@xs4all.nl>2010-04-16 14:03:05 +0200
commit657e06c98954af67a44f5f656146e090199a9e30 (patch)
tree4e2332e245b470ae284672e74625edc1977f0b3a
parentbea44226491dc1db6d1f4bf2fadb3466c511b963 (diff)
parent4bdcd28f79941508a8c93ba2f2708d7a6cd03bc2 (diff)
downloadperl-657e06c98954af67a44f5f656146e090199a9e30.tar.gz
Merge branch 'blead' of perl5.git.perl.org:/gitroot/perl into blead
-rw-r--r--MANIFEST2
-rw-r--r--Porting/Glossary4
-rwxr-xr-xPorting/Maintainers.pl6
-rw-r--r--Porting/how_to_write_a_perldelta.pod4
-rw-r--r--av.c2
-rw-r--r--cop.h1
-rw-r--r--cpan/CGI/Changes20
-rw-r--r--cpan/CGI/lib/CGI.pm79
-rw-r--r--cpan/CGI/lib/CGI/Carp.pm53
-rw-r--r--cpan/CGI/lib/CGI/Cookie.pm21
-rw-r--r--cpan/CGI/lib/CGI/Fast.pm8
-rw-r--r--cpan/CGI/lib/CGI/Util.pm29
-rw-r--r--cpan/CGI/t/carp.t110
-rw-r--r--cpan/CGI/t/function.t5
-rw-r--r--cpan/CGI/t/url.t23
-rw-r--r--dist/Data-Dumper/Changes6
-rw-r--r--dist/Data-Dumper/Dumper.pm6
-rw-r--r--dist/Data-Dumper/Dumper.xs4
-rw-r--r--dist/Data-Dumper/t/terse.t22
-rw-r--r--dist/threads-shared/shared.pm9
-rw-r--r--dist/threads-shared/shared.xs45
-rw-r--r--dist/threads/t/basic.t11
-rw-r--r--dist/threads/t/exit.t10
-rw-r--r--dist/threads/t/thread.t24
-rw-r--r--dist/threads/threads.pm27
-rwxr-xr-xdist/threads/threads.xs56
-rw-r--r--dump.c1
-rw-r--r--ext/IPC-Open3/lib/IPC/Open3.pm147
-rw-r--r--ext/IPC-Open3/t/IPC-Open3.t19
-rw-r--r--handy.h9
-rw-r--r--lib/perl5db.t2
-rw-r--r--mg.c15
-rw-r--r--numeric.c6
-rw-r--r--pod/perl5114delta.pod2
-rw-r--r--pod/perldiag.pod8
-rw-r--r--pod/perlrepository.pod23
-rw-r--r--pod/perltodo.pod5
-rw-r--r--pod/perlvar.pod7
-rw-r--r--pp.c2
-rw-r--r--pp_ctl.c7
-rw-r--r--pp_hot.c9
-rw-r--r--regexec.c26
-rw-r--r--run.c4
-rw-r--r--scope.c4
-rw-r--r--sv.c6
-rw-r--r--t/op/magic.t34
-rw-r--r--t/re/re.t10
-rw-r--r--toke.c2
-rw-r--r--utf8.c3
49 files changed, 685 insertions, 253 deletions
diff --git a/MANIFEST b/MANIFEST
index da0c1f3fb2..eae0fffbb0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -224,6 +224,7 @@ cpan/CGI/t/unescapeHTML.t See if CGI::unescapeHTML() works
cpan/CGI/t/uploadInfo.t See if CGI.pm works
cpan/CGI/t/upload_post_text.txt Test data for CGI.pm
cpan/CGI/t/upload.t See if CGI.pm works
+cpan/CGI/t/url.t See if CGI.pm works
cpan/CGI/t/user_agent.t See if CGI->user_agent() works
cpan/CGI/t/utf8.t See if CGI.pm works
cpan/CGI/t/util-58.t See if 5.8-dependent features work
@@ -2606,6 +2607,7 @@ dist/Data-Dumper/t/freezer.t See if $Data::Dumper::Freezer works
dist/Data-Dumper/Todo Data pretty printer, futures
dist/Data-Dumper/t/overload.t See if Data::Dumper works for overloaded data
dist/Data-Dumper/t/pair.t See if Data::Dumper pair separator works
+dist/Data-Dumper/t/terse.t See if Data::Dumper terse option works
dist/ExtUtils-Install/Changes ExtUtils-Install change log
dist/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on installed extensions
dist/ExtUtils-Install/lib/ExtUtils/Install.pm Handles 'make install' on extensions
diff --git a/Porting/Glossary b/Porting/Glossary
index 57626e55c2..e0df178db8 100644
--- a/Porting/Glossary
+++ b/Porting/Glossary
@@ -1621,8 +1621,8 @@ d_prctl (d_prctl.U):
This variable conditionally defines the HAS_PRCTL symbol, which
indicates to the C program that the prctl() routine is available.
-d_prctl_set_name (d_prctl_set_name.U):
- This variable conditionally defines the HAS_PRCTL_SET_NAME symbol,
+d_prctl_set_name (d_prctl.U):
+ This variable conditionally defines the HAS_PRCTL_SET_NAME symbol,
which indicates to the C program that the prctl() routine supports
the PR_SET_NAME option.
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index f37c89593f..771aade873 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -308,7 +308,7 @@ use File::Glob qw(:case);
'CGI' =>
{
'MAINTAINER' => 'lstein',
- 'DISTRIBUTION' => 'LDS/CGI.pm-3.48.tar.gz',
+ 'DISTRIBUTION' => 'LDS/CGI.pm-3.49.tar.gz',
'FILES' => q[cpan/CGI],
'EXCLUDED' => [ qr{^t/lib/Test},
qw( cgi-lib_porting.html
@@ -1559,7 +1559,7 @@ use File::Glob qw(:case);
'threads' =>
{
'MAINTAINER' => 'jdhedden',
- 'DISTRIBUTION' => 'JDHEDDEN/threads-1.75.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-1.77.tar.gz',
'FILES' => q[dist/threads],
'EXCLUDED' => [ qw(examples/pool.pl
t/pod.t
@@ -1573,7 +1573,7 @@ use File::Glob qw(:case);
'threads::shared' =>
{
'MAINTAINER' => 'jdhedden',
- 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.32.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.33.tar.gz',
'FILES' => q[dist/threads-shared],
'EXCLUDED' => [ qw(examples/class.pl
shared.h
diff --git a/Porting/how_to_write_a_perldelta.pod b/Porting/how_to_write_a_perldelta.pod
index 5a55095f7d..6cae763b37 100644
--- a/Porting/how_to_write_a_perldelta.pod
+++ b/Porting/how_to_write_a_perldelta.pod
@@ -302,11 +302,11 @@ The list of people to thank goes here.
You can find the list of committers and authors by:
- % git log v5.11.1..HEAD | perl -nlwe '$seen{$1}++ if /^Author: ([^<]*)/; END { print for sort keys %seen }'
+ % git log --pretty='format:%an' v5.11.1..HEAD | sort | uniq
And how many files where changed by:
- % git diff v5.11.1..HEAD | diffstat
+ % git diff --stat=200,200 v5.11.1..HEAD
=item Reporting Bugs
diff --git a/av.c b/av.c
index a4d6ea2d06..fb853a648c 100644
--- a/av.c
+++ b/av.c
@@ -977,7 +977,7 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
mg = mg_find(sv, PERL_MAGIC_tiedelem);
if (mg) {
magic_existspack(sv, mg);
- return (bool)SvTRUE(sv);
+ return cBOOL(SvTRUE(sv));
}
}
diff --git a/cop.h b/cop.h
index 6c51d73285..420a5d1790 100644
--- a/cop.h
+++ b/cop.h
@@ -592,6 +592,7 @@ struct block {
/* Exit a block (RETURN and LAST). */
#define POPBLOCK(cx,pm) \
DEBUG_CX("POP"); \
+ PERL_ASYNC_CHECK(); \
cx = &cxstack[cxstack_ix--], \
newsp = PL_stack_base + cx->blk_oldsp, \
PL_curcop = cx->blk_oldcop, \
diff --git a/cpan/CGI/Changes b/cpan/CGI/Changes
index e7acabd0fa..fb1644ff64 100644
--- a/cpan/CGI/Changes
+++ b/cpan/CGI/Changes
@@ -1,3 +1,23 @@
+Version 3.49
+
+ [BUG FIXES]
+ 1. Fix a regression since 3.44 involving a case when the header includes "Content-Length: 0".
+ Thanks to Alex Vandiver (RT#51109)
+ 2. Suppress uninitialized warnings under -w. Thanks to burak. (RT#50301)
+ 3. url() now uses virtual_port() instead of server_port(). Thanks to MKANAT and Yanick Champoux. (RT#51562)
+
+ [SECURITY]
+ 1. embedded newlines are now filtered out of header values in header().
+ Thanks to Mark Stosberg and Yanick Champoux.
+
+ [DOCUMENTATION]
+ 1. README was updated to reflect that CGI.pm was moved under ./lib.
+ Thanks to Alex Vandiver.
+
+ [INTERNALS]
+ 1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485)
+ 2. Attempt to avoid test failures with t/fast, thanks to Steve Hay. (RT#49599)
+
Version 3.48
[BUG FIXES]
diff --git a/cpan/CGI/lib/CGI.pm b/cpan/CGI/lib/CGI.pm
index 0cba88172c..355b8d1805 100644
--- a/cpan/CGI/lib/CGI.pm
+++ b/cpan/CGI/lib/CGI.pm
@@ -19,7 +19,7 @@ use Carp 'croak';
# http://stein.cshl.org/WWW/software/CGI/
$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.48';
+$CGI::VERSION='3.49';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -663,7 +663,7 @@ sub init {
if ( $content_length > 0 ) {
$self->read_from_client(\$query_string,$content_length,0);
}
- else {
+ elsif (not defined $ENV{CONTENT_LENGTH}) {
$self->read_from_stdin(\$query_string);
# should this be PUTDATA in case of PUT ?
my($param) = $meth . 'DATA' ;
@@ -1542,6 +1542,16 @@ sub header {
'EXPIRES','NPH','CHARSET',
'ATTACHMENT','P3P'],@p);
+ # CR escaping for values, per RFC 822
+ for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
+ if (defined $header) {
+ $header =~ s/
+ (?<=\n) # For any character proceeded by a newline
+ (?=\S) # ... that is not whitespace
+ / /xg; # ... inject a leading space in the new line
+ }
+ }
+
$nph ||= $NPH;
$type ||= 'text/html' unless defined($type);
@@ -1557,7 +1567,7 @@ sub header {
# need to fix it up a little.
for (@other) {
# Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
@@ -2566,6 +2576,7 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
+ $name = q{} if ! defined $name;
$result = qq/<select name="$name" $tabindex$other>\n/;
for (@values) {
if (/<optgroup/) {
@@ -2626,7 +2637,7 @@ sub optgroup {
@values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
my($other) = @other ? " @other" : '';
- $name=$self->_maybe_escapeHTML($name);
+ $name = $self->_maybe_escapeHTML($name) || q{};
$result = qq/<optgroup label="$name"$other>\n/;
for (@values) {
if (/<optgroup/) {
@@ -2842,21 +2853,22 @@ sub url {
# $uri =~ s/\Q$path\E$// if defined $path; # remove path
if ($full) {
- my $protocol = $self->protocol();
- $url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host') || '';
- $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
- if ($vh) {
- $url .= $vh;
- } else {
- $url .= server_name();
- }
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
+ my $protocol = $self->protocol();
+ $url = "$protocol://";
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
+
+ $url .= $vh || server_name();
+
+ my $port = $self->virtual_port;
+
+ # add the port to the url unless it's the protocol's default port
+ $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
+ or (lc($protocol) eq 'https' && $port == 443);
+
return $url if $base;
- $url .= $uri;
+
+ $url .= $uri;
} elsif ($relative) {
($url) = $uri =~ m!([^/]+)$!;
} elsif ($absolute) {
@@ -4759,7 +4771,7 @@ a short example of creating multiple session records:
use CGI;
- open (OUT,">>test.out") || die;
+ open (OUT,'>>','test.out') || die;
$records = 5;
for (0..$records) {
my $q = CGI->new;
@@ -4769,7 +4781,7 @@ a short example of creating multiple session records:
close OUT;
# reopen for reading
- open (IN,"test.out") || die;
+ open (IN,'<','test.out') || die;
while (!eof(IN)) {
my $q = CGI->new(\*IN);
print $q->param('counter'),"\n";
@@ -5265,6 +5277,18 @@ In either case, the outgoing header will be formatted as:
P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
+Note that if a header value contains a carriage return, a leading space will be
+added to each new line that doesn't already have one as specified by RFC2616
+section 4.2. For example:
+
+ print header( -ingredients => "ham\neggs\nbacon" );
+
+will generate
+
+ Ingredients: ham
+ eggs
+ bacon
+
=head2 GENERATING A REDIRECTION HEADER
print $q->redirect('http://somewhere.else/in/movie/land');
@@ -6198,12 +6222,12 @@ handle for a file upload field like this:
# undef may be returned if it's not a valid file handle
if (defined $lightweight_fh) {
# Upgrade the handle to one compatible with IO::Handle:
- my $io_handle = $lightweight_fh->handle;
+ my $io_handle = $lightweight_fh->handle;
- open (OUTFILE,">>/usr/local/web/users/feedback");
- while ($bytesread = $io_handle->read($buffer,1024)) {
- print OUTFILE $buffer;
- }
+ open (OUTFILE,'>>','/usr/local/web/users/feedback');
+ while ($bytesread = $io_handle->read($buffer,1024)) {
+ print OUTFILE $buffer;
+ }
}
In a list context, upload() will return an array of filehandles.
@@ -8024,13 +8048,12 @@ for suggestions and bug fixes.
}
sub do_work {
- my(@values,$key);
print "<h2>Here are the current settings in this form</h2>";
- for $key (param) {
+ for my $key (param) {
print "<strong>$key</strong> -> ";
- @values = param($key);
+ my @values = param($key);
print join(", ",@values),"<br>\n";
}
}
diff --git a/cpan/CGI/lib/CGI/Carp.pm b/cpan/CGI/lib/CGI/Carp.pm
index 381635e87e..5f9911b32e 100644
--- a/cpan/CGI/lib/CGI/Carp.pm
+++ b/cpan/CGI/lib/CGI/Carp.pm
@@ -423,35 +423,26 @@ sub ineval {
sub die {
my ($arg,@rest) = @_;
- if ($DIE_HANDLER) {
- &$DIE_HANDLER($arg,@rest);
- }
+ &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
- if ( ineval() ) {
- if (!ref($arg)) {
- $arg = join("",($arg,@rest)) || "Died";
- my($file,$line,$id) = id(1);
- $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
- realdie($arg);
- }
- else {
- realdie($arg,@rest);
- }
- }
+ # if called as die( $object, 'string' ),
+ # all is stringified, just like with
+ # the real 'die'
+ $arg = join '' => "$arg", @rest if @rest;
+
+ $arg ||= 'Died';
+
+ my($file,$line,$id) = id(1);
+
+ $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
+
+ realdie $arg if ineval();
+ &fatalsToBrowser($arg) if $WRAP;
+
+ $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
+
+ $arg .= "\n" unless $arg =~ /\n$/;
- if (!ref($arg)) {
- $arg = join("", ($arg,@rest));
- my($file,$line,$id) = id(1);
- $arg .= " at $file line $line." unless $arg=~/\n$/;
- &fatalsToBrowser($arg) if $WRAP;
- if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
- my $stamp = stamp;
- $arg=~s/^/$stamp/gm;
- }
- if ($arg !~ /\n$/) {
- $arg .= "\n";
- }
- }
realdie $arg;
}
@@ -503,11 +494,15 @@ sub warningsToBrowser {
# headers
sub fatalsToBrowser {
- my($msg) = @_;
+ my $msg = shift;
+
+ $msg = "$msg" if ref $msg;
+
$msg=~s/&/&amp;/g;
$msg=~s/>/&gt;/g;
$msg=~s/</&lt;/g;
- $msg=~s/\"/&quot;/g;
+ $msg=~s/"/&quot;/g;
+
my($wm) = $ENV{SERVER_ADMIN} ?
qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
"this site's webmaster";
diff --git a/cpan/CGI/lib/CGI/Cookie.pm b/cpan/CGI/lib/CGI/Cookie.pm
index 85a07f0bc0..7bc090d418 100644
--- a/cpan/CGI/lib/CGI/Cookie.pm
+++ b/cpan/CGI/lib/CGI/Cookie.pm
@@ -1,5 +1,8 @@
package CGI::Cookie;
+use strict;
+use warnings;
+
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
@@ -78,14 +81,13 @@ sub get_raw_cookie {
$r ||= eval { $MOD_PERL == 2 ?
Apache2::RequestUtil->request() :
Apache->request } if $MOD_PERL;
- if ($r) {
- $raw_cookie = $r->headers_in->{'Cookie'};
- } else {
- if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
- die "Run $r->subprocess_env; before calling fetch()";
- }
- $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
- }
+
+ return $r->headers_in->{'Cookie'} if $r;
+
+ die "Run $r->subprocess_env; before calling fetch()"
+ if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
+
+ return $ENV{HTTP_COOKIE} || $ENV{COOKIE};
}
@@ -122,7 +124,8 @@ sub new {
shift if ref $_[0]
&& eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
my($name,$value,$path,$domain,$secure,$expires,$httponly) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
+ rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
+ HTTPONLY / ], @_);
# Pull out our parameters.
my @values;
diff --git a/cpan/CGI/lib/CGI/Fast.pm b/cpan/CGI/lib/CGI/Fast.pm
index 67d67ee685..e31dac3f50 100644
--- a/cpan/CGI/lib/CGI/Fast.pm
+++ b/cpan/CGI/lib/CGI/Fast.pm
@@ -1,6 +1,10 @@
package CGI::Fast;
use strict;
-$^W=1; # A way to say "use warnings" that's compatible with even older perls.
+
+# A way to say "use warnings" that's compatible with even older perls.
+# making it local will not affect the code that loads this module
+# and since we're not in a BLOCK, warnings are enabled until the EOF
+local $^W = 1;
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
@@ -15,7 +19,7 @@ $^W=1; # A way to say "use warnings" that's compatible with even older perls.
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-$CGI::Fast::VERSION='1.07';
+$CGI::Fast::VERSION='1.08';
use CGI;
use FCGI;
diff --git a/cpan/CGI/lib/CGI/Util.pm b/cpan/CGI/lib/CGI/Util.pm
index 1f4201d064..eb639e40d5 100644
--- a/cpan/CGI/lib/CGI/Util.pm
+++ b/cpan/CGI/lib/CGI/Util.pm
@@ -244,11 +244,38 @@ sub unescape {
# was always so and cannot be fixed without breaking the binary data case.
# -- Stepan Kasal <skasal@redhat.com>
#
+if ($] == 5.008) {
+ package utf8;
+
+ no warnings 'redefine'; # needed for Perl 5.8.1+
+
+ my $is_utf8_redefinition = <<'EOR';
+ sub is_utf8 {
+ my ($text) = @_;
+
+ my $ctext = pack q{C0a*}, $text;
+
+ return ($text ne $ctext) && ($ctext =~ m/^(
+ [\x09\x0A\x0D\x20-\x7E]
+ | [\xC2-\xDF][\x80-\xBF]
+ | \xE0[\xA0-\xBF][\x80-\xBF]
+ | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}
+ | \xED[\x80-\x9F][\x80-\xBF]
+ | \xF0[\x90-\xBF][\x80-\xBF]{2}
+ | [\xF1-\xF3][\x80-\xBF]{3}
+ | \xF4[\x80-\x8F][\x80-\xBF]{2}
+ )*$/xo);
+ }
+EOR
+
+ eval $is_utf8_redefinition;
+}
+
sub escape {
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
my $toencode = shift;
return undef unless defined($toencode);
- utf8::encode($toencode) if ($] > 5.008001 && utf8::is_utf8($toencode));
+ utf8::encode($toencode) if ($] >= 5.008 && utf8::is_utf8($toencode));
if ($EBCDIC) {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
diff --git a/cpan/CGI/t/carp.t b/cpan/CGI/t/carp.t
index ff5eaf498e..be6292867b 100644
--- a/cpan/CGI/t/carp.t
+++ b/cpan/CGI/t/carp.t
@@ -3,7 +3,7 @@
use strict;
-use Test::More tests => 41;
+use Test::More tests => 59;
use IO::Handle;
BEGIN { use_ok('CGI::Carp') };
@@ -116,12 +116,13 @@ like($@,
# Test that realwarn is called
{
local $^W = 0;
- eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
-}
+ local *CGI::Carp::realdie = sub { my $mess = shift; return $mess };
-like(CGI::Carp::die('There is a problem'),
- $stamp,
- 'CGI::Carp::die calls CORE::die, but adds stamp');
+ like(CGI::Carp::die('There is a problem'),
+ $stamp,
+ 'CGI::Carp::die calls CORE::die, but adds stamp');
+
+}
#-----------------------------------------------------------------------------
# Test set_message
@@ -273,3 +274,100 @@ ok( defined buffer( $fh ), '$fh returns proper filehandle');
ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle');
ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle');
+
+# Calling die with code refs with no WRAP
+{
+ local $CGI::Carp::WRAP = 0;
+
+ eval { CGI::Carp::die( 'regular string' ) };
+ like $@ => qr/regular string/, 'die with string';
+
+ eval { CGI::Carp::die( [ 1..10 ] ) };
+ like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref';
+
+ eval { CGI::Carp::die( { a => 1 } ) };
+ like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref';
+
+ eval { CGI::Carp::die( sub { 'Farewell' } ) };
+ like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref';
+
+ eval { CGI::Carp::die( My::Plain::Object->new ) };
+ isa_ok $@, 'My::Plain::Object';
+
+ eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) };
+ like $@ => qr/My::Plain::Object/, 'object is stringified';
+ like $@ => qr/and another argument/, 'second argument is present';
+
+ eval { CGI::Carp::die( My::Stringified::Object->new ) };
+ isa_ok $@, 'My::Stringified::Object';
+
+ eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) };
+ like $@ => qr/stringified/, 'object is stringified';
+ like $@ => qr/and another argument/, 'second argument is present';
+
+ eval { CGI::Carp::die() };
+ like $@ => qr/Died at/, 'die with no argument';
+}
+
+# Calling die with code refs when WRAPped
+{
+ local $CGI::Carp::WRAP = 1;
+ local *CGI::Carp::realdie = sub { return @_ };
+ local *STDOUT;
+
+ tie *STDOUT, 'StoreStuff';
+
+ my %result; # store results because stdout is kidnapped
+
+ CGI::Carp::die( 'regular string' );
+ $result{string} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( [ 1..10 ] );
+ $result{array_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( { a => 1 } );
+ $result{hash_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( sub { 'Farewell' } );
+ $result{code_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( My::Plain::Object->new );
+ $result{plain_object} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( My::Stringified::Object->new );
+ $result{string_object} .= $_ while <STDOUT>;
+
+ CGI::Carp::die();
+ $result{no_args} .= $_ while <STDOUT>;
+
+ untie *STDOUT;
+
+ like $result{string} => qr/regular string/, 'regular string, wrapped';
+ like $result{array_ref} => qr/ARRAY\(\w+?\)/, 'array ref, wrapped';
+ like $result{hash_ref} => qr/HASH\(\w+?\)/, 'hash ref, wrapped';
+ like $result{code_ref} => qr/CODE\(\w+?\)/, 'code ref, wrapped';
+ like $result{plain_object} => qr/My::Plain::Object/,
+ 'plain object, wrapped';
+ like $result{string_object} => qr/stringified/,
+ 'stringified object, wrapped';
+ like $result{no_args} => qr/Died at/, 'no args, wrapped';
+
+}
+
+{
+ package My::Plain::Object;
+
+ sub new {
+ return bless {}, shift;
+ }
+}
+
+{
+ package My::Stringified::Object;
+
+ use overload '""' => sub { 'stringified' };
+
+ sub new {
+ return bless {}, shift;
+ }
+}
diff --git a/cpan/CGI/t/function.t b/cpan/CGI/t/function.t
index 316b5858a6..101333953f 100644
--- a/cpan/CGI/t/function.t
+++ b/cpan/CGI/t/function.t
@@ -32,11 +32,6 @@ if ($^O eq 'VMS') { $CRLF = "\n"; }
if (ord("\t") != 9) { $CRLF = "\r\n"; }
-# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
-# translation hence CRLF is used as \r\n within CGI.pm on such machines.
-
-if (ord("\t") != 9) { $CRLF = "\r\n"; }
-
# Set up a CGI environment
$ENV{REQUEST_METHOD}='GET';
$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
diff --git a/cpan/CGI/t/url.t b/cpan/CGI/t/url.t
new file mode 100644
index 0000000000..16e20b6fc1
--- /dev/null
+++ b/cpan/CGI/t/url.t
@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+
+use Test::More tests => 4; # last test to print
+
+use CGI qw/ :all /;
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+is virtual_port() => 8484, 'virtual_port()';
+is server_port() => 8080, 'server_port()';
+
+is url() => 'http://proxy:8484', 'url()';
+
+# let's see if we do the defaults right
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80';
+
+is url() => 'http://proxy', 'url() with default port';
+
diff --git a/dist/Data-Dumper/Changes b/dist/Data-Dumper/Changes
index 4efe854ec4..257e7f57d9 100644
--- a/dist/Data-Dumper/Changes
+++ b/dist/Data-Dumper/Changes
@@ -6,6 +6,12 @@ HISTORY - public release history for Data::Dumper
=over 8
+=item 2.126 (Apr 15 2010)
+
+Fix Data::Dumper's Fix Terse(1) + Indent(2):
+perl-RT #73604: When $Data::Dumper::Terse is true, the indentation is thrown
+off. It appears to be acting as if the $VAR1 = is still there.
+
=item 2.125 (Aug 8 2009)
CPAN distribution fixes (meta information for META.yml).
diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm
index 0eb8bf74fd..5967642315 100644
--- a/dist/Data-Dumper/Dumper.pm
+++ b/dist/Data-Dumper/Dumper.pm
@@ -9,7 +9,7 @@
package Data::Dumper;
-$VERSION = '2.125'; # Don't forget to set version and release date in POD!
+$VERSION = '2.126'; # Don't forget to set version and release date in POD!
#$| = 1;
@@ -234,7 +234,7 @@ sub Dumpperl {
my $valstr;
{
local($s->{apad}) = $s->{apad};
- $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
+ $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2 and !$s->{terse};
$valstr = $s->_dump($val, $name);
}
@@ -1297,7 +1297,7 @@ modify it under the same terms as Perl itself.
=head1 VERSION
-Version 2.125 (Aug 8 2009)
+Version 2.126 (Apr 15 2010)
=head1 SEE ALSO
diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index e3867a1838..f2c18211c8 100644
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -1179,7 +1179,7 @@ Data_Dumper_Dumpxs(href, ...)
sv_catpvn(name, tmpbuf, nchars);
}
- if (indent >= 2) {
+ if (indent >= 2 && !terse) {
SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
newapad = newSVsv(apad);
sv_catsv(newapad, tmpsv);
@@ -1193,7 +1193,7 @@ Data_Dumper_Dumpxs(href, ...)
freezer, toaster, purity, deepcopy, quotekeys,
bless, maxdepth, sortkeys);
- if (indent >= 2)
+ if (indent >= 2 && !terse)
SvREFCNT_dec(newapad);
postlen = av_len(postav);
diff --git a/dist/Data-Dumper/t/terse.t b/dist/Data-Dumper/t/terse.t
new file mode 100644
index 0000000000..8d3ad48894
--- /dev/null
+++ b/dist/Data-Dumper/t/terse.t
@@ -0,0 +1,22 @@
+#!perl
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use Data::Dumper;
+
+my $hash = { foo => 42 };
+
+for my $useperl (0..1) {
+ my $dumper = Data::Dumper->new([$hash]);
+ $dumper->Terse(1);
+ $dumper->Indent(2);
+ $dumper->Useperl($useperl);
+
+ is $dumper->Dump, <<'WANT', "Terse(1), Indent(2), Useperl($useperl)";
+{
+ 'foo' => 42
+}
+WANT
+}
diff --git a/dist/threads-shared/shared.pm b/dist/threads-shared/shared.pm
index 72192bc7a0..15e7a021be 100644
--- a/dist/threads-shared/shared.pm
+++ b/dist/threads-shared/shared.pm
@@ -7,7 +7,7 @@ use warnings;
use Scalar::Util qw(reftype refaddr blessed);
-our $VERSION = '1.32';
+our $VERSION = '1.33';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -187,7 +187,7 @@ threads::shared - Perl extension for sharing data structures between threads
=head1 VERSION
-This document describes threads::shared version 1.32
+This document describes threads::shared version 1.33
=head1 SYNOPSIS
@@ -527,7 +527,8 @@ 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.
-Does not support C<splice> on arrays!
+Does not support C<splice> on arrays. Does not support explicitly changing
+array lengths via $#array -- use C<push> and C<pop> instead.
Taking references to the elements of shared arrays and hashes does not
autovivify the elements, and neither does slicing a shared array/hash over
@@ -588,7 +589,7 @@ L<threads::shared> Discussion Forum on CPAN:
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.32/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.33/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs
index 7c9526e2bb..a1c6925f29 100644
--- a/dist/threads-shared/shared.xs
+++ b/dist/threads-shared/shared.xs
@@ -864,29 +864,32 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
- SV** svp;
+ SV** svp = NULL;
ENTER_LOCK;
- if (SvTYPE(saggregate) == SVt_PVAV) {
- assert ( mg->mg_ptr == 0 );
- SHARED_CONTEXT;
- svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
- } else {
- char *key = mg->mg_ptr;
- I32 len = mg->mg_len;
- assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY) {
- STRLEN slen;
- key = SvPV((SV *)mg->mg_ptr, slen);
- len = slen;
- if (SvUTF8((SV *)mg->mg_ptr)) {
- len = -len;
+ if (saggregate) { /* During global destruction, underlying
+ aggregate may no longer exist */
+ if (SvTYPE(saggregate) == SVt_PVAV) {
+ assert ( mg->mg_ptr == 0 );
+ SHARED_CONTEXT;
+ svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
+ } else {
+ char *key = mg->mg_ptr;
+ I32 len = mg->mg_len;
+ assert ( mg->mg_ptr != 0 );
+ if (mg->mg_len == HEf_SVKEY) {
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
}
+ SHARED_CONTEXT;
+ svp = hv_fetch((HV*) saggregate, key, len, 0);
}
- SHARED_CONTEXT;
- svp = hv_fetch((HV*) saggregate, key, len, 0);
+ CALLER_CONTEXT;
}
- CALLER_CONTEXT;
if (svp) {
/* Exists in the array */
if (SvROK(*svp)) {
@@ -957,6 +960,12 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
dTHXc;
MAGIC *shmg;
SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+
+ /* Object may not exist during global destruction */
+ if (! saggregate) {
+ return (0);
+ }
+
ENTER_LOCK;
sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
diff --git a/dist/threads/t/basic.t b/dist/threads/t/basic.t
index 19ce793374..f4d030b792 100644
--- a/dist/threads/t/basic.t
+++ b/dist/threads/t/basic.t
@@ -27,7 +27,7 @@ sub ok {
BEGIN {
$| = 1;
- print("1..33\n"); ### Number of tests that will be run ###
+ print("1..34\n"); ### Number of tests that will be run ###
};
use threads;
@@ -153,14 +153,17 @@ $thrx = threads->object();
ok(30, ! defined($thrx), 'No object');
$thrx = threads->object(undef);
ok(31, ! defined($thrx), 'No object');
-$thrx = threads->object(0);
-ok(32, ! defined($thrx), 'No object');
threads->import('stringify');
$thr1 = threads->create(sub {});
-ok(33, "$thr1" eq $thr1->tid(), 'Stringify');
+ok(32, "$thr1" eq $thr1->tid(), 'Stringify');
$thr1->join();
+# ->object($tid) works like ->self() when $tid is thread's TID
+$thrx = threads->object(threads->tid());
+ok(33, defined($thrx), 'Main thread object');
+ok(34, 0 == $thrx->tid(), "Check so that tid for threads work for main thread");
+
exit(0);
# EOF
diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t
index bb1cec0d5b..29c3dca0da 100644
--- a/dist/threads/t/exit.t
+++ b/dist/threads/t/exit.t
@@ -48,7 +48,7 @@ my $rc = $thr->join();
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
'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 1.75 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.77 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 1.75 qw(exit thread_only);' .
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
}
-my $out = run_perl(prog => 'use threads 1.75;' .
+my $out = run_perl(prog => 'use threads 1.77;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.75;' .
like($out, '1 finished and unjoined', "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.77 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 1.75 qw(exit thread_only);' .
like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t
index 6f33cd4256..b390215f16 100644
--- a/dist/threads/t/thread.t
+++ b/dist/threads/t/thread.t
@@ -20,7 +20,7 @@ BEGIN {
}
$| = 1;
- print("1..34\n"); ### Number of tests that will be run ###
+ print("1..35\n"); ### Number of tests that will be run ###
};
print("ok 1 - Loaded\n");
@@ -161,7 +161,7 @@ package main;
# bugid #24165
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -304,6 +304,26 @@ SKIP: {
"counts of calls to DESTROY");
}
+# Bug 73330 - Apply magic to arg to ->object()
+{
+ my @tids :shared;
+
+ my $thr = threads->create(sub {
+ lock(@tids);
+ push(@tids, threads->tid());
+ cond_signal(@tids);
+ });
+
+ {
+ lock(@tids);
+ cond_wait(@tids) while (! @tids);
+ }
+
+ ok(threads->object($_), 'Got threads object') foreach (@tids);
+
+ $thr->join();
+}
+
exit(0);
# EOF
diff --git a/dist/threads/threads.pm b/dist/threads/threads.pm
index 4552e50959..883678935e 100644
--- a/dist/threads/threads.pm
+++ b/dist/threads/threads.pm
@@ -5,7 +5,7 @@ use 5.008;
use strict;
use warnings;
-our $VERSION = '1.75';
+our $VERSION = '1.77_01';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
=head1 VERSION
-This document describes threads version 1.75
+This document describes threads version 1.77
=head1 SYNOPSIS
@@ -361,9 +361,10 @@ key) will cause its ID to be used as the value:
=item threads->object($tid)
This will return the I<threads> object for the I<active> thread associated
-with the specified thread ID. Returns C<undef> if there is no thread
-associated with the TID, if the thread is joined or detached, if no TID is
-specified or if the specified TID is undef.
+with the specified thread ID. If C<$tid> is the value for the current thread,
+then this call works the same as C<-E<gt>self()>. Otherwise, returns C<undef>
+if there is no thread associated with the TID, if the thread is joined or
+detached, if no TID is specified or if the specified TID is undef.
=item threads->yield()
@@ -902,6 +903,18 @@ other threads are started afterwards.
If the above does not work, or is not adequate for your application, then file
a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
+=item Memory consumption
+
+On most systems, frequent and continual creation and destruction of threads
+can lead to ever-increasing growth in the memory footprint of the Perl
+interpreter. While it is simple to just launch threads and then
+C<-E<gt>join()> or C<-E<gt>detach()> them, for long-lived applications, it is
+better to maintain a pool of threads, and to reuse them for the work needed,
+using L<queues|Thread::Queue> to notify threads of pending work. The CPAN
+distribution of this module contains a simple example
+(F<examples/pool_reuse.pl>) illustrating the creation, use and monitoring of a
+pool of I<reusable> threads.
+
=item Current working directory
On all platforms except MSWin32, the setting for the current working directory
@@ -975,7 +988,7 @@ 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
later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
-you can pass them via L<shared queues| Thread::Queue>.
+you can pass them via L<shared queues|Thread::Queue>.
=item END blocks in threads
@@ -1021,7 +1034,7 @@ L<threads> Discussion Forum on CPAN:
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.75/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.77/threads.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 9e602a1bf4..b0f7dc8b00 100755
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -52,7 +52,7 @@ typedef perl_os_thread pthread_t;
/* Values for 'state' member */
#define PERL_ITHR_DETACHED 1 /* Thread has been detached */
-#define PERL_ITHR_JOINED 2 /* Thread has been joined */
+#define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */
#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */
#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */
#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */
@@ -1409,6 +1409,7 @@ void
ithread_object(...)
PREINIT:
char *classname;
+ SV *arg;
UV tid;
ithread *thread;
int state;
@@ -1421,34 +1422,47 @@ ithread_object(...)
}
classname = (char *)SvPV_nolen(ST(0));
- if ((items < 2) || ! SvOK(ST(1))) {
+ /* Turn $tid from PVLV to SV if needed (bug #73330) */
+ arg = ST(1);
+ SvGETMAGIC(arg);
+
+ if ((items < 2) || ! SvOK(arg)) {
XSRETURN_UNDEF;
}
/* threads->object($tid) */
- tid = SvUV(ST(1));
+ tid = SvUV(arg);
- /* Walk through threads list */
- MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
- for (thread = MY_POOL.main_thread.next;
- thread != &MY_POOL.main_thread;
- thread = thread->next)
- {
- /* Look for TID */
- if (thread->tid == tid) {
- /* Ignore if detached or joined */
- MUTEX_LOCK(&thread->mutex);
- state = thread->state;
- MUTEX_UNLOCK(&thread->mutex);
- if (! (state & PERL_ITHR_UNCALLABLE)) {
- /* Put object on stack */
- ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
- have_obj = 1;
+ /* If current thread wants its own object, then behave the same as
+ ->self() */
+ thread = S_ithread_get(aTHX);
+ if (thread->tid == tid) {
+ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+ have_obj = 1;
+
+ } else {
+ /* Walk through threads list */
+ MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
+ for (thread = MY_POOL.main_thread.next;
+ thread != &MY_POOL.main_thread;
+ thread = thread->next)
+ {
+ /* Look for TID */
+ if (thread->tid == tid) {
+ /* Ignore if detached or joined */
+ MUTEX_LOCK(&thread->mutex);
+ state = thread->state;
+ MUTEX_UNLOCK(&thread->mutex);
+ if (! (state & PERL_ITHR_UNCALLABLE)) {
+ /* Put object on stack */
+ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+ have_obj = 1;
+ }
+ break;
}
- break;
}
+ MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
}
- MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
if (! have_obj) {
XSRETURN_UNDEF;
diff --git a/dump.c b/dump.c
index bc1ba58ab1..d1fa26ecbf 100644
--- a/dump.c
+++ b/dump.c
@@ -2026,7 +2026,6 @@ Perl_runops_debug(pTHX)
DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
do {
- PERL_ASYNC_CHECK();
if (PL_debug) {
if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
PerlIO_printf(Perl_debug_log,
diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm
index 82c20ae828..50ae61eb32 100644
--- a/ext/IPC-Open3/lib/IPC/Open3.pm
+++ b/ext/IPC-Open3/lib/IPC/Open3.pm
@@ -9,7 +9,7 @@ require Exporter;
use Carp;
use Symbol qw(gensym qualify);
-$VERSION = 1.05;
+$VERSION = 1.06;
@ISA = qw(Exporter);
@EXPORT = qw(open3);
@@ -48,7 +48,7 @@ instead of a pipe(2) made.
If either reader or writer is the null string, this will be replaced
by an autogenerated filehandle. If so, you must pass a valid lvalue
-in the parameter slot so it can be overwritten in the caller, or
+in the parameter slot so it can be overwritten in the caller, or
an exception will be raised.
The filehandles may also be integers, in which case they are understood
@@ -68,9 +68,9 @@ C<open(FOO, "-|")> the child process will just be the forked Perl
process rather than an external command. This feature isn't yet
supported on Win32 platforms.
-open3() does not wait for and reap the child process after it exits.
+open3() does not wait for and reap the child process after it exits.
Except for short programs where it's acceptable to let the operating system
-take care of this, you need to do this yourself. This is normally as
+take care of this, you need to do this yourself. This is normally as
simple as calling C<waitpid $pid, 0> when you're done with the process.
Failing to do this can result in an accumulation of defunct or "zombie"
processes. See L<perlfunc/waitpid> for more information.
@@ -161,6 +161,18 @@ sub xpipe {
pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
}
+sub xpipe_anon {
+ pipe $_[0], $_[1] or croak "$Me: pipe failed: $!";
+}
+
+sub xclose_on_exec {
+ require Fcntl;
+ my $flags = fcntl($_[0], &Fcntl::F_GETFD, 0)
+ or croak "$Me: fcntl failed: $!";
+ fcntl($_[0], &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC)
+ or croak "$Me: fcntl failed: $!";
+}
+
# I tried using a * prototype character for the filehandle but it still
# disallows a bearword while compiling under strict subs.
@@ -199,12 +211,12 @@ sub _open3 {
unless (eval {
$dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
$dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
- 1; })
+ 1; })
{
# must strip crud for croak to add back, or looks ugly
$@ =~ s/(?<=value attempted) at .*//s;
croak "$Me: $@";
- }
+ }
$dad_err ||= $dad_rdr;
@@ -225,54 +237,89 @@ sub _open3 {
xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
- $kidpid = DO_SPAWN ? -1 : xfork;
- if ($kidpid == 0) { # Kid
- # A tie in the parent should not be allowed to cause problems.
- untie *STDIN;
- untie *STDOUT;
- # If she wants to dup the kid's stderr onto her stdout I need to
- # save a copy of her stdout before I put something else there.
- if ($dad_rdr ne $dad_err && $dup_err
- && xfileno($dad_err) == fileno(STDOUT)) {
- my $tmp = gensym;
- xopen($tmp, ">&$dad_err");
- $dad_err = $tmp;
- }
+ if (!DO_SPAWN) {
+ # Used to communicate exec failures.
+ xpipe my $stat_r, my $stat_w;
+
+ $kidpid = xfork;
+ if ($kidpid == 0) { # Kid
+ eval {
+ # A tie in the parent should not be allowed to cause problems.
+ untie *STDIN;
+ untie *STDOUT;
+
+ close $stat_r;
+ xclose_on_exec $stat_w;
+
+ # If she wants to dup the kid's stderr onto her stdout I need to
+ # save a copy of her stdout before I put something else there.
+ if ($dad_rdr ne $dad_err && $dup_err
+ && xfileno($dad_err) == fileno(STDOUT)) {
+ my $tmp = gensym;
+ xopen($tmp, ">&$dad_err");
+ $dad_err = $tmp;
+ }
+
+ if ($dup_wtr) {
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
+ } else {
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&=" . fileno $kid_rdr;
+ }
+ if ($dup_rdr) {
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
+ } else {
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ # I have to use a fileno here because in this one case
+ # I'm doing a dup but the filehandle might be a reference
+ # (from the special case above).
+ xopen \*STDERR, ">&" . xfileno($dad_err)
+ if fileno(STDERR) != xfileno($dad_err);
+ } else {
+ xclose $dad_err;
+ xopen \*STDERR, ">&=" . fileno $kid_err;
+ }
+ } else {
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+ }
+ return 0 if ($cmd[0] eq '-');
+ exec @cmd or do {
+ local($")=(" ");
+ croak "$Me: exec of @cmd failed";
+ };
+ };
+
+ my $bang = 0+$!;
+ my $err = $@;
+ utf8::encode $err if $] >= 5.008;
+ print $stat_w pack('IIa*', $bang, length($err), $err);
+ close $stat_w;
- if ($dup_wtr) {
- xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
- } else {
- xclose $dad_wtr;
- xopen \*STDIN, "<&=" . fileno $kid_rdr;
- }
- if ($dup_rdr) {
- xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
- } else {
- xclose $dad_rdr;
- xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+ eval { require POSIX; POSIX::_exit(255); };
+ exit 255;
}
- if ($dad_rdr ne $dad_err) {
- if ($dup_err) {
- # I have to use a fileno here because in this one case
- # I'm doing a dup but the filehandle might be a reference
- # (from the special case above).
- xopen \*STDERR, ">&" . xfileno($dad_err)
- if fileno(STDERR) != xfileno($dad_err);
- } else {
- xclose $dad_err;
- xopen \*STDERR, ">&=" . fileno $kid_err;
+ else { # Parent
+ close $stat_w;
+ my $to_read = length(pack('I', 0)) * 2;
+ my $bytes_read = read($stat_r, my $buf = '', $to_read);
+ if ($bytes_read) {
+ (my $bang, $to_read) = unpack('II', $buf);
+ read($stat_r, my $err = '', $to_read);
+ if ($err) {
+ utf8::decode $err if $] >= 5.008;
+ } else {
+ $err = "$Me: " . ($! = $bang);
+ }
+ $! = $bang;
+ die($err);
}
- } else {
- xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
}
- return 0 if ($cmd[0] eq '-');
- local($")=(" ");
- exec @cmd or do {
- carp "$Me: exec of @cmd failed";
- eval { require POSIX; POSIX::_exit(255); };
- exit 255;
- };
- } elsif (DO_SPAWN) {
+ }
+ else { # DO_SPAWN
# All the bookkeeping of coincidence between handles is
# handled in spawn_with_handles.
diff --git a/ext/IPC-Open3/t/IPC-Open3.t b/ext/IPC-Open3/t/IPC-Open3.t
index 79d5cedde5..23ca8e5602 100644
--- a/ext/IPC-Open3/t/IPC-Open3.t
+++ b/ext/IPC-Open3/t/IPC-Open3.t
@@ -47,7 +47,7 @@ my ($pid, $reaped_pid);
STDOUT->autoflush;
STDERR->autoflush;
-print "1..22\n";
+print "1..23\n";
# basic
ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
@@ -146,3 +146,20 @@ else {
print WRITE "ok 22\n";
waitpid $pid, 0;
}
+
+# RT 72016
+eval{$pid = open3 'WRITE', 'READ', 'ERROR', '/non/existant/program'; };
+if (IPC::Open3::DO_SPAWN) {
+ if ($@ || waitpid($pid, 0) > 0) {
+ print "ok 23\n";
+ } else {
+ print "not ok 23\n";
+ }
+} else {
+ if ($@) {
+ print "ok 23\n";
+ } else {
+ waitpid($pid, 0);
+ print "not ok 23\n";
+ }
+}
diff --git a/handy.h b/handy.h
index 81bf1e270d..1ff7fde5b9 100644
--- a/handy.h
+++ b/handy.h
@@ -110,6 +110,12 @@ Null SV pointer. (No longer available when C<PERL_CORE> is defined.)
# define HAS_BOOL 1
#endif
+/* a simple (bool) cast may not do the right thing: if bool is defined
+ * as char for example, then the cast from int is implementation-defined
+ */
+
+#define cBOOL(cbool) ((bool)!!(cbool))
+
/* Try to figure out __func__ or __FUNCTION__ equivalent, if any.
* XXX Should really be a Configure probe, with HAS__FUNCTION__
* and FUNCTION__ as results.
@@ -208,8 +214,7 @@ typedef U64TYPE U64;
* GMTIME_MAX GMTIME_MIN LOCALTIME_MAX LOCALTIME_MIN
* HAS_CTIME64 HAS_LOCALTIME64 HAS_GMTIME64 HAS_DIFFTIME64
* HAS_MKTIME64 HAS_ASCTIME64 HAS_GETADDRINFO HAS_GETNAMEINFO
- * HAS_INETNTOP HAS_INETPTON CHARBITS HAS_PRCTL_SET_NAME
- * HAS_PRCTL
+ * HAS_INETNTOP HAS_INETPTON CHARBITS HAS_PRCTL
* Not (yet) used at top level, but mention them for metaconfig
*/
diff --git a/lib/perl5db.t b/lib/perl5db.t
index 59acd7a059..3f68759efe 100644
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -143,7 +143,7 @@ SKIP: {
{
rc(
qq|
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+ &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
\n|,
qq|
diff --git a/mg.c b/mg.c
index 3fb8ec43f4..0341f6e9d6 100644
--- a/mg.c
+++ b/mg.c
@@ -57,6 +57,10 @@ tie.
# include <sys/pstat.h>
#endif
+#ifdef HAS_PRCTL_SET_NAME
+# include <sys/prctl.h>
+#endif
+
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
#else
@@ -193,7 +197,7 @@ Perl_mg_get(pTHX_ SV *sv)
{
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
- const bool was_temp = (bool)SvTEMP(sv);
+ const bool was_temp = cBOOL(SvTEMP(sv));
bool have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
/* guard against sv having being freed midway by holding a private
@@ -2359,7 +2363,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
sv_setsv(PL_bodytarget, sv);
break;
case '\003': /* ^C */
- PL_minus_c = (bool)SvIV(sv);
+ PL_minus_c = cBOOL(SvIV(sv));
break;
case '\004': /* ^D */
@@ -2823,6 +2827,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
PL_origargv[0][PL_origalen-1] = 0;
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = 0;
+#ifdef HAS_PRCTL_SET_NAME
+ /* Set the legacy process name in addition to the POSIX name on Linux */
+ if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
+ /* diag_listed_as: SKIPME */
+ Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
+ }
+#endif
}
#endif
UNLOCK_DOLLARZERO_MUTEX;
diff --git a/numeric.c b/numeric.c
index bfe67427a6..b116376916 100644
--- a/numeric.c
+++ b/numeric.c
@@ -142,7 +142,7 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
NV value_nv = 0;
const UV max_div_2 = UV_MAX / 2;
- const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
+ const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
bool overflowed = FALSE;
char bit;
@@ -259,7 +259,7 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
UV value = 0;
NV value_nv = 0;
const UV max_div_16 = UV_MAX / 16;
- const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
+ const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
bool overflowed = FALSE;
PERL_ARGS_ASSERT_GROK_HEX;
@@ -373,7 +373,7 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
- const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
+ const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
bool overflowed = FALSE;
PERL_ARGS_ASSERT_GROK_OCT;
diff --git a/pod/perl5114delta.pod b/pod/perl5114delta.pod
index 3c0680112b..05a387f2d3 100644
--- a/pod/perl5114delta.pod
+++ b/pod/perl5114delta.pod
@@ -51,7 +51,7 @@ example U+FF10: FULLWIDTH DIGIT ZERO.
=item C<less>
-Upgraded from version 0.03 to 0.03.
+Upgraded from version 0.02 to 0.03.
This version introduces the C<stash_name> method to allow subclasses of less to
pick where in %^H to store their stash.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 4e9f04b342..edccac1348 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -4880,6 +4880,14 @@ modifier is not presently meaningful in substitutions.
use the /g modifier. Currently, /c is meaningful only when /g is
used. (This may change in the future.)
+=item Use of := for an empty attribute list is deprecated
+
+(D deprecated) The construction C<my $x := 42> currently
+parses correctly in perl, being equivalent to C<my $x : = 42>
+(applying an empty attribute list to C<$x>). This useless
+construct is now deprecated, so C<:=> can be reclaimed as a new
+operator in the future.
+
=item Use of freed value in iteration
(F) Perhaps you modified the iterated array within the loop?
diff --git a/pod/perlrepository.pod b/pod/perlrepository.pod
index 731735dd7e..eb748df2a0 100644
--- a/pod/perlrepository.pod
+++ b/pod/perlrepository.pod
@@ -359,10 +359,13 @@ Now you should create a patch file for all your local changes:
% git format-patch origin
0001-Rename-Leon-Brocard-to-Orange-Brocard.patch
-You should now send an email to perl5-porters@perl.org with a
-description of your changes, and include this patch file as an
-attachment. (See the next section for how to configure and use git to
-send these emails for you.)
+You should now send an email to either perlbug@perl.org or
+perl5-porters@perl.org with a description of your changes, and include
+this patch file as an attachment. The perlbug address is preferred,
+but use perl5-porters for patches intended for discussion.
+
+See the next section for how to configure and use git to send these
+emails for you.
If you want to delete your temporary branch, you may do so with:
@@ -375,8 +378,12 @@ If you want to delete your temporary branch, you may do so with:
=head2 Using git to send patch emails
-In your ~/git/perl repository, set the destination email to the
-perl5-porters mailing list.
+In your ~/git/perl repository, set the destination email to perl's bug
+tracker:
+
+ $ git config sendemail.to perlbug@perl.org
+
+Or maybe perl5-porters (discussed above):
$ git config sendemail.to perl5-porters@perl.org
@@ -742,8 +749,8 @@ The same patch as above, using github might look like this:
% git push origin orange
The orange branch has been pushed to GitHub, so you should now send an
-email to perl5-porters@perl.org with a description of your changes and
-the following information:
+email (see L</SUBMITTING A PATCH>) with a description of your changes
+and the following information:
http://github.com/USERNAME/perl/tree/orange
git@github.com:USERNAME/perl.git branch orange
diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index a16cf0d604..0a03bf4175 100644
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -1046,11 +1046,6 @@ slices. This would be good to fix.
The regexp optimiser is not optional. It should configurable to be, to allow
its performance to be measured, and its bugs to be easily demonstrated.
-=head2 delete &function
-
-Allow to delete functions. One can already undef them, but they're still
-in the stash.
-
=head2 C</w> regex modifier
That flag would enable to match whole words, and also to interpolate
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index febf15f65f..0dd2e1e2f1 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -1026,6 +1026,13 @@ have their own copies of it.
If the program has been given to perl via the switches C<-e> or C<-E>,
C<$0> will contain the string C<"-e">.
+On Linux as of perl 5.14 the legacy process name will be set with
+L<prctl(2)>, in addition to altering the POSIX name via C<argv[0]> as
+perl has done since version 4.000. Now system utilities that read the
+legacy process name such as ps, top and killall will recognize the
+name you set when assigning to C<$0>. The string you supply will be
+cut off at 16 bytes, this is a limitation imposed by Linux.
+
=item $[
X<$[>
diff --git a/pp.c b/pp.c
index 9565c6c473..2c5f69a6c8 100644
--- a/pp.c
+++ b/pp.c
@@ -1030,7 +1030,7 @@ PP(pp_pow)
on same algorithm as above */
register UV result = 1;
register UV base = baseuv;
- const bool odd_power = (bool)(power & 1);
+ const bool odd_power = cBOOL(power & 1);
if (odd_power) {
result *= base;
}
diff --git a/pp_ctl.c b/pp_ctl.c
index bbb2d1587c..e766d7dde3 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -264,6 +264,9 @@ PP(pp_substcont)
register REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
+
+ PERL_ASYNC_CHECK();
+
if(old != rx) {
if(old)
ReREFCNT_dec(old);
@@ -1870,6 +1873,8 @@ PP(pp_dbstate)
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
@@ -2652,6 +2657,8 @@ PP(pp_goto)
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
diff --git a/pp_hot.c b/pp_hot.c
index 70d35568fd..6224f3db6a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -52,6 +52,7 @@ PP(pp_nextstate)
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
return NORMAL;
}
@@ -98,6 +99,7 @@ PP(pp_gv)
PP(pp_and)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (!SvTRUE(TOPs))
RETURN;
else {
@@ -203,6 +205,7 @@ PP(pp_sassign)
PP(pp_cond_expr)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
@@ -416,6 +419,7 @@ PP(pp_preinc)
PP(pp_or)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
else {
@@ -434,6 +438,7 @@ PP(pp_defined)
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
+ PERL_ASYNC_CHECK();
sv = TOPs;
if (!sv || !SvANY(sv)) {
if (op_type == OP_DOR)
@@ -2076,9 +2081,11 @@ PP(pp_subst)
bool is_cow;
#endif
SV *nsv = NULL;
-
/* known replacement string? */
register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
else if (PL_op->op_private & OPpTARGET_MY)
diff --git a/regexec.c b/regexec.c
index 17a0dc69a4..a9b33354bd 100644
--- a/regexec.c
+++ b/regexec.c
@@ -193,7 +193,7 @@
LEAVE; \
} \
if (!(OP(scan) == NAME \
- ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8) \
+ ? cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)) \
: LCFUNC_utf8((U8*)locinput))) \
{ \
sayNO; \
@@ -224,7 +224,7 @@
LEAVE; \
} \
if ((OP(scan) == NAME \
- ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8) \
+ ? cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)) \
: LCFUNC_utf8((U8*)locinput))) \
{ \
sayNO; \
@@ -1179,7 +1179,7 @@ uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
if ( (CoNd) \
&& (ln == len || \
!ibcmp_utf8(s, &my_strend, 0, do_utf8, \
- m, NULL, ln, (bool)UTF)) \
+ m, NULL, ln, cBOOL(UTF))) \
&& (!reginfo || regtry(reginfo, &s)) ) \
goto got_it; \
else { \
@@ -1190,7 +1190,7 @@ uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
&& (f == c1 || f == c2) \
&& (ln == len || \
!ibcmp_utf8(s, &my_strend, 0, do_utf8,\
- m, NULL, ln, (bool)UTF)) \
+ m, NULL, ln, cBOOL(UTF)))\
&& (!reginfo || regtry(reginfo, &s)) ) \
goto got_it; \
} \
@@ -1479,7 +1479,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
LOAD_UTF8_CHARCLASS_ALNUM();
REXEC_FBC_UTF8_SCAN(
if (tmp == !(OP(c) == BOUND ?
- (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
+ cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) :
isALNUM_LC_utf8((U8*)s)))
{
tmp = !tmp;
@@ -1517,7 +1517,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
LOAD_UTF8_CHARCLASS_ALNUM();
REXEC_FBC_UTF8_SCAN(
if (tmp == !(OP(c) == NBOUND ?
- (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
+ cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) :
isALNUM_LC_utf8((U8*)s)))
tmp = !tmp;
else REXEC_FBC_TRYIT;
@@ -1872,7 +1872,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *stre
I32 end_shift = 0; /* Same for the end. */ /* CC */
I32 scream_pos = -1; /* Internal iterator of scream. */
char *scream_olds = NULL;
- const bool do_utf8 = (bool)DO_UTF8(sv);
+ const bool do_utf8 = cBOOL(DO_UTF8(sv));
I32 multiline;
RXi_GET_DECL(prog,progi);
regmatch_info reginfo; /* create some info to pass to regtry etc */
@@ -3419,7 +3419,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
const char * const l = locinput;
char *e = PL_regeol;
- if (ibcmp_utf8(s, 0, ln, (bool)UTF,
+ if (ibcmp_utf8(s, 0, ln, cBOOL(UTF),
l, &e, 0, do_utf8)) {
/* One more case for the sharp s:
* pack("U0U*", 0xDF) =~ /ss/i,
@@ -4055,7 +4055,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
/* NOTREACHED */
}
/* logical is 1, /(?(?{...})X|Y)/ */
- sw = (bool)SvTRUE(ret);
+ sw = cBOOL(SvTRUE(ret));
logical = 0;
break;
}
@@ -4156,11 +4156,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
/*NOTREACHED*/
case GROUPP:
n = ARG(scan); /* which paren pair */
- sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
+ sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
break;
case NGROUPP:
/* reg_check_named_buff_matched returns 0 for no match */
- sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
+ sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
break;
case INSUBP:
n = ARG(scan);
@@ -5167,7 +5167,7 @@ NULL
/* trivial fail */
if (logical) {
logical = 0;
- sw = 1 - (bool)ST.wanted;
+ sw = 1 - cBOOL(ST.wanted);
}
else if (ST.wanted)
sayNO;
@@ -5196,7 +5196,7 @@ NULL
case IFMATCH_A: /* body of (?...A) succeeded */
if (ST.logical) {
- sw = (bool)ST.wanted;
+ sw = cBOOL(ST.wanted);
}
else if (!ST.wanted)
sayNO;
diff --git a/run.c b/run.c
index be280eeedb..eb465da57c 100644
--- a/run.c
+++ b/run.c
@@ -37,8 +37,8 @@ int
Perl_runops_standard(pTHX)
{
dVAR;
- while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
- PERL_ASYNC_CHECK();
+ register OP *op = PL_op;
+ while ((PL_op = op = CALL_FPTR(op->op_ppaddr)(aTHX))) {
}
TAINT_NOT;
diff --git a/scope.c b/scope.c
index 994151e676..6ee1254b60 100644
--- a/scope.c
+++ b/scope.c
@@ -780,7 +780,7 @@ Perl_leave_scope(pTHX_ I32 base)
break;
case SAVEt_BOOL: /* bool reference */
ptr = SSPOPPTR;
- *(bool*)ptr = (bool)SSPOPBOOL;
+ *(bool*)ptr = cBOOL(SSPOPBOOL);
break;
case SAVEt_I32: /* I32 reference */
ptr = SSPOPPTR;
@@ -1115,6 +1115,8 @@ Perl_leave_scope(pTHX_ I32 base)
}
PL_tainted = was;
+
+ PERL_ASYNC_CHECK();
}
void
diff --git a/sv.c b/sv.c
index 5759b2b4c6..21d0a8e9c2 100644
--- a/sv.c
+++ b/sv.c
@@ -3124,7 +3124,7 @@ Perl_sv_2bool(pTHX_ register SV *const sv)
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLun(sv,bool_);
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return (bool)SvTRUE(tmpsv);
+ return cBOOL(SvTRUE(tmpsv));
}
return SvRV(sv) != 0;
}
@@ -11243,7 +11243,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param) : 0;
+ cBOOL(HvSHAREKEYS(sstr)), param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
@@ -11696,7 +11696,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
longval = (long)POPBOOL(ss,ix);
- TOPBOOL(nss,ix) = (bool)longval;
+ TOPBOOL(nss,ix) = cBOOL(longval);
break;
case SAVEt_SET_SVFLAGS:
i = POPINT(ss,ix);
diff --git a/t/op/magic.t b/t/op/magic.t
index 5a2733fd3a..bef4922719 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
use Config;
-plan (tests => 81);
+plan (tests => 83);
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
@@ -347,6 +347,37 @@ SKIP: {
}
}
+# Check that assigning to $0 on Linux sets the process name with both
+# argv[0] assignment and by calling prctl()
+{
+ SKIP: {
+ skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
+
+ # We don't really need these tests. prctl() is tested in the
+ # Kernel, but test it anyway for our sanity. If something doesn't
+ # work (like if the system doesn't have a ps(1) for whatever
+ # reason) just bail out gracefully.
+ my $maybe_ps = sub {
+ my ($cmd) = @_;
+ local ($?, $!);
+
+ no warnings;
+ my $res = `$cmd`;
+ skip "Couldn't shell out to `$cmd', returned code $?", 2 if $?;
+ return $res;
+ };
+
+ my $name = "Good Morning, Dave";
+ $0 = $name;
+
+ chomp(my $argv0 = $maybe_ps->("ps h $$"));
+ chomp(my $prctl = $maybe_ps->("ps hc $$"));
+
+ like($argv0, $name, "Set process name through argv[0] ($argv0)");
+ like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
+ }
+}
+
{
my $ok = 1;
my $warn = '';
@@ -435,6 +466,7 @@ is "@+", "10 1 6 10";
# Test for bug [perl #27839]
{
+ local $TODO = "fixing a casting issue revealed broken behaviour in this test";
my $x;
sub f {
"abc" =~ /(.)./;
diff --git a/t/re/re.t b/t/re/re.t
index 87965f20aa..249c6ddf22 100644
--- a/t/re/re.t
+++ b/t/re/re.t
@@ -51,6 +51,14 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
}
is(regnames_count(),3);
}
+
+ { # Keep this test last, as whole script will be interrupted if times out
+ # Bug #72998; this can loop
+ watchdog(2);
+ eval '"\x{100}\x{FB00}" =~ /\x{100}\N{U+66}+/i';
+ pass("Didn't loop");
+ }
+
# New tests above this line, don't forget to update the test count below!
-BEGIN { plan tests => 18 }
+BEGIN { plan tests => 19 }
# No tests here!
diff --git a/toke.c b/toke.c
index b6735cfe49..b5236dadbf 100644
--- a/toke.c
+++ b/toke.c
@@ -13700,7 +13700,7 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
SV *const utf8_buffer = filter;
IV status = IoPAGE(filter);
- const bool reverse = (bool) IoLINES(filter);
+ const bool reverse = cBOOL(IoLINES(filter));
I32 retval;
/* As we're automatically added, at the lowest level, and hence only called
diff --git a/utf8.c b/utf8.c
index 9ed0663e19..1a6077c8d2 100644
--- a/utf8.c
+++ b/utf8.c
@@ -2609,7 +2609,8 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const
/* A match is defined by all the scans that specified
* an explicit length reaching their final goals. */
- match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
+ match = (n1 == 0 && n2 == 0 /* Must not match partial char; Bug #72998 */
+ && (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2));
if (match) {
if (pe1)