Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Psh::PerlEval; |
2 | ||
3 | # | |
4 | # Must be on top of file before any "my" variables! | |
5 | # | |
6 | # | |
7 | # array protected_eval(string EXPR, string FROM) | |
8 | # | |
9 | # Evaluates "$Psh::eval_preamble EXPR", handling trapped signals and | |
10 | # printing errors properly. The FROM string is passed on to | |
11 | # handle_message to indicate where errors came from. | |
12 | # | |
13 | # If EXPR ends in an ampersand, it is stripped and the eval is done in | |
14 | # a forked copy of perl. | |
15 | # | |
16 | ||
17 | $Psh::PerlEval::current_package='main'; | |
18 | ||
19 | sub protected_eval | |
20 | { | |
21 | # | |
22 | # Local package variables because lexical variables here mask | |
23 | # variables of the same name in main!! | |
24 | # | |
25 | ||
26 | local ($Psh::PerlEval::str, $Psh::PerlEval::from) = @_; | |
27 | local $Psh::PerlEval::redo_sentinel = 0; | |
28 | ||
29 | # It's not possible to use fork_process for foreground perl | |
30 | # as we would lose all variables etc. | |
31 | ||
32 | { #Dummy block to catch loop-control statements at outermost | |
33 | #level in EXPR | |
34 | # First, protect against infinite loop | |
35 | # caused by redo: | |
36 | if ($Psh::PerlEval::redo_sentinel) { last; } | |
37 | $Psh::PerlEval::redo_sentinel = 1; | |
38 | local $Psh::currently_active= -1; | |
39 | $_= $Psh::PerlEval::lastscalar; | |
40 | @_= @Psh::PerlEval::lastarray; | |
41 | local @Psh::PerlEval::result= eval $Psh::eval_preamble.' package '.$Psh::PerlEval::current_package.'; '.$Psh::PerlEval::str; | |
42 | $Psh::PerlEval::lastscalar= $_; | |
43 | @Psh::PerlEval::lastarray= @_; | |
44 | ||
45 | if ( !$@ && @Psh::PerlEval::result && | |
46 | $#Psh::PerlEval::result==0 && $Psh::PerlEval::str && | |
47 | $Psh::PerlEval::result[0] && | |
48 | $Psh::PerlEval::result[0] eq $Psh::PerlEval::str && | |
49 | !Psh::is_number($Psh::PerlEval::str) && | |
50 | $Psh::PerlEval::str=~ /^\s*\S+\s*$/ && | |
51 | $Psh::PerlEval::str!~ /^\s*(\'|\")\S+(\'|\")\s*$/ ) { | |
52 | # | |
53 | # Very whacky error handling | |
54 | # If you pass one word to perl and it's no function etc | |
55 | # it will simply return the word - that's not even a | |
56 | # bug actually but in case of psh it's annoying | |
57 | # so we try to detect these cases | |
58 | # | |
59 | ||
60 | Psh::Util::print_error_i18n('no_command',$Psh::PerlEval::str); | |
61 | return undef; | |
62 | } | |
63 | else { | |
64 | if ($@) { | |
65 | Psh::handle_message($@, $Psh::PerlEval::from); | |
66 | } | |
67 | } | |
68 | return @Psh::PerlEval::result; | |
69 | } | |
70 | Psh::handle_message("Can't use loop control outside a block", | |
71 | $Psh::PerlEval::from); | |
72 | return undef; | |
73 | } | |
74 | ||
75 | ||
76 | # | |
77 | # array variable_expansion (arrayref WORDS) | |
78 | # | |
79 | # For each element x of the array referred to by WORDS, substitute | |
80 | # perl variables that appear in x respecting the quoting symbols ' and | |
81 | # ", and return the array of substituted values. Substitutions inside | |
82 | # quotes always return a single element in the resulting array; | |
83 | # outside quotes, the result is split() and pushed on to the | |
84 | # accumulating array of substituted values | |
85 | # | |
86 | ||
87 | sub variable_expansion | |
88 | { | |
89 | local ($Psh::arref) = @_; | |
90 | local @Psh::retval = (); | |
91 | local $Psh::word; | |
92 | ||
93 | for $Psh::word (@{$Psh::arref}) { | |
94 | if ($Psh::word =~ m/^\'/) { push @Psh::retval, $Psh::word; } | |
95 | elsif ($Psh::word =~ m/^\"/) { | |
96 | local $Psh::word2= $Psh::word; | |
97 | $Psh::word2 =~ s/\\/\\\\/g; | |
98 | local $Psh::val = eval("$Psh::eval_preamble $Psh::word2"); | |
99 | ||
100 | if ($@) { push @Psh::retval, $Psh::word; } | |
101 | else { push @Psh::retval, "\"$Psh::val\""; } | |
102 | } else { | |
103 | local $Psh::word2= $Psh::word; | |
104 | $Psh::word2 =~ s/\\/\\\\/g; | |
105 | local $Psh::val = eval("$Psh::eval_preamble \"$Psh::word2\""); | |
106 | ||
107 | if ($@) { push @Psh::retval, $Psh::word; } | |
108 | else { push @Psh::retval, $Psh::val; } | |
109 | # in former times we used to do a wordsplit here in | |
110 | # case of success, but this breaks certain things and | |
111 | # don't know exactly why it was here in the first place | |
112 | } | |
113 | } | |
114 | ||
115 | return @Psh::retval; | |
116 | } | |
117 | ||
118 | 1; | |
119 | ||
120 | ||
121 | __END__ | |
122 | ||
123 | =head1 NAME | |
124 | ||
125 | Psh::PerlEval - package containing perl evaluation codes | |
126 | ||
127 | ||
128 | =head1 SYNOPSIS | |
129 | ||
130 | use Psh::PerlEval; | |
131 | ||
132 | =head1 DESCRIPTION | |
133 | ||
134 | TBD | |
135 | ||
136 | =head1 AUTHOR | |
137 | ||
138 | Glen Whitney I think.. | |
139 | ||
140 | =head1 SEE ALSO | |
141 | ||
142 | =cut | |
143 | ||
144 | # The following is for Emacs - I hope it won't annoy anyone | |
145 | # but this could solve the problems with different tab widths etc | |
146 | # | |
147 | # Local Variables: | |
148 | # tab-width:4 | |
149 | # indent-tabs-mode:t | |
150 | # c-basic-offset:4 | |
151 | # perl-indent-level:4 | |
152 | # End: |