File Coverage

blib/lib/App/sh2p/Handlers.pm
Criterion Covered Total %
statement 12 500 2.4
branch 0 264 0.0
condition 0 42 0.0
subroutine 4 24 16.6
pod 0 20 0.0
total 16 850 1.8


line stmt bran cond sub pod time code
1             package App::sh2p::Handlers;
2              
3 1     1   5 use strict;
  1         3  
  1         27  
4              
5 1     1   562 use App::sh2p::Parser;
  1         2  
  1         19  
6 1     1   4 use App::sh2p::Utils;
  1         2  
  1         215  
7 1     1   494 use App::sh2p::Here;
  1         2  
  1         7223  
8              
9             our $VERSION = '0.06';
10             sub App::sh2p::Parser::convert(\@\@);
11              
12             my $g_unterminated_backtick = 0;
13             my $g_redirect_filename_w;
14             my $g_redirect_filename_r;
15             my %g_subs;
16              
17             # For use by App::sh2p only
18             ############################################################################
19              
20             sub Handle_assignment {
21            
22 0     0 0   my $ntok = 1;
23 0           my ($in, @rest) = @_;
24            
25             #print STDERR "Handle_assignment: <$in>\n";
26            
27 0           $in =~ /^(\w+)(\+?=?)(.*)$/;
28 0           my $lhs = $1;
29 0           my $sign = $2;
30 0           my $rhs = $3;
31            
32 0           my $special_var = get_special_var($lhs,0); # January 2009
33            
34 0 0         if (defined $special_var) {
35 0           set_special_var ($lhs, $rhs);
36 0 0         if ($special_var =~ s/^\$//) {
37 0           $lhs = $special_var; # Converted special variable
38             }
39             else {
40 0           $special_var = undef;
41             }
42             }
43              
44             # Bash 3.0, ksh93 array initialisation
45 0 0         if (substr($rhs,0,1) eq '(') {
46 0           return Handle_list_assign($lhs, $sign, $rhs, @rest);
47             }
48              
49 0           my $name = "\$$lhs";
50            
51 0 0 0       if (!defined $special_var && Register_variable ($name) ) {
52 0           iout "my $name";
53             }
54             else {
55 0           iout "$name";
56             }
57            
58 0 0         if ( ! defined $rhs ) {
59 0           out ';';
60 0 0         if ($ntok == @_) {
61 0           out "\n";
62             }
63            
64 0           return $ntok;
65             }
66             else {
67 0           out ' = ';
68             }
69            
70 0           my $isa_int = 0;
71 0 0         if (get_variable_type($name) eq 'int') {
72 0           $isa_int = 1;
73             }
74            
75 0 0         if ( $rhs eq '' ) {
    0          
76 0 0         if ($isa_int) {
77 0           out 0
78             }
79             else {
80 0           out '""'
81             }
82             }
83             elsif ($rhs =~ /^\d+$/) {
84 0           out $rhs
85             }
86             else {
87             # Process the rhs
88            
89 0 0         if ($isa_int) {
90 0           out "int(";
91             }
92            
93 0           for my $tok (@rest) {
94 0 0 0       last if substr($tok,0,1) eq '#' || is_break($tok);
95 0           $rhs .= "$tok ";
96 0           $ntok++;
97             }
98            
99 0           no_semi_colon();
100 0           my @tokens = App::sh2p::Parser::tokenise ($rhs);
101 0           my @types = App::sh2p::Parser::identify (1, @tokens);
102            
103             #print_types_tokens (\@types, \@tokens);
104            
105             # Avoid recursion
106 0 0         die "Nested assignment $in" if $types[0] eq 'ASSIGNMENT';
107            
108 0           App::sh2p::Parser::convert (@tokens, @types);
109 0           reset_semi_colon();
110            
111 0 0         if ($isa_int) {
112 0           out ")";
113             }
114             }
115            
116 0           out ';';
117             #if ($ntok == @_) { 0.05 (regression OK)
118 0           out "\n";
119             #}
120            
121 0           return $ntok;
122             }
123              
124             ############################################################################
125             # Bash 3.0, ksh93 array initialisation (inc. += )
126             sub Handle_list_assign {
127 0     0 0   my ($lhs, $sign, $rhs, @rest) = @_;
128 0           my $ntok = 1;
129 0           my $name = "\@$lhs";
130 0           my $new = 0;
131 0           my $start_index = 0;
132            
133 0 0         if (Register_variable ($name, '@')) {
134 0           $new = 1;
135 0           iout "my $name";
136             }
137            
138             # Process the rhs
139             #print STDERR "Handle_list_assign: <$lhs> <$sign> <$rhs> <@rest>\n";
140 0           $rhs =~ s/^\((.*)\)$/$1/; # strip out the ()
141            
142 0           my @elements = split (/\s+/, $rhs);
143 0           my @initial;
144            
145             # Get first set of elements without [] (might be all, or none)
146 0           while (@elements) {
147 0 0         last if ($elements[0] =~ /^\s*\[\d+\]=/);
148              
149 0           push @initial,(shift @elements);
150             }
151            
152 0 0         if (@initial) {
153            
154 0 0         if ($sign eq '+=') {
155 0 0         if ($new) {
156 0           out ";\n";
157             }
158            
159 0           iout "push $name,(";
160             }
161             else {
162 0 0         if (!$new) {
163 0           iout "$name";
164             }
165 0           out ' = (';
166             }
167              
168 0           App::sh2p::Parser::join_parse_tokens (',', @initial);
169 0           out ");\n";
170             }
171             else {
172 0           out ";\n";
173             }
174            
175             # indexed elements
176             # Start the index at the end of the initial array
177             # Is this a problem with += ??
178 0           my $index = @initial;
179            
180 0           for (my $i = 0; $i < @elements; $i++) {
181            
182 0           my $rhs;
183 0 0         if ($elements[$i] =~ /^\s*\[(\d+)\]=(.*)/) {
184 0           $index = $1;
185 0           $rhs = $2;
186             }
187             else {
188 0           $index++;
189 0           $rhs = $elements[$i];
190             }
191            
192 0           iout "\$$lhs\[$index\] = ";
193 0           my @tokens = ($rhs);
194 0           my @types = App::sh2p::Parser::identify (1, @tokens);
195 0           App::sh2p::Parser::convert (@tokens, @types);
196 0           out ";\n"
197             }
198            
199             # No processing of @rest
200            
201 0           return 1;
202             }
203              
204             ############################################################################
205              
206             sub define_idx_var {
207              
208 0     0 0   my $var = shift;
209            
210 0           $var =~ s/^\$//; # remove leading $, if any
211            
212 0           $var =~ s/\s*[\+\-\*\/]?\s*\d+\s*//; # remove arithmetic
213            
214 0 0         if (Register_variable ($var, '$') ) {
215 0           iout "my \$$var;\n";
216             }
217             }
218              
219             sub Handle_array_assignment {
220 0     0 0   my $ntok = @_;
221 0           my $in = shift;
222            
223 0           $in =~ /^(\w+)\[(.*)\]=(.*)$/;
224            
225 0           my $arr = $1;
226 0           my $idx = $2;
227 0           my $rhs = $3;
228            
229             #print STDERR "Handle_array_assignment: <$arr> <$idx> <$rhs>\n";
230            
231 0 0         if ( !defined $rhs) {
232 0           die "++++ Internal error No rhs in array assignment. <$in>"
233             }
234            
235 0 0         if (Register_variable ("\@$arr", '@') ) {
236 0           iout "my \@$arr;\n";
237             }
238              
239             # The shell allows a variable index without a '$'
240 0 0         if ($idx =~ /^[[:alpha:]_]/) { # No '$' [count + 1], or [i] ([1 + count] is illegal)
    0          
241            
242 0           define_idx_var ($idx);
243            
244 0           iout "\$$arr\[\$$idx\] = ";
245             }
246             elsif ( $idx =~ /^\D+$/) { # \D is non-digit
247             # Process the lhs
248            
249 0           my @tokens = App::sh2p::Parser::tokenise ($idx);
250 0           my @types = App::sh2p::Parser::identify (1, @tokens);
251            
252 0           iout "\$$arr\[";
253 0           App::sh2p::Parser::convert (@tokens, @types);
254 0           out "] = ";
255             }
256             else {
257 0 0         if ( $idx =~ /^\s*\$/ ) {
258 0           define_idx_var ($idx);
259             }
260            
261 0           iout "\$$arr\[$idx\] = ";
262             }
263            
264 0 0         if ( !defined $rhs ) {
265 0           out 'undef'
266             }
267             else {
268             # Process the rhs
269            
270 0           my @tokens = App::sh2p::Parser::tokenise ($rhs);
271 0           my @types = App::sh2p::Parser::identify (1, @tokens);
272            
273             # Avoid recursion
274 0 0         die "++++ Internal error: Nested array assignment $in" if $types[0] eq 'ARRAY_ASSIGNMENT';
275             #print_types_tokens (\@types, \@tokens);
276            
277 0           App::sh2p::Parser::convert (@tokens, @types);
278             }
279            
280 0           out ";\n";
281 0           return $ntok;
282              
283             }
284              
285             ############################################################################
286              
287             sub Handle_break {
288              
289             # Maybe check to see if we are in a heredoc?
290            
291             # 0.05
292             #if (!App::sh2p::Utils::new_line()) {
293             # out "\n";
294             #}
295            
296 0     0 0   return 1;
297             }
298              
299             ############################################################################
300              
301             sub Handle_open_redirection {
302 0     0 0   my ($type, $filename) = @_;
303            
304             #print STDERR "Handle_open_redirection: <$type> <$filename>\n";
305 0           my @caller = caller();
306             #print STDERR "Handle_open_redirection: @caller\n";
307            
308 0           out ("\n");
309            
310 0           my $var = 'sh2p_handle';
311 0 0         if (Register_variable($var, '$')) {
312 0           rd_iout "my \$$var;\n";
313             }
314            
315 0           rd_iout ("open(\$$var,'$type',\"$filename\") or\n");
316 0           rd_iout (" die \"Unable to open $filename: \$!\";\n");
317            
318 0 0 0       if ( $type eq '>' || $type eq '>>' ) {
319 0           $g_redirect_filename_w = $filename;
320             }
321             else {
322 0           $g_redirect_filename_r = $filename;
323             }
324             }
325              
326             ############################################################################
327              
328             sub Handle_close_redirection {
329            
330 0     0 0   my ($mode) = @_;
331 0           my $filename;
332            
333 0 0         if ($mode eq 'w') {
334 0           $filename = $g_redirect_filename_w;
335 0           $g_redirect_filename_w = undef;
336             }
337             else {
338 0           $filename = $g_redirect_filename_r;
339 0           $g_redirect_filename_r = undef;
340             }
341            
342 0 0         if (defined $filename) {
343 0           iout ("close(\$sh2p_handle);\n");
344 0           iout ("undef \$sh2p_handle;\n\n");
345             }
346            
347 0           return 1; # In case it gets used as a token
348             }
349              
350             ############################################################################
351              
352             sub Query_redirection {
353 0     0 0   my ($mode) = @_;
354            
355 0 0         if ($mode eq 'w') {
356 0           return $g_redirect_filename_w;
357             }
358             else {
359 0           return $g_redirect_filename_r;
360             }
361             }
362              
363             ############################################################################
364              
365             sub Handle_variable {
366 0     0 0   my ($token, $join) = @_;
367 0           my $new_token;
368            
369             #print STDERR "Handle_variable: <$token> ".query_in_quotes()." context: <".
370             # App::sh2p::Compound::get_context().">\n";
371            
372             # Check for specials
373 0 0         if ($new_token = get_special_var($token)) {
    0          
    0          
    0          
    0          
    0          
374 0           $token = $new_token;
375             }
376             elsif ( $token =~ s/^\$#(\w+)(.*)/\$$1/ ) { # length
377 0           my $suffix = $2;
378 0 0         if ( $suffix =~ /\[\s*[\*\@]\s*\]/ ) { # [*] or [@]
379 0           $token =~ s/^\$/\@/;
380 0           out "scalar($token)";
381             }
382             else {
383 0           out "length($token)";
384             }
385 0           return 1;
386             }
387             elsif ( $token =~ s/^\$!(\w+)\[.*\]/\@$1/ ) { # ksh92 & bash !
388             # Find indexes of set variables
389 0           iout "sh2p_array_count($token)";
390 0           store_sh2p_array_count ($token);
391            
392 0           return 1;
393             }
394             elsif ( substr($token, 0, 3) eq '$((' ) {
395             # Calculation
396 0           $token =~ s/\$\(\((.*)\)\)/$1/g;
397            
398             }
399             elsif ( substr($token, 0, 2) eq '$(' ) {
400             # Back-ticks
401            
402 0           $token =~ s/\$\((.*)\)/`$1`/g;
403             }
404             elsif ( $token =~ /\[(.+)\]/) {
405             #print STDERR "Handle_variable array <$1>\n";
406 0           my $idx = $1;
407            
408             # The shell allows a variable index without a '$'
409 0 0 0       if ($idx =~ /^[[:alpha:]_]/) { # No '$' [count + 1] or even [i]
    0          
410 0           $idx = "\$$idx";
411            
412 0           $token =~ s/\[(.+)\]/[$idx]/;
413             }
414             elsif ( $idx eq '*' || $idx eq '@' ) {
415             # How do we find if we are quoted?
416 0           $token =~ s/\$(.+)\[.*\]/$1/;
417              
418 0 0         if (query_in_quotes()) {
419 0 0         if ($idx eq '@') {
420 0           $token = "\"\@$token\"";
421             }
422             else {
423 0           my $glue = get_special_var('IFS');
424 0           $glue =~ s/^([\"\'])(.*)\1$/$2/; # Not certain there are quotes
425 0           $glue = substr($glue,0,1);
426 0           $token = "join(\"$glue\",\@$token)";
427             }
428             }
429             else {
430 0           $token = "\@$token";
431             }
432             }
433              
434             }
435            
436 0           out $token;
437            
438 0           return 1;
439             }
440              
441             ############################################################################
442             sub Handle_expansion {
443 0     0 0   my ($token) = @_;
444 0           my $ntok;
445            
446             #print STDERR "Handle_expansion: <$token>\n";
447             # my @caller = caller();
448             # print STDERR "Called from @caller\n";
449              
450             # Strip out the braces
451             # $2: (.*?) replaced with (.*) 0.04
452 0           $token =~ s/\$\{(.*?)\}(.*)/\$$1/;
453 0           my $suffix = $2;
454            
455             # Arrays
456 0 0         if ($token =~ /\w+\[.*\]/) {
    0          
    0          
    0          
457 0           $ntok = Handle_variable($token);
458             }
459             elsif ( $token =~ /(\w+)([:?\-=+]{1,2})([^:?\-=+]+)/ ) {
460 0           my $var = '$'.$1;
461 0           my $qual = $2;
462 0           my $extras = $3;
463             #print STDERR "Handle_expansion <$var><$2><$3>\n";
464            
465 0 0         if (my $new_var = get_special_var($var)) {
466 0           $var = $new_var;
467             }
468              
469             # Remove the :
470             # Done this way in case further modification is required
471 0           $qual =~ s/^://;
472            
473 0 0         if ($qual eq '?') {
    0          
    0          
    0          
474 0 0         if (! $extras) {
475 0           $extras = "'$var undef or not set'";
476             }
477            
478             # $extras should already be quoted
479 0           out ("print STDERR $extras,\"\\n\" if (! defined $var or ! $var);");
480             }
481             elsif ($qual eq '=') {
482 0           out ("(defined $var or $var) || $var = ");
483 0           my @tmp = ($extras);
484 0           my @types = App::sh2p::Parser::identify (1, @tmp);
485 0           App::sh2p::Parser::convert (@tmp, @types);
486             }
487             elsif ($qual eq '-') {
488 0           out ("(defined $var or $var) || ");
489 0           my @tmp = ($extras);
490 0           my @types = App::sh2p::Parser::identify (1, @tmp);
491 0           App::sh2p::Parser::convert (@tmp, @types);
492             }
493             elsif ($qual eq '+') {
494 0           out ("(! defined $var or ! $var) || ");
495 0           my @tmp = ($extras);
496 0           my @types = App::sh2p::Parser::identify (1, @tmp);
497 0           App::sh2p::Parser::convert (@tmp, @types);
498             }
499             else {
500 0           error_out ("Pattern $qual not currently supported");
501 0           out ($token);
502             }
503 0           $ntok = 1;
504             }
505             elsif ( $token =~ s/^\$#(.+)/\$$1/ ) {
506 0           out "length($token)";
507 0           $ntok = 1;
508             }
509             elsif ($token =~ /^(\$\w+)([%#]{1,2})(.*)/) {
510 0           my $var = $1;
511 0           my $mod = $2;
512 0           my $pattern = $3;
513             #print STDERR "Handle_expansion <$var><$2><$3>\n";
514            
515 0 0         if (my $new_var = get_special_var($var)) {
516 0           $var = $new_var;
517             }
518            
519 0 0         if ($mod eq '#') { # delete the shortest on the left
    0          
520 0           $pattern = App::sh2p::Compound::glob2pat($pattern,1,1);
521 0           out "($var =~ /^(?:$pattern)+?(.*)/)[0]";
522             }
523             elsif ($mod eq '##') { # delete the longest on the left
524 0           $pattern = App::sh2p::Compound::glob2pat($pattern,1,0);
525 0           out "($var =~ /^(?:$pattern)+(.*)/)[0]";
526             }
527 0 0         if ($mod eq '%') { # delete the shortest on the right
    0          
528 0           $pattern = App::sh2p::Compound::glob2pat($pattern,1,1);
529 0           out "($var =~ /^(.*)(?:$pattern)+?\$/)[0]";
530             }
531             elsif ($mod eq '%%') { # delete the longest on the right
532 0           $pattern = App::sh2p::Compound::glob2pat($pattern,1,0);
533 0           out "($var =~ /^(.*?)$pattern\$/)[0]";
534             }
535            
536 0           $ntok = 1;
537             }
538             else {
539 0           $ntok = Handle_variable($token);
540             }
541            
542 0 0         if ($suffix) {
543 0           out '.';
544 0           my @tokens = App::sh2p::Parser::tokenise ($suffix);
545 0           my @types = App::sh2p::Parser::identify (1, @tokens);
546            
547 0           App::sh2p::Handlers::no_semi_colon();
548 0           App::sh2p::Parser::convert (@tokens, @types);
549 0           App::sh2p::Handlers::reset_semi_colon();
550             }
551            
552             # Suffix was in the same token
553 0           return $ntok;
554             }
555              
556             ############################################################################
557              
558             sub Handle_delimiter {
559              
560 0     0 0   my $ntok = 1;
561 0           my ($tok) = @_;
562            
563             #print STDERR "Handle_delimiter: <$tok>\n";
564            
565 0 0 0       if ($tok =~ /^\(\((.+)=(.+)\)\)$/) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
566 0           my $lhs = $1;
567 0           my $rhs = $2;
568             # Could be compound assignment (like +=)
569 0           out "\$$lhs= $rhs;\n";
570             }
571             elsif (substr($tok,0,1) eq '"') {
572             # Special case for an empty string January 2009
573 0 0         if ($tok eq '""') {
574 0           out $tok;
575             }
576             else {
577 0           interpolation($tok);
578             }
579             }
580             elsif (substr($tok,0,1) eq "'") {
581 0           out $tok;
582             }
583             elsif ($tok =~ s/^\((.+)\)/$1/) { # subshell
584 0           Handle_subshell ($tok);
585             }
586             elsif ($tok eq ')' && $g_unterminated_backtick) {
587 0           out '`';
588 0           $g_unterminated_backtick = 0;
589 0           dec_indent();
590             }
591             elsif ($tok eq ';') {
592 0           out "\n";
593             }
594             elsif ( $tok =~ /\|[^\|]/) { # RE change 0.05
595 0           shift @_;
596 0           out $tok;
597 0 0         if ( @_ ) {
598 0           $ntok += App::sh2p::Parser::analyse_pipeline (@_);
599             }
600             }
601             elsif ($tok =~ /^#/ && App::sh2p::Utils::new_line()) {
602 0           out $tok;
603             }
604             elsif ($tok =~ /^(.*)\`\s*(.*)\s*\`(.*)/ && substr($tok,0,1) ne '"') {
605 0           my $preamble = $1; # Added January 2009
606 0           my $cmd = $2;
607 0           my $rest = $3;
608 0           my @cmd = split (/\s+/, $cmd);
609 0           my @perlbi;
610              
611 0 0         if (@perlbi = App::sh2p::Parser::get_perl_builtin($cmd[0])) {
612             # print STDERR "Handle_delimiter2: <@cmd> <$rest>\n";
613             # Do my best to trap unnecessary child processes
614 0 0         out "\n" if query_semi_colon(); # For tidy messages
615             #&{$perlbi[0]}(@cmd,$rest);
616 0           &{$perlbi[0]}(@cmd);
  0            
617            
618 0 0         if ($rest) {
619 0 0 0       unless ($preamble eq $rest &&
      0        
620             ($rest eq '"' or $rest eq "'"))
621             {
622 0           out '.';
623 0           interpolation ($rest);
624             }
625             }
626             }
627             else {
628 0           out " $tok ";
629             }
630             }
631             else {
632 0           out " $tok";
633 0 0         out ' ' unless substr($tok,-1) eq "\n"; # 0.04
634             }
635            
636 0           return $ntok;
637             }
638              
639             ############################################################################
640              
641             sub Handle_subshell {
642              
643 0     0 0   my ($subshell) = @_;
644            
645 0           error_out "Subshell: ($subshell)";
646 0           iout "{\n";
647 0           inc_indent();
648 0           inc_block_level(); # 0.05
649 0           mark_subshell();
650 0           iout "local \%ENV;\n"; # one of the features of a subshell
651            
652             # Search for different statements
653            
654 0           for my $tok (split (';', $subshell)) {
655             # should probably be done in sh2p
656 0           my @tokens = App::sh2p::Parser::tokenise ($tok);
657 0           my @types = App::sh2p::Parser::identify (0, @tokens);
658             #print_types_tokens (\@types,\@tokens);
659 0           App::sh2p::Parser::convert (@tokens, @types);
660             }
661            
662 0           dec_indent();
663 0           dec_block_level(); # 0.05
664 0           unmark_subshell();
665 0           out "}\n";
666              
667             }
668              
669             ############################################################################
670              
671             sub interpolation {
672 0     0 0   my ($string) = @_;
673 0           my $delimiter = '';
674            
675             #print STDERR "interpolation: <$string>\n";
676             #my @caller = caller();
677             #print STDERR "@caller\n";
678            
679             # single quoted string
680 0 0         if ($string =~ /^(\'.*\')(.*)/) {
681 0           my $single = $1;
682 0           $string = $2;
683            
684 0 0         if ($string) {
685 0           out "$single.";
686             }
687             else {
688 0           out "$single";
689 0           return;
690             }
691             }
692            
693 0 0         if ( substr($string,0,1) eq '"') {
694             # strip out leading & trailing double quotes
695 0           $string =~ s/^\"(.*)\"$/$1/;
696 0           set_in_quotes();
697             }
698            
699             # Insert leading quote to balance end
700             # Why? Because the string might not be quoted
701 0           out ('"');
702            
703 0           my @chars = split '', $string;
704            
705 0           for (my $i = 0; $i < @chars; $i++) {
706            
707 0 0 0       if ($chars[$i] eq '\\') { # esc
    0          
    0          
    0          
708 0           out $chars[$i];
709 0           $i++;
710 0           out $chars[$i];
711             }
712             elsif ($chars[$i] eq '"' and !query_in_quotes()) {
713             # embedded quote 0.04
714 0           out '\\"';
715             }
716             elsif ($chars[$i] eq '`') {
717 0           out '".';
718 0           $delimiter = '`';
719            
720 0           my $cmd = $chars[$i];
721 0           $i++;
722            
723 0           while ($i < @chars) {
724 0           $cmd .= $chars[$i];
725 0 0         last if ($chars[$i] eq $delimiter);
726 0           $i++; # Position change January 2009
727             }
728              
729 0           Handle_delimiter ($cmd);
730 0 0         out '."' if $i < (@chars-1);
731             }
732             elsif ($chars[$i] eq '$') {
733 0           my $token = $chars[$i];
734 0           $i++;
735              
736 0 0         if ($chars[$i] eq '(') {
    0          
737 0           out '".';
738 0           $delimiter = ')';
739 0           while ($i < @chars) {
740 0           $token .= $chars[$i];
741 0           $i++;
742 0 0         if ($chars[$i] eq $delimiter) {
743 0           $token .= $chars[$i];
744             last
745 0           }
746             }
747 0           Handle_2char_qx ($token);
748 0 0         out '."' if $i < (@chars-1);
749            
750             }
751             elsif ($chars[$i] eq '{') {
752            
753 0           out '".';
754 0           $delimiter = '}';
755 0           while ($i < @chars) {
756 0           $token .= $chars[$i];
757 0           $i++;
758 0 0         if ($chars[$i] eq '}') {
759 0           $token .= $chars[$i];
760             last
761 0           }
762             }
763 0           Handle_expansion ($token);
764 0 0         out '."' if $i < (@chars-1);
765             }
766             else {
767 0           $delimiter = '';
768            
769 0           while ($i < @chars) {
770 0           $token .= $chars[$i];
771 0 0         last if ($chars[$i+1] !~ /[a-z0-9\#\[\]\@\*]/i); # 0.04
772 0           $i++;
773             }
774            
775             # Remove trailing whitespace, then put it back
776 0           my $whitespace = '';
777            
778 0 0         if ($token =~ s/(\s+)$//) {
779 0           $whitespace = $1;
780             }
781            
782 0 0         out '".' if ! can_var_interpolate($token);
783            
784 0           Handle_variable ($token);
785            
786 0 0         out '."' if ! can_var_interpolate($token);
787            
788 0 0         out $whitespace if ($whitespace);
789            
790             }
791             }
792             else {
793 0           $delimiter = '';
794 0           out $chars[$i];
795             }
796            
797             }
798            
799 0 0         if ($chars[-1] ne $delimiter) {
800 0           out '"';
801             }
802            
803 0           unset_in_quotes();
804            
805             # Not my favorite hack (in Utils)
806 0           rem_empty_string();
807             }
808              
809             ############################################################################
810              
811             sub Handle_2char_qx {
812            
813 0     0 0   my $ntok;
814 0           my ($tok) = @_;
815            
816             #print STDERR "Handle_2char_qx token: <$tok>\n";
817            
818             # Simple case first
819 0 0         if ($tok =~ /^\$\((.*)\)(.*)$/) {
    0          
820 0           my $cmd = $1;
821 0           my $rest = $2;
822 0           my @cmd = split (/\s+/, $cmd);
823 0           my @perlbi;
824 0           my $shell = 0;
825            
826             # Any shell meta-characters?
827 0 0         $shell = 1 if ($tok =~ /[|><&]/);
828            
829 0 0 0       if (!$shell and @perlbi = App::sh2p::Parser::get_perl_builtin($cmd[0])) {
    0          
830             # Do my best to trap unnecessary child processes
831 0 0         out "\n" if query_semi_colon(); # For tidy messages
832 0           &{$perlbi[0]}(@cmd,$rest);
  0            
833             }
834             elsif (is_user_function($cmd[0])) {
835 0           error_out "User function '$cmd[0]' called in back-ticks";
836 0           iout "`$cmd`$rest";
837             }
838             else {
839 0           my $pipe = 0;
840            
841             # Is this really a pipe, or is | embeded in a string? January 2009
842 0 0         if ( $cmd =~ /\|[^\|]/) { # RE change 0.05
843 0           my $quote = 0;
844 0           for my $char (split '',$cmd) {
845            
846 0 0 0       if ($char eq "'" || $char eq '"') {
847 0 0         $quote = $quote?0:1;
848             }
849            
850 0 0         next if $quote;
851 0 0         if ($char eq '|') {
852 0           $pipe = 1;
853 0           last;
854             }
855             }
856             }
857            
858 0 0         if ($pipe) {
859 0 0         if ( substr($tok, 0, 2) eq '$(' ) {
860 0           $tok =~ s/^\$\((.*)\)$/$1/;
861             }
862             else {
863 0           $tok =~ s/^`(.*)`$/$1/;
864             }
865            
866 0           App::sh2p::Parser::analyse_pipeline ($tok);
867 0           out " $rest";
868             }
869             else {
870 0           iout "`$cmd`$rest";
871             }
872             }
873            
874 0           $ntok = 1;
875             }
876             elsif ( substr($tok, 0, 2) eq '$(' ) {
877 0           $tok =~ s/\$\(/`/;
878            
879             # This is the ONLY place this is set, and might now be obsolete
880 0           $g_unterminated_backtick = 1;
881              
882 0           my @tokens = App::sh2p::Parser::tokenise ($tok);
883 0           my @types = App::sh2p::Parser::identify (1, @tokens);
884            
885             #print_types_tokens (\@types,\@tokens);
886 0           App::sh2p::Parser::convert (@tokens, @types);
887            
888 0           inc_indent();
889 0           $ntok = @_;
890             }
891             else {
892 0           iout "@_";
893 0           $ntok = @_;
894             }
895            
896 0           return $ntok;
897             }
898              
899             ############################################################################
900             # Simplistic call to external program, should this be converted?
901              
902             sub Handle_external {
903            
904 0     0 0   my $ntok = 0;
905 0           my (@args) = @_;
906 0           my $func = 'system';
907            
908             #{local $" = '*'; print STDERR "Handle_external <@args>\n";}
909            
910             # Is final token a comment?
911 0           my $last = '';
912              
913 0 0         if (substr($args[-1],0,1) eq '#') {
914 0           pop @args;
915             }
916            
917 0 0         if ($g_unterminated_backtick) {
918 0 0         if ($args[-1] eq ')') {
919 0           $args[-1] = '`';
920 0           $g_unterminated_backtick = 0;
921 0           iout "@args $last";
922 0           dec_indent();
923             }
924             else {
925 0           iout "@args $last";
926             }
927            
928 0           $ntok += @args; # January 2009
929             }
930             else {
931 0           my @perlbi;
932 0           my $user_function = 0;
933            
934             # pipes?
935             # This loop replaces the grep below (it was detecting | inside quotes)
936 0           for my $tok (@args) {
937 0 0         next if $tok =~ /^([\'\"]).*\1$/;
938 0 0         if ($tok =~ /\|[^\|]/) { # RE change 0.05
939 0           $ntok = App::sh2p::Parser::analyse_pipeline (@args);
940 0           return $ntok;
941             }
942             }
943              
944             #if ( grep /\|[^\|]/, @args) { # RE change 0.05
945             # $ntok = App::sh2p::Parser::analyse_pipeline (@args);
946             # return $ntok;
947             #}
948            
949             # shortcuts or break? 0.05
950 0           my @types = App::sh2p::Parser::identify (1, @args);
951 0           my $i;
952 0           for ($i = 0;$i < @types; $i++) {
953 0 0         if ($types[$i][0] eq 'OPERATOR') {
    0          
954 0           no_semi_colon();
955 0           splice (@args, $i);
956             last
957 0           }
958             elsif ($types[$i][0] eq 'BREAK') {
959 0           splice (@args, $i);
960             last
961 0           }
962             }
963            
964             # Strip quotes January 2009
965 0           my $name = $args[0];
966 0           $name =~ s/^([\"\'])(.*)\1$/$2/;
967             #print STDERR "Handle_external: <$name>\n";
968            
969             # If a user function, then call it as a subroutine
970 0 0         if (is_user_function($name)) {
    0          
971 0           $func = $name;
972 0           shift @args;
973 0           $user_function = 1;
974 0           $ntok++;
975             }
976             elsif (@perlbi = App::sh2p::Parser::get_perl_builtin($name)) {
977             # Do my best to trap unnecessary child processes
978 0           $ntok = &{$perlbi[0]}(@_);
  0            
979 0           return $ntok;
980             }
981            
982 0 0         if (is_break($args[0])) {
983 0           my @caller = caller();
984 0           print STDERR "@caller\n";
985 0           error_out ("++++ Internal error: Invalid break in Handle_external");
986             }
987            
988 0           my $append = '';
989 0 0         $append = ';' if query_semi_colon();
990            
991 0           iout "$func (";
992            
993             # Parse arguments
994 0 0         if ( $user_function ) {
995            
996 0 0         if (@args) {
997            
998 0           for (my $i = 0; $i < @args; $i++) {
999 0           $ntok++;
1000             # Escape embedded quotes
1001 0           $args[$i] =~ s/\"/\\\"/g;
1002             #"help syntax highlighter
1003 0           $args[$i] = "\"$args[$i]\"";
1004 0 0         $args[$i] .= ',' if $i < $#args;
1005             }
1006            
1007 0           interpolation ("@args");
1008             }
1009             }
1010             else {
1011 0           for my $arg (@args) {
1012 0           $ntok++;
1013             # Escape embedded quotes
1014 0           $arg =~ s/\"/\\\"/g;
1015             #"help syntax highlighter
1016             }
1017            
1018 0           interpolation ("@args");
1019             }
1020            
1021             # Added 0.03
1022 0 0         if ($func eq 'system') {
1023 0           my $context = App::sh2p::Compound::get_context();
1024 0 0 0       if ($context eq 'if' || $context eq 'while') {
    0          
1025 0           $append .= '== 0';
1026             }
1027             elsif ($context eq 'until') {
1028 0           $append .= '!= 0';
1029             }
1030             }
1031            
1032 0           out ")$append $last"; # Moved 0.04
1033              
1034 0 0         out "\n" if query_semi_colon();
1035             }
1036            
1037 0           return $ntok;
1038             }
1039              
1040             ##############################################################
1041              
1042             sub Handle_Glob {
1043              
1044 0     0 0   my (@tokens) = @_;
1045 0           my $ntok = @tokens;
1046            
1047 0           local $" = '';
1048 0           iout "(glob(\"@tokens\"))";
1049            
1050 0           return $ntok;
1051             }
1052              
1053             ############################################################################
1054              
1055             sub Handle_unknown {
1056              
1057 0     0 0   my ($token) = @_;
1058              
1059             # Don't quote if numeric or already has quotes
1060 0 0 0       if ($token =~ /^[-+]?\d+$/ || $token =~ /^\".*\"$/) {
1061 0           out "$token";
1062             }
1063             else {
1064             #my @caller = caller();
1065             #print STDERR "Handle_unknown token: <$token> @caller\n";
1066 0           out "\"$token\"";
1067             }
1068            
1069 0           return 1;
1070             }
1071              
1072             ############################################################################
1073             sub store_subs {
1074              
1075 0     0 0   my ($name, $subroutine) = @_;
1076            
1077 0           $g_subs{$name} = $subroutine;
1078            
1079             }
1080              
1081             sub write_subs {
1082              
1083 0 0   0 0   if (%g_subs) {
1084 0           out "\n#\n# Subroutines added by sh2p\n#\n";
1085             }
1086              
1087 0           for my $sub (sort keys %g_subs) {
1088 0           out $g_subs{$sub};
1089             }
1090             }
1091              
1092             ############################################################################
1093              
1094             sub store_sh2p_array_count {
1095 0 0   0 0   return if exists $g_subs{sh2p_array_count};
1096            
1097 0           $g_subs{sh2p_array_count} = << 'AC_HERE';
1098              
1099             ############################################################################
1100             # Generated when ${!array[@]} is used
1101             sub sh2p_array_count {
1102             my @array = @_;
1103             my $result = '';
1104            
1105             for (my $i=0; $i < @array; $i++) {
1106             $result .= "$i " if defined $array[$i];
1107             }
1108            
1109             # Should return a space separated scalar
1110             chop $result; # remove final space
1111             return $result;
1112             }
1113              
1114             AC_HERE
1115             }
1116              
1117             ############################################################################
1118              
1119             1;
1120              
1121             __END__