MDEREF_SHIFT
);
-$VERSION = '1.34';
+$VERSION = '1.38';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# be to fake up a dummy constant that will never actually be true.
foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
- RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST
+ PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
- eval { import B $_ };
+ eval { B->import($_) };
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
}
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- if (ref $ent->[3]) { # lexical sub
- my @text;
+ my ($seq, $cv, $is_form, $name) = @$ent;
- # At this point, we may not yet have deparsed the hints that allow
- # lexical subroutines to be recognized. So adjust the current
- # hints and deparse them.
- # When lex subs cease being experimental, we should be able to
- # remove this code.
- {
- local $^H = $self->{'hints'};
- local %^H = %{ $self->{'hinthash'} || {} };
- local ${^WARNING_BITS} = $self->{'warnings'};
- feature->import("lexical_subs");
- warnings->unimport("experimental::lexical_subs");
- # Here we depend on the fact that individual features
- # will always set the feature bundle to ‘custom’
- # (== $feature::hint_mask). If we had another specific bundle
- # enabled previously, normalise it.
- if (($self->{'hints'} & $feature::hint_mask)
- != $feature::hint_mask)
- {
- if ($self->{'hinthash'}) {
- delete $self->{'hinthash'}{$_}
- for grep /^feature_/, keys %{$self->{'hinthash'}};
- }
- else { $self->{'hinthash'} = {} }
- $self->{'hinthash'}
- = _features_from_bundle(@$self{'hints','hinthash'});
- }
- push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
- $self->{indent_size}, $^H);
- push @text, $self->declare_warnings($self->{'warnings'},
- ${^WARNING_BITS})
- unless ($self->{'warnings'} // 'u')
- eq (${^WARNING_BITS } // 'u');
- $self->{'warnings'} = ${^WARNING_BITS};
- $self->{'hints'} = $^H;
- $self->{'hinthash'} = {%^H};
- }
+ # any 'use strict; package foo' that should come before the sub
+ # declaration to sync with the first COP of the sub
+ my $pragmata = '';
+ if ($cv and !null($cv->START) and is_state($cv->START)) {
+ $pragmata = $self->pragmata($cv->START);
+ }
- # Now emit the sub itself.
- my $padname = $ent->[3];
- my $flags = $padname->FLAGS;
+ if (ref $name) { # lexical sub
+ # emit the sub.
+ my @text;
+ my $flags = $name->FLAGS;
push @text,
- !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
+ !$cv || $seq <= $name->COP_SEQ_RANGE_LOW
? $self->keyword($flags & SVpad_OUR
? "our"
: $flags & SVpad_STATE
# XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
# doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
# we have a core bug here.
- push @text, "sub " . substr $padname->PVX, 1;
+ push @text, "sub " . substr $name->PVX, 1;
if ($cv) {
# my sub foo { }
push @text, " " . $self->deparse_sub($cv);
# my sub foo;
push @text, ";\n";
}
- return join "", @text;
+ return $pragmata . join "", @text;
}
+
my $gv = $cv->GV;
- my $name = $ent->[3] // $self->gv_name($gv);
- if ($ent->[2]) {
- return $self->keyword("format") . " $name =\n"
- . $self->deparse_format($ent->[1]). "\n";
+ $name //= $self->gv_name($gv);
+ if ($is_form) {
+ return $pragmata . $self->keyword("format") . " $name =\n"
+ . $self->deparse_format($cv). "\n";
} else {
my $use_dec;
if ($name eq "BEGIN") {
$use_dec = $self->begin_is_use($cv);
if (defined ($use_dec) and $self->{'expand'} < 5) {
- return () if 0 == length($use_dec);
+ return $pragmata if 0 == length($use_dec);
$use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
}
}
}
}
if ($use_dec) {
- return "$p$l$use_dec";
+ return "$pragmata$p$l$use_dec";
}
if ( $name !~ /::/ and $self->lex_in_scope("&$name")
|| $self->lex_in_scope("&$name", 1) )
} elsif (defined $stash) {
$name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
- my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
+ my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
. $self->deparse_sub($cv);
$self->{'subs_declared'}{$name} = 1;
return $ret;
}
}
+
# Return a "use" declaration for this BEGIN block, if appropriate
sub begin_is_use {
my ($self, $cv) = @_;
sub deparse_sub {
my $self = shift;
my $cv = shift;
- my $proto = "";
+ my @attrs;
+ my $protosig; # prototype or signature (what goes in the (....))
+
Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
local $self->{'curcop'} = $self->{'curcop'};
+
+ my $has_sig = $self->{hinthash}{feature_signatures};
if ($cv->FLAGS & SVf_POK) {
- $proto = "(". $cv->PV . ") ";
+ my $proto = $cv->PV;
+ if ($has_sig) {
+ push @attrs, "prototype($proto)";
+ }
+ else {
+ $protosig = $proto;
+ }
}
if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
- $proto .= ": ";
- $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
- $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
- $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
- $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST;
+ push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
+ push @attrs, "locked" if $cv->CvFLAGS & CVf_LOCKED;
+ push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD;
+ push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
}
local($self->{'curcv'}) = $cv;
push @ops, $o;
}
$body = $self->lineseq(undef, 0, @ops).";";
+ if ($ops[-1]->name =~ /^(next|db)state$/) {
+ # this handles void context in
+ # use feature signatures; sub ($=1) {}
+ $body .= "\n()";
+ }
my $scope_en = $self->find_scope_en($lineseq);
if (defined $scope_en) {
my $subs = join"", $self->seq_subs($scope_en);
else {
$body = $self->deparse($root->first, 0);
}
+ $body = "{\n\t$body\n\b}";
}
else {
my $sv = $cv->const_sv;
if ($$sv) {
# uh-oh. inlinable sub... format it differently
- return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ $body = "{ " . $self->const($sv, 0) . " }\n";
} else { # XSUB? (or just a declaration)
- return "$proto;\n";
+ $body = ';'
}
}
- return $proto ."{\n\t$body\n\b}" ."\n";
+ $protosig = defined $protosig ? "($protosig) " : "";
+ my $attrs = '';
+ $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs;
+ return "$protosig$attrs$body\n";
}
sub deparse_format {
return $hh;
}
-# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
-sub pp_nextstate {
+# generate any pragmas, 'package foo' etc needed to synchronise
+# with the given cop
+
+sub pragmata {
my $self = shift;
- my($op, $cx) = @_;
- $self->{'curcop'} = $op;
+ my($op) = @_;
+
my @text;
- push @text, $self->cop_subs($op);
- if (@text) {
- # Special marker to swallow up the semicolon
- push @text, "\cK";
- }
+
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, $self->keyword("package") . " $stash;\n";
$self->{'hinthash'} = $newhh;
}
+ return join("", @text);
+}
+
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+
+ my @text;
+
+ my @subs = $self->cop_subs($op);
+ if (@subs) {
+ # Special marker to swallow up the semicolon
+ push @subs, "\cK";
+ }
+ push @text, @subs;
+
+ push @text, $self->pragmata($op);
+
+
# This should go after of any branches that add statements, to
# increase the chances that it refers to the same line it did in
# the original program.
my $self = shift;
my($op, $cx) = @_;
my $kid = $op->first;
- if (is_scalar($kid)) {
- my $kid_deparsed = $self->deparse($kid, 1);
- return '<<>>' if $op->flags & OPf_SPECIAL and $kid_deparsed eq 'ARGV';
- return "<$kid_deparsed>";
+ if (is_scalar($kid)
+ and $op->flags & OPf_SPECIAL
+ and $self->deparse($kid, 1) eq 'ARGV')
+ {
+ return '<<>>';
}
return $self->unop($op, $cx, "readline");
}
my $kid = $op->first->sibling; # skip pushmark
my $keyword =
$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
- my $text;
- if ($keyword =~ /^CORE::/
- or $kid->name ne 'const'
- or ($text = $self->dq($kid))
- =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- $text = $self->deparse($kid);
- return $cx >= 5 || $self->{'parens'}
- ? "$keyword($text)"
- : "$keyword $text";
- } else {
- return '<' . $text . '>';
- }
+ my $text = $self->deparse($kid);
+ return $cx >= 5 || $self->{'parens'}
+ ? "$keyword($text)"
+ : "$keyword $text";
}
# Truncate is special because OPf_SPECIAL makes a bareword first arg
if ($op->first && ($op->first->flags & OPf_KIDS)) {
# arbitrary initial expression, e.g. f(1,2,3)->[...]
- $text .= $self->deparse($op->first, 24);
+ my $expr = $self->deparse($op->first, 24);
+ # stop "exists (expr)->{...}" being interpreted as
+ #"(exists (expr))->{...}"
+ $expr = "+$expr" if $expr =~ /^\(/;
+ $text .= $expr;
}
my @items = $op->aux_list($self->{curcv});
$flags .= "s" if $pmflags & PMf_SINGLELINE;
$flags .= "x" if $pmflags & PMf_EXTENDED;
$flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
- $flags .= "p" if $pmflags & RXf_PMf_KEEPCOPY;
- if (my $charset = $pmflags & RXf_PMf_CHARSET) {
+ $flags .= "p" if $pmflags & PMf_KEEPCOPY;
+ $flags .= "n" if $pmflags & PMf_NOCAPTURE;
+ if (my $charset = $pmflags & PMf_CHARSET) {
# Hardcoding this is fragile, but B does not yet export the
# constants we need.
$flags .= qw(d l u a aa)[$charset >> 7]
or $self->{hints} & $feature::hint_mask
&& ($self->{hints} & $feature::hint_mask)
!= $feature::hint_mask
- && do {
- $self->{hints} & $feature::hint_uni8bit;
- }
- ) {
+ && $self->{hints} & $feature::hint_uni8bit
+ ) {
$flags .= 'd';
}
$flags;
: &pp_padsv) . ')'
}
+
+sub pp_argcheck {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv});
+ my $mandatory = $params - $opt_params;
+ my $check = '';
+
+ $check .= <<EOF if !$slurpy;
+die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params;
+EOF
+
+ $check .= <<EOF if $mandatory > 0;
+die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory;
+EOF
+
+ my $cond = ($params & 1) ? 'unless' : 'if';
+ $check .= <<EOF if $slurpy eq '%';
+die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1);
+EOF
+
+ $check =~ s/;\n\z//;
+ return $check;
+}
+
+
+sub pp_argelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $var = $self->padname($op->targ);
+ my $ix = $op->string($self->{curcv});
+ my $expr;
+ if ($op->flags & OPf_KIDS) {
+ $expr = $self->deparse($op->first, 7);
+ }
+ elsif ($var =~ /^[@%]/) {
+ $expr = $ix ? "\@_[$ix .. \$#_]" : '@_';
+ }
+ else {
+ $expr = "\$_[$ix]";
+ }
+ return "my $var = $expr";
+}
+
+
+sub pp_argdefelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $ix = $op->targ;
+ my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
+ $expr .= $self->deparse($op->first, $cx);
+ return $expr;
+}
+
+
1;
__END__
=item *
Lexical (my) variables declared in scopes external to a subroutine
-appear in code2ref output text as package variables. This is a tricky
+appear in coderef2text output text as package variables. This is a tricky
problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
https://perl5.git.perl.org / perl5.git / blobdiff