summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
Diffstat (limited to 'ext')
-rw-r--r--ext/B/B.xs9
-rw-r--r--ext/B/B/CC.pm44
-rw-r--r--ext/B/B/Deparse.pm72
-rw-r--r--ext/B/B/Xref.pm50
-rw-r--r--ext/IO/lib/IO/Socket/INET.pm14
-rw-r--r--ext/attrs/attrs.pm2
6 files changed, 144 insertions, 47 deletions
diff --git a/ext/B/B.xs b/ext/B/B.xs
index df0b501075..d0ee8e463a 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -95,6 +95,11 @@ cc_opclass(pTHX_ OP *o)
if (o->op_type == OP_SASSIGN)
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)
+ return OPc_PADOP;
+#endif
+
switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
case OA_BASEOP:
return OPc_BASEOP;
@@ -685,8 +690,8 @@ PMOP_precomp(o)
if (rx)
sv_setpvn(ST(0), rx->precomp, rx->prelen);
-#define SVOP_sv(o) cSVOPx_sv(o)
-#define SVOP_gv(o) cGVOPx_gv(o)
+#define SVOP_sv(o) cSVOPo->op_sv
+#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index cf0e81f92e..c5ca2a3df5 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -6,6 +6,7 @@
# License or the Artistic License, as specified in the README file.
#
package B::CC;
+use Config;
use strict;
use B qw(main_start main_root class comppadlist peekop svref_2object
timing_info init_av sv_undef amagic_generation
@@ -223,7 +224,8 @@ sub save_or_restore_lexical_state {
next unless ref($lex);
${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
}
- }else{
+ }
+ else {
foreach my $lex (@pad) {
next unless ref($lex);
my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
@@ -586,9 +588,16 @@ sub pp_padsv {
sub pp_const {
my $op = shift;
my $sv = $op->sv;
- my $obj = $constobj{$$sv};
- if (!defined($obj)) {
- $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+ my $obj;
+ # constant could be in the pad (under useithreads)
+ if ($$sv) {
+ $obj = $constobj{$$sv};
+ if (!defined($obj)) {
+ $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+ }
+ }
+ else {
+ $obj = $pad[$op->targ];
}
push(@stack, $obj);
return $op->next;
@@ -656,10 +665,17 @@ sub pp_sort {
write_back_stack();
doop($op);
return $op->next;
-}
+}
+
sub pp_gv {
my $op = shift;
- my $gvsym = $op->gv->save;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
write_back_stack();
runtime("XPUSHs((SV*)$gvsym);");
return $op->next;
@@ -667,7 +683,13 @@ sub pp_gv {
sub pp_gvsv {
my $op = shift;
- my $gvsym = $op->gv->save;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
write_back_stack();
if ($op->private & OPpLVAL_INTRO) {
runtime("XPUSHs(save_scalar($gvsym));");
@@ -679,7 +701,13 @@ sub pp_gvsv {
sub pp_aelemfast {
my $op = shift;
- my $gvsym = $op->gv->save;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
my $ix = $op->private;
my $flag = $op->flags & OPf_MOD;
write_back_stack();
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index f8bcc7c8df..cd53c112d8 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -8,6 +8,7 @@
package B::Deparse;
use Carp 'cluck', 'croak';
+use Config;
use B qw(class main_root main_start main_cv svref_2object opnumber
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
@@ -251,18 +252,19 @@ sub walk_sub {
walk_tree($op, sub {
my $op = shift;
if ($op->name eq "gv") {
+ my $gv = $self->maybe_padgv($op);
if ($op->next->name eq "entersub") {
- next if $self->{'subs_done'}{$ {$op->gv}}++;
- next if class($op->gv->CV) eq "SPECIAL";
- $self->todo($op->gv, $op->gv->CV, 0);
- $self->walk_sub($op->gv->CV);
+ next if $self->{'subs_done'}{$$gv}++;
+ next if class($gv->CV) eq "SPECIAL";
+ $self->todo($gv, $gv->CV, 0);
+ $self->walk_sub($gv->CV);
} elsif ($op->next->name eq "enterwrite"
or ($op->next->name eq "rv2gv"
and $op->next->next->name eq "enterwrite")) {
- next if $self->{'forms_done'}{$ {$op->gv}}++;
- next if class($op->gv->FORM) eq "SPECIAL";
- $self->todo($op->gv, $op->gv->FORM, 1);
- $self->walk_sub($op->gv->FORM);
+ next if $self->{'forms_done'}{$$gv}++;
+ next if class($gv->FORM) eq "SPECIAL";
+ $self->todo($gv, $gv->FORM, 1);
+ $self->walk_sub($gv->FORM);
}
}
});
@@ -455,7 +457,7 @@ sub deparse_format {
$op = $op->sibling; # skip nextstate
my @exprs;
$kid = $op->first->sibling; # skip pushmark
- push @text, $kid->sv->PV;
+ push @text, $self->const_sv($kid)->PV;
$kid = $kid->sibling;
for (; not null $kid; $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 0);
@@ -984,7 +986,7 @@ sub pp_require {
if (class($op) eq "UNOP" and $op->first->name eq "const"
and $op->first->private & OPpCONST_BARE)
{
- my $name = $op->first->sv->PV;
+ my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
return "require($name)";
@@ -1008,6 +1010,7 @@ sub pp_scalar {
sub padval {
my $self = shift;
my $targ = shift;
+ #cluck "curcv was undef" unless $self->{curcv};
return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
}
@@ -1537,7 +1540,7 @@ sub pp_truncate {
my $fh;
if ($op->flags & OPf_SPECIAL) {
# $kid is an OP_CONST
- $fh = $kid->sv->PV;
+ $fh = $self->const_sv($kid)->PV;
} else {
$fh = $self->deparse($kid, 6);
$fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
@@ -1876,22 +1879,37 @@ sub pp_threadsv {
return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
}
+sub maybe_padgv {
+ my $self = shift;
+ my $op = shift;
+ my $gv;
+ if ($Config{useithreads}) {
+ $gv = $self->padval($op->padix);
+ }
+ else {
+ $gv = $op->gv;
+ }
+ return $gv;
+}
+
sub pp_gvsv {
my $self = shift;
my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
+ my $gv = $self->maybe_padgv($op);
+ return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
}
sub pp_gv {
my $self = shift;
my($op, $cx) = @_;
- return $self->gv_name($op->gv);
+ my $gv = $self->maybe_padgv($op);
+ return $self->gv_name($gv);
}
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
- my $gv = $op->gv;
+ my $gv = $self->maybe_padgv($op);
return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
}
@@ -1927,7 +1945,7 @@ sub pp_rv2av {
my($op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "const") { # constant list
- my $av = $kid->sv;
+ my $av = $self->const_sv($kid);
return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
} else {
return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
@@ -2083,13 +2101,13 @@ sub method {
}
$obj = $self->deparse($obj, 24);
if ($meth->name eq "method_named") {
- $meth = $meth->sv->PV;
+ $meth = $self->const_sv($meth)->PV;
} else {
$meth = $meth->first;
if ($meth->name eq "const") {
# As of 5.005_58, this case is probably obsoleted by the
# method_named case above
- $meth = $meth->sv->PV; # needs to be bare
+ $meth = $self->const_sv($meth)->PV; # needs to be bare
} else {
$meth = $self->deparse($meth, 1);
}
@@ -2202,7 +2220,7 @@ sub pp_entersub {
$amper = "&";
$kid = "{" . $self->deparse($kid, 0) . "}";
} elsif ($kid->first->name eq "gv") {
- my $gv = $kid->first->gv;
+ my $gv = $self->maybe_padgv($kid->first);
if (class($gv->CV) ne "SPECIAL") {
$proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
}
@@ -2347,13 +2365,23 @@ sub const {
}
}
+sub const_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
-# return $op->sv->PV;
+# return $self->const_sv($op)->PV;
# }
- return const($op->sv);
+ my $sv = $self->const_sv($op);
+ return const($sv);
}
sub dq {
@@ -2361,7 +2389,7 @@ sub dq {
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return uninterp(escape_str(unback($op->sv->PV)));
+ return uninterp(escape_str(unback($self->const_sv($op)->PV)));
} elsif ($type eq "concat") {
return $self->dq($op->first) . $self->dq($op->last);
} elsif ($type eq "uc") {
@@ -2650,7 +2678,7 @@ sub re_dq {
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return uninterp($op->sv->PV);
+ return uninterp($self->const_sv($op)->PV);
} elsif ($type eq "concat") {
return $self->re_dq($op->first) . $self->re_dq($op->last);
} elsif ($type eq "uc") {
diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
index 53b655c82e..0a5ceabda1 100644
--- a/ext/B/B/Xref.pm
+++ b/ext/B/B/Xref.pm
@@ -85,6 +85,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
=cut
use strict;
+use Config;
use B qw(peekop class comppadlist main_start svref_2object walksymtable
OPpLVAL_INTRO SVf_POK
);
@@ -133,10 +134,10 @@ sub process {
sub load_pad {
my $padlist = shift;
- my ($namelistav, @namelist, $ix);
+ my ($namelistav, $vallistav, @namelist, $ix);
@pad = ();
return if class($padlist) eq "SPECIAL";
- ($namelistav) = $padlist->ARRAY;
+ ($namelistav,$vallistav) = $padlist->ARRAY;
@namelist = $namelistav->ARRAY;
for ($ix = 1; $ix < @namelist; $ix++) {
my $namesv = $namelist[$ix];
@@ -144,6 +145,17 @@ sub load_pad {
my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
$pad[$ix] = ["(lexical)", $type, $name];
}
+ if ($Config{useithreads}) {
+ my (@vallist);
+ @vallist = $vallistav->ARRAY;
+ for ($ix = 1; $ix < @vallist; $ix++) {
+ my $valsv = $vallist[$ix];
+ next unless class($valsv) eq "GV";
+ # these pad GVs don't have corresponding names, so same @pad
+ # array can be used without collisions
+ $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
+ }
+ }
}
sub xref {
@@ -229,23 +241,45 @@ sub pp_rv2gv { deref($top, "*"); }
sub pp_gvsv {
my $op = shift;
- my $gv = $op->gv;
- $top = [$gv->STASH->NAME, '$', $gv->NAME];
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '$';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, '$', $gv->NAME];
+ }
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
}
sub pp_gv {
my $op = shift;
- my $gv = $op->gv;
- $top = [$gv->STASH->NAME, "*", $gv->NAME];
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '*';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, "*", $gv->NAME];
+ }
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
}
sub pp_const {
my $op = shift;
my $sv = $op->sv;
- $top = ["?", "",
- (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+ # constant could be in the pad (under useithreads)
+ if ($$sv) {
+ $top = ["?", "",
+ (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+ }
+ else {
+ $top = $pad[$op->targ];
+ }
}
sub pp_method {
diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm
index af64c9603e..696e988802 100644
--- a/ext/IO/lib/IO/Socket/INET.pm
+++ b/ext/IO/lib/IO/Socket/INET.pm
@@ -12,11 +12,13 @@ use IO::Socket;
use Socket;
use Carp;
use Exporter;
-use Errno qw(EINVAL); # EINVAL appears portable
+use Errno;
@ISA = qw(IO::Socket);
$VERSION = "1.25";
+my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
+
IO::Socket::INET->register_domain( AF_INET );
my %socket_type = ( tcp => SOCK_STREAM,
@@ -117,7 +119,7 @@ sub configure {
$laddr = defined $laddr ? inet_aton($laddr)
: INADDR_ANY;
- return _error($sock, EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
unless(defined $laddr);
$arg->{PeerAddr} = $arg->{PeerHost}
@@ -139,7 +141,7 @@ sub configure {
if(defined $raddr) {
@raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
- return _error($sock, EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless @raddr;
}
@@ -169,13 +171,13 @@ sub configure {
$raddr = shift @raddr;
- return _error($sock, EINVAL, 'Cannot determine remote port')
+ return _error($sock, $EINVAL, 'Cannot determine remote port')
unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
last
unless($type == SOCK_STREAM || defined $raddr);
- return _error($sock, EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless defined $raddr;
# my $timeout = ${*$sock}{'io_socket_timeout'};
@@ -192,7 +194,7 @@ sub configure {
# if ($timeout) {
# my $new_timeout = $timeout - (time() - $before);
# return _error($sock,
-# (exists(&Errno::ETIMEDOUT) ? &Errno::ETIMEDOUT : EINVAL),
+# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
# "Timeout") if $new_timeout <= 0;
# ${*$sock}{'io_socket_timeout'} = $new_timeout;
# }
diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm
index f744e36c66..2070632558 100644
--- a/ext/attrs/attrs.pm
+++ b/ext/attrs/attrs.pm
@@ -20,7 +20,7 @@ attrs - set/get attributes of a subroutine (deprecated)
NOTE: Use of this pragma is deprecated. Use the syntax
- sub foo : locked, method { }
+ sub foo : locked method { }
to declare attributes instead. See also L<attributes>.
View Lorry Controller Status