Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Psh::Strategy; |
2 | ||
3 | use strict; | |
4 | require Psh::Util; | |
5 | require Psh::OS; | |
6 | ||
7 | my %loaded=(); | |
8 | my %active=(); | |
9 | my @order=(); | |
10 | ||
11 | my @lvl1order=(); | |
12 | my @lvl2order=(); | |
13 | my @lvl3order=(); | |
14 | ||
15 | sub CONSUME_LINE() { 1; } | |
16 | sub CONSUME_WORDS() { 2; } # currently unsupported | |
17 | sub CONSUME_TOKENS() { 3; } | |
18 | ||
19 | ##################################################################### | |
20 | # Strategy List | |
21 | ##################################################################### | |
22 | ||
23 | sub get { | |
24 | my $name= shift; | |
25 | $name=ucfirst(lc($name)); | |
26 | my $obj; | |
27 | unless (exists $loaded{$name}) { | |
28 | my $tmp='Psh::Strategy::'.$name; | |
29 | eval "use $tmp;"; | |
30 | if ($@) { | |
31 | print STDERR "$@"; | |
32 | return undef; | |
33 | } | |
34 | eval { | |
35 | $obj= "Psh::Strategy::$name"->new(); | |
36 | }; | |
37 | if ($@ or !$obj) { | |
38 | print STDERR "$@"; | |
39 | return undef; | |
40 | } | |
41 | $loaded{$name}= $obj; | |
42 | return $obj; | |
43 | } | |
44 | return $loaded{$name}; | |
45 | } | |
46 | ||
47 | sub remove { | |
48 | my $name= shift; | |
49 | @order= grep { $name ne $_->name } @order; | |
50 | delete $active{$name} if $active{$name}; | |
51 | regenerate_cache(); | |
52 | } | |
53 | ||
54 | sub list { | |
55 | return @order; | |
56 | } | |
57 | ||
58 | sub available_list { | |
59 | my %result= (); | |
60 | foreach my $tmp (@INC) { | |
61 | my $tmpdir= Psh::OS::catdir($tmp,'Psh','Strategy'); | |
62 | my @tmp= Psh::OS::glob('*.pm',$tmpdir); | |
63 | foreach my $strat (@tmp) { | |
64 | $strat=~s/\.pm$//; | |
65 | $strat=lc($strat); | |
66 | $result{$strat}=1; | |
67 | } | |
68 | } | |
69 | return sort keys %result; | |
70 | } | |
71 | ||
72 | sub find { | |
73 | my $strategy= shift; | |
74 | $strategy=lc($strategy); | |
75 | for (my $i=0; $i<@order; $i++) { | |
76 | if ($order[$i]->name() eq $strategy) { | |
77 | return $i; | |
78 | } | |
79 | } | |
80 | return -1; | |
81 | } | |
82 | ||
83 | sub add { | |
84 | my $str_obj= shift; | |
85 | my $suggested_pos= shift; | |
86 | ||
87 | my $max= $#order; # add right before eval | |
88 | my $min= 0; | |
89 | ||
90 | my @tmp= $str_obj->runs_before(); | |
91 | if (@tmp) { | |
92 | foreach (@tmp) { | |
93 | my $tmp= find($_); | |
94 | $max= $tmp if $tmp<$max and $tmp>=0; | |
95 | } | |
96 | } | |
97 | my $consumes= $str_obj->consumes(); | |
98 | for (my $i=0; $i<=$max; $i++) { | |
99 | if ($order[$i]->consumes()<$consumes) { | |
100 | $min= $i if $i>$min; | |
101 | next; | |
102 | } | |
103 | if ($order[$i]->consumes()>$consumes) { | |
104 | $max= $i if $i<$max; | |
105 | last; | |
106 | } | |
107 | } | |
108 | my $pos=$max; | |
109 | if (defined $suggested_pos) { | |
110 | if ($pos>=$min and $pos<=$max) { | |
111 | $pos=$suggested_pos; | |
112 | } | |
113 | } | |
114 | splice(@order,$pos,0,$str_obj); | |
115 | $active{$str_obj->name}=1; | |
116 | regenerate_cache(); | |
117 | } | |
118 | ||
119 | sub regenerate_cache { | |
120 | @lvl1order= grep { $_ && $_->consumes() == CONSUME_LINE } @order; | |
121 | @lvl2order= grep { $_ && $_->consumes() == CONSUME_WORDS } @order; | |
122 | @lvl3order= grep { $_ && $_->consumes() == CONSUME_TOKENS } @order; | |
123 | } | |
124 | ||
125 | sub parser_strategy_list { | |
126 | return (\@lvl1order,\@lvl2order,\@lvl3order); | |
127 | } | |
128 | ||
129 | sub parser_return_objects { | |
130 | my @objs= map { get($_) } @_; | |
131 | my @lvl1= grep { $_->consumes() == CONSUME_LINE } @objs; | |
132 | my @lvl2= grep { $_->consumes() == CONSUME_WORDS } @objs; | |
133 | my @lvl3= grep { $_->consumes() == CONSUME_TOKENS } @objs; | |
134 | return (\@lvl1,\@lvl2,\@lvl3); | |
135 | } | |
136 | ||
137 | sub setup_defaults { | |
138 | require Psh::StrategyBunch; | |
139 | foreach my $name (qw(bang perl brace built_in perlfunc executable eval)) { | |
140 | my $tmpname= ucfirst($name); | |
141 | my $obj; | |
142 | eval { | |
143 | $obj= "Psh::Strategy::$tmpname"->new(); | |
144 | }; | |
145 | push @order, $obj; | |
146 | $loaded{$tmpname}= $obj; | |
147 | $active{$name}= 1; | |
148 | } | |
149 | if ($^O =~ /darwin/i) { | |
150 | splice(@order,@order-1,0, get('darwin_apps')); | |
151 | $active{darwin_apps}=1; | |
152 | } | |
153 | regenerate_cache(); | |
154 | } | |
155 | ||
156 | sub active { | |
157 | my $name= shift; | |
158 | return $active{$name}; | |
159 | } | |
160 | ||
161 | ##################################################################### | |
162 | # Base class for strategies | |
163 | ##################################################################### | |
164 | ||
165 | sub new { | |
166 | my $proto= shift; | |
167 | my $class= ref($proto) || $proto; | |
168 | my %init= (); | |
169 | my $name; | |
170 | if ($class=~/^Psh::Strategy::(.*)$/) { | |
171 | $name= lc($1); | |
172 | return $loaded{$name} if exists $loaded{$name}; | |
173 | } else { | |
174 | die 'Strategies must be in Psh::Strategy:: namespace!'; | |
175 | } | |
176 | my $self = \%init; | |
177 | $self->{name}= $name; | |
178 | bless $self, $class; | |
179 | return $self; | |
180 | } | |
181 | ||
182 | sub name { | |
183 | return $_[0]->{name}; | |
184 | } | |
185 | ||
186 | sub runs_before { | |
187 | return (); | |
188 | } | |
189 | ||
190 | sub consumes { | |
191 | die 'Abstract method'; | |
192 | } | |
193 | ||
194 | sub applies { | |
195 | die 'Abstract method'; | |
196 | } | |
197 | ||
198 | sub execute { | |
199 | die 'Abstract method'; | |
200 | } | |
201 | ||
202 | 1; | |
203 | ||
204 | __END__ | |
205 | ||
206 | =head1 NAME | |
207 | ||
208 | Psh::Strategy - a Perl Shell Evaluation Strategy (base class) | |
209 | ||
210 | =head1 SYNOPSIS | |
211 | ||
212 | use Psh::Strategy; | |
213 | ||
214 | =head1 DESCRIPTION | |
215 | ||
216 | Psh::Strategy offers a procedural strategy list interface and a | |
217 | base class for developing strategies. | |
218 | ||
219 | =head1 PROCEDURAL STRATEGY LIST | |
220 | ||
221 | ||
222 | Psh::Strategy::list() | |
223 | ||
224 | Returns a list of active Psh::Strategy objects. | |
225 | ||
226 | my $obj= Psh::Strategy::get('name') | |
227 | ||
228 | Loads and initializes a certain Psh::Strategy object | |
229 | ||
230 | Psh::Strategy::add($obj [, $suggest_position]) | |
231 | ||
232 | Adds a strategy object to the list of active strategies | |
233 | ||
234 | Psh::Strategy::remove($name) | |
235 | ||
236 | Removes a strategy | |
237 | ||
238 | @list= Psh::Strategy::available_list() | |
239 | ||
240 | Lists available strategies | |
241 | ||
242 | my $pos= find($name) | |
243 | ||
244 | Finds the position of the named strategy | |
245 | ||
246 | my $flag= active($name) | |
247 | ||
248 | Returns true if the named strategy is currently active | |
249 | ||
250 | ||
251 | =head1 DEVELOPING STRATEGIES | |
252 | ||
253 | You have to inherit from Psh::Strategy and you MUST at least | |
254 | override the functions C<consumes>, C<applies>, C<execute>. | |
255 | You CAN also override the function C<runs_before> | |
256 | ||
257 | =over 4 | |
258 | ||
259 | =item * consumes | |
260 | ||
261 | Returns either CONSUME_LINE, CONSUME_WORDS, CONSUME_TOKENS. | |
262 | CONSUME_LINE means you want to receive the whole input line | |
263 | unparsed. CONSUME_WORDS means you want to receive the whole | |
264 | input line tokenized (currenty unimplemented). CONSUME_TOKENS | |
265 | means that you want to receive a sub-part of the line, tokenized | |
266 | (this is probably what you want) | |
267 | ||
268 | =item * applies | |
269 | ||
270 | Returns undef if the strategy does not want to handle the input. | |
271 | Returns a human-readable description if it wants to handle the input. | |
272 | ||
273 | If you specified CONSUME_LINE, this method will be called as | |
274 | $obj->applies(\$inputline); | |
275 | ||
276 | If you specified CONSUME_TOKENS, this method will be called as | |
277 | $obj->applies(\$inputline,\@tokens,$piped_flag) | |
278 | ||
279 | =item * execute | |
280 | ||
281 | Will be called as | |
282 | $obj->execute(\$inputline,\@tokens,$how,$piped_flag) | |
283 | ||
284 | C<$how> is what the call to applies returned. If C<@tokens> is | |
285 | not applicable an empty array will be supplied. | |
286 | ||
287 | Your execute function should return an array of the form: | |
288 | ||
289 | ($evalcode, \@words, $forcefork, @return_val) | |
290 | ||
291 | If C<$evalcode>, <@words> and <$forcefork> are undef, execution is finished | |
292 | after this call and C<@return_val> will be used as return value. | |
293 | ||
294 | But C<$evalcode> can also be a Perl sub - in which case it is evaluated | |
295 | later on, or a string - in which case it's a filename of a program to | |
296 | execute. C<@words> will then be used as arguments for the program. | |
297 | ||
298 | C<$forcefork> may be used to force a C<fork()> call even for the perl | |
299 | subs. | |
300 | ||
301 | =item * runs_before | |
302 | ||
303 | Returns a list of names of other strategies. It is guaranteed that | |
304 | the evaluation strategy will be tried before those other named strategies | |
305 | are tried. | |
306 | ||
307 | =back | |
308 | ||
309 | =cut |