tools/perl-5.8.0/lib/site_perl/5.8.0/Psh/Strategy/Perlfunc_heavy.pm

package Psh::Strategy::Perlfunc_heavy;

=item * C<perlfunc_heavy>

Tries to detect perl builtins - this is helpful if you e.g. have
a print command on your system.

=cut

require Psh::Strategy;

use vars qw($builtins $packages $expand_arguments);

$builtins=0;
$packages=1;

@Psh::Strategy::Perlfunc_heavy::ISA=('Psh::Strategy');


sub new { Psh::Strategy::new(@_) }

sub consumes {
        return Psh::Strategy::CONSUME_TOKENS;
}

sub runs_before {
        return qw(perlscript auto_resume executable);
}

#
# TODO: Is there a better way to detect Perl built-in-functions and
# keywords than the following? Surprisingly enough,
# defined(&CORE::abs) does not work, i.e., it returns false.
#
# If a value is anything > 1, then it's the minimum number of
# arguments for that function
#

my %perl_builtins = qw( -X 1 abs 1 accept 1 alarm 1 atan2 1 bind 1
binmode 1 bless 1 caller 1 chdir 1 chmod 3 chomp 1 chop 1 chown 3 chr
1 chroot 1 close 1 closedir 1 connect 3 continue 1 cos 1 crypt 1
dbmclose 1 dbmopen 1 defined 1 delete 1 die 1 do 1 dump 1 each 1
endgrent 1 endhostent 1 endnetent 1 endprotoent 1 endpwent 1
endservent 1 eof 1 eval 1 exec 3 exists 1 exit 1 exp 1 fcntl 1 fileno
1 flock 1 for 1 foreach 1 fork 1 format 1 formline 1 getc 1 getgrent 1
getgrgid 1 getgrnam 1 gethostbyaddr 1 gethostbyname 1 gethostent 1
getlogin 1 getnetbyaddr 1 getnetbyname 1 getnetent 1 getpeername 1
getpgrp 1 getppid 1 getpriority 1 getprotobyname 1 getprotobynumber 1
getprotoent 1 getpwent 1 getpwnam 1 getpwuid 1 getservbyname 1
getservbyport 1 getservent 1 getsockname 1 getsockopt 1 glob 1 gmtime
1 goto 1 grep 3 hex 1 import 1 if 1 int 1 ioctl 1 join 1 keys 1 kill 1
last 1 lc 1 lcfirst 1 length 1 link 1 listen 1 local 1 localtime 1 log
1 lstat 1 m// 1 map 1 mkdir 3 msgctl 1 msgget 1 msgrcv 1 msgsnd 1 my 1
next 1 no 1 oct 1 open 1 opendir 1 ord 1 pack 1 package 1 pipe 1 pop 1
pos 1 print 1 printf 1 prototype 1 push 1 q/STRING/ 1 qq/STRING/ 1
quotemeta 1 qw/STRING/ 1 qx/STRING/ 1 rand 1 read 1 readdir 1 readlink
1 recv 1 redo 1 ref 1 rename 1 require 1 reset 1 return 1 reverse 1
rewinddir 1 rindex 1 rmdir 1 s/// 1 scalar 1 seek 1 seekdir 1 select 1
semctl 1 semget 1 semop 1 send 1 setgrent 1 sethostent 1 setnetent 1
setpgrp 1 setpriority 1 setprotoent 1 setpwent 1 setservent 1
setsockopt 1 shift 1 shmctl 1 shmget 1 shmread 1 shmwrite 1 shutdown 1
sin 1 sleep 1 socket 1 socketpair 1 sort 1 splice 1 split 1 sprintf 1
sqrt 1 srand 1 stat 1 study 1 sub 1 substr 1 symlink 1 syscall 1
sysread 1 system 1 syswrite 1 tell 1 telldir 1 tie 1 time 1 times 1
tr/// 1 truncate 1 uc 1 ucfirst 1 umask 1 undef 1 unless 1 unlink 1
unpack 1 unshift 1 untie 1 until 1 use 1 utime 1 values 1 vec 1 wait 1
waitpid 1 wantarray 1 warn 1 while 1 write 1 y/// 1 );


#
# The following hash contains names where the arguments should never
# undergo expansion in the sense of
# $Psh::perlfunc_expand_arguments. For example, any perl keyword where
# an argument is interpreted literally by Perl anyway (such as "use":
# use $yourpackage; is a syntax error) should be on this
# list. Flow-control keywords should be here too.
#
# TODO: Is this list complete ?
#

%perl_builtins_noexpand = qw( continue 1 do 1 for 1 foreach 1 goto 1 if 1 last 1 local 1 my 1 next 1 package 1 redo 1 sub 1 until 1 use 1 while 1);


sub applies {
        my $firstword = @{$_[2]}->[0];
        my $copy = ${$_[1]};

        my $fnname = $firstword;
        my $parenthesized = 0;
        # catch "join(':',@foo)" here as well:
        if ($firstword =~ m/\(/) {
                $parenthesized = 1;
                $fnname = (split('\(', $firstword))[0];
        }
        my $qPerlFunc = 0;
        if ( $builtins &&
                 exists($perl_builtins{$fnname})) {
                my $needArgs = $perl_builtins{$fnname};
                if ($needArgs > 0
                        and ($parenthesized
                                 or scalar(@{$_[2]}) >= $needArgs)) {
                        $qPerlFunc = 1;
                }
        } elsif( $packages &&
                         $fnname =~ /^([a-zA-Z0-9_]+)\:\:([a-zA-Z0-9_:]+)$/) {
                if( $1 eq 'CORE') {
                        my $needArgs = $perl_builtins{$2};
                        if ($needArgs > 0
                                and ($parenthesized or scalar(@{$_[2]}) >= $needArgs)) {
                                $qPerlFunc = 1;
                        }
                } else {
                        $qPerlFunc = (Psh::PerlEval::protected_eval("defined(&{'$fnname'})"))[0];
                }
        } elsif( $fnname =~ /^[a-zA-Z0-9_]+$/) {
                $qPerlFunc = (Psh::PerlEval::protected_eval("defined(&{'$fnname'})"))[0];
        }
        if ( $qPerlFunc ) {

                #
                # remove braces containing no whitespace
                # and at least one comma in checking,
                # since they might be for brace expansion
                #

                $copy =~ s/{\S*,\S*}//g;

                if (!$expand_arguments
                        or exists($perl_builtins_noexpand{$fnname}) or
                        ($Psh::current_options and
                         $Psh::current_options->{noexpand}) or
                        or $fnname ne $firstword
                        or $copy =~ m/[(){},]/) {
                        return ${$_[1]};
                } else {                     # no parens, braces, or commas, so  do expansion
                        my $ampersand = '';
                        my $lastword  = pop @{$_[2]};

                        if ($lastword eq '&') { $ampersand = '&';         }
                        else                  { push @{$_[2]}, $lastword; }

                        shift @{$_[2]};          # OK to destroy command line since we matched

                        #
                        # No need to do variable expansion, because the whole thing
                        # will be evaluated later.
                        #
                        my @args;
                        if (!$Psh::current_options and
                            !$Psh::current_options->{noglob}) {
                                @args = Psh::Parser::glob_expansion($_[2]);

                                #
                                # But we will quote barewords, expressions involving
                                # $variables, filenames, and the like:
                                #

                                foreach (@args) {
                                        if (&Psh::Parser::needs_double_quotes($_)) {
                                                $_ = "\"$_\"";
                                        }
                                }
                        } else {
                                @args= @{$_[2]};
                        }

                        my $possible_proto = '';

                        if (defined($perl_builtins{$fnname})) {
                                $possible_proto = prototype("CORE::$fnname");
                        } else {
                                $possible_proto = prototype($fnname);
                        }

                        #
                        # TODO: Can we use the prototype more fully here?
                        #
                        my $command = '';

                        if (defined($possible_proto) and $possible_proto ne '@') {
                                #
                                # if it's not just a list operator, better not put in
                                # parens, because they could change the semantics
                                #
                                $command = "$fnname " . join(",",@args);
                        } else {
                                #
                                # Otherwise put in the parens to avoid any ambiguity: we
                                # want to pass the given list of args to the function. It
                                # would be better in perlfunc eval to get a reference to
                                # the function and simply pass the args to it, but I
                                # couldn't find any way to make that work with perl
                                # builtins. You can't take a reference to CODE::sort, for
                                # example.
                                #
                                $command .= "$fnname(" . join(",",@args) . ')';
                        }

                        return $command . $ampersand;                   }
        }

        return '';
}

sub execute {
        $_[4]=undef;
        return Psh::Strategy::Eval(@_);
}

1;