App-sh2p

 view release on metacpan or  search on metacpan

lib/App/sh2p/Builtins.pm  view on Meta::CPAN

        $signal = shift @rest;
    }
    else {
        $signal = 'TERM';  # default signal
        
        # 0.06 Hack because this is an inserted token and 
        # general_arg_list will include this in its count
        $ntok--;           
    }

    #print STDERR "do_kill: <@rest>\n";

    $ntok += general_arg_list ($cmd, $signal, @rest);
    
    return $ntok;
}

########################################################

sub do_let {

    my ($cmd, @rest) = @_;
    my $ntok = 1;
    
    # Find any comment - this should go first
    if (substr($rest[-1],0,1) eq '#') {
        $ntok++;
        iout $rest[-1];      # Write the comment out
        pop @rest
    }
    
    for my $token (@rest) {
        # strip quotes
	$token =~ s/[\'\"]//g;

        # Get variable name
        $token =~ /^(.*?)=/;
        my $var = "\$$1";
        if (Register_variable($var, int)) {
            iout "my $var;\n";      # 0.05 added leading $
        }
        
        App::sh2p::Compound::arith ($token);
        $ntok++;
    }
    
    return $ntok;
}

########################################################
# Also does for echo
sub do_print {

   my $ntok = 1;
   my ($name, @args) = @_;
   my $newline = 1;
   my $handle = '';

   my $opt_u;
   my %options;
   local @ARGV;

   my $redirection = '';
   my $file        = '';
   my $from_fd     = '';       # TODO - not currently supported
   
   # Move the comment to before the statement
   if ( substr($args[-1],0,1) eq '#' ) {
       my $comment = pop @args;
       out "\n";
       iout $comment;
       $ntok++;
   }
   
   for my $arg (@args) {
       last if is_break($arg) || $arg eq ';';
       my $in_redirection_token = 0;
       
       # This is so a > inside a string is not seen as redirection
       if ($arg =~ /^([\"\']).*?\1/) {
           set_in_quotes();
       }
       
       # This should also strip out the redirection
       if (!query_in_quotes() && $arg =~ s/(\>{1,2})//) {
           
           $ntok++;
           $redirection = $1;
           $in_redirection_token = 1;
           
           if ($ARGV[-1] =~ /\d/) {
	       $from_fd = pop @ARGV;
               error_out ("dup file descriptors ($from_fd>&n) not currently supported");
               $ntok++;
           }
       }
       
       if ($arg && $redirection && (! $file)) {
           $arg =~ s/(\S+)//;
           $file = $1;
           $ntok++ unless $in_redirection_token;
       }
       
       unset_in_quotes();
       push @ARGV, $arg if $arg;
       #$ntok++;    0.05 commented out
   }
   
   if ($redirection) {
       
       #print STDERR "do_print redirection file <$file>\n";
       # January 2009
       if ( $file =~ /^\&(\d+)$/ ) {
           my $fd = $1;
           if ($fd == 1) {
               $handle = 'STDOUT ';
           }
           elsif ($fd == 2) {
               $handle = 'STDERR ';
           }
           else {

lib/App/sh2p/Builtins.pm  view on Meta::CPAN

            $string .= "$tokens[0]";
            
            # append with a space for print/echo
            $string .= ' ' if $i < $#args; 
        }
        elsif ($types[0][0] eq 'OPERATOR') {   # 0.05
            @trailing_tokens = splice (@args, $i);
            last;
        }
        else {
        
            if ($string) {
                App::sh2p::Handlers::interpolation ($string);   
                $string = ' ';  # Add a space between args
                out ',';
            }
        
            App::sh2p::Parser::convert (@tokens, @types); 
            out ',' if $i < $#args; 
        }
        
        $ntok++;    # 0.05 (moved)
    }
       
    if ($string && $string ne ' ') {
       if ($newline) {
          $string .= "\\n"
       }

       App::sh2p::Handlers::interpolation ($string);
    }
    elsif ($newline) {
       out ",\"\\n\""
    }
    
    if (@trailing_tokens) {    # 0.05
        out " ";    # cosmetic
        $ntok += @trailing_tokens;
        my @trailing_types  = App::sh2p::Parser::identify (1, @trailing_tokens);
        App::sh2p::Parser::convert (@trailing_tokens, @trailing_types); 
    }
    else {
        out ";\n";
    }
    
    # An ugly hack, but necessary where the first arg is parenthesised
    fix_print_arg();
    
    App::sh2p::Handlers::Handle_close_redirection('w') if $redirection;

    return $ntok;
    
}   # do_print

########################################################

sub do_read {
   my %args;
   my $prompt = 'undef';
   my $ntok;
   local @ARGV;

   # First argument is 'read'
   shift @_;
   $ntok++;
   
   # Find end of statement
   for my $arg (@_) {   
      last if is_break($arg) || $arg eq ';';   # Inserted in sh2p loop
      push @ARGV, $arg;
      $ntok++;
   }
   
   getopts ('p:rsu:nAa', \%args);
   
   if (exists $args{p} && which_shell() eq 'bash') { 
       # Bash syntax for prompt
       $prompt = $args{p}
   }
   elsif ($ARGV[0] =~ /^(\w*)\?(.*)$/) {   # ksh syntax for prompt
       
      $ARGV[0] = $1 || 'REPLY';    
      $prompt  = $2;
   }   

   # Default variable
   @ARGV = ('REPLY') if ! @ARGV;     

   # Add $ prefix to variable names   
   # Do I need to pre-define them?
   for (my $i = 0; $i < @ARGV; $i++) {

       if (exists $args{a} || exists $args{A}) {
           $ARGV[$i] = "\@$ARGV[$i]";
           if (Register_variable($ARGV[$i], '@')) {
               pre_out "my $ARGV[$i];\n";
           }
       }
       elsif ($ARGV[$i] =~ s/^<//) {
           my $filename;
           if (defined $ARGV[$i] && $ARGV[$i]) {
               $filename = $ARGV[$i];
           }
           else {
               $filename = $ARGV[$i+1];
           }
           pop @ARGV;
           pop @ARGV if $i == $#ARGV;
           
           App::sh2p::Handlers::Handle_open_redirection('<', $filename);
           
       }
       else {
           $ARGV[$i] = "\$$ARGV[$i]";
           if (Register_variable($ARGV[$i], '$')) {
               pre_out "my $ARGV[$i];\n";
           }
       }
   }
   
   if (exists $args{p} && which_shell() eq 'ksh') { 

lib/App/sh2p/Builtins.pm  view on Meta::CPAN


}

########################################################

sub do_shopt {

   my (undef, $switch, @rest) = @_;
   my $ntok = 2;
   my @options;
   
   for my $option (@rest) {
       last if is_break($option) || $option eq ';' || substr($option,0,1) eq '#';
       push @options, $option;
       $ntok++;
   }  
   
   error_out ("Shell option @options being set");
   if ($switch eq '-s') {
       @g_shell_options{@options} = undef;
   }
   elsif ($switch eq '+s') {
       delete @g_shell_options{@options};
   }
   else {
       error_out ("Unrecognised shopt argument: <$switch>");
   }
   
   return $ntok;
   
}

########################################################

sub do_source {

   my (undef, @tokens) = @_;
   my $ntok = 1;
   
   error_out ();
   error_out "sourced file should also be converted";
   
   # Removed enclosing " in 0.06
   iout 'do ';
   
   no_semi_colon(); 
   
   $ntok += App::sh2p::Parser::join_parse_tokens ('.', @tokens);
   
   reset_semi_colon();
   out ';';
   
   return $ntok;
}

########################################################

sub do_touch {
    my    $ntok = @_;
    my    $cmd  = shift;
    local @ARGV = @_;

    my %args;
    getopts ('acdfmr:t', \%args);
    if (keys %args) {
        error_out "$cmd options not currently supported";
    }

    my $text = "# $cmd @_\n";
    
    for my $file (@ARGV) {
        if (substr ($file,0,1) eq '#') {
            iout "$file\n";     # Output comment first         
        }
        
        # Remove surrounding quotes
        $file =~ s/^([\'\"])(.*)\1/$2/;
        
$text .= << "END"
    if (-e \"$file\") {
        # update access and modification times, requires perl 5.8
        utime undef, undef, \"$file\";
    }
    else {
        open(my \$fh,'>',\"$file\") or warn \"$file:\$!\";
    }

END
    }

    iout $text;

    return $ntok;
}

########################################################

sub do_tr {

    my ($cmd, @args) = @_;
    my $ntok = 1;
    my %args;
    
    local @ARGV = @args;
    getopts ('cCsd', \%args);
    if (keys %args) {
        error_out "$cmd options not currently supported";
    }
    
    $ntok = @_ - @ARGV;
    
    return $ntok if !@ARGV;
    
    my $from = shift @ARGV;
    $ntok++;
    
    my $to;
    if (@ARGV) {
        $to = shift @ARGV;
        $ntok++;
    }
    
    # Strip quotes if there are any
    $from =~ s/^\'(.*)\'/$1/g;
    $to   =~ s/^\'(.*)\'/$1/g;
    
    # common case
    if (($from eq '[a-z]' || $from eq '[:lower:]') && 
        ($to   eq '[A-Z]' || $to   eq '[:upper:]')) {
        iout 'uc ';    
    }
    elsif (($from eq '[A-Z]' || $from eq '[:upper:]') && 
           ($to   eq '[a-z]' || $to   eq '[:lower:]')) {
        iout 'lc ';
    }
    else {
        # Convert patterns TODO
        iout "tr/$from/$to/";
    }
    
    return $ntok;
}

########################################################
# typeset [[+-Ulprtux] [-L[n]]  [-R[n]]  [-Z[n]]  [-i[n]]  |  -f  [-tux]]
#         [name[=value] ...]
# Needs more work!
sub do_typeset {
   
   my $ntok = @_;
   my %args;
   
   #print STDERR "do_typeset: $_[0]\n";
   # First argument should be 'typeset' or 'declare'
   shift @_;
   
   local @ARGV = @_;
   
   getopts ('UPRTUXLRZ:iftux', \%args);
   
   my %type = (i => 'int',
               l => 'lc',
               u => 'uc',
               Z => '%0nd',
               L => '%-s',
               R => '%s',
               X => '%X',
               x => '%x');
   
   my $type = '$';
   my @opt = grep {$args{$_}} keys %args;
   
   if (exists $type{$opt[0]}) {
      $type = $type{$opt[0]};
   }

   # These types are not yet supported by other functions
   if (@opt > 1) {
       if ( $args{Z} && defined $args{Z}) {
           $type =~ s/n/$args{Z}/;
       }
       elsif ( $args{f} ) {
           if ($args{u}) {
               $ntok += do_autoload ('typeset -fu',@ARGV);
               $ntok--;   # artificial 1st argument
           }
           return $ntok;
       }
       else {
           error_out "Only one option supported for typedef or declare";
       }
   }

   my $var = $ARGV[0];

   # Remove any assignment for the name
   $var =~ s/=.*//;
   
   if (Register_variable ("\$$var", $type) ) {
          iout 'my ';
   }
   
   #$ntok +=    January 2009 
   App::sh2p::Handlers::Handle_assignment (@ARGV);
   
   return $ntok;
}

########################################################
# Need getopt here, but it can't deal with +
#  set [+-abCefhkmnpsuvxX] [+-o [option]] [+-A name] [--] [arg ...]

sub do_set {
   
   my $ntok = 1;
   
   # First argument is 'set'



( run in 0.237 second using v1.01-cache-2.11-cpan-4d50c553e7e )