view release on metacpan or  search on metacpan

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

         }
         elsif ($char eq '>' && !$comment) {
           if (defined $tokens[$index] && $tokens[$index] ne '>') {          # Append? 
              $index++ if defined $tokens[$index];
              $tokens[$index] .= $char;
           }
           else {
              $tokens[$index] .= $char;
              $index++;
           }
         }
         else {
            $tokens[$index] .= $char;
         }
      }
      else {
         $tokens[$index] .= $char;
      }
   }
   
   $tokens[$index] .= "\n" if $comment;
   
   return @tokens
}

###########################################################
# First argument is used to identify external program calls
#   nested = 0 - call is not nested, first argument may be an external program
#   nested = 1 - call is not nested, first argument is not an external program
#   nested = 2 - as 1, plus call is as a list

sub identify {
   my ($nested, @in) = @_;
   my @out;
   my $first = $in[0];
   
   if (!@in) {
       print STDERR "+++ Internal error: Empty input array to identify\n";
       my @caller = caller();
       die "@caller\n";
   }
   
   #print STDERR "identify first <$first>\n";
   # Special processing for the first token
   
   if ($first =~ /^\w+\+?=/) {
      $out[0] = [('ASSIGNMENT', 
                 \&App::sh2p::Handlers::Handle_assignment)];
      shift @in
   }
   elsif ($first =~ /^\w+\[.*\]=/) {
      $out[0] = [('ARRAY_ASSIGNMENT', 
                 \&App::sh2p::Handlers::Handle_array_assignment)];
      shift @in
   }
   elsif (is_break($first)) {
      $out[0] = [('BREAK', 
                 \&App::sh2p::Handlers::Handle_break)];
      shift @in
   }
   elsif (!$nested && $first =~ /^([\"]?)\$[A-Z0-9#@*{}\[\]]+\1/i) {   # Optional " added January 2009
       # Not a variable, but a call (variable contains call name)
       $out[0] = [('EXTERNAL',
                  \&App::sh2p::Handlers::Handle_external)];
       shift @in;
   }

   # Now process the rest
   
   for my $token (@in) {
   
      #print STDERR "Identify token: <$token> <$nested>\n";
   
      my $type = 'UNKNOWN';
      my $sub  = \&App::sh2p::Handlers::Handle_unknown;

      if (ref($token) eq 'CODE') {
         $sub  = $token;
         $type = 'INTERNAL';      
      }
      elsif ($token =~ /^\w+=/) {
         $sub  = \&App::sh2p::Handlers::Handle_assignment;
         $type = 'ASSIGNMENT';
      }
      elsif ($token =~ /^\w+\[.*\]=/) {
          $sub  = \&App::sh2p::Handlers::Handle_array_assignment;
          $type = 'ARRAY_ASSIGNMENT';
      }
      elsif (exists $icompound{$token}) {
         $sub  = $icompound{$token};
         $type = 'COMPOUND';
      }
      elsif (exists $ioperator{$token} && $nested < 2) {
         $sub  = $ioperator{$token};
         $type = 'OPERATOR';
         # Shortcut, next is another command
      }
      elsif (exists $ibuiltins{$token} && $nested < 2) {
         $sub  = $ibuiltins{$token};
         $type = 'BUILTIN'
      }
      elsif (exists $perl_builtins{$token} && $nested < 2) {
         $sub  = $perl_builtins{$token}[0];
         $type = 'PERL_BUILTIN'
      }      
      else {
         my $first_char  = '';
         my $two_chars   = '';
         my $three_chars = '';
         
         $first_char  = substr($token, 0, 1);
         $two_chars   = substr($token, 0, 2) if length($token) > 1;
         $three_chars = substr($token, 0, 3) if length($token) > 2;
                  
         if (exists $idelimiter{$three_chars}) {
            $type = 'THREE_CHAR_DELIMITER';
            $sub  = $idelimiter{$three_chars};        
         }
         elsif (exists $idelimiter{$two_chars}) {
            # Special hack for variables
            if ( $two_chars eq '${' && (!@out || ($out[-1]->[0] eq 'BREAK')) && 
	    	  !$nested && !is_break($first_char)) {   # Must be first token
	        $type = 'EXTERNAL';
	    	$sub = \&App::sh2p::Handlers::Handle_external;
	    }
	    else {
                $type = 'TWO_CHAR_DELIMITER';
                $sub  = $idelimiter{$two_chars};
            }
         }
         elsif (exists $idelimiter{$first_char}) {   # January 2009
            if ( $first_char eq '"' && (!@out || ($out[-1]->[0] eq 'BREAK')) && 
	    	  !$nested && !is_break($first_char)) {   # Must be first token
	        $type = 'EXTERNAL';
	    	$sub = \&App::sh2p::Handlers::Handle_external;
	    }
	    else {
                $type = 'SINGLE_DELIMITER';
                $sub  = $idelimiter{$first_char};
            }
         }
         elsif ($first_char eq '~') {
            $type = 'GLOB';
            $sub  = \&App::sh2p::Handlers::Handle_Glob;
         }
         elsif ( (!@out || ($out[-1]->[0] eq 'BREAK')) && 
                  !$nested && !is_break($first_char)) {   # Must be first token
            $type = 'EXTERNAL';
            $sub = \&App::sh2p::Handlers::Handle_external;
         }
         # January 2009 This test must come after the 'EXTERNAL' test, 
         # otherwise a bare variable is not seen as an external call
         elsif ($first_char eq '$' && $token =~ /^\$[A-Z0-9\#\@\*\?\{\}\[\]]+$/i) {        
            $type = 'VARIABLE';
            $sub  = \&App::sh2p::Handlers::Handle_variable
         }
         elsif (is_break($token)) {      # 0.06
            $type = 'BREAK';
            $sub = \&App::sh2p::Handlers::Handle_break;
         }
         elsif (exists $ioperator{$two_chars} && $nested) {
	    $sub  = $ioperator{$two_chars};
	    $type = 'OPERATOR'
	 }
         elsif (exists $ioperator{$first_char} && $nested) {
            $sub  = $ioperator{$first_char};
            $type = 'OPERATOR'
         }
         elsif ($token =~ /\[|\*|\?/ && !query_in_quotes()) {
            # No globbing inside quotes
	    $sub  = \&App::sh2p::Handlers::Handle_Glob;
	    $type = 'GLOB';
	 }

      }
      push @out, [($type, $sub)];
   }
   
   return @out;
   
}

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

sub convert (\@\@) {
   my ($rtok, $rtype) = @_;  
   
   if ( $DEBUG ) {
      my @caller = caller();
      print STDERR "\nconvert called from @caller\n";
      local $" = '|';
      print STDERR "convert:@$rtok\nconvert: ";
      print STDERR (map {"$_->[0] "} @$rtype),"\n";
   }

   if (@$rtok != @$rtype ) {
      print STDERR "+++ Internal Error rtok: <@$rtok>, rtype: <@$rtype>\n";
      die "Parser::convert: token and type arrays uneven\n"
   }
   
   pop @$rtok if (is_break($rtok->[-1]));
   my $tokens_processed = 0;
   
   #print_types_tokens ($rtype, $rtok);
   
   while (@$rtok) {
    
      my $type = $rtype->[0][0];
      my $sub  = $rtype->[0][1];
      
      #print STDERR "tokens: <@$rtok> type: $type, sub: $sub\n";
      if (ref($sub) eq 'CODE' ) {