[ 18280]
Integrate from the maint-5.8/ branch :
changes 18219, 18236, 18242-3, 18247-8,
18253-5, 18257, 18273-6
[ 18740]
Re: -Os for Darwin why?
From: schwern@pobox.com
Date: tis feb 18, 2003 04:14:03 Europe/Stockholm
Message-Id: <
20030217191403.A17553@ttul.org>
[ 18737]
Subject: [PATCH] Re: [perl #21261] B::Terse not outputting correct constants or variable names
From: Stephen McCamant <smcc@mit.edu>
Date: Mon, 17 Feb 2003 19:34:36 -0500
Date: Mon, 17 Feb 2003 19:34:36 -0500
Message-ID: <15953.32668.277063.470885@syllepsis.MIT.EDU>
[ 18723]
Subject: Re: [perl #20798] foo(eval {}) crashes Perl 5.8
From: Enache Adrian <enache@rdslink.ro>
Date: Sun, 16 Feb 2003 00:05:10 +0200
Message-ID: <
20030215220510.GB893@ratsnest.hole>
[ 18722]
outdent else-if chain in scope()
[ 18721]
Subject: [PATCH] arcane tainting bug in vms.c
From: "Craig A. Berry" <craigberry@mac.com>
Date: Sat, 15 Feb 2003 12:29:03 -0600
Message-ID: <
3E4E86EF.8090609@mac.com>
[ 18720]
restrict PERL_PRESERVE_IVUV to things that should really give an
integer, but extend to runtime. Based on:
Subject: Re: [perl #20827] Unexpected scientific notation.
From: hv@crypt.org
Date: Wed, 12 Feb 2003 03:12:43 +0000
Message-Id: <
200302120312.h1C3ChS02613@crypt.compulink.co.uk>
[ 18708]
Subject: Re: [perl #20912] UTF8 related glitch + fix
From: Enache Adrian <enache@rdslink.ro>
Date: Sat, 15 Feb 2003 00:37:40 +0200
Message-ID: <
20030214223740.GA13575@ratsnest.hole>
[ 18707]
Subject: [doc patch] ext/threads/shared/shared.pm
From: Stas Bekman <stas@stason.org>
Date: Fri, 14 Feb 2003 11:12:39 +1100
Message-ID: <
3E4C3477.7030306@stason.org>
[ 18706]
Subject: Re: perlvar phrasing clarification for $^S
From: "Iain 'Spoon' Truskett" <perl@dellah.anu.edu.au>
Date: Fri, 14 Feb 2003 10:12:00 +1100
Message-ID: <
20030213231200.GE16300@ouroboros.anu.edu.au>
[ 18705]
Subject: Re: [perl #20933] \substr reuses lvalues (sometimes)
From: Dave Mitchell <davem@fdgroup.com>
Date: Fri, 14 Feb 2003 22:48:27 +0000
Message-ID: <
20030214224827.B6783@fdgroup.com>
with tests:
From: Slaven Rezic <slaven@rezic.de>
Date: 14 Feb 2003 20:23:20 +0100
Message-ID: <87bs1e4qfr.fsf@vran.herceg.de>
[ 18704]
Subject: Re: overriding builtins quirk
From: Jerrad Pierce <belg4mit@MIT.EDU>
Date: Fri, 14 Feb 2003 09:28:13 -0500
Message-Id: <
200302141428.JAA25752@cathedral-seven.mit.edu>
[ 18703]
Subject: Re: trying to fix #20154, #20357
From: Enache Adrian <enache@rdslink.ro>
Date: Sat, 8 Feb 2003 21:05:14 +0200
Message-ID: <
20030208190514.GA866@ratsnest.hole>
(fixes #19061 as well)
p4raw-link: @18740 on //depot/perl:
14c260282869b514252d84245cb9a2c34eb7d421
p4raw-link: @18737 on //depot/perl:
31b49ad407e88940fdaef710e5f6a42665a067d8
p4raw-link: @18723 on //depot/perl:
4927db4444d4255bf5c9a54ba1d153bb533bd274
p4raw-link: @18722 on //depot/perl:
fdb2241864c257e44490544064b09a293414e55f
p4raw-link: @18721 on //depot/perl:
ec618cdf8cd188a382b8a5ab7751b8c7e9ef80c2
p4raw-link: @18720 on //depot/perl:
52a96ae66a5b0cd12cd52516c48cc6bf774e2038
p4raw-link: @18708 on //depot/perl:
3b0d546b549c81b8fd7281af083002e289e306d6
p4raw-link: @18707 on //depot/perl:
72ac79b36fc2613b9b03b8424fe60fdaa5759b16
p4raw-link: @18706 on //depot/perl:
fa05a9fd14fa1e936b4708399d5cb3873024a775
p4raw-link: @18705 on //depot/perl:
24aef97f7fec4668a5731fc6d5179ebebd43f183
p4raw-link: @18704 on //depot/perl:
163e3a99f83605ff107fb86a86c7dd9dc9dece8f
p4raw-link: @18703 on //depot/perl:
33d34e4c563f3e0b3627fb43d2e2a2ef278a273a
p4raw-link: @18280 on //depot/perl:
3a2263fe90d1c0e6c8f9368f10e6672379a975a2
p4raw-id: //depot/maint-5.8/perl@18744
p4raw-integrated: from //depot/perl@18743 'copy in' t/op/substr.t
(@9270..) t/op/goto.t (@10643..) ext/B/B/Terse.pm (@13034..)
ext/B/B/Bblock.pm (@13697..) t/op/vec.t (@14887..)
ext/B/t/terse.t (@16882..) pod/perlsub.pod (@17220..)
ext/threads/shared/shared.pm (@17810..) t/op/lc.t (@18266..)
t/op/split.t (@18280..) 'edit in' pp.c (@18708..) 'merge in'
vms/vms.c (@18030..) ext/B/B.xs (@18220..) hints/darwin.sh
(@18406..) ext/B/B/Concise.pm (@18694..)
p4raw-integrated: from //depot/perl@18723 'edit in' op.c (@18722..)
p4raw-integrated: from //depot/perl@18706 'merge in' pod/perlvar.pod
(@18490..)
p4raw-integrated: from //depot/perl@18703 'merge in' pp_ctl.c
(@18688..)
return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
#ifdef USE_ITHREADS
- if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+ o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
return OPc_PADOP;
#endif
main_root main_start svref_2object
OPf_SPECIAL OPf_STACKED );
-use B::Terse;
+use B::Concise qw(concise_cv concise_main set_style_standard);
use strict;
my $bblock;
}
printf " %s\n", peekop($lastop);
}
- print "-------\n";
- walkoptree_exec($start, "terse");
}
sub walk_bblocks_obj {
$objname = "main::$objname" unless $objname =~ /::/;
eval "walk_bblocks_obj(\\&$objname)";
die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ print "-------\n";
+ set_style_standard("terse");
+ eval "concise_cv('exec', \\&$objname)";
+ die "concise_cv('exec', \\&$objname) failed: $@" if $@;
}
}
} else {
- return sub { walk_bblocks(main_root, main_start) };
+ return sub {
+ walk_bblocks(main_root, main_start);
+ print "-------\n";
+ set_style_standard("terse");
+ concise_main("exec");
+ };
}
}
use Exporter ();
-our $VERSION = "0.54";
+our $VERSION = "0.55";
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(set_style add_callback);
+our @EXPORT_OK = qw(set_style set_style_standard add_callback
+ concise_cv concise_main);
use B qw(class ppname main_start main_root main_cv cstring svref_2object
- SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
+ SVf_IOK SVf_NOK SVf_POK SVf_IVisUV OPf_KIDS);
my %style =
("terse" =>
($format, $gotofmt, $treefmt) = @_;
}
+sub set_style_standard {
+ my($name) = @_;
+ set_style(@{$style{$name}});
+}
+
sub add_callback {
push @callbacks, @_;
}
}
}
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
my $start_sym = "\e(0"; # "\cN" sometimes also works
my $end_sym = "\e(B"; # "\cO" respectively
my $order = "basic";
-set_style(@{$style{concise}});
+set_style_standard("concise");
sub compile {
my @options = grep(/^-/, @_);
}
if (!@args or $do_main) {
print "main program:\n" if $do_main;
- sequence(main_start);
- $curcv = main_cv;
- if ($order eq "exec") {
- return if class(main_start) eq "NULL";
- walk_exec(main_start);
- } elsif ($order eq "tree") {
- return if class(main_root) eq "NULL";
- print tree(main_root, 0);
- } elsif ($order eq "basic") {
- return if class(main_root) eq "NULL";
- walk_topdown(main_root,
- sub { $_[0]->concise($_[1]) }, 0);
- }
+ concise_main($order);
}
}
}
walk_topdown($kid, $sub, $level + 1);
}
}
- if (class($op) eq "PMOP" and $ {$op->pmreplroot}
+ if (class($op) eq "PMOP" and $op->pmreplroot and $ {$op->pmreplroot}
and $op->pmreplroot->isa("B::OP")) {
walk_topdown($op->pmreplroot, $sub, $level + 1);
}
sub concise_sv {
my($sv, $hr) = @_;
$hr->{svclass} = class($sv);
+ $hr->{svclass} = "UV"
+ if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
$hr->{svaddr} = sprintf("%#x", $$sv);
if ($hr->{svclass} eq "GV") {
my $gv = $sv;
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
- $hr->{svval} .= $sv->IV;
+ $hr->{svval} .= $sv->int_value;
} elsif ($sv->FLAGS & SVf_POK) {
$hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
}
return $hr->{svclass} . " " . $hr->{svval};
}
}
my $pmreplroot = $op->pmreplroot;
my $pmreplstart;
- if ($$pmreplroot && $pmreplroot->isa("B::GV")) {
+ if ($pmreplroot && $$pmreplroot && $pmreplroot->isa("B::GV")) {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in pmreplroot.
$h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
} else {
$h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
}
+ } elsif ($h{class} eq "PADOP") {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
+ $h{arg} = "[" . concise_sv($sv, \%h) . "]";
}
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
print concise_op($op, $level, $format);
}
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print fmt_line($h, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print concise_op($op, $level, $style{"terse"}[0]);
+}
+
sub tree {
my $op = shift;
my $level = shift;
references to scalars, but it is unlikely that they will need to be
changed or even used.
+To switch back to one of the standard styles like C<concise> or
+C<terse>, use C<set_style_standard>.
+
To see the output, call the subroutine returned by B<compile> in the
same way that B<O> does.
=head1 AUTHOR
-Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
+Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
=cut
package B::Terse;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
use strict;
-use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
- main_start main_root cstring svref_2object SVf_IVisUV);
+use B qw(class);
use B::Asmdata qw(@specialsv_name);
+use B::Concise qw(concise_cv set_style_standard);
+use Carp;
sub terse {
my ($order, $cvref) = @_;
- my $cv = svref_2object($cvref);
+ set_style_standard("terse");
if ($order eq "exec") {
- walkoptree_exec($cv->START, "terse");
+ concise_cv('exec', $cvref);
} else {
- walkoptree_slow($cv->ROOT, "terse");
+ concise_cv('basic', $cvref);
}
+
}
sub compile {
- my $order = @_ ? shift : "";
- my @options = @_;
- B::clearsym();
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- eval "terse(\$order, \\&$objname)";
- die "terse($order, \\&$objname) failed: $@" if $@;
- }
- }
- } else {
- if ($order eq "exec") {
- return sub { walkoptree_exec(main_start, "terse") }
- } else {
- return sub { walkoptree_slow(main_root, "terse") }
- }
- }
+ my @args = @_;
+ my $order = @args ? shift(@args) : "";
+ $order = "-exec" if $order eq "exec";
+ unshift @args, $order if $order ne "";
+ B::Concise::compile("-terse", @args);
}
sub indent {
return " " x $level;
}
+# Don't use this, at least on OPs in subroutines: it has no way of
+# getting to the pad, and will give wrong answers or crash.
sub B::OP::terse {
- my ($op, $level) = @_;
- my $targ = $op->targ;
- $targ = ($targ > 0) ? " [$targ]" : "";
- print indent($level), peekop($op), $targ, "\n";
+ carp "B::OP::terse is deprecated; use B::Concise instead";
+ B::Concise::b_terse(@_);
}
-sub B::SVOP::terse {
- my ($op, $level) = @_;
- print indent($level), peekop($op), " ";
- $op->sv->terse(0);
-}
-
-sub B::PADOP::terse {
- my ($op, $level) = @_;
- print indent($level), peekop($op), " ", $op->padix, "\n";
-}
-
-sub B::PMOP::terse {
- my ($op, $level) = @_;
- my $precomp = $op->precomp;
- print indent($level), peekop($op),
- defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
-
-}
-
-sub B::PVOP::terse {
- my ($op, $level) = @_;
- print indent($level), peekop($op), " ", cstring($op->pv), "\n";
-}
-
-sub B::COP::terse {
- my ($op, $level) = @_;
- my $label = $op->label;
- if ($label) {
- $label = " label ".cstring($label);
- }
- print indent($level), peekop($op), $label || "", "\n";
-}
-
-sub B::PV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
-}
-
-sub B::AV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
-}
-
-sub B::GV::terse {
- my ($gv, $level) = @_;
- my $stash = $gv->STASH->NAME;
- if ($stash eq "main") {
- $stash = "";
- } else {
- $stash = $stash . "::";
- }
- print indent($level);
- printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME;
-}
-
-sub B::IV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d";
- printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value;
-}
-
-sub B::NV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
-}
-
-sub B::RV::terse {
- my ($rv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) %s\n", class($rv), $$rv, printref($rv);
-}
-
-sub printref {
- my $rv = shift;
- my $rcl = class($rv->RV);
- if ($rcl eq 'PV') {
- return "\\" . cstring($rv->RV->$rcl);
- } elsif ($rcl eq 'NV') {
- return "\\" . $rv->RV->$rcl;
- } elsif ($rcl eq 'IV') {
- return sprintf "\\%" . ($rv->RV->FLAGS & SVf_IVisUV ? "u" : "d"),
- $rv->RV->int_value;
- } elsif ($rcl eq 'RV') {
- return "\\" . printref($rv->RV);
- }
+sub B::SV::terse {
+ my($sv, $level) = (@_, 0);
+ my %info;
+ B::Concise::concise_sv($sv, \%info);
+ my $s = B::Concise::fmt_line(\%info, "#svclass~(?((#svaddr))?)~#svval", 0);
+ print indent($level), $s, "\n";
}
sub B::NULL::terse {
print indent($level);
printf "%s (0x%lx)\n", class($sv), $$sv;
}
-
+
sub B::SPECIAL::terse {
my ($sv, $level) = @_;
print indent($level);
=head1 DESCRIPTION
-See F<ext/B/README>.
+This version of B::Terse is really just a wrapper that calls B::Concise
+with the B<-terse> option. It is provided for compatibility with old scripts
+(and habits) but using B::Concise directly is now recommended instead.
+
+For compatiblilty with the old B::Terse, this module also adds a
+method named C<terse> to B::OP and B::SV objects. The B::SV method is
+largely compatible with the old one, though authors of new software
+might be advised to choose a more user-friendly output format. The
+B::OP C<terse> method, however, doesn't work well. Since B::Terse was
+first written, much more information in OPs has migrated to the
+scratchpad datastructure, but the C<terse> interface doesn't have any
+way of getting to the correct pad. As a kludge, the new version will
+always use the pad for the main program, but for OPs in subroutines
+this will give the wrong answer or crash.
=head1 AUTHOR
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+The original version of B::Terse was written by Malcolm Beattie,
+E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
+McCamant, E<lt>smcc@MIT.EDUE<gt>.
=cut
@INC = '../lib';
}
-use Test::More tests => 15;
+use Test::More tests => 16;
use_ok( 'B::Terse' );
# now build some regexes that should match the dumped ops
my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
my %ops = map { $_ => qr/$_ $hex$op/ }
- qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP );
+ qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
# split up the output lines into individual ops (terse is, well, terse!)
# use an array here so $_ is modifiable
# XXX:
# this tries to get at all tersified optypes in B::Terse
-# if you add AV, NULL, PADOP, PVOP, or SPECIAL, add it to the regex above too
+# if you can think of a way to produce AV, NULL, PADOP, or SPECIAL,
+# add it to the regex above too. (PADOPs are currently only produced
+# under ithreads, though).
#
use vars qw( $a $b );
sub bar {
# this is awful, but it gives a PMOP
my $boo = split('', $foo);
- # PMOP
+ # PVOP, LOOP
LOOP: for (1 .. 10) {
last LOOP if $_ % 2;
}
$foo =~ s/(a)/$1/;
}
-SKIP: {
- use Config;
- skip("- B::Terse won't grok RVs under ithreads yet", 1)
- if $Config{useithreads};
- # Schwern's example of finding an RV
- my $path = join " ", map { qq["-I$_"] } @INC;
- $path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
- my $redir = $^O eq 'MacOS' ? '' : "2>&1";
- my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
- like( $items, qr/RV $hex \\42/, 'RV' );
-}
+# Schwern's example of finding an RV
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
+my $redir = $^O eq 'MacOS' ? '' : "2>&1";
+my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
+like( $items, qr/RV $hex \\42/, 'RV' );
package TieOut;
autovivify the elements, and neither does slicing a shared array/hash
over non-existent indices/keys autovivify the elements.
-share() allows you to C<share $hashref->{key}> without giving any error
-message. But the C<$hashref->{key}> is B<not> shared, causing the error
+share() allows you to C<< share $hashref->{key} >> without giving any error
+message. But the C<< $hashref->{key} >> is B<not> shared, causing the error
"locking can only be used on shared values" to occur when you attempt to
-C<lock $hasref->{key}>.
+C<< lock $hasref->{key} >>.
=head1 AUTHOR
# nm works.
usenm='true';
-# Optimize.
+# Optimizing for size also mean less resident memory usage on the part
+# of Perl. Apple asserts that this is a more important optimization than
+# saving on CPU cycles. Given that memory speed has not increased at
+# pace with CPU speed over time (on any platform), this is probably a
+# reasonable assertion.
if [ -z "${optimize}" ]; then
case "$osvers" in
[12345].*) optimize='-O3' ;;
o->op_type = OP_LEAVE;
o->op_ppaddr = PL_ppaddr[OP_LEAVE];
}
- else {
- if (o->op_type == OP_LINESEQ) {
- OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
- kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- op_null(kid);
- }
- else
- o = newLISTOP(OP_SCOPE, 0, o, Nullop);
+ else if (o->op_type == OP_LINESEQ) {
+ OP *kid;
+ o->op_type = OP_SCOPE;
+ o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ kid = ((LISTOP*)o)->op_first;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
}
+ else
+ o = newLISTOP(OP_SCOPE, 0, o, Nullop);
}
return o;
}
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- line_t copline = PL_copline;
OP* retval = scalarseq(seq);
/* If there were syntax errors, don't try to close a block */
if (PL_yynerrs) return retval;
- if (!seq) {
- /* scalarseq() gave us an OP_STUB */
- retval->op_flags |= OPf_PARENS;
- /* there should be a nextstate in every block */
- retval = newSTATEOP(0, Nullch, retval);
- PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
- }
LEAVE_SCOPE(floor);
PL_pad_reset_pending = FALSE;
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
op_free(o);
if (type == OP_RV2GV)
return newGVOP(OP_GV, 0, (GV*)sv);
- else {
- /* try to smush double to int, but don't smush -2.0 to -2 */
- if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
- type != OP_NEGATE)
- {
-#ifdef PERL_PRESERVE_IVUV
- /* Only bother to attempt to fold to IV if
- most operators will benefit */
- SvIV_please(sv);
-#endif
- }
- return newSVOP(OP_CONST, 0, sv);
- }
+ return newSVOP(OP_CONST, 0, sv);
nope:
return o;
done by a package attempting to emulate missing built-in functionality
on a non-Unix system.
-Overriding may be done only by importing the name from a
-module--ordinary predeclaration isn't good enough. However, the
+Overriding may be done only by importing the name from a module at
+compile time--ordinary predeclaration isn't good enough. However, the
C<use subs> pragma lets you, in effect, predeclare subs
via the import syntax, and these names may then override built-in ones:
=item $^S
-Current state of the interpreter. Undefined if parsing of the current
-module/eval is not finished (may happen in $SIG{__DIE__} and
-$SIG{__WARN__} handlers). True if inside an eval(), otherwise false.
+Current state of the interpreter.
+
+ $^S State
+ --------- -------------------
+ undef Parsing module/eval
+ true (1) Executing an eval
+ false (0) Otherwise
+
+The first state may happen in $SIG{__DIE__} and $SIG{__WARN__} handlers.
=item $BASETIME
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ dSP; dATARGET;
#ifdef PERL_PRESERVE_IVUV
- /* ** is implemented with pow. pow is floating point. Perl programmers
- write 2 ** 31 and expect it to be 2147483648
- pow never made any guarantee to deliver a result to 53 (or whatever)
- bits of accuracy. Which is unfortunate, as perl programmers expect it
- to, and on some platforms (eg Irix with long doubles) it doesn't in
- a very visible case. (2 ** 31, which a regression test uses)
- So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
- these problems. */
+ bool is_int = 0;
+#endif
+ tryAMAGICbin(pow,opASSIGN);
+#ifdef PERL_PRESERVE_IVUV
+ /* For integer to integer power, we do the calculation by hand wherever
+ we're sure it is safe; otherwise we call pow() and try to convert to
+ integer afterwards. */
{
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
goto float_it; /* Can't do negative powers this way. */
}
}
- /* now we have integer ** positive integer.
- foo & (foo - 1) is zero only for a power of 2. */
+ /* now we have integer ** positive integer. */
+ is_int = 1;
+
+ /* foo & (foo - 1) is zero only for a power of 2. */
if (!(baseuv & (baseuv - 1))) {
- /* We are raising power-of-2 to postive integer.
+ /* We are raising power-of-2 to a positive integer.
The logic here will work for any base (even non-integer
bases) but it can be less accurate than
pow (base,power) or exp (power * log (base)) when the
NV base = baseuok ? baseuv : -(NV)baseuv;
int n = 0;
- /* The logic is this.
- x ** n === x ** m1 * x ** m2 where n = m1 + m2
- so as 42 is 32 + 8 + 2
- x ** 42 can be written as
- x ** 32 * x ** 8 * x ** 2
- I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
- x ** 2n is x ** n * x ** n
- So I loop round, squaring x each time
- (x, x ** 2, x ** 4, x ** 8) and multiply the result
- by the x-value whenever that bit is set in the power.
- To finish as soon as possible I zero bits in the power
- when I've done them, so that power becomes zero when
- I clear the last bit (no more to do), and the loop
- terminates. */
for (; power; base *= base, n++) {
/* Do I look like I trust gcc with long longs here?
Do I hell. */
if (power & bit) {
result *= base;
/* Only bother to clear the bit if it is set. */
- power &= ~bit;
+ power -= bit;
/* Avoid squaring base again if we're done. */
if (power == 0) break;
}
}
SP--;
SETn( result );
+ SvIV_please(TOPs);
RETURN;
- }
- }
- }
+ } else {
+ register unsigned int highbit = 8 * sizeof(UV);
+ register unsigned int lowbit = 0;
+ register unsigned int diff;
+ while ((diff = (highbit - lowbit) >> 1)) {
+ if (baseuv & ~((1 << (lowbit + diff)) - 1))
+ lowbit += diff;
+ else
+ highbit -= diff;
+ }
+ /* we now have baseuv < 2 ** highbit */
+ if (power * highbit <= 8 * sizeof(UV)) {
+ /* result will definitely fit in UV, so use UV math
+ on same algorithm as above */
+ register UV result = 1;
+ register UV base = baseuv;
+ register int n = 0;
+ for (; power; base *= base, n++) {
+ register UV bit = (UV)1 << (UV)n;
+ if (power & bit) {
+ result *= base;
+ power -= bit;
+ if (power == 0) break;
+ }
+ }
+ SP--;
+ if (baseuok || !(power & 1))
+ /* answer is positive */
+ SETu( result );
+ else if (result <= (UV)IV_MAX)
+ /* answer negative, fits in IV */
+ SETi( -(IV)result );
+ else if (result == (UV)IV_MIN)
+ /* 2's complement assumption: special case IV_MIN */
+ SETi( IV_MIN );
+ else
+ /* answer negative, doesn't fit */
+ SETn( -(NV)result );
+ RETURN;
+ }
+ }
+ }
+ }
}
- float_it:
+ float_it:
#endif
{
- dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
- RETURN;
+ dPOPTOPnnrl;
+ SETn( Perl_pow( left, right) );
+#ifdef PERL_PRESERVE_IVUV
+ if (is_int)
+ SvIV_please(TOPs);
+#endif
+ RETURN;
}
}
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
}
+ if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
+ TARG = sv_newmortal();
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
+ if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
+ TARG = sv_newmortal();
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
}
/* temporarily switch stacks */
SWITCHSTACK(PL_curstack, ary);
+ PL_curstackinfo->si_stack = ary;
make_mortal = 0;
}
}
if (realarray) {
if (!mg) {
SWITCHSTACK(ary, oldstack);
+ PL_curstackinfo->si_stack = oldstack;
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
if (o->op_type == OP_LEAVE ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVESUB ||
o->op_type == OP_LEAVETRY)
{
*ops++ = cUNOPo->op_first;
if (label && *label) {
OP *gotoprobe = 0;
bool leaving_eval = FALSE;
+ bool in_block = FALSE;
PERL_CONTEXT *last_eval_cx = 0;
/* find label */
case CXt_SUBST:
continue;
case CXt_BLOCK:
- if (ix)
+ if (ix) {
gotoprobe = cx->blk_oldcop->op_sibling;
- else
+ in_block = TRUE;
+ } else
gotoprobe = PL_main_root;
break;
case CXt_SUB:
if (*enterops && enterops[1]) {
OP *oldop = PL_op;
- for (ix = 1; enterops[ix]; ix++) {
+ ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
# "This IS structured code. It's just randomly structured."
-print "1..22\n";
+print "1..27\n";
while ($?) {
$foo = 1;
}
print ($ok ? "ok 22\n" : "not ok 22\n");
+{
+ my $false = 0;
+
+ $ok = 0;
+ { goto A; A: $ok = 1 } continue { }
+ print "not " unless $ok;
+ print "ok 23 - #20357 goto inside /{ } continue { }/ loop\n";
+
+ $ok = 0;
+ { do { goto A; A: $ok = 1 } while $false }
+ print "not " unless $ok;
+ print "ok 24 - #20154 goto inside /do { } while ()/ loop\n";
+
+ $ok = 0;
+ foreach(1) { goto A; A: $ok = 1 } continue { };
+ print "not " unless $ok;
+ print "ok 25 - goto inside /foreach () { } continue { }/ loop\n";
+
+ $ok = 0;
+ sub a {
+ A: { if ($false) { redo A; B: $ok = 1; redo A; } }
+ goto B unless $r++
+ }
+ a();
+ print "not " unless $ok;
+ print "ok 26 - #19061 loop label wiped away by goto\n";
+
+ $ok = 0;
+ for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
+ print "not " unless $ok;
+ print "ok 27 - weird case of goto and for(;;) loop\n";
+}
+
exit;
bypass:
$b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA.
($c = $b) =~ s/(\w+)/lc($1)/ge;
-ok($c eq $a, "Using s///e to change case.");
+is($c , $a, "Using s///e to change case.");
($c = $a) =~ s/(\w+)/uc($1)/ge;
-ok($c eq $b, "Using s///e to change case.");
+is($c , $b, "Using s///e to change case.");
($c = $b) =~ s/(\w+)/lcfirst($1)/ge;
-ok($c eq "\x{3c3}FOO.bAR", "Using s///e to change case.");
+is($c , "\x{3c3}FOO.bAR", "Using s///e to change case.");
($c = $a) =~ s/(\w+)/ucfirst($1)/ge;
-ok($c eq "\x{3a3}foo.Bar", "Using s///e to change case.");
+is($c , "\x{3a3}foo.Bar", "Using s///e to change case.");
# #18931: perl5.8.0 bug in \U..\E processing
# Test case from Nick Clark.
$test++;
}
}
-
require './test.pl';
}
-plan tests => 51;
+plan tests => 50;
$FS = ':';
{
# [perl #18195]
- for my $u (0, 1) {
- for my $a (0, 1) {
- $_ = 'readin,database,readout';
- utf8::upgrade $_ if $u;
- /(.+)/;
- my @d = split /[,]/,$1;
- is(join (':',@d), 'readin:database:readout', "[perl #18195]");
+ for my $a (0,1) {
+ $_ = 'readin,database,readout';
+ if ($ARGV[0]) {
+ $_ .= chr 256;
+ chop;
}
+ /(.+)/;
+ my @d = split /[,]/,$1;
+ is(join (':',@d), 'readin:database:readout', "[perl #18195]")
}
}
+
+{
+ $p="a,b";
+ utf8::upgrade $p;
+ @a=split(/[, ]+/,$p);
+ is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8');
+}
#!./perl
-print "1..174\n";
+print "1..175\n";
#P = start of string Q = start of substr R = end of substr S = end of string
substr($x = "\x{100}\x{200}", 2, 0, "\xFFb");
ok 174, $x eq "\x{100}\x{200}\xFFb";
+# [perl #20933]
+{
+ my $s = "ab";
+ my @r;
+ $r[$_] = \ substr $s, $_, 1 for (0, 1);
+ ok 175, join("", map { $$_ } @r) eq "ab";
+}
#!./perl
-print "1..30\n";
+print "1..31\n";
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
vec(substr($foo, 1,3), 5, 4) = 3;
print "not " if $foo ne "\x61\x62\x63\x34\x65\x66";
print "ok 30\n";
+
+# A variation of [perl #20933]
+{
+ my $s = "";
+ vec($s, 0, 1) = 0;
+ vec($s, 1, 1) = 1;
+ my @r;
+ $r[$_] = \ vec $s, $_, 1 for (0, 1);
+ print "not " if (${ $r[0] } != 0 || ${ $r[1] } != 1);
+ print "ok 31\n";
+}
* hasn't been allocated when vms_image_init() is called.
*/
if (will_taint) {
- char ***newap;
- New(1320,newap,*argcp+2,char **);
- newap[0] = argvp[0];
- *newap[1] = "-T";
- Copy(argvp[1],newap[2],*argcp-1,char **);
+ char **newargv, **oldargv;
+ oldargv = *argvp;
+ New(1320,newargv,(*argcp)+2,char *);
+ newargv[0] = oldargv[0];
+ New(1320,newargv[1],3,char);
+ strcpy(newargv[1], "-T");
+ Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
+ (*argcp)++;
+ newargv[*argcp] = NULL;
/* We orphan the old argv, since we don't know where it's come from,
* so we don't know how to free it.
*/
- *argcp++; argvp = newap;
+ *argvp = newargv;
}
else { /* Did user explicitly request tainting? */
int i;
https://perl5.git.perl.org / perl5.git / commitdiff