view release on metacpan or  search on metacpan

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

    double_delim
    dq
    dq_unop
    dquote
    e_anoncode
    e_method
    elem
    filetest
    for_loop
    func_needs_parens
    givwhen
    indirop
    is_lexical_subs
    is_list_newer
    is_list_older
    list_const
    listop
    logassignop
    logop
    loop_common
    loopex
    map_texts
    mapop
    matchop
    maybe_local
    maybe_local_str
    maybe_my
    maybe_parens
    maybe_parens_func
    maybe_parens_unop
    maybe_qualify
    maybe_targmy
    _method
    null_newer
    null_older
    pfixop
    pp_padsv
    range
    repeat
    rv2x
    scopeop
    single_delim
    slice
    split
    stringify_newer
    stringify_older
    subst_newer
    subst_older
    unop
    );


# The BEGIN {} is used here because otherwise this code isn't executed
# when you run B::Deparse on itself.
my %globalnames;
BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
	    "ENV", "ARGV", "ARGVOUT", "_"); }

BEGIN {
    # List version-specific constants here.
    # Easiest way to keep this code portable between version looks to
    # be to fake up a dummy constant that will never actually be true.
    foreach (qw(
	     CVf_LOCKED
	     OPpCONST_ARYBASE
	     OPpCONST_NOVER
	     OPpEVAL_BYTES
	     OPpITER_REVERSED
	     OPpOUR_INTRO
	     OPpPAD_STATE
	     OPpREVERSE_INPLACE
	     OPpSORT_DESCEND
	     OPpSORT_INPLACE
	     OPpTARGET_MY
	     OPpSUBSTR_REPL_FIRST
	     PMf_EVAL PMf_EXTENDED
	     PMf_NONDESTRUCT
	     PMf_SKIPWHITE
	     RXf_PMf_CHARSET
	     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;

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

	    return $self->info_from_string("$my", $op, "$my $text");
	} elsif ($self->func_needs_parens($text, $cx, 16)) {
	    return $self->info_from_string("$my()", $op, "$my($text)");
	} else {
	    return $self->info_from_string("$my", $op, "$my $text");
	}
    } else {
	return $self->info_from_string("not my", $op, $need_parens ? "($text)" : $text);
    }
}

sub maybe_my_older
{
    my $self = shift;
    my($op, $cx, $text, $forbid_parens) = @_;
    if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
	my $my_str = $op->private & OPpPAD_STATE
	    ? $self->keyword("state")
	    : "my";
	if ($forbid_parens || B::Deparse::want_scalar($op)) {
	    return $self->info_from_string('my',  $op, "$my_str $text");
	} else {
	    return $self->info_from_string('my (maybe with parens)',  $op,
					   "$my_str $text",
					   {maybe_parens => [$self, $cx, 16]});
	}
    } else {
	return $self->info_from_string('not my', $op, $text);
    }
}

# Possibly add () around $text depending on precedence $prec and
# context $cx. We return a string.
sub maybe_parens($$$$)
{
    my($self, $text, $cx, $prec) = @_;
    if (B::DeparseTree::TreeNode::parens_test($self, $cx, $prec)) {
	$text = "($text)";
	# In a unop, let parent reuse our parens; see maybe_parens_unop
	# FIXME:
	$text = "\cS" . $text if $cx == 16;
	return $text;
    } else {
	return $text;
    }
}

# FIXME: go back to default B::Deparse routine and return a string.
sub maybe_parens_func($$$$$)
{
    my($self, $func, $params, $cx, $prec) = @_;
    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.