\$\[\s* results from the CPAN

B-DeparseTree

	     RXf_PMf_KEEPCOPY
	     RXf_SKIPWHITE
	     )) {
	eval { import B $_ };
	no strict 'refs';
	*{$_} = sub () {0} unless *{$_}{CODE};
    }
}

my %strict_bits = do {
    local $^H;
    map +($_ => strict::bits($_)), qw/refs subs vars/
};

BEGIN { for (qw[ pushmark ]) {
    eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}

{
    # Mask out the bits that L<warnings::register> uses
    my $WARN_MASK;
    BEGIN {
	$WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
    }
    sub WARN_MASK () {
	return $WARN_MASK;
    }
}

my(%left, %right);

sub ambient_pragmas {
    my $self = shift;
    my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);

    while (@_ > 1) {
	my $name = shift();
	my $val  = shift();

	if ($name eq 'strict') {
	    require strict;

	    if ($val eq 'none') {
		$hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
		next();
	    }

	    my @names;
	    if ($val eq "all") {
		@names = qw/refs subs vars/;
	    }
	    elsif (ref $val) {
		@names = @$val;
	    }
	    else {
		@names = split' ', $val;
	    }
	    $hint_bits |= $strict_bits{$_} for @names;
	}

	elsif ($name eq '$[') {
	    if (OPpCONST_ARYBASE) {
		$arybase = $val;
	    } else {
		croak "\$[ can't be non-zero on this perl" unless $val == 0;
	    }
	}

	elsif ($name eq 'integer'
	    || $name eq 'bytes'
	    || $name eq 'utf8') {
	    require "$name.pm";
	    if ($val) {
		$hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
	    }
	    else {
		$hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
	    }
	}

	elsif ($name eq 're') {
	    require re;
	    if ($val eq 'none') {
		$hint_bits &= ~re::bits(qw/taint eval/);
		next();
	    }

	    my @names;
	    if ($val eq 'all') {
		@names = qw/taint eval/;
	    }
	    elsif (ref $val) {
		@names = @$val;
	    }
	    else {
		@names = split' ',$val;
	    }
	    $hint_bits |= re::bits(@names);
	}

	elsif ($name eq 'warnings') {
	    if ($val eq 'none') {
		$warning_bits = $warnings::NONE;
		next();
	    }

	    my @names;
	    if (ref $val) {
		@names = @$val;
	    }
	    else {
		@names = split/\s+/, $val;
	    }

	    $warning_bits = $warnings::NONE if !defined ($warning_bits);
	    $warning_bits |= warnings::bits(@names);
	}

	elsif ($name eq 'warning_bits') {
	    $warning_bits = $val;
	}

	elsif ($name eq 'hint_bits') {
	    $hint_bits = $val;
	}

lib/B/DeparseTree/PPfns.pm view on Meta::CPAN


sub code_list {
    my ($self, $op, $cv) = @_;

    # localise stuff relating to the current sub
    $cv and
	local($self->{'curcv'}) = $cv,
	local($self->{'curcvlex'}),
	local(@$self{qw'curstash warnings hints hinthash curcop'})
	    = @$self{qw'curstash warnings hints hinthash curcop'};

    my $re;
    for ($op = $op->first->sibling; !B::Deparse::null($op); $op = $op->sibling) {
	if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
	    my $scope = $op->first;
	    # 0 context (last arg to scopeop) means statement context, so
	    # the contents of the block will not be wrapped in do{...}.
	    my $block = scopeop($scope->first->name eq "enter", $self,
				$scope, 0);
	    # next op is the source code of the block
	    $op = $op->sibling;
	    $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
	    my $multiline = $block =~ /\n/;
	    $re .= $multiline ? "\n\t" : ' ';
	    $re .= $block;
	    $re .= $multiline ? "\n\b})" : " })";
	} else {
	    $re = B::Deparse::re_dq_disambiguate($re, $self->re_dq($op));
	}
    }
    $re;
}

# Concatenation or '.' is special because concats-of-concats are
# optimized to save copying by making all but the first concat
# stacked. The effect is as if the programmer had written:
#   ($a . $b) .= $c'
# but the above is illegal.

sub concat {
    my $self = shift;
    my($op, $cx) = @_;
    my $left = $op->first;
    my $right = $op->last;
    my $eq = "";
    my $prec = 18;
    if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
	$eq = "=";
	$prec = 7;
    }
    my $lhs = $self->deparse_binop_left($op, $left, $prec);
    my $rhs = $self->deparse_binop_right($op, $right, $prec);
    return $self->info_from_template(".$eq", $op,
				     "%c .$eq %c", undef, [$lhs, $rhs],
				     {maybe_parens => [$self, $cx, $prec]});
}

# Handle pp_dbstate, and pp_nextstate and COP ops.
#
# Notice how subs and formats are inserted between statements here;
# also $[ assignments and pragmas.

sub cops
{
    my ($self, $op, $cx, $name) = @_;
    $self->{'curcop'} = $op;
    my @texts = ();
    my $opts = {};
    my @args_spec = ();
    my $fmt = '%;';

    push @texts, $self->B::Deparse::cop_subs($op);

    if (@texts) {
	# Special marker to swallow up the semicolon
	$opts->{'omit_next_semicolon'} = 1;
    }

    my $stash = $op->stashpv;
    if ($stash ne $self->{'curstash'}) {
	push @texts, $self->keyword("package") . " $stash;";
	$self->{'curstash'} = $stash;
    }

    if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
	push @texts, '$[ = '. $op->arybase .";";
	$self->{'arybase'} = $op->arybase;
    }

    my $warnings = $op->warnings;
    my $warning_bits;
    if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
	$warning_bits = $warnings::Bits{"all"} & WARN_MASK;
    }
    elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
        $warning_bits = $warnings::NONE;
    }
    elsif ($warnings->isa("B::SPECIAL")) {
	$warning_bits = undef;
    }
    else {
	$warning_bits = $warnings->PV & WARN_MASK;
    }

    if (defined ($warning_bits) and
       !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
	my @warnings = $self->declare_warnings($self->{'warnings'}, $warning_bits);
	foreach my $warning (@warnings) {
	    push @texts, $warning;
	}
    	$self->{'warnings'} = $warning_bits;
    }

    my $hints = $] < 5.008009 ? $op->private : $op->hints;
    my $old_hints = $self->{'hints'};
    if ($self->{'hints'} != $hints) {
	my @hints = $self->declare_hints($self->{'hints'}, $hints);
	foreach my $hint (@hints) {
	    push @texts, $hint;
	}
	$self->{'hints'} = $hints;
    }

    my $newhh;
    if ($] > 5.009) {
	$newhh = $op->hints_hash->HASH;
    }

    if ($] >= 5.015006) {
	# feature bundle hints
	my $from = $old_hints & $feature::hint_mask;
	my $to   = $    hints & $feature::hint_mask;
	if ($from != $to) {
	    if ($to == $feature::hint_mask) {
		if ($self->{'hinthash'}) {
		    delete $self->{'hinthash'}{$_}
			for grep /^feature_/, keys %{$self->{'hinthash'}};
		}
		else { $self->{'hinthash'} = {} }
		$self->{'hinthash'}
		    = B::Deparse::_features_from_bundle($from,
							$self->{'hinthash'});
	    }
	    else {
		my $bundle =
		    $feature::hint_bundles[$to >> $feature::hint_shift];

lib/B/DeparseTree/PPfns.pm view on Meta::CPAN

	return $self->deparse($right, $prec - .00001, $op);
    } else {
	return $self->deparse($right, $prec, $op);
    }
}

# Iterate via sibling links a list of OP nodes starting with
# $first. Each OP is deparsed, with $op and $precedence each to get a
# node. Then the "prev" field in the node is set, and finally it is
# pushed onto the end of the $exprs reference ARRAY.
sub deparse_op_siblings($$$$$)
{
    my ($self, $exprs, $kid, $op, $precedence) = @_;
    my $prev_expr = undef;
    $prev_expr = $exprs->[-1] if scalar @{$exprs};
    for ( ; !B::Deparse::null($kid); $kid = $kid->sibling) {
	my $expr = $self->deparse($kid, $precedence, $op);
	if (defined $expr) {
	    $expr->{prev_expr} = $prev_expr;
	    $prev_expr = $expr;
	    push @$exprs, $expr;
	}
    }
}


# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
# note that tr(from)/to/ is OK, but not tr/from/(to)
sub double_delim {
    my($from, $to) = @_;
    my($succeed, $delim);
    if ($from !~ m[/] and $to !~ m[/]) {
	return "/$from/$to/";
    } elsif (($succeed, $from) = B::Deparse::balanced_delim($from) and $succeed) {
	if (($succeed, $to) = B::Deparse::balanced_delim($to) and $succeed) {
	    return "$from$to";
	} else {
	    for $delim ('/', '"', '#') { # note no "'" -- s''' is special
		return "$from$delim$to$delim" if index($to, $delim) == -1;
	    }
	    $to =~ s[/][\\/]g;
	    return "$from/$to/";
	}
    } else {
	for $delim ('/', '"', '#') { # note no '
	    return "$delim$from$delim$to$delim"
		if index($to . $from, $delim) == -1;
	}
	$from =~ s[/][\\/]g;
	$to =~ s[/][\\/]g;
	return "/$from/$to/";
    }
}

sub dq($$$)
{
    my ($self, $op, $parent) = @_;
    my $type = $op->name;
    my $info;
    if ($type eq "const") {
	return info_from_text($op, $self, '$[', 'dq constant ary', {}) if $op->private & OPpCONST_ARYBASE;
	return info_from_text($op, $self,
			      B::Deparse::uninterp(B::Deparse::escape_str(B::Deparse::unback($self->const_sv($op)->as_string))),
			 'dq constant', {});
    } elsif ($type eq "concat") {
	my $first = $self->dq($op->first, $op);
	my $last  = $self->dq($op->last, $op);

	# FIXME: convert to newer conventions
	# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
	($last->{text} =~ /^[A-Z\\\^\[\]_?]/ &&
	    $first->{text} =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
	    || ($last->{text} =~ /^[:'{\[\w_]/ && #'
		$first->{text} =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);

	return info_from_list($op, $self, [$first->{text}, $last->{text}], '', 'dq_concat',
			      {body => [$first, $last]});
    } elsif ($type eq "join") {
	return $self->deparse($op->last, 26, $op); # was join($", @ary)
    } else {
	return $self->deparse($op, 26, $parent);
    }
    my $kid = $self->dq($op->first->sibling, $op);
    my $kid_text = $kid->{text};
    if ($type eq "uc") {
	$info = info_from_lists(['\U', $kid, '\E'], '', 'dq_uc', {});
    } elsif ($type eq "lc") {
	$info = info_from_lists(['\L', $kid, '\E'], '', 'dq_lc', {});
    } elsif ($type eq "ucfirst") {
	$info = info_from_lists(['\u', $kid, '\E'], '', 'dq_ucfirst', {});
    } elsif ($type eq "lcfirst") {
	$info = info_from_lists(['\l', $kid, '\E'], '', 'dq_lcfirst', {});
    } elsif ($type eq "quotemeta") {
	$info = info_from_lists(['\Q', $kid, '\E'], '', 'dq_quotemeta', {});
    } elsif ($type eq "fc") {
	$info = info_from_lists(['\F', $kid, '\E'], '', 'dq_fc', {});
    }
    $info->{body} = [$kid];
    return $info;
}

# Handle unary operators that can occur as pseudo-listops inside
# double quotes
sub dq_unop
{
    my($self, $op, $cx, $name, $prec, $flags) = (@_, 0, 0);
    my $kid;
    if ($op->flags & B::OPf_KIDS) {
	my $pushmark_op = undef;
	$kid = $op->first;
	if (not B::Deparse::null $kid->sibling) {
	    # If there's more than one kid, the first is an ex-pushmark.
	    $pushmark_op = $kid;
	    $kid = $kid->sibling;
	}
	my $info = $self->maybe_parens_unop($name, $kid, $cx, $op);
	if ($pushmark_op) {
	    # For the pushmark opc we'll consider it the "name" portion
	    # of info. We examine that to get the text.
	    my $text = $info->{text};
	    my $word_end = index($text, ' ');

lib/B/DeparseTree/PPfns.pm view on Meta::CPAN

    if ($prec <= $cx or substr($params, 0, 1) eq "(" or $self->{'parens'}) {
	return ($func, '(', $params, ')');
    } else {
	return ($func, ' ', $params);
    }
}

# Sort of like maybe_parens in that we may possibly add ().  However we take
# an op rather than text, and return a tree node. Also, we get around
# the 'if it looks like a function' rule.
sub maybe_parens_unop($$$$$)
{
    my ($self, $name, $op, $cx, $parent, $opts) = @_;
    $opts = {} unless $opts;
    my $info =  $self->deparse($op, 1, $parent);
    my $fmt;
    my @exprs = ($info);
    if ($name eq "umask" && $info->{text} =~ /^\d+$/) {
	# Display umask numbers in octal.
	# FIXME: add as a info_node option to run a transformation function
	# such as the below
	$info->{text} = sprintf("%#o", $info->{text});
	$exprs[0] = $info;
    }
    $name = $self->keyword($name);
    if ($cx > 16 or $self->{'parens'}) {
	my $node = $self->info_from_template(
	    "$name()", $parent, "$name(%c)",[0], \@exprs, $opts);
	$node->{prev_expr} = $exprs[0];
	return $node;
    } else {
	# FIXME: we don't do \cS
	# if (substr($text, 0, 1) eq "\cS") {
	#     # use op's parens
	#     return info_from_list($op, $self,[$name, substr($text, 1)],
	# 			  '',  'maybe_parens_unop_cS', {body => [$info]});
	# } else
	my $node;
	if (substr($info->{text}, 0, 1) eq "(") {
	    # avoid looks-like-a-function trap with extra parens
	    # ('+' can lead to ambiguities)
	    $node = $self->info_from_template(
		"$name(()) dup remove", $parent, "$name(%c)", [0], \@exprs, $opts);
	} else {
	    $node = $self->info_from_template(
		"$name <args>", $parent, "$name %c", [0], \@exprs, $opts);
	}
	$node->{prev_expr} = $exprs[0];
	return $node;
    }
    Carp::confess("unhandled condition in maybe_parens_unop");
}

sub maybe_qualify {
    my ($self,$prefix,$name) = @_;
    my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
    return $name if !$prefix || $name =~ /::/;
    return $self->{'curstash'}.'::'. $name
	if
	    $name =~ /^(?!\d)\w/         # alphabetic
	 && $v    !~ /^\$[ab]\z/	 # not $a or $b
	 && !$globalnames{$name}         # not a global name
	 && $self->{hints} & $strict_bits{vars}  # strict vars
	 && !$self->B::Deparse::lex_in_scope($v,1)   # no "our"
      or $self->B::Deparse::lex_in_scope($v);        # conflicts with "my" variable
    return $name;
}

# FIXME: need a way to pass in skipped_ops
# FIXME: see if we can move to some 5.xx-specific module
sub maybe_targmy
{
    my($self, $op, $cx, $func, @args) = @_;
    if ($op->private & OPpTARGET_MY) {
	my $var = $self->padname($op->targ);
	my $val = $func->($self, $op, 7, @args);
	my @texts = ($var, '=', $val);
	return $self->info_from_template("my", $op,
					 "%c = %c", [0, 1],
					 [$var, $val],
					 {maybe_parens => [$self, $cx, 7]});
    } else {
	return $self->$func($op, $cx, @args);
    }
}

# Note: this is used in 5.28 and later versions only.
# FIXME: see if we can move to some 5.xx-specific module
sub maybe_var_attr {
    my ($self, $op, $cx) = @_;

    my @skipped_ops = ($op->first);
    my $kid = $op->first->sibling; # skip pushmark
    return if B::class($kid) eq 'NULL';

    my $lop;
    my $type;

    # Extract out all the pad ops and entersub ops into
    # @padops and @entersubops. Return if anything else seen.
    # Also determine what class (if any) all the pad vars belong to
    my $class;
    my $decl; # 'my' or 'state'
    my (@padops, @entersubops);
    for ($lop = $kid; !B::Deparse::null($lop); $lop = $lop->sibling) {
	my $lopname = $lop->name;
	my $loppriv = $lop->private;
        if ($lopname =~ /^pad[sah]v$/) {
            return unless $loppriv & B::Deparse::OPpLVAL_INTRO;

            my $padname = $self->padname_sv($lop->targ);
            my $thisclass = ($padname->FLAGS & SVpad_TYPED)
                                ? $padname->B::Deparse::SvSTASH->NAME : 'main';

            # all pad vars must be in the same class
            $class //= $thisclass;
            return unless $thisclass eq $class;

            # all pad vars must be the same sort of declaration
            # (all my, all state, etc)
            my $this = ($loppriv & B::Deparse::OPpPAD_STATE) ? 'state' : 'my';

( run in 0.524 second using v1.01-cache-2.11-cpan-5735350b133 )