caller\( results from the CPAN

App-sh2p

   }
   elsif ( $idx =~ /^\D+$/) {       # \D is non-digit
       # Process the lhs
         
       my @tokens = App::sh2p::Parser::tokenise ($idx);
       my @types  = App::sh2p::Parser::identify (1, @tokens); 
 
       iout "\$$arr\[";  
       App::sh2p::Parser::convert (@tokens, @types);
       out "] = ";
   }
   else {
       if ( $idx =~ /^\s*\$/ ) {
           define_idx_var ($idx);
       }
       
       iout "\$$arr\[$idx\] = ";
   }
   
   if ( !defined $rhs ) {
      out 'undef'
   }
   else {
      # Process the rhs
      
      my @tokens = App::sh2p::Parser::tokenise ($rhs);
      my @types  = App::sh2p::Parser::identify (1, @tokens); 
      
      # Avoid recursion
      die "++++ Internal error: Nested array assignment $in" if $types[0] eq 'ARRAY_ASSIGNMENT';
      #print_types_tokens (\@types, \@tokens);
      
      App::sh2p::Parser::convert (@tokens, @types);
   }
   
   out ";\n";
   return $ntok;

}

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

sub Handle_break {

   # Maybe check to see if we are in a heredoc?
   
   # 0.05
   #if (!App::sh2p::Utils::new_line()) {
   #    out "\n";
   #}
   
   return 1;
}

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

sub Handle_open_redirection {
    my ($type, $filename) = @_;
    
    #print STDERR "Handle_open_redirection: <$type> <$filename>\n";
    my @caller = caller();
    #print STDERR "Handle_open_redirection: @caller\n";
    
    out ("\n");
    
    my $var = 'sh2p_handle';
    if (Register_variable($var, '$')) {
       rd_iout "my \$$var;\n";
    }
    
    rd_iout ("open(\$$var,'$type',\"$filename\") or\n");
    rd_iout ("     die \"Unable to open $filename: \$!\";\n");
    
    if ( $type eq '>' || $type eq '>>' ) {
        $g_redirect_filename_w = $filename;
    }
    else {
        $g_redirect_filename_r = $filename;
    }
}

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

sub Handle_close_redirection {
   
    my ($mode) = @_;
    my $filename;
    
    if ($mode eq 'w') {
        $filename = $g_redirect_filename_w;
        $g_redirect_filename_w = undef; 
    }
    else {
        $filename = $g_redirect_filename_r;
        $g_redirect_filename_r = undef; 
    }
    
    if (defined $filename) {
        iout ("close(\$sh2p_handle);\n");
        iout ("undef \$sh2p_handle;\n\n");
    }
    
    return 1;   # In case it gets used as a token
}

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

sub Query_redirection { 
    my ($mode) = @_;
    
    if ($mode eq 'w') {
        return $g_redirect_filename_w;
    }
    else {
        return $g_redirect_filename_r;
    }
}

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

sub Handle_variable {

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

   elsif ( $token =~ s/^\$!(\w+)\[.*\]/\@$1/ ) {    # ksh92 & bash !
        # Find indexes of set variables
        iout "sh2p_array_count($token)";
        store_sh2p_array_count ($token);
        
        return 1;
   }
   elsif ( substr($token, 0, 3) eq '$((' ) {
      # Calculation
      $token =~ s/\$\(\((.*)\)\)/$1/g;
      
   }
   elsif ( substr($token, 0, 2) eq '$(' ) {
      # Back-ticks
            
      $token =~ s/\$\((.*)\)/`$1`/g;
   }
   elsif ( $token =~ /\[(.+)\]/) {
       #print STDERR "Handle_variable array <$1>\n";
       my $idx = $1;
       
       # The shell allows a variable index without a '$'
       if ($idx =~ /^[[:alpha:]_]/)  {  # No '$' [count + 1] or even [i]
          $idx = "\$$idx"; 
          
          $token =~ s/\[(.+)\]/[$idx]/;
       }
       elsif ( $idx eq '*' || $idx eq '@' ) {
           # How do we find if we are quoted?
           $token =~ s/\$(.+)\[.*\]/$1/; 

           if (query_in_quotes()) {
               if ($idx eq '@') {
                   $token = "\"\@$token\"";
               }
               else {
                   my $glue = get_special_var('IFS');
                   $glue =~ s/^([\"\'])(.*)\1$/$2/;   # Not certain there are quotes
                   $glue = substr($glue,0,1);
                   $token = "join(\"$glue\",\@$token)";
               }
           }
           else {
               $token = "\@$token";
           }
       }

   }
      
   out $token;
   
   return 1;
}

############################################################################
sub Handle_expansion {
    my ($token) = @_;
    my $ntok;
    
    #print STDERR "Handle_expansion: <$token>\n";
    #  my @caller = caller();
    #  print STDERR "Called from @caller\n";

    # Strip out the braces
    # $2: (.*?) replaced with (.*) 0.04
    $token =~ s/\$\{(.*?)\}(.*)/\$$1/;
    my $suffix = $2;
            
    # Arrays
    if ($token =~ /\w+\[.*\]/) {
        $ntok = Handle_variable($token);
    }
    elsif ( $token =~ /(\w+)([:?\-=+]{1,2})([^:?\-=+]+)/ ) {
        my $var    = '$'.$1;
        my $qual   = $2;
        my $extras = $3;
        #print STDERR "Handle_expansion <$var><$2><$3>\n";
        
        if (my $new_var = get_special_var($var)) {
    	    $var = $new_var;
        }

        # Remove the : 
        # Done this way in case further modification is required
        $qual =~ s/^://;
   
        if ($qual eq '?') {
            if (! $extras) {
                $extras = "'$var undef or not set'";
            }
            
            # $extras should already be quoted
            out ("print STDERR $extras,\"\\n\" if (! defined $var or ! $var);");
        }
        elsif ($qual eq '=') {
 	    out ("(defined $var or $var) || $var = ");
 	    my @tmp = ($extras);
 	    my @types  = App::sh2p::Parser::identify (1, @tmp);     
 	    App::sh2p::Parser::convert (@tmp, @types);
        }
        elsif ($qual eq '-') {
	    out ("(defined $var or $var) || ");
	    my @tmp = ($extras);
	    my @types  = App::sh2p::Parser::identify (1, @tmp);     
	    App::sh2p::Parser::convert (@tmp, @types);
        }
        elsif ($qual eq '+') {
	    out ("(! defined $var or ! $var) || ");
	    my @tmp = ($extras);
	    my @types  = App::sh2p::Parser::identify (1, @tmp);     
	    App::sh2p::Parser::convert (@tmp, @types);
  	}
        else {
            error_out ("Pattern $qual not currently supported");
            out ($token);
        }
        $ntok = 1;
    }    
    elsif ( $token =~ s/^\$#(.+)/\$$1/ ) {
        out "length($token)";
        $ntok = 1;

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

          &{$perlbi[0]}(@cmd);
          
          if ($rest) {
              unless ($preamble eq $rest && 
                     ($rest eq '"' or $rest eq "'"))
              {
                  out '.';
                  interpolation ($rest);
              }
          }
      }
      else {
          out " $tok ";
      }
   }
   else {
      out " $tok";
      out ' ' unless substr($tok,-1) eq "\n";     # 0.04
   }
   
   return $ntok;
}

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

sub Handle_subshell {

   my ($subshell) = @_;
   
   error_out "Subshell: ($subshell)";
   iout "{\n";
   inc_indent();
   inc_block_level();    # 0.05
   mark_subshell();
   iout "local \%ENV;\n";      # one of the features of a subshell
      
   # Search for different statements
   
   for my $tok (split (';', $subshell)) {
      # should probably be done in sh2p
      my @tokens = App::sh2p::Parser::tokenise ($tok);
      my @types  = App::sh2p::Parser::identify (0, @tokens);
      #print_types_tokens (\@types,\@tokens);
      App::sh2p::Parser::convert (@tokens, @types);
   }
   
   dec_indent();
   dec_block_level();    # 0.05
   unmark_subshell();
   out "}\n";

}

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

sub interpolation {
   my ($string) = @_;
   my $delimiter = '';
   
   #print STDERR "interpolation: <$string>\n";
   #my @caller = caller();
   #print STDERR "@caller\n";
   
   # single quoted string
   if ($string =~ /^(\'.*\')(.*)/) {
       my $single = $1;
       $string = $2;
       
       if ($string) {
           out "$single.";
       }
       else {
           out "$single";
           return;
       }
   }
   
   if ( substr($string,0,1) eq '"') {
       # strip out leading & trailing double quotes
       $string =~ s/^\"(.*)\"$/$1/;
       set_in_quotes();
   }
   
   # Insert leading quote to balance end
   # Why?  Because the string might not be quoted 
   out ('"');           
   
   my @chars = split '', $string;
   
   for (my $i = 0; $i < @chars; $i++) {
   
       if ($chars[$i] eq '\\') {   # esc
           out $chars[$i];
           $i++;
           out $chars[$i];
       }
       elsif ($chars[$i] eq '"' and !query_in_quotes()) {   
           # embedded quote 0.04
           out '\\"';
       }
       elsif ($chars[$i] eq '`') {
           out '".';
           $delimiter = '`';
         
           my $cmd = $chars[$i];
           $i++;
           
           while ($i < @chars) {
               $cmd .= $chars[$i];
               last if ($chars[$i] eq $delimiter);
               $i++;    # Position change January 2009
           }

           Handle_delimiter ($cmd);
           out '."' if $i < (@chars-1);
       }
       elsif ($chars[$i] eq '$') {
           my $token = $chars[$i];
           $i++;

           if ($chars[$i] eq '(') {

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

      }
      else {
         iout "@args $last";
      }
      
      $ntok += @args;      # January 2009
   }
   else {
      my @perlbi;
      my $user_function = 0;
      
      # pipes?
      # This loop replaces the grep below (it was detecting | inside quotes)
      for my $tok (@args) {
          next if $tok =~ /^([\'\"]).*\1$/;
          if ($tok =~ /\|[^\|]/) {    # RE change 0.05
              $ntok = App::sh2p::Parser::analyse_pipeline (@args);
              return $ntok;
          }
      }

      #if ( grep /\|[^\|]/, @args) {    # RE change 0.05
      #    $ntok = App::sh2p::Parser::analyse_pipeline (@args);
      #    return $ntok;
      #}
      
      # shortcuts or break? 0.05
      my @types  = App::sh2p::Parser::identify (1, @args);
      my $i;
      for ($i = 0;$i < @types; $i++) {
          if ($types[$i][0] eq 'OPERATOR') {
              no_semi_colon();
              splice (@args, $i);
              last
          }
          elsif ($types[$i][0] eq 'BREAK') {
              splice (@args, $i);
              last
          }
      }
            
      # Strip quotes January 2009
      my $name = $args[0];
      $name =~ s/^([\"\'])(.*)\1$/$2/;
      #print STDERR "Handle_external: <$name>\n";
      
      # If a user function, then call it as a subroutine
      if (is_user_function($name)) {
         $func = $name;
         shift @args;
         $user_function = 1;
         $ntok++;
      }
      elsif (@perlbi = App::sh2p::Parser::get_perl_builtin($name)) {
         # Do my best to trap unnecessary child processes
         $ntok = &{$perlbi[0]}(@_);
         return $ntok;
      }
      
      if (is_break($args[0])) {
          my @caller = caller();
          print STDERR "@caller\n";
          error_out ("++++ Internal error: Invalid break in Handle_external");
      }
     
      my $append = '';
      $append = ';' if query_semi_colon();
      
      iout "$func (";
                
      # Parse arguments
      if ( $user_function ) {
          
          if (@args) {
          
              for (my $i = 0; $i < @args; $i++) {         
                  $ntok++;
                  # Escape embedded quotes
                  $args[$i] =~ s/\"/\\\"/g;
                  #"help syntax highlighter
                  $args[$i] = "\"$args[$i]\"";
                  $args[$i] .= ',' if $i < $#args;
              } 
              
	      interpolation ("@args");
	  }
      }
      else {
          for my $arg (@args) {           
              $ntok++;
              # Escape embedded quotes
              $arg =~ s/\"/\\\"/g;
              #"help syntax highlighter
          }
                        
	  interpolation ("@args");
      }
      
      # Added 0.03
      if ($func eq 'system') {
          my $context = App::sh2p::Compound::get_context();
          if ($context eq 'if' || $context eq 'while') {
              $append .= '== 0';
          }
          elsif ($context eq 'until') {
              $append .= '!= 0';
          }
      }
      
      out ")$append $last";   # Moved 0.04

      out "\n" if query_semi_colon();
   }
   
   return $ntok;
}

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

sub Handle_Glob {

   my (@tokens) = @_;
   my $ntok = @tokens;
   
   local $" = '';
   iout "(glob(\"@tokens\"))";
   
   return $ntok;
}

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

sub Handle_unknown {   

   my ($token) = @_;

   # Don't quote if numeric or already has quotes
   if ($token =~ /^[-+]?\d+$/ || $token =~ /^\".*\"$/) {
       out "$token";
   }
   else {
       #my @caller = caller();
       #print STDERR "Handle_unknown token: <$token> @caller\n";
       out "\"$token\"";
   }
   
   return 1;
}

############################################################################
sub store_subs {

    my ($name, $subroutine) = @_;
    
    $g_subs{$name} = $subroutine;
    
}

sub write_subs {

    if (%g_subs) {
        out "\n#\n#  Subroutines added by sh2p\n#\n";
    }

    for my $sub (sort keys %g_subs) {
        out $g_subs{$sub};   
    }
}

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

sub store_sh2p_array_count {
    return if exists $g_subs{sh2p_array_count};
    
    $g_subs{sh2p_array_count} = << 'AC_HERE';

############################################################################
# Generated when ${!array[@]} is used
sub sh2p_array_count {
    my @array = @_;
    my $result = '';
    
    for (my $i=0; $i < @array; $i++) {
        $result .= "$i " if defined $array[$i];
    }
    
    # Should return a space separated scalar
    chop $result;   # remove final space
    return $result;
}

AC_HERE
}

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

1;

__END__
=head1 Summary

package App::sh2p::Handlers;

( run in 1.913 second using v1.01-cache-2.11-cpan-97f6503c9c8 )