view release on metacpan or  search on metacpan

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

		    !B::Deparse::null($real = $arg->first) and
		    ($chr =~ /\$/ && B::Deparse::is_scalar($real->first)
		     or ($chr =~ /@/
			 && class($real->first->sibling) ne 'NULL'
			 && $real->first->sibling->name
			 =~ /^(rv2|pad)av$/)
		     or ($chr =~ /%/
			 && class($real->first->sibling) ne 'NULL'
			 && $real->first->sibling->name
			 =~ /^(rv2|pad)hv$/)
		     #or ($chr =~ /&/ # This doesn't work
		     #   && $real->first->name eq "rv2cv")
		     or ($chr =~ /\*/
			 && $real->first->name eq "rv2gv")))
		  {
		      push @reals, $self->deparse($real, 6, $op);
		  } else {
		      return ('&', []);
		  }
	    }
       }
    }
    return ('&', []) if $proto and !$doneok; # too few args and no ';'
    return ('&', []) if @args;               # too many args
    return ('', \@reals);
}

sub retscalar {
    my $name = $_[0]->name;
    # XXX There has to be a better way of doing this scalar-op check.
    #     Currently PL_opargs is not exposed.
    if ($name eq 'null') {
        $name = substr B::ppname($_[0]->targ), 3
    }
    $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
                 |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
                 |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
                 |transr|sassign|chop|schop|chomp|schomp|defined|undef
                 |study|pos|preinc|i_preinc|predec|i_predec|postinc
                 |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
                 |divide|i_divide|modulo|i_modulo|add|i_add|subtract
                 |i_subtract|concat|stringify|left_shift|right_shift|lt
                 |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|n_cmp|i_cmp
                 |s_lt|s_gt|s_le|s_ge|s_eq|s_ne|s_cmp|([isn]_)?bit_(?:and|x?or)|negate
                 |i_negate|not|([isn]_)?complement|smartmatch|atan2|sin|cos
                 |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
                 |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
                 |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
                 |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
                 |andassign|orassign|dorassign|warn|die|reset|nextstate
                 |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
                 |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
                 |dbmclose|select|getc|read|enterwrite|prtf|print|say
                 |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
                 |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
                 |listen|accept|shutdown|gsockopt|ssockopt|getsockname
                 |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
                 |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
                 |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
                 |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
                 |chown|chroot|unlink|chmod|utime|rename|link|symlink
                 |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
                 |closedir|fork|wait|waitpid|system|exec|kill|getppid
                 |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
                 |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
                 |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
                 |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
                 |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
                 |i_aelem|n_aelem|s_aelem|aelem_u|i_aelem_u|n_aelem_u|s_aelem_u
                 |u_add|u_multiply|u_subtract
                 |fc)\z/x
}

sub pp_enterxssub { goto &pp_entersub; }

# FIXME: go over
# sub pp_entersub {
#     my $self = shift;
#     my($op, $cx) = @_;
#     return $self->e_method($self->_method($op, $cx))
#         unless null $op->first->sibling;
#     my $prefix = "";
#     my $amper = "";
#     my($kid, @exprs);
#     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
# 	$prefix = "do ";
#     } elsif ($op->private & OPpENTERSUB_AMPER) {
# 	$amper = "&";
#     }
#     $kid = $op->first;
#     $kid = $kid->first->sibling; # skip ex-list, pushmark
#     for (; not null $kid->sibling; $kid = $kid->sibling) {
# 	push @exprs, $kid;
#     }
#     my $simple = 0;
#     my $proto = undef;
#     my $lexical;
#     if (is_scope($kid)) {
# 	$amper = "&";
# 	$kid = "{" . $self->deparse($kid, 0) . "}";
#     } elsif ($kid->first->name eq "gv") {
# 	my $gv = $self->gv_or_padgv($kid->first);
# 	my $cv;
# 	if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
# 	 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
# 	    $proto = $cv->PV if $cv->FLAGS & SVf_POK;
# 	}
# 	$simple = 1; # only calls of named functions can be prototyped
# 	$kid = $self->deparse($kid, 24);
# 	my $fq;
# 	# Fully qualify any sub name that conflicts with a lexical.
# 	if ($self->lex_in_scope("&$kid")
# 	 || $self->lex_in_scope("&$kid", 1))
# 	{
# 	    $fq++;
# 	} elsif (!$amper) {
# 	    if ($kid eq 'main::') {
# 		$kid = '::';
# 	    }
# 	    else {
# 	      if ($kid !~ /::/ && $kid ne 'x') {