blib/lib/CGI/Snapp.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 216 | 363 | 59.5 |
branch | 64 | 176 | 36.3 |
condition | 14 | 41 | 34.1 |
subroutine | 36 | 52 | 69.2 |
pod | 31 | 32 | 96.8 |
total | 361 | 664 | 54.3 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package CGI::Snapp; | ||||||
2 | |||||||
3 | 2 | 2 | 51938 | use strict; | |||
2 | 2 | ||||||
2 | 741 | ||||||
4 | 2 | 2 | 8 | use warnings; | |||
2 | 1 | ||||||
2 | 51 | ||||||
5 | |||||||
6 | 2 | 2 | 6 | use Carp; | |||
2 | 3 | ||||||
2 | 112 | ||||||
7 | |||||||
8 | 2 | 2 | 827 | use Class::ISA; | |||
2 | 930 | ||||||
2 | 42 | ||||||
9 | |||||||
10 | 2 | 2 | 1331 | use Log::Handler; | |||
2 | 67125 | ||||||
2 | 12 | ||||||
11 | |||||||
12 | 2 | 2 | 990 | use Moo; | |||
2 | 13964 | ||||||
2 | 9 | ||||||
13 | |||||||
14 | 2 | 2 | 1939 | use Try::Tiny; | |||
2 | 2 | ||||||
2 | 7039 | ||||||
15 | |||||||
16 | has _current_run_mode => | ||||||
17 | ( | ||||||
18 | is => 'rw', | ||||||
19 | default => sub{return ''}, | ||||||
20 | required => 0, | ||||||
21 | ); | ||||||
22 | |||||||
23 | has _error_mode => | ||||||
24 | ( | ||||||
25 | is => 'rw', | ||||||
26 | default => sub{return ''}, | ||||||
27 | required => 0, | ||||||
28 | ); | ||||||
29 | |||||||
30 | has _headers => | ||||||
31 | ( | ||||||
32 | is => 'rw', | ||||||
33 | default => sub{return {} }, | ||||||
34 | required => 0, | ||||||
35 | ); | ||||||
36 | |||||||
37 | has _header_type => | ||||||
38 | ( | ||||||
39 | is => 'rw', | ||||||
40 | default => sub{return 'header'}, | ||||||
41 | required => 0, | ||||||
42 | ); | ||||||
43 | |||||||
44 | has logger => | ||||||
45 | ( | ||||||
46 | is => 'rw', | ||||||
47 | default => sub{return ''}, | ||||||
48 | required => 0, | ||||||
49 | ); | ||||||
50 | |||||||
51 | has _object_callbacks => | ||||||
52 | ( | ||||||
53 | is => 'rw', | ||||||
54 | default => sub{return {} }, | ||||||
55 | required => 0, | ||||||
56 | ); | ||||||
57 | |||||||
58 | has PARAMS => | ||||||
59 | ( | ||||||
60 | is => 'rw', | ||||||
61 | default => sub{return {} }, | ||||||
62 | required => 0, | ||||||
63 | ); | ||||||
64 | |||||||
65 | has _params => | ||||||
66 | ( | ||||||
67 | is => 'rw', | ||||||
68 | default => sub{return {} }, | ||||||
69 | required => 0, | ||||||
70 | ); | ||||||
71 | |||||||
72 | has _prerun_mode_lock => | ||||||
73 | ( | ||||||
74 | is => 'rw', | ||||||
75 | default => sub{return 1}, | ||||||
76 | required => 0, | ||||||
77 | ); | ||||||
78 | |||||||
79 | has _psgi => | ||||||
80 | ( | ||||||
81 | is => 'rw', | ||||||
82 | default => sub{return 0}, | ||||||
83 | required => 0, | ||||||
84 | ); | ||||||
85 | |||||||
86 | has QUERY => | ||||||
87 | ( | ||||||
88 | is => 'rw', | ||||||
89 | default => sub{return ''}, | ||||||
90 | required => 0, | ||||||
91 | ); | ||||||
92 | |||||||
93 | has _query => | ||||||
94 | ( | ||||||
95 | is => 'rw', | ||||||
96 | default => sub{return ''}, | ||||||
97 | required => 0, | ||||||
98 | ); | ||||||
99 | |||||||
100 | has _run_mode_source => | ||||||
101 | ( | ||||||
102 | is => 'rw', | ||||||
103 | default => sub{return 'rm'}, # I.e. the CGI form field of that name. | ||||||
104 | required => 0,, | ||||||
105 | ); | ||||||
106 | |||||||
107 | has _run_modes => | ||||||
108 | ( | ||||||
109 | is => 'rw', | ||||||
110 | default => sub{return {} }, | ||||||
111 | required => 0, | ||||||
112 | ); | ||||||
113 | |||||||
114 | has send_output => | ||||||
115 | ( | ||||||
116 | is => 'rw', | ||||||
117 | default => sub{return 1}, | ||||||
118 | required => 0, | ||||||
119 | ); | ||||||
120 | |||||||
121 | has _start_mode => | ||||||
122 | ( | ||||||
123 | is => 'rw', | ||||||
124 | default => sub{return 'start'}, | ||||||
125 | required => 0, | ||||||
126 | ); | ||||||
127 | |||||||
128 | my(%class_callbacks) = | ||||||
129 | ( | ||||||
130 | error => {}, | ||||||
131 | forward_prerun => {}, | ||||||
132 | init => {'CGI::Snapp' => ['cgiapp_init']}, | ||||||
133 | prerun => {'CGI::Snapp' => ['cgiapp_prerun']}, | ||||||
134 | postrun => {'CGI::Snapp' => ['cgiapp_postrun']}, | ||||||
135 | teardown => {'CGI::Snapp' => ['teardown']}, | ||||||
136 | ); | ||||||
137 | |||||||
138 | my($myself); | ||||||
139 | |||||||
140 | our $VERSION = '2.01'; | ||||||
141 | |||||||
142 | # -------------------------------------------------- | ||||||
143 | |||||||
144 | sub add_callback | ||||||
145 | { | ||||||
146 | 7 | 7 | 1 | 441 | my($self, $hook, $option) = @_; | ||
147 | |||||||
148 | 7 | 50 | 19 | croak "Error: Can't use undef as a hook name\n" if (! defined $hook); | |||
149 | |||||||
150 | 7 | 9 | $hook = lc $hook; | ||||
151 | |||||||
152 | 7 | 22 | $self -> log(debug => "add_callback($hook, ...)"); | ||||
153 | |||||||
154 | 7 | 50 | 867 | croak "Error: Unknown hook name '$hook'\n" if (! $class_callbacks{$hook}); | |||
155 | |||||||
156 | 7 | 100 | 17 | if (ref $self) | |||
157 | { | ||||||
158 | # it's an object-level callback. | ||||||
159 | |||||||
160 | 2 | 4 | my($object_callback) = $self -> _object_callbacks; | ||||
161 | 2 | 50 | 7 | $$object_callback{$hook} = [] if (! $$object_callback{$hook}); | |||
162 | |||||||
163 | 2 | 2 | push @{$$object_callback{$hook} }, $option; | ||||
2 | 4 | ||||||
164 | |||||||
165 | 2 | 11 | $self -> _object_callbacks($object_callback); | ||||
166 | } | ||||||
167 | else | ||||||
168 | { | ||||||
169 | # It's a class-level callback. | ||||||
170 | |||||||
171 | 5 | 5 | push @{$class_callbacks{$hook}{$self} }, $option; | ||||
5 | 27 | ||||||
172 | } | ||||||
173 | |||||||
174 | } # End of add_callback. | ||||||
175 | |||||||
176 | # -------------------------------------------------- | ||||||
177 | |||||||
178 | sub add_header | ||||||
179 | { | ||||||
180 | 0 | 0 | 1 | 0 | my($self, @headers) = @_; | ||
181 | |||||||
182 | 0 | 0 | $self -> log(debug => 'add_header(...)'); | ||||
183 | |||||||
184 | 0 | 0 | my($old) = $self -> _headers; | ||||
185 | |||||||
186 | 0 | 0 | 0 | if (@headers) | |||
187 | { | ||||||
188 | 0 | 0 | my(%new) = ref $headers[0] eq 'HASH' ? %{$headers[0]} | ||||
189 | 0 | 0 | 0 | : ref $headers[0] eq 'ARRAY' ? @{$headers[0]} | |||
0 | 0 | 0 | |||||
0 | |||||||
190 | : scalar(@headers) % 2 == 0 ? @headers | ||||||
191 | : croak "Error: Odd number of parameters passed to add_header()\n"; | ||||||
192 | |||||||
193 | 0 | 0 | my($value); | ||||
194 | |||||||
195 | 0 | 0 | for my $key (keys %new) | ||||
196 | { | ||||||
197 | 0 | 0 | $value = $$old{$key}; | ||||
198 | |||||||
199 | 0 | 0 | 0 | if (ref $new{$key} eq 'ARRAY') | |||
200 | { | ||||||
201 | 0 | 0 | 0 | if (ref $value eq 'ARRAY') | |||
202 | { | ||||||
203 | 0 | 0 | $new{$key} = [@$value, @{$new{$key} }]; | ||||
0 | 0 | ||||||
204 | } | ||||||
205 | else | ||||||
206 | { | ||||||
207 | 0 | 0 | 0 | $new{$key} = [$value, @{$new{$key} }] if (defined $value); | |||
0 | 0 | ||||||
208 | } | ||||||
209 | } | ||||||
210 | else | ||||||
211 | { | ||||||
212 | 0 | 0 | 0 | if (ref $value eq 'ARRAY') | |||
213 | { | ||||||
214 | 0 | 0 | $new{$key} = [@$value, $new{$key}]; | ||||
215 | } | ||||||
216 | else | ||||||
217 | { | ||||||
218 | 0 | 0 | 0 | $new{$key} = [$value, $new{$key}] if (defined $value); | |||
219 | } | ||||||
220 | } | ||||||
221 | } | ||||||
222 | |||||||
223 | 0 | 0 | $old = {%$old, %new}; | ||||
224 | |||||||
225 | 0 | 0 | $self -> _headers($old); | ||||
226 | } | ||||||
227 | |||||||
228 | 0 | 0 | return %$old; | ||||
229 | |||||||
230 | } # End of add_header. | ||||||
231 | |||||||
232 | # -------------------------------------------------- | ||||||
233 | |||||||
234 | sub BUILD | ||||||
235 | { | ||||||
236 | 7 | 7 | 0 | 45 | my($self, $args) = @_; | ||
237 | 7 | 10 | $myself = $self; | ||||
238 | |||||||
239 | 7 | 100 | 66 | 199 | $self -> _params($$args{PARAMS}) if ($$args{PARAMS} && (ref $$args{PARAMS} eq 'HASH') ); | ||
240 | 7 | 50 | 25 | $self -> _query($$args{QUERY}) if ($$args{QUERY}); | |||
241 | 7 | 50 | 16 | $self -> send_output(0) if ($ENV{CGI_SNAPP_RETURN_ONLY}); | |||
242 | 7 | 47 | $self -> _run_modes({$self -> _start_mode => 'dump_html'}); | ||||
243 | 7 | 26 | $self -> call_hook('init', %$args); | ||||
244 | 7 | 20 | $self -> setup; | ||||
245 | |||||||
246 | } # End of BUILD. | ||||||
247 | |||||||
248 | # -------------------------------------------------- | ||||||
249 | |||||||
250 | sub call_hook | ||||||
251 | { | ||||||
252 | 29 | 29 | 1 | 47 | my($self, $hook, @args) = @_; | ||
253 | |||||||
254 | 29 | 50 | 45 | croak "Error: Can't use undef as a hook name\n" if (! defined $hook); | |||
255 | |||||||
256 | 29 | 29 | $hook = lc $hook; | ||||
257 | |||||||
258 | 29 | 81 | $self -> log(debug => "call_hook($hook, ...)"); | ||||
259 | |||||||
260 | 29 | 3877 | my($count) = {class => 0, object => 0}; | ||||
261 | |||||||
262 | 29 | 33 | my(%seen); | ||||
263 | |||||||
264 | # Call object-level hooks. | ||||||
265 | |||||||
266 | 29 | 18 | for my $callback (@{${$self -> _object_callbacks}{$hook} }) | ||||
29 | 27 | ||||||
29 | 101 | ||||||
267 | { | ||||||
268 | 1 | 50 | 4 | next if ($seen{$callback}); | |||
269 | |||||||
270 | try | ||||||
271 | { | ||||||
272 | 1 | 1 | 28 | $self -> $callback(@args); | |||
273 | } | ||||||
274 | catch | ||||||
275 | { | ||||||
276 | 0 | 0 | 0 | 0 | croak "Error executing object-level callback for hook '$hook': $@\n" if ($@); | ||
277 | 1 | 7 | }; | ||||
278 | |||||||
279 | 1 | 17 | $$count{object}++; | ||||
280 | |||||||
281 | 1 | 3 | $seen{$callback} = 1; | ||||
282 | } | ||||||
283 | |||||||
284 | # Call class-level hooks. | ||||||
285 | |||||||
286 | 29 | 33 | 115 | for my $class (Class::ISA::self_and_super_path(ref $self || $self) ) | |||
287 | { | ||||||
288 | 87 | 100 | 1051 | next if (! exists $class_callbacks{$hook}{$class}); | |||
289 | |||||||
290 | 33 | 25 | for my $callback (@{$class_callbacks{$hook}{$class} }) | ||||
33 | 82 | ||||||
291 | { | ||||||
292 | 43 | 100 | 74 | next if ($seen{$callback}); | |||
293 | |||||||
294 | try | ||||||
295 | { | ||||||
296 | 28 | 28 | 739 | $self -> $callback(@args); | |||
297 | } | ||||||
298 | catch | ||||||
299 | { | ||||||
300 | 0 | 0 | 0 | 0 | croak "Error executing class-level callback for class '$class', hook '$hook': $@\n" if ($@); | ||
301 | 28 | 165 | }; | ||||
302 | |||||||
303 | 28 | 2988 | $$count{class}++; | ||||
304 | |||||||
305 | 28 | 57 | $seen{$callback} = 1; | ||||
306 | } | ||||||
307 | } | ||||||
308 | |||||||
309 | 29 | 69 | return $count; | ||||
310 | |||||||
311 | } # End of call_hook. | ||||||
312 | |||||||
313 | # -------------------------------------------------- | ||||||
314 | |||||||
315 | sub cgiapp_get_query | ||||||
316 | { | ||||||
317 | 0 | 0 | 1 | 0 | my($self) = @_; | ||
318 | |||||||
319 | 0 | 0 | $self -> log(debug => 'cgiapp_get_query()'); | ||||
320 | |||||||
321 | 0 | 0 | 0 | if (! $self -> _query) | |||
322 | { | ||||||
323 | 0 | 0 | require CGI; | ||||
324 | |||||||
325 | 0 | 0 | $self -> _query(CGI -> new); | ||||
326 | } | ||||||
327 | |||||||
328 | 0 | 0 | return $self -> _query; | ||||
329 | |||||||
330 | } # End of cgiapp_get_query. | ||||||
331 | |||||||
332 | # -------------------------------------------------- | ||||||
333 | |||||||
334 | sub cgiapp_init | ||||||
335 | { | ||||||
336 | 7 | 7 | 1 | 7 | my($self) = @_; | ||
337 | |||||||
338 | 7 | 13 | $self -> log(debug => 'cgiapp_init()'); | ||||
339 | |||||||
340 | } # End of cgiapp_init. | ||||||
341 | |||||||
342 | # -------------------------------------------------- | ||||||
343 | |||||||
344 | sub cgiapp_prerun | ||||||
345 | { | ||||||
346 | 2 | 2 | 1 | 2 | my($self) = @_; | ||
347 | |||||||
348 | 2 | 5 | $self -> log(debug => 'cgiapp_prerun()'); | ||||
349 | |||||||
350 | } # End of cgiapp_prerun. | ||||||
351 | |||||||
352 | # -------------------------------------------------- | ||||||
353 | |||||||
354 | sub cgiapp_postrun | ||||||
355 | { | ||||||
356 | 7 | 7 | 1 | 9 | my($self) = @_; | ||
357 | |||||||
358 | 7 | 13 | $self -> log(debug => 'cgiapp_postrun()'); | ||||
359 | |||||||
360 | } # End of cgiapp_postrun. | ||||||
361 | |||||||
362 | # -------------------------------------------------- | ||||||
363 | |||||||
364 | sub delete | ||||||
365 | { | ||||||
366 | 0 | 0 | 1 | 0 | my($self, $key) = @_; | ||
367 | |||||||
368 | 0 | 0 | $self -> log(debug => 'delete()'); | ||||
369 | |||||||
370 | 0 | 0 | my($result); | ||||
371 | |||||||
372 | 0 | 0 | 0 | if (defined $key) | |||
373 | { | ||||||
374 | 0 | 0 | my($param) = $self -> _params; | ||||
375 | 0 | 0 | $result = delete $$param{$key}; | ||||
376 | |||||||
377 | 0 | 0 | $self -> _params($param); | ||||
378 | } | ||||||
379 | |||||||
380 | 0 | 0 | return $result; | ||||
381 | |||||||
382 | } # End of delete. | ||||||
383 | |||||||
384 | # -------------------------------------------------- | ||||||
385 | |||||||
386 | sub delete_header | ||||||
387 | { | ||||||
388 | 0 | 0 | 1 | 0 | my($self, @keys) = @_; | ||
389 | |||||||
390 | 0 | 0 | $self -> log(debug => 'delete_header()'); | ||||
391 | |||||||
392 | 0 | 0 | my($old) = $self -> _headers; | ||||
393 | |||||||
394 | 0 | 0 | delete $$old{$_} for (@keys); | ||||
395 | |||||||
396 | 0 | 0 | $self -> _headers($old); | ||||
397 | |||||||
398 | 0 | 0 | return %$old; | ||||
399 | |||||||
400 | } # End of delete_header. | ||||||
401 | |||||||
402 | # -------------------------------------------------- | ||||||
403 | |||||||
404 | sub _determine_cgi_header | ||||||
405 | { | ||||||
406 | 7 | 7 | 7 | my($self) = @_; | |||
407 | |||||||
408 | 7 | 11 | $self -> log(debug => '_determine_cgi_header()'); | ||||
409 | |||||||
410 | 7 | 815 | my($q) = $self -> query; | ||||
411 | 7 | 19 | my($type) = $self -> header_type; | ||||
412 | |||||||
413 | return | ||||||
414 | 7 | 50 | 33 | $type eq 'header' | |||
100 | |||||||
415 | ? $q -> header($self -> header_props) | ||||||
416 | : $type eq 'redirect' | ||||||
417 | ? $q -> redirect($self -> header_props) | ||||||
418 | : ''; | ||||||
419 | |||||||
420 | } # End of _determine_cgi_header. | ||||||
421 | |||||||
422 | # -------------------------------------------------- | ||||||
423 | |||||||
424 | sub _determine_output | ||||||
425 | { | ||||||
426 | 7 | 7 | 10 | my($self) = @_; | |||
427 | |||||||
428 | 7 | 13 | $self -> log(debug => '_determine_output()'); | ||||
429 | |||||||
430 | 7 | 854 | my($run_mode) = $self -> _determine_run_mode; | ||||
431 | |||||||
432 | 7 | 22 | $self -> _prerun_mode_lock(0); | ||||
433 | 7 | 15 | $self -> call_hook('prerun', $run_mode); | ||||
434 | 7 | 11 | $self -> _prerun_mode_lock(1); | ||||
435 | |||||||
436 | 7 | 21 | my($output) = $self -> _generate_output; | ||||
437 | 7 | 50 | 15 | $output = $$output if (ref $output eq 'SCALAR'); | |||
438 | |||||||
439 | 7 | 16 | $self -> call_hook('postrun', \$output); | ||||
440 | |||||||
441 | 7 | 11 | return $output; | ||||
442 | |||||||
443 | } # End of _determine_output. | ||||||
444 | |||||||
445 | # -------------------------------------------------- | ||||||
446 | |||||||
447 | sub _determine_psgi_header | ||||||
448 | { | ||||||
449 | 0 | 0 | 0 | my($self) = @_; | |||
450 | |||||||
451 | 0 | 0 | $self -> log(debug => '_determine_psgi_header()'); | ||||
452 | |||||||
453 | 0 | 0 | my($q) = $self -> query; | ||||
454 | 0 | 0 | my($type) = $self -> header_type; | ||||
455 | |||||||
456 | return | ||||||
457 | 0 | 0 | 0 | $type eq 'header' | |||
0 | |||||||
458 | ? $q -> psgi_header($self -> header_props) | ||||||
459 | : $type eq 'redirect' | ||||||
460 | ? $q -> psgi_redirect($self -> header_props) | ||||||
461 | : (200, []); | ||||||
462 | |||||||
463 | } # End of _determine_psgi_header. | ||||||
464 | |||||||
465 | # -------------------------------------------------- | ||||||
466 | |||||||
467 | sub _determine_run_mode | ||||||
468 | { | ||||||
469 | 7 | 7 | 10 | my($self) = @_; | |||
470 | 7 | 15 | my($mode_source) = $self -> _run_mode_source; | ||||
471 | |||||||
472 | 7 | 8 | my($run_mode); | ||||
473 | |||||||
474 | 7 | 50 | 102 | if (ref $mode_source eq 'CODE') | |||
50 | |||||||
475 | { | ||||||
476 | 0 | 0 | $run_mode = $mode_source -> ($self); | ||||
477 | } | ||||||
478 | elsif (ref $mode_source eq 'HASH') | ||||||
479 | { | ||||||
480 | 0 | 0 | $run_mode = $$mode_source{run_mode}; | ||||
481 | } | ||||||
482 | else | ||||||
483 | { | ||||||
484 | 7 | 50 | 11 | $self -> cgiapp_get_query if (! $self -> query); | |||
485 | |||||||
486 | 7 | 14 | $run_mode = $self -> query -> param($mode_source); | ||||
487 | } | ||||||
488 | |||||||
489 | 7 | 50 | 113 | $run_mode = $self -> start_mode if (! defined $run_mode); | |||
490 | |||||||
491 | 7 | 19 | $self -> _current_run_mode($run_mode); | ||||
492 | 7 | 17 | $self -> log(debug => "_determine_run_mode() => $run_mode"); | ||||
493 | |||||||
494 | 7 | 870 | return $run_mode; | ||||
495 | |||||||
496 | } # End of _determine_run_mode. | ||||||
497 | |||||||
498 | # -------------------------------------------------- | ||||||
499 | |||||||
500 | sub dump | ||||||
501 | { | ||||||
502 | 0 | 0 | 1 | 0 | my($self) = @_; | ||
503 | |||||||
504 | 0 | 0 | $self -> log(debug => 'dump()'); | ||||
505 | |||||||
506 | 0 | 0 | my($q) = $self -> query; | ||||
507 | 0 | 0 | 0 | my($output) = 'Run mode: ' . ($self -> _current_run_mode || ''). "\n" . | |||
508 | "Query parameters:\n" . $q -> Dump . "\nQuery environment:\n"; | ||||||
509 | |||||||
510 | 0 | 0 | for my $key (sort keys %ENV) | ||||
511 | { | ||||||
512 | 0 | 0 | $output .= $q -> escapeHTML($key) . ' => ' . $q -> escapeHTML($ENV{$key}) . "\n"; | ||||
513 | } | ||||||
514 | |||||||
515 | 0 | 0 | return $output; | ||||
516 | |||||||
517 | } # End of dump. | ||||||
518 | |||||||
519 | # -------------------------------------------------- | ||||||
520 | |||||||
521 | sub dump_html | ||||||
522 | { | ||||||
523 | 0 | 0 | 1 | 0 | my($self) = @_; | ||
524 | |||||||
525 | 0 | 0 | $self -> log(debug => 'dump_html()'); | ||||
526 | |||||||
527 | 0 | 0 | my($q) = $self -> query; | ||||
528 | 0 | 0 | 0 | my($output) = ' Run mode: ' . ($self -> _current_run_mode || ''). " \n" . |
|||
529 | " Query parameters: \n" . $q -> Dump . "\nQuery environment: \n" . |
||||||
530 | "
|
||||||
531 | |||||||
532 | 0 | 0 | for my $key (sort keys %ENV) | ||||
533 | { | ||||||
534 | 0 | 0 | $output .= ' |
||||
535 | } | ||||||
536 | |||||||
537 | 0 | 0 | $output .= "\n"; | ||||
538 | |||||||
539 | 0 | 0 | return $output; | ||||
540 | |||||||
541 | } # End of dump_html. | ||||||
542 | |||||||
543 | # -------------------------------------------------- | ||||||
544 | |||||||
545 | sub error_mode | ||||||
546 | { | ||||||
547 | 0 | 0 | 1 | 0 | my($self, $method_name) = @_; | ||
548 | 0 | 0 | 0 | $method_name ||= ''; | |||
549 | |||||||
550 | 0 | 0 | $self -> log(debug => "error_mode($method_name)"); | ||||
551 | 0 | 0 | 0 | $self -> _error_mode($method_name) if ($method_name); | |||
552 | |||||||
553 | 0 | 0 | return $self -> _error_mode; | ||||
554 | |||||||
555 | } # End of error_mode. | ||||||
556 | |||||||
557 | # -------------------------------------------------- | ||||||
558 | |||||||
559 | sub forward | ||||||
560 | { | ||||||
561 | 1 | 1 | 1 | 12 | my($self, $run_mode, @args) = @_; | ||
562 | 1 | 50 | 3 | $run_mode = defined $run_mode ? $run_mode : ''; | |||
563 | |||||||
564 | 1 | 28 | $self -> log(debug => "forward($run_mode, ...)"); | ||||
565 | 1 | 61 | $self -> _current_run_mode($run_mode); | ||||
566 | 1 | 2 | $self -> call_hook('forward_prerun'); | ||||
567 | |||||||
568 | 1 | 5 | return $self -> _generate_output(@args); | ||||
569 | |||||||
570 | } # End of forward. | ||||||
571 | |||||||
572 | # -------------------------------------------------- | ||||||
573 | |||||||
574 | sub _generate_output | ||||||
575 | { | ||||||
576 | 8 | 8 | 10 | my($self, @args) = @_; | |||
577 | |||||||
578 | 8 | 11 | $self -> log(debug => '_generate_output()'); | ||||
579 | |||||||
580 | 8 | 913 | my($is_autoload) = 0; | ||||
581 | 8 | 18 | my($run_mode) = $self -> _current_run_mode; | ||||
582 | 8 | 15 | my(%run_modes) = $self -> run_modes; | ||||
583 | |||||||
584 | 8 | 10 | my($method_name); | ||||
585 | |||||||
586 | 8 | 50 | 16 | if (exists $run_modes{$run_mode}) | |||
587 | { | ||||||
588 | 8 | 15 | $method_name = $run_modes{$run_mode}; | ||||
589 | } | ||||||
590 | else | ||||||
591 | { | ||||||
592 | 0 | 0 | 0 | croak "Error: No such run mode: '$run_mode'\n" if (! exists $run_modes{'AUTOLOAD'}); | |||
593 | |||||||
594 | 0 | 0 | $method_name = $run_modes{'AUTOLOAD'}; | ||||
595 | 0 | 0 | $is_autoload = 1; | ||||
596 | } | ||||||
597 | |||||||
598 | 8 | 7 | my($output); | ||||
599 | |||||||
600 | try | ||||||
601 | { | ||||||
602 | 8 | 50 | 8 | 197 | $output = $is_autoload ? $self -> $method_name($run_mode, @args) : $self -> $method_name(@args); | ||
603 | } | ||||||
604 | catch | ||||||
605 | { | ||||||
606 | 0 | 0 | 0 | my($error) = $_; | |||
607 | |||||||
608 | 0 | 0 | $self -> call_hook('error', $error); | ||||
609 | |||||||
610 | 0 | 0 | 0 | if ($method_name = $self -> error_mode) | |||
611 | { | ||||||
612 | try | ||||||
613 | { | ||||||
614 | 0 | 0 | $output = $self -> $method_name($error); | ||||
615 | } | ||||||
616 | catch | ||||||
617 | { | ||||||
618 | 0 | 0 | croak "Error executing the error mode method '$method_name': $_\n"; | ||||
619 | 0 | 0 | }; | ||||
620 | } | ||||||
621 | else | ||||||
622 | { | ||||||
623 | 0 | 0 | croak "Error executing run mode '$run_mode': $error\n"; | ||||
624 | } | ||||||
625 | 8 | 57 | }; | ||||
626 | |||||||
627 | 8 | 100 | 133 | return defined($output) ? $output : ''; | |||
628 | |||||||
629 | } # End of _generate_output. | ||||||
630 | |||||||
631 | # -------------------------------------------------- | ||||||
632 | |||||||
633 | sub get_callbacks | ||||||
634 | { | ||||||
635 | 0 | 0 | 1 | 0 | my($self, $type, $hook) = @_; | ||
636 | 0 | 0 | 0 | $type ||= ''; | |||
637 | 0 | 0 | 0 | $hook ||= ''; | |||
638 | |||||||
639 | 0 | 0 | $self -> log(debug => "get_callbacks($type, $hook)"); | ||||
640 | |||||||
641 | 0 | 0 | 0 | croak "Error: \$type parameter to get_callbacks() must be 'class' or 'object'\n" if ($type !~ /^(?:class|object)$/); | |||
642 | 0 | 0 | 0 | croak "Error: \$hook parameter to get_callbacks() must be a string\n" if (length($hook) == 0); | |||
643 | |||||||
644 | 0 | 0 | 0 | return $type eq 'class' ? $class_callbacks{$hook} : ${$self -> _object_callbacks}{$hook}; | |||
0 | 0 | ||||||
645 | |||||||
646 | } # End of get_callbacks. | ||||||
647 | |||||||
648 | # -------------------------------------------------- | ||||||
649 | |||||||
650 | sub get_current_runmode | ||||||
651 | { | ||||||
652 | 2 | 2 | 1 | 555 | my($self) = @_; | ||
653 | |||||||
654 | 2 | 5 | $self -> log(debug => 'get_current_runmode()'); | ||||
655 | |||||||
656 | 2 | 132 | return $self -> _current_run_mode; | ||||
657 | |||||||
658 | } # End of get_current_runmode. | ||||||
659 | |||||||
660 | # -------------------------------------------------- | ||||||
661 | |||||||
662 | sub header_add | ||||||
663 | { | ||||||
664 | 4 | 4 | 1 | 6 | my($self, @headers) = @_; | ||
665 | |||||||
666 | 4 | 12 | $self -> log(debug => 'header_add(...)'); | ||||
667 | |||||||
668 | 0 | 0 | my(%new) = ref $headers[0] eq 'HASH' ? %{$headers[0]} | ||||
669 | 4 | 50 | 605 | : ref $headers[0] eq 'ARRAY' ? @{$headers[0]} | |||
0 | 50 | 0 | |||||
50 | |||||||
670 | : scalar(@headers) % 2 == 0 ? @headers | ||||||
671 | : croak "Error: Odd number of parameters passed to header_add()\n"; | ||||||
672 | |||||||
673 | 4 | 14 | my($old) = $self -> _headers; | ||||
674 | |||||||
675 | 4 | 50 | 10 | if (scalar keys %new) | |||
676 | { | ||||||
677 | 4 | 5 | my($value); | ||||
678 | |||||||
679 | 4 | 8 | for my $key (grep{ref $new{$_} eq 'ARRAY'} keys %new) | ||||
5 | 16 | ||||||
680 | { | ||||||
681 | 0 | 0 | $value = $$old{$key}; | ||||
682 | |||||||
683 | 0 | 0 | 0 | next if (! defined $value); | |||
684 | |||||||
685 | 0 | 0 | 0 | $value = [$value] if (ref $value ne 'ARRAY'); | |||
686 | 0 | 0 | $new{$key} = [@$value, @{$new{$key} }]; | ||||
0 | 0 | ||||||
687 | } | ||||||
688 | |||||||
689 | 4 | 12 | $old = {%$old, %new}; | ||||
690 | |||||||
691 | 4 | 11 | $self -> _headers($old); | ||||
692 | } | ||||||
693 | |||||||
694 | 4 | 8 | return %$old; | ||||
695 | |||||||
696 | } # End of header_add. | ||||||
697 | |||||||
698 | # -------------------------------------------------- | ||||||
699 | |||||||
700 | sub header_props | ||||||
701 | { | ||||||
702 | 7 | 7 | 1 | 31 | my($self, @headers) = @_; | ||
703 | |||||||
704 | 7 | 14 | $self -> log(debug => 'header_props(...)'); | ||||
705 | |||||||
706 | 7 | 50 | 797 | if (@headers) | |||
707 | { | ||||||
708 | 0 | 0 | my(%new) = ref $headers[0] eq 'HASH' ? %{$headers[0]} | ||||
709 | 0 | 0 | 0 | : ref $headers[0] eq 'ARRAY' ? @{$headers[0]} | |||
0 | 0 | 0 | |||||
0 | |||||||
710 | : scalar(@headers) % 2 == 0 ? @headers | ||||||
711 | : croak "Error: Odd number of parameters passed to header_props()\n"; | ||||||
712 | |||||||
713 | 0 | 0 | $self -> _headers({%new}); | ||||
714 | } | ||||||
715 | |||||||
716 | 7 | 8 | return %{$self -> _headers}; | ||||
7 | 49 | ||||||
717 | |||||||
718 | } # End of header_props. | ||||||
719 | |||||||
720 | # -------------------------------------------------- | ||||||
721 | |||||||
722 | sub header_type | ||||||
723 | { | ||||||
724 | 11 | 11 | 1 | 16 | my($self, $option) = @_; | ||
725 | 11 | 100 | 37 | $option ||= ''; | |||
726 | |||||||
727 | 11 | 28 | $self -> log(debug => "header_type($option)"); | ||||
728 | |||||||
729 | 11 | 100 | 1491 | if ($option) | |||
730 | { | ||||||
731 | 4 | 16 | my(%valid) = (header => 1, none => 1, redirect => 1); | ||||
732 | |||||||
733 | 4 | 50 | 9 | croak "Error: Invalid header type '$option'. Must be one of: " . join(', ', sort keys %valid) . "\n" if (! $valid{$option}); | |||
734 | |||||||
735 | 4 | 15 | $self -> _header_type($option); | ||||
736 | } | ||||||
737 | |||||||
738 | 11 | 59 | return $self -> _header_type; | ||||
739 | |||||||
740 | } # End of header_type. | ||||||
741 | |||||||
742 | # -------------------------------------------------- | ||||||
743 | |||||||
744 | sub log | ||||||
745 | { | ||||||
746 | 201 | 201 | 1 | 225 | my($self, $level, $s) = @_; | ||
747 | 201 | 50 | 291 | $level ||= 'info'; | |||
748 | 201 | 50 | 236 | $s ||= ''; | |||
749 | |||||||
750 | # We can't use $self here because add_callback can be called as a class method, | ||||||
751 | # and logging inside add_callback would then call here without initializing $self | ||||||
752 | # to be an instance. It would just be the string name of the class calling add_callback. | ||||||
753 | |||||||
754 | 201 | 50 | 33 | 1039 | $myself -> logger -> log($level => $s) if ($myself && $myself -> logger); | ||
755 | |||||||
756 | } # End of log. | ||||||
757 | |||||||
758 | # -------------------------------------------------- | ||||||
759 | |||||||
760 | sub mode_param | ||||||
761 | { | ||||||
762 | 7 | 7 | 1 | 54 | my($self, @new_options) = @_; | ||
763 | |||||||
764 | 7 | 10 | $self -> log(debug => 'mode_param(...)'); | ||||
765 | |||||||
766 | 7 | 808 | my($mode_source); | ||||
767 | |||||||
768 | 7 | 50 | 16 | if (@new_options) | |||
769 | { | ||||||
770 | 7 | 11 | my($ref) = ref $new_options[0]; | ||||
771 | |||||||
772 | 7 | 50 | 33 | 32 | if ( ($#new_options == 0) && ($ref !~ /(?:ARRAY|HASH)/) ) | ||
773 | { | ||||||
774 | 7 | 11 | $mode_source = $new_options[0]; | ||||
775 | } | ||||||
776 | else | ||||||
777 | { | ||||||
778 | 0 | 0 | my(%new_options) = $ref eq 'HASH' ? %{$new_options[0]} | ||||
779 | 0 | 0 | 0 | : $ref eq 'ARRAY' ? @{$new_options[0]} | |||
0 | 0 | 0 | |||||
0 | |||||||
780 | : scalar(@new_options) % 2 == 0 ? @new_options | ||||||
781 | : croak "Error: Odd number of parameters passed to mode_param()\n"; | ||||||
782 | |||||||
783 | # We need defined in case someone uses a run mode of 0. | ||||||
784 | |||||||
785 | 0 | 0 | 0 | $mode_source = defined($new_options{param}) ? $new_options{param} : ''; | |||
786 | 0 | 0 | my($index) = $new_options{path_info}; | ||||
787 | 0 | 0 | my($path_info) = $self -> query -> path_info; | ||||
788 | |||||||
789 | 0 | 0 | 0 | 0 | if ($index && $path_info) | ||
790 | { | ||||||
791 | 0 | 0 | 0 | $index -= 1 if ($index > 0); | |||
792 | 0 | 0 | $path_info =~ s!^/!!; | ||||
793 | 0 | 0 | 0 | $path_info = (split m|/|, $path_info)[$index] || ''; | |||
794 | 0 | 0 | 0 | $mode_source = length $index ? {run_mode => $path_info} : $mode_source; | |||
795 | } | ||||||
796 | } | ||||||
797 | |||||||
798 | 7 | 25 | $self -> _run_mode_source($mode_source); | ||||
799 | } | ||||||
800 | else | ||||||
801 | { | ||||||
802 | 0 | 0 | $mode_source = $self -> _run_mode_source; | ||||
803 | } | ||||||
804 | |||||||
805 | 7 | 13 | return $mode_source; | ||||
806 | |||||||
807 | } # End of mode_param. | ||||||
808 | |||||||
809 | # -------------------------------------------------- | ||||||
810 | |||||||
811 | sub new_hook | ||||||
812 | { | ||||||
813 | 0 | 0 | 1 | 0 | my($self, $hook) = @_; | ||
814 | |||||||
815 | 0 | 0 | 0 | croak "Error: Can't use undef as a hook name\n" if (! defined $hook); | |||
816 | |||||||
817 | 0 | 0 | $hook = lc $hook; | ||||
818 | |||||||
819 | 0 | 0 | $self -> log(debug => "new_hook($hook)"); | ||||
820 | |||||||
821 | 0 | 0 | 0 | $class_callbacks{$hook} ||= {}; | |||
822 | |||||||
823 | 0 | 0 | return 1; | ||||
824 | |||||||
825 | } # End of new_hook. | ||||||
826 | |||||||
827 | # -------------------------------------------------- | ||||||
828 | |||||||
829 | sub param | ||||||
830 | { | ||||||
831 | 18 | 18 | 1 | 845 | my($self, @params) = @_; | ||
832 | |||||||
833 | 18 | 30 | $self -> log(debug => 'param(...)'); | ||||
834 | |||||||
835 | 18 | 2720 | my(%old) = %{$self -> _params}; | ||||
18 | 91 | ||||||
836 | |||||||
837 | 18 | 17 | my($returnz); | ||||
838 | my($value); | ||||||
839 | |||||||
840 | 18 | 50 | 43 | if (@params) | |||
841 | { | ||||||
842 | 18 | 17 | my(%new); | ||||
843 | |||||||
844 | 18 | 50 | 63 | if (ref $params[0] eq 'HASH') | |||
50 | |||||||
50 | |||||||
50 | |||||||
845 | { | ||||||
846 | 0 | 0 | %new = %{$params[0]}; | ||||
0 | 0 | ||||||
847 | } | ||||||
848 | elsif (ref $params[0] eq 'ARRAY') | ||||||
849 | { | ||||||
850 | 0 | 0 | %new = @{$params[0]}; | ||||
0 | 0 | ||||||
851 | } | ||||||
852 | elsif (scalar @params % 2 == 0) | ||||||
853 | { | ||||||
854 | 0 | 0 | %new = @params; | ||||
855 | 0 | 0 | 0 | $value = $params[1] if ($#params == 1); | |||
856 | } | ||||||
857 | elsif ($#params == 0) | ||||||
858 | { | ||||||
859 | 18 | 23 | $value = $old{$params[0]}; | ||||
860 | } | ||||||
861 | else | ||||||
862 | { | ||||||
863 | 0 | 0 | croak "Error: Odd number of parameters passed to param()\n"; | ||||
864 | } | ||||||
865 | |||||||
866 | 18 | 16 | $returnz = 'scalar'; | ||||
867 | 18 | 32 | %old = (%old, %new); | ||||
868 | |||||||
869 | 18 | 47 | $self -> _params({%old}); | ||||
870 | } | ||||||
871 | else | ||||||
872 | { | ||||||
873 | 0 | 0 | $returnz = 'array'; | ||||
874 | } | ||||||
875 | |||||||
876 | 18 | 50 | 63 | return $returnz eq 'scalar' ? $value : keys %{$self -> _params}; | |||
0 | 0 | ||||||
877 | |||||||
878 | } # End of param. | ||||||
879 | |||||||
880 | # -------------------------------------------------- | ||||||
881 | |||||||
882 | sub prerun_mode | ||||||
883 | { | ||||||
884 | 1 | 1 | 1 | 2 | my($self, $run_mode) = @_; | ||
885 | 1 | 50 | 2 | $run_mode = defined($run_mode) ? $run_mode : ''; | |||
886 | |||||||
887 | 1 | 4 | $self -> log(debug => "prerun_mode($run_mode)"); | ||||
888 | |||||||
889 | 1 | 50 | 143 | croak "Error: prerun_mode() can only be called from within cgiapp_prerun()\n" if ($self -> _prerun_mode_lock); | |||
890 | |||||||
891 | 1 | 3 | $self -> _current_run_mode($run_mode); | ||||
892 | |||||||
893 | 1 | 2 | return $run_mode; | ||||
894 | |||||||
895 | } # End of prerun_mode. | ||||||
896 | |||||||
897 | # -------------------------------------------------- | ||||||
898 | |||||||
899 | sub psgi_app | ||||||
900 | { | ||||||
901 | 0 | 0 | 1 | 0 | my($self, %arg) = @_; | ||
902 | |||||||
903 | 0 | 0 | $self -> log(debug => 'psgi_app(...)'); | ||||
904 | |||||||
905 | return | ||||||
906 | sub | ||||||
907 | { | ||||||
908 | 0 | 0 | 0 | my($env) = @_; | |||
909 | |||||||
910 | 0 | 0 | 0 | if (! $arg{QUERY}) | |||
911 | { | ||||||
912 | 0 | 0 | require CGI::PSGI; | ||||
913 | |||||||
914 | 0 | 0 | $arg{QUERY} = CGI::PSGI -> new($env); | ||||
915 | } | ||||||
916 | |||||||
917 | 0 | 0 | $arg{_psgi} = 1; # Required. | ||||
918 | 0 | 0 | my($class) = $self; | ||||
919 | 0 | 0 | $class =~ s/=HASH\(.+\)//; | ||||
920 | |||||||
921 | 0 | 0 | return $class -> new(%arg) -> run; | ||||
922 | 0 | 0 | }; | ||||
923 | |||||||
924 | } # End of psgi_app. | ||||||
925 | |||||||
926 | # -------------------------------------------------- | ||||||
927 | |||||||
928 | sub query | ||||||
929 | { | ||||||
930 | 28 | 28 | 1 | 1730 | my($self, $q) = @_; | ||
931 | 28 | 100 | 86 | $q ||= ''; | |||
932 | |||||||
933 | 28 | 70 | $self -> log(debug => "_query($q)"); | ||||
934 | 28 | 100 | 3504 | $self -> _query($q) if ($q); | |||
935 | 28 | 50 | 67 | $self -> cgiapp_get_query if (! $self -> _query); | |||
936 | |||||||
937 | 28 | 64 | return $self -> _query; | ||||
938 | |||||||
939 | } # End of _query. | ||||||
940 | |||||||
941 | # -------------------------------------------------- | ||||||
942 | |||||||
943 | sub redirect | ||||||
944 | { | ||||||
945 | 4 | 4 | 1 | 20 | my($self, $url, $status) = @_; | ||
946 | 4 | 50 | 8 | $url ||= ''; | |||
947 | 4 | 100 | 14 | $status ||= 0; | |||
948 | |||||||
949 | 4 | 9 | $self -> log(debug => "redirect($url, ...)"); | ||||
950 | |||||||
951 | # If we're in the prerun phase, generate a no-op via a dummy sub. | ||||||
952 | |||||||
953 | 4 | 100 | 600 | if ($self -> _prerun_mode_lock == 0) | |||
954 | { | ||||||
955 | 1 | 1 | 5 | $self -> run_modes(dummy_redirect => sub{}); | |||
956 | 1 | 7 | $self -> prerun_mode('dummy_redirect'); | ||||
957 | } | ||||||
958 | |||||||
959 | 4 | 100 | 13 | if ($status) | |||
960 | { | ||||||
961 | 1 | 8 | $self -> header_add(-location => $url, -status => $status); | ||||
962 | } | ||||||
963 | else | ||||||
964 | { | ||||||
965 | 3 | 16 | $self -> header_add(-location => $url); | ||||
966 | } | ||||||
967 | |||||||
968 | 4 | 12 | $self -> header_type('redirect'); | ||||
969 | |||||||
970 | } # End of redirect. | ||||||
971 | |||||||
972 | # -------------------------------------------------- | ||||||
973 | |||||||
974 | sub run | ||||||
975 | { | ||||||
976 | 7 | 7 | 1 | 22 | my($self) = @_; | ||
977 | |||||||
978 | 7 | 12 | $self -> log(debug => 'run()'); | ||||
979 | |||||||
980 | 7 | 877 | my($output) = $self -> _determine_output; | ||||
981 | |||||||
982 | 7 | 50 | 29 | if ($self -> _psgi) | |||
983 | { | ||||||
984 | 0 | 0 | my($status, $header) = $self -> _determine_psgi_header; | ||||
985 | |||||||
986 | 0 | 0 | utf8::downgrade($_, 0) for @$header; | ||||
987 | |||||||
988 | 0 | 0 | $self -> call_hook('teardown'); | ||||
989 | |||||||
990 | 0 | 0 | return [$status, $header, [$output] ]; | ||||
991 | } | ||||||
992 | else | ||||||
993 | { | ||||||
994 | 7 | 17 | my($header) = $self -> _determine_cgi_header; | ||||
995 | |||||||
996 | 7 | 6022 | utf8::downgrade($header, 0); | ||||
997 | |||||||
998 | 7 | 12 | $output = $header . $output; | ||||
999 | |||||||
1000 | 7 | 50 | 26 | print $output if ($self -> send_output); | |||
1001 | |||||||
1002 | 7 | 13 | $self -> call_hook('teardown'); | ||||
1003 | |||||||
1004 | 7 | 19 | return $output; | ||||
1005 | } | ||||||
1006 | |||||||
1007 | } # End of run. | ||||||
1008 | |||||||
1009 | # -------------------------------------------------- | ||||||
1010 | |||||||
1011 | sub run_modes | ||||||
1012 | { | ||||||
1013 | 16 | 16 | 1 | 56 | my($self, @new_modes) = @_; | ||
1014 | |||||||
1015 | 16 | 23 | $self -> log(debug => 'run_modes(...)'); | ||||
1016 | |||||||
1017 | 16 | 1898 | my($old_modes) = $self -> _run_modes; | ||||
1018 | |||||||
1019 | 16 | 100 | 36 | if (@new_modes) | |||
1020 | { | ||||||
1021 | 7 | 17 | $old_modes = ref $new_modes[0] eq 'HASH' ? {%$old_modes, %{$new_modes[0]} } | ||||
1022 | 8 | 50 | 43 | : ref $new_modes[0] eq 'ARRAY' ? {%$old_modes, map{($_ => $_)} @{$new_modes[0]} } | |||
0 | 50 | 0 | |||||
0 | 100 | 0 | |||||
1023 | : scalar(@new_modes) % 2 == 0 ? {%$old_modes, @new_modes} | ||||||
1024 | : croak "Error: Odd number of parameters passed to run_modes()\n"; | ||||||
1025 | |||||||
1026 | 8 | 25 | $self -> _run_modes($old_modes); | ||||
1027 | } | ||||||
1028 | |||||||
1029 | 16 | 51 | return %$old_modes; | ||||
1030 | |||||||
1031 | } # End of run_modes. | ||||||
1032 | |||||||
1033 | # -------------------------------------------------- | ||||||
1034 | |||||||
1035 | sub setup | ||||||
1036 | { | ||||||
1037 | 0 | 0 | 1 | 0 | my($self) = @_; | ||
1038 | |||||||
1039 | 0 | 0 | $self -> log(debug => 'setup()'); | ||||
1040 | |||||||
1041 | } # End of setup. | ||||||
1042 | |||||||
1043 | # -------------------------------------------------- | ||||||
1044 | |||||||
1045 | sub start_mode | ||||||
1046 | { | ||||||
1047 | 7 | 7 | 1 | 29 | my($self, $run_mode) = @_; | ||
1048 | |||||||
1049 | 7 | 50 | 13 | if ($run_mode) | |||
1050 | { | ||||||
1051 | 7 | 50 | 17 | $self -> _start_mode($run_mode = defined $run_mode ? $run_mode : ''); | |||
1052 | } | ||||||
1053 | else | ||||||
1054 | { | ||||||
1055 | 0 | 0 | $run_mode = $self -> _start_mode; | ||||
1056 | } | ||||||
1057 | |||||||
1058 | 7 | 18 | $self -> log(debug => "start_mode($run_mode)"); | ||||
1059 | |||||||
1060 | 7 | 824 | return $self -> _start_mode; | ||||
1061 | |||||||
1062 | } # End of start_mode. | ||||||
1063 | |||||||
1064 | # -------------------------------------------------- | ||||||
1065 | |||||||
1066 | sub teardown | ||||||
1067 | { | ||||||
1068 | 7 | 7 | 1 | 8 | my($self) = @_; | ||
1069 | |||||||
1070 | 7 | 13 | $self -> log(debug => 'teardown()'); | ||||
1071 | |||||||
1072 | } # End of teardown. | ||||||
1073 | |||||||
1074 | # -------------------------------------------------- | ||||||
1075 | |||||||
1076 | 1; | ||||||
1077 | |||||||
1078 | =pod | ||||||
1079 | |||||||
1080 | =head1 NAME | ||||||
1081 | |||||||
1082 | CGI::Snapp - An almost back-compat fork of CGI::Application | ||||||
1083 | |||||||
1084 | =head1 Synopsis | ||||||
1085 | |||||||
1086 | In general, use as you would L |
||||||
1087 | |||||||
1088 | But be warned, load_tmp() and tmp_path() in particular are not supported, because they're too tied to the L |
||||||
1089 | |||||||
1090 | =head1 Description | ||||||
1091 | |||||||
1092 | A fork of L |
||||||
1093 | production - I |
||||||
1094 | |||||||
1095 | You are I |
||||||
1096 | |||||||
1097 | =head1 The Flow of Control | ||||||
1098 | |||||||
1099 | This is a short article on which methods get called in which order. Steve Comrie has written a version for L |
||||||
1100 | L |
||||||
1101 | |||||||
1102 | =head2 An Overview | ||||||
1103 | |||||||
1104 | If you have trouble following this explanation, consider working thru the tests (t/*.pl called by t/test.t) shipped with this distro. | ||||||
1105 | |||||||
1106 | Now, under normal circumstances, your CGI script receives CGI form data and accesses it via an object of type L |
||||||
1107 | |||||||
1108 | Let's say you have a CGI form field called 'rm', and when the user submits the form, that field has the value 'start'. | ||||||
1109 | |||||||
1110 | Then in the terminology of this module, and its predecessor, 'start' is called a run mode. | ||||||
1111 | |||||||
1112 | (In fact, 'rm' is the default name of the CGI form field this module uses to find the name of the run mode. And, when that CGI form field's name does not exist, or is empty, the | ||||||
1113 | default run mode is 'start'.) | ||||||
1114 | |||||||
1115 | Then L |
||||||
1116 | |||||||
1117 | How does it use 'start' to find the name of the method? By examining a dispatch table (a hash), which is explained under | ||||||
1118 | L. 'start' is the key, and (in the simplest case) the value is the name of a method. | ||||||
1119 | |||||||
1120 | Your run mode methods must all I |
||||||
1121 | |||||||
1122 | You can of course override the defaults just mentioned: | ||||||
1123 | |||||||
1124 | =over 4 | ||||||
1125 | |||||||
1126 | =item o The default CGI form field name 'rm' | ||||||
1127 | |||||||
1128 | Method L allows you to change that CGI form field name from 'rm' to another string, amongst other options. | ||||||
1129 | |||||||
1130 | =item o The default run mode 'start' | ||||||
1131 | |||||||
1132 | Method L allows you to change that run mode 'start' to another string. | ||||||
1133 | |||||||
1134 | =item o The default association between 'start' and 'dump_html()' | ||||||
1135 | |||||||
1136 | Method L allows you to associate any run mode name with any method name. | ||||||
1137 | |||||||
1138 | =back | ||||||
1139 | |||||||
1140 | =head2 The Simple View | ||||||
1141 | |||||||
1142 | So, a basic L |
||||||
1143 | |||||||
1144 | #!/usr/bin/env perl | ||||||
1145 | |||||||
1146 | use KillerApp; | ||||||
1147 | KillerApp -> new -> run; | ||||||
1148 | |||||||
1149 | Here's what happens as L |
||||||
1150 | |||||||
1151 | =over 4 | ||||||
1152 | |||||||
1153 | =item o The call to new(): | ||||||
1154 | |||||||
1155 | This calls some initialization code, which you never override (so we ignore it), and then calls, in this order: | ||||||
1156 | |||||||
1157 | =over 4 | ||||||
1158 | |||||||
1159 | =item o 1: cgiapp_init(@args) | ||||||
1160 | |||||||
1161 | Here, @args is the array of options passed in to L. | ||||||
1162 | |||||||
1163 | =item o 2: setup() | ||||||
1164 | |||||||
1165 | =back | ||||||
1166 | |||||||
1167 | These 2 methods give you scope to set up anything you want before your run mode method is activated, by sub-classing L |
||||||
1168 | |||||||
1169 | For instance, if we have this inheritance structure: CGI::Snapp --> parent of --> GlobalApp --> parent of --> SpecificApp, then one or both of these methods could be | ||||||
1170 | implemented in GlobalApp and/or in SpecificApp. This would allow yet other descendents of GlobalApp (in parallel with SpecificApp) to share GlobalApp's code, and at the same time | ||||||
1171 | implement their own run methods. | ||||||
1172 | |||||||
1173 | After calling L, a call to L will return undef, since determination of the run mode only takes place during the call to L. | ||||||
1174 | |||||||
1175 | =item o The call to run(): | ||||||
1176 | |||||||
1177 | This in turn calls: | ||||||
1178 | |||||||
1179 | =over 4 | ||||||
1180 | |||||||
1181 | =item o 3: mode_param([@new_options]) | ||||||
1182 | |||||||
1183 | =back | ||||||
1184 | |||||||
1185 | So now we know how you want run modes to be determined. See L for how to control this mechanism. | ||||||
1186 | |||||||
1187 | Then it calls internal code to get the name of the run mode, using - by default - the L |
||||||
1188 | |||||||
1189 | Finally, methods are called in this order: | ||||||
1190 | |||||||
1191 | =over 4 | ||||||
1192 | |||||||
1193 | =item o 4: cgiapp_prerun($run_mode) | ||||||
1194 | |||||||
1195 | During this call (and at no other time), you can call L to change the name of the run mode which is about to be executed. | ||||||
1196 | |||||||
1197 | =item o 5: your_run_mode_method() | ||||||
1198 | |||||||
1199 | This is found via the dispatch table described at length under L | ||||||
1200 | |||||||
1201 | The name of the run mode is the key used to find this method name in the dispatch table (which is just a hash). | ||||||
1202 | |||||||
1203 | Your run mode method must return a string, or a scalarref to a string, containing the HTML to be output to the HTTP client (normally a browser of course). | ||||||
1204 | |||||||
1205 | See note 1 (just below) on what parameters are passed to the method. | ||||||
1206 | |||||||
1207 | See note 2 (just below) on what happens if the key is not present in the dispatch table. | ||||||
1208 | |||||||
1209 | See note 3 (just below) on what happens if the run mode method fails to run. | ||||||
1210 | |||||||
1211 | =item o 6: cgiapp_postrun(\$html) | ||||||
1212 | |||||||
1213 | A scalarref of the generated HTML is passed in to cgiapp_postrun(), which can overwrite that HTML if desired. | ||||||
1214 | |||||||
1215 | Now, the HTTP headers are generated, and both those headers and the HTML are sent to the HTTP client. You can stop the transmission with L. | ||||||
1216 | |||||||
1217 | utf8::downgrade() is used to turn off any stray UTF-8 bits on the headers. | ||||||
1218 | |||||||
1219 | =item o 7: teardown() | ||||||
1220 | |||||||
1221 | Here's where you clean up, by disconnecting from the database, or whatever. | ||||||
1222 | |||||||
1223 | =back | ||||||
1224 | |||||||
1225 | =back | ||||||
1226 | |||||||
1227 | =head3 Note 1: Parameters passed to your run mode method | ||||||
1228 | |||||||
1229 | Normally, the only parameter passed is $self, which is an object of type L |
||||||
1230 | |||||||
1231 | However, if the method was invoked via the AUTOLOAD mechanism (note 2), the next parameter is the run mode. | ||||||
1232 | |||||||
1233 | Lastly, if the method was invoked via L |
||||||
1234 | |||||||
1235 | =head3 Note 2: When the run mode is not a key in the dispatch table, this algorithm is invoked | ||||||
1236 | |||||||
1237 | =over 4 | ||||||
1238 | |||||||
1239 | =item o The AUTOLOAD run mode | ||||||
1240 | |||||||
1241 | The code checks if you have defined a run mode named 'AUTOLOAD'. If so, it's value in the dispatch table is used as the method name. | ||||||
1242 | |||||||
1243 | =item o Fallback | ||||||
1244 | |||||||
1245 | If no run mode called 'AUTOLOAD' is found, the code calls L |
||||||
1246 | |||||||
1247 | =back | ||||||
1248 | |||||||
1249 | =head3 Note 3: When the run mode method fails to run, this algorithm is invoked | ||||||
1250 | |||||||
1251 | =over 4 | ||||||
1252 | |||||||
1253 | =item o The error hook | ||||||
1254 | |||||||
1255 | The method, if any, attached to the 'error' hook is called. The error message generated from the run mode method's failure is passed as the parameter, for you to utilize when deciding what | ||||||
1256 | action to take. | ||||||
1257 | |||||||
1258 | Hooks are discussed under L just below. | ||||||
1259 | |||||||
1260 | =item o The error_mode method | ||||||
1261 | |||||||
1262 | Next, L |
||||||
1263 | |||||||
1264 | =item o Fallback | ||||||
1265 | |||||||
1266 | Finally, if L |
||||||
1267 | |||||||
1268 | =back | ||||||
1269 | |||||||
1270 | Aren't you glad that was the I |
||||||
1271 | |||||||
1272 | =head2 A More Complex View | ||||||
1273 | |||||||
1274 | L |
||||||
1275 | |||||||
1276 | See the Wikipedia article L |
||||||
1277 | |||||||
1278 | It works like this: A hook name is a key in a hash, and the corresponding value is a package name, which in turn points to an arrayref of method names. So, for a given hook name and | ||||||
1279 | package, we can execute a series of named methods, where those names are listed in that arrayref. | ||||||
1280 | |||||||
1281 | The hooked methods are not expected to return anything. | ||||||
1282 | |||||||
1283 | Here's the default set of hooks aka (default) dispatch table. It's just a hash with fancy values per key: | ||||||
1284 | |||||||
1285 | my(%class_callback) = | ||||||
1286 | ( | ||||||
1287 | error => {}, | ||||||
1288 | forward_prerun => {}, | ||||||
1289 | init => {'CGI::Snapp' => ['cgiapp_init']}, | ||||||
1290 | prerun => {'CGI::Snapp' => ['cgiapp_prerun']}, | ||||||
1291 | postrun => {'CGI::Snapp' => ['cgiapp_postrun']}, | ||||||
1292 | teardown => {'CGI::Snapp' => ['teardown']}, | ||||||
1293 | ); | ||||||
1294 | |||||||
1295 | An explanation: | ||||||
1296 | |||||||
1297 | =over 4 | ||||||
1298 | |||||||
1299 | =item o Yes, there are class-level callbacks and object-level callbacks | ||||||
1300 | |||||||
1301 | See L for details. | ||||||
1302 | |||||||
1303 | =item o The error hook | ||||||
1304 | |||||||
1305 | By default, there is no method attached to the 'error' hook. See L for details. | ||||||
1306 | |||||||
1307 | =item o The init hook | ||||||
1308 | |||||||
1309 | Instead of calling cgiapp_init() directly at the start of the run as alleged above, we call all those methods named as belonging to the 'init' hook, of which - here - there is just the | ||||||
1310 | default one, CGI::Snapp::cgiapp_init(). | ||||||
1311 | |||||||
1312 | =item o The prerun hook | ||||||
1313 | |||||||
1314 | Likewise. | ||||||
1315 | |||||||
1316 | =item o The postrun hook | ||||||
1317 | |||||||
1318 | Likewise. | ||||||
1319 | |||||||
1320 | =item o The teardown hook | ||||||
1321 | |||||||
1322 | Likewise, instead of calling teardown() directly at the finish of the run, we call all those methods named as belonging to the 'teardown' hook, starting with (the default) CGI::Snapp::teardown(). | ||||||
1323 | |||||||
1324 | =back | ||||||
1325 | |||||||
1326 | Now, when I say 'all those methods', that's because you can add your own hooked methods, to enhance this process. What happens is that your hooks are pushed onto the stack of hooked methods | ||||||
1327 | attached to a given hook name, and run in turn at the appropriate time. | ||||||
1328 | |||||||
1329 | Further, besides extending the stack of methods attached to a pre-existing hook name, you can create new hook names, and attach any number of methods to each. | ||||||
1330 | |||||||
1331 | The pre-defined hooks are called 'error', 'init', 'prerun', 'postrun' and 'teardown', so there is no need to call L for those. | ||||||
1332 | |||||||
1333 | This matter is discussed in depth under the entry for L. Also, see L and L for how hooks are named and invoked. | ||||||
1334 | |||||||
1335 | Sample code is in t/callback.pl, in the distro. | ||||||
1336 | |||||||
1337 | =head1 Distributions | ||||||
1338 | |||||||
1339 | This module is available as a Unix-style distro (*.tgz). | ||||||
1340 | |||||||
1341 | See L |
||||||
1342 | for help on unpacking and installing distros. | ||||||
1343 | |||||||
1344 | =head1 Installation | ||||||
1345 | |||||||
1346 | Install L |
||||||
1347 | |||||||
1348 | Run: | ||||||
1349 | |||||||
1350 | cpanm CGI::Snapp | ||||||
1351 | |||||||
1352 | or run: | ||||||
1353 | |||||||
1354 | sudo cpan CGI::Snapp | ||||||
1355 | |||||||
1356 | or unpack the distro, and then either: | ||||||
1357 | |||||||
1358 | perl Build.PL | ||||||
1359 | ./Build | ||||||
1360 | ./Build test | ||||||
1361 | sudo ./Build install | ||||||
1362 | |||||||
1363 | or: | ||||||
1364 | |||||||
1365 | perl Makefile.PL | ||||||
1366 | make (or dmake or nmake) | ||||||
1367 | make test | ||||||
1368 | make install | ||||||
1369 | |||||||
1370 | =head1 Constructor and Initialization | ||||||
1371 | |||||||
1372 | C |
||||||
1373 | |||||||
1374 | It returns a new object of type C |
||||||
1375 | |||||||
1376 | Key-value pairs accepted in the parameter list (see corresponding methods for details | ||||||
1377 | [e.g. L]): | ||||||
1378 | |||||||
1379 | =over 4 | ||||||
1380 | |||||||
1381 | =item o logger => $aLoggerObject | ||||||
1382 | |||||||
1383 | Specify a logger compatible with L |
||||||
1384 | |||||||
1385 | Default: '' (The empty string). | ||||||
1386 | |||||||
1387 | To clarify: The built-in calls to log() all use a log level of 'debug', so if your logger has 'maxlevel' set | ||||||
1388 | to anything less than 'debug', nothing will get logged. | ||||||
1389 | |||||||
1390 | 'maxlevel' and 'minlevel' are discussed in L |
||||||
1391 | |||||||
1392 | Also, see L and L. | ||||||
1393 | |||||||
1394 | =item o PARAMS => $hashref | ||||||
1395 | |||||||
1396 | Provides a set of ($key => $value) pairs as initial data available to your sub-class of L |
||||||
1397 | |||||||
1398 | Default: {}. | ||||||
1399 | |||||||
1400 | =item o send_output => $Boolean | ||||||
1401 | |||||||
1402 | Controls whether or not the HTML output is sent (printed) to the HTTP client. | ||||||
1403 | |||||||
1404 | This corresponds to L |
||||||
1405 | |||||||
1406 | Default: 1 (meaning yes, send). However, if $ENV{CGI_SNAPP_RETURN_ONLY} has a Perlish true value, the default is 0. | ||||||
1407 | |||||||
1408 | Using 0 means you have to get the output from the return value of the L method. | ||||||
1409 | |||||||
1410 | =item o QUERY => $q | ||||||
1411 | |||||||
1412 | Provides L with a pre-created L |
||||||
1413 | |||||||
1414 | Default: ''. | ||||||
1415 | |||||||
1416 | However, a new L |
||||||
1417 | |||||||
1418 | =back | ||||||
1419 | |||||||
1420 | =head1 Methods | ||||||
1421 | |||||||
1422 | =head2 add_callback($hook, $option) | ||||||
1423 | |||||||
1424 | Adds another method to the stack of methods associated with $hook. | ||||||
1425 | |||||||
1426 | $hook is the name of a hook. $hook is forced to be lower-case. | ||||||
1427 | |||||||
1428 | Returns nothing. | ||||||
1429 | |||||||
1430 | That name is either pre-defined (see L) or one of your own, which you've previously set up with L. | ||||||
1431 | |||||||
1432 | Sample code: | ||||||
1433 | |||||||
1434 | # Class-level callbacks. | ||||||
1435 | $class_name -> add_callback('init', \&method_1); | ||||||
1436 | KillerApp -> add_callback('init', 'method_2'); | ||||||
1437 | |||||||
1438 | # Object-level callbacks. | ||||||
1439 | $app = CGI::Snapp -> new; | ||||||
1440 | $app -> add_callback('init', \&method_3); | ||||||
1441 | |||||||
1442 | Notes: | ||||||
1443 | |||||||
1444 | =over 4 | ||||||
1445 | |||||||
1446 | =item o Callback lifetimes | ||||||
1447 | |||||||
1448 | Class-level callbacks outlive the life of the $app object (of type L |
||||||
1449 | environment like L |
||||||
1450 | |||||||
1451 | Object-level callbacks, however, go out of scope at the same time the $app object itself does. | ||||||
1452 | |||||||
1453 | =item o The class hierarchy | ||||||
1454 | |||||||
1455 | Callbacks can be registered by an object, or any of its parent classes, all the way up the hierarchy to L |
||||||
1456 | |||||||
1457 | =item o Callback name resolution | ||||||
1458 | |||||||
1459 | Callback names are checked, and only the first with a given name is called. The type of callback, class or object, is ignored in this test, as it is in L |
||||||
1460 | This also means, that if there are 2 callbacks with the same name, in different classes, then still only the first is called. | ||||||
1461 | |||||||
1462 | Consider: | ||||||
1463 | |||||||
1464 | In Class A: $self -> add_callback('teardown', 'teardown_sub'); | ||||||
1465 | In Class B: $self -> add_callback('teardown', 'teardown_sub'); | ||||||
1466 | |||||||
1467 | Here, because the names are the same, only one (1) teardown_sub() will be called. Which one called depends on the order in which those calls to add_callback() take place. | ||||||
1468 | |||||||
1469 | In Class A: $self -> add_callback('teardown', \&teardown_sub); | ||||||
1470 | In Class B: $self -> add_callback('teardown', \&teardown_sub); | ||||||
1471 | |||||||
1472 | This time, both teardown_sub()s are called, because what's passed to add_callback() are 2 subrefs, which are memory addresses, and can't be the same for 2 different subs. | ||||||
1473 | |||||||
1474 | =item o Pre-defined hooks | ||||||
1475 | |||||||
1476 | Only the pre-defined hooks are called by L |
||||||
1477 | |||||||
1478 | The pre-defined hooks are called 'error', 'init', 'prerun', 'postrun' and 'teardown', and there is no need to call L for those. | ||||||
1479 | |||||||
1480 | =item o Class-level callbacks | ||||||
1481 | |||||||
1482 | These belong to the class of the object calling L. | ||||||
1483 | |||||||
1484 | =item o Multiple callbacks for a given hook | ||||||
1485 | |||||||
1486 | If multiple I |
||||||
1487 | That it, the callback for the most derived class is executed first. This is the way normal class-hierarchy overrides work - nothing unexpected here. | ||||||
1488 | |||||||
1489 | If multiple I |
||||||
1490 | callbacks). | ||||||
1491 | |||||||
1492 | If multiple I | ||||||
1493 | |||||||
1494 | =item o The 'init' hook | ||||||
1495 | |||||||
1496 | Since the 'init' hook is triggered during the call to L, even before L is called, there is no opportunity for normal end-user code (your sub-class of L |
||||||
1497 | a callback to this hook. | ||||||
1498 | |||||||
1499 | The way around this is to write a class which is I |
||||||
1500 | |||||||
1501 | There is a group of examples on how to do this. Start with t/hook.test.a.pl, which 'use's t/lib/CGI/Snapp/HookTestA.pm, which in turn 'use's t/lib/CGI/Snapp/Plugin/HookTest1.pm. | ||||||
1502 | |||||||
1503 | Alternately, examine the source code of L |
||||||
1504 | |||||||
1505 | =back | ||||||
1506 | |||||||
1507 | To summarize, you are I |
||||||
1508 | statements in your sub-class of L |
||||||
1509 | |||||||
1510 | =head2 add_header(@headers) | ||||||
1511 | |||||||
1512 | Adds headers to the list which will be sent to the HTTP client. | ||||||
1513 | |||||||
1514 | Returns all headers as a hash. | ||||||
1515 | |||||||
1516 | See also L, L, L, L and L. | ||||||
1517 | |||||||
1518 | =head2 call_hook($hook, @args) | ||||||
1519 | |||||||
1520 | Call the named hook. $hook is forced to be lower-case. | ||||||
1521 | |||||||
1522 | Returns a hashref of the number of callbacks actually called, where the keys are 'class' and 'object', and the values are integer counts. | ||||||
1523 | |||||||
1524 | @args takes various values, depending on the name of the callback: | ||||||
1525 | |||||||
1526 | =over 4 | ||||||
1527 | |||||||
1528 | =item o init | ||||||
1529 | |||||||
1530 | Here, @args is the hash of options passed in to L. | ||||||
1531 | |||||||
1532 | Defaults to calling CGI::Snapp::cgiapp_init(@args). | ||||||
1533 | |||||||
1534 | =item o prerun | ||||||
1535 | |||||||
1536 | @args is the name of the run mode. | ||||||
1537 | |||||||
1538 | Defaults to calling CGI::Snapp::cgiapp_prerun($run_mode). | ||||||
1539 | |||||||
1540 | =item o postrun | ||||||
1541 | |||||||
1542 | @args is a scalarref, where the scalar is the output generated by the run mode method. This scalar does not yet have the HTTP headers attatched (if any). | ||||||
1543 | |||||||
1544 | Defaults to calling CGI::Snapp::cgiapp_postrun(\$html). | ||||||
1545 | |||||||
1546 | =item o teardown | ||||||
1547 | |||||||
1548 | @args is not used in this case. | ||||||
1549 | |||||||
1550 | Defauts to calling CGI::Snapp::teardown(). | ||||||
1551 | |||||||
1552 | =back | ||||||
1553 | |||||||
1554 | If you call an unregistered hook, the call is just ignored. | ||||||
1555 | |||||||
1556 | See L and L if you wish to register a new type of hook. | ||||||
1557 | |||||||
1558 | =head2 cgiapp_get_query() | ||||||
1559 | |||||||
1560 | Returns the query object. | ||||||
1561 | |||||||
1562 | This method only creates an object of type L |
||||||
1563 | |||||||
1564 | Alternately, you can pass your own query object to the L method. | ||||||
1565 | |||||||
1566 | You can override this method in your sub-class, if you wish to provide a L |
||||||
1567 | |||||||
1568 | =over 4 | ||||||
1569 | |||||||
1570 | =item o The object must have a param() method | ||||||
1571 | |||||||
1572 | Normally, your object just needs to have a L method, for it to be 'similar enough' to a L |
||||||
1573 | |||||||
1574 | =item o The object may need a header() method | ||||||
1575 | |||||||
1576 | This is called if L returns 'header'. | ||||||
1577 | |||||||
1578 | =item o The object may need a redirect() method | ||||||
1579 | |||||||
1580 | This is called if L returns 'redirect'. | ||||||
1581 | |||||||
1582 | =item o If you use the 'path_info' option in the call to L | ||||||
1583 | |||||||
1584 | In this case the path_info() method will be called on your object. | ||||||
1585 | |||||||
1586 | =item o If you call L, which is the default run mode method for the default run mode 'start' | ||||||
1587 | |||||||
1588 | Lastly, if you don't override the 'start' run mode, the L method (of L |
||||||
1589 | |||||||
1590 | =back | ||||||
1591 | |||||||
1592 | =head2 cgiapp_init() | ||||||
1593 | |||||||
1594 | Does nothing. You implement it in a sub-class, if desired. | ||||||
1595 | |||||||
1596 | Defaults to returning nothing. | ||||||
1597 | |||||||
1598 | =head2 cgiapp_prerun() | ||||||
1599 | |||||||
1600 | Does nothing. You implement it in a sub-class, if desired. | ||||||
1601 | |||||||
1602 | Defaults to returning nothing. | ||||||
1603 | |||||||
1604 | =head2 cgiapp_postrun() | ||||||
1605 | |||||||
1606 | Does nothing. You implement it in a sub-class, if desired. | ||||||
1607 | |||||||
1608 | Defaults to returning nothing. | ||||||
1609 | |||||||
1610 | =head2 delete($key) | ||||||
1611 | |||||||
1612 | Deletes a (key => value) pair from the hash of private storage managed by L, so a later call to param($key) will return undef. | ||||||
1613 | |||||||
1614 | Returns the value deleted, or undef if $key is absent. | ||||||
1615 | |||||||
1616 | =head2 delete_header(@keys) | ||||||
1617 | |||||||
1618 | Deletes headers from the list which will be sent to the HTTP client. | ||||||
1619 | |||||||
1620 | @keys are the names of the headers you wish to delete. | ||||||
1621 | |||||||
1622 | Returns the remaining headers as a hash. | ||||||
1623 | |||||||
1624 | See also L, L, L, L and L. | ||||||
1625 | |||||||
1626 | =head2 dump() | ||||||
1627 | |||||||
1628 | Returns the same string as does L, but without any HTML. | ||||||
1629 | |||||||
1630 | =head2 dump_html() | ||||||
1631 | |||||||
1632 | Returns a nicely-formatted block of HTML, i.e. a set of paragraphs, containing: | ||||||
1633 | |||||||
1634 | =over 4 | ||||||
1635 | |||||||
1636 | =item o The run mode | ||||||
1637 | |||||||
1638 | =item o The query parameters | ||||||
1639 | |||||||
1640 | This is derived from the query object's Dump() method. | ||||||
1641 | |||||||
1642 | =item o The environment | ||||||
1643 | |||||||
1644 | This is derived from %ENV. | ||||||
1645 | |||||||
1646 | =back | ||||||
1647 | |||||||
1648 | See L for how to influence the type of query object used. | ||||||
1649 | |||||||
1650 | =head2 error_mode([$method_name]) | ||||||
1651 | |||||||
1652 | Sets and gets the name of the error mode method. | ||||||
1653 | |||||||
1654 | Note: This is a method name, not a run mode as is returned from L. | ||||||
1655 | |||||||
1656 | Here, the [] indicate an optional parameter. | ||||||
1657 | |||||||
1658 | Default: ''. | ||||||
1659 | |||||||
1660 | Returns the current error mode method name. | ||||||
1661 | |||||||
1662 | =head2 forward($run_mode[, @args]) | ||||||
1663 | |||||||
1664 | Switches from the current run mode to the given $run_mode, passing the optional @args to the new mode's method. | ||||||
1665 | |||||||
1666 | For this to work, you must have previously called $self -> run_modes($run_mode => 'some_method'), so the code | ||||||
1667 | knows which method it must call. | ||||||
1668 | |||||||
1669 | Just before the method associated with $run_mode is invoked, the current run mode is set to $run_mode, and any | ||||||
1670 | methods attached to the hook 'forward_prerun' are called. | ||||||
1671 | |||||||
1672 | Calling this hook gives you the opportunity of making any preparations you wish before the new run mode is entered. | ||||||
1673 | |||||||
1674 | Finally, $run_mode's method is called, using @args as its arguments. | ||||||
1675 | |||||||
1676 | Returns the output of the $run_mode's method. | ||||||
1677 | |||||||
1678 | See t/forward.t and t/lib/CGI/Snapp/ForwardTest.pm for sample code. | ||||||
1679 | |||||||
1680 | If you wish to interrupt the current request, and redirect to an external url, then the | ||||||
1681 | L method is probably what you want. | ||||||
1682 | |||||||
1683 | =head2 get_current_runmode() | ||||||
1684 | |||||||
1685 | Returns the name of the current run mode. | ||||||
1686 | |||||||
1687 | =head2 header_add(@headers) | ||||||
1688 | |||||||
1689 | Adds I |
||||||
1690 | This strange behaviour is copied directly from L |
||||||
1691 | |||||||
1692 | Returns the remaining headers as a hash. | ||||||
1693 | |||||||
1694 | Deprecated. | ||||||
1695 | |||||||
1696 | See also L, L, L, L and L. | ||||||
1697 | |||||||
1698 | =head2 get_callbacks($type, $hook) | ||||||
1699 | |||||||
1700 | Gets callback information associated with the given $type (class/object) and $hook. | ||||||
1701 | |||||||
1702 | $type is 'class' for class-level callbacks, and 'object' for object-level callbacks. | ||||||
1703 | |||||||
1704 | Values for $type: | ||||||
1705 | |||||||
1706 | =over 4 | ||||||
1707 | |||||||
1708 | =item o 'class' | ||||||
1709 | |||||||
1710 | get_callbacks('class', $hook) returns a I |
||||||
1711 | |||||||
1712 | The keys of this hashref are the class names which have registered callbacks for $hook. | ||||||
1713 | |||||||
1714 | The values of this hashref are arrayrefs of method names or references. | ||||||
1715 | |||||||
1716 | =item o 'object' | ||||||
1717 | |||||||
1718 | get_callbacks('object', $hook) returns an I |
||||||
1719 | |||||||
1720 | The values of this arrayref are arrayrefs of method names or references. | ||||||
1721 | |||||||
1722 | =back | ||||||
1723 | |||||||
1724 | See t/defaults.pl for sample code. | ||||||
1725 | |||||||
1726 | =head2 header_props([@headers]) | ||||||
1727 | |||||||
1728 | Sets the headers to be sent to the HTTP client. These headers are expected to be a hash of L |
||||||
1729 | These properties will be ignored (sic) or passed directly to the header() or redirect() method of the L object, depending on the value returned by L. | ||||||
1730 | |||||||
1731 | Returns all headers as a hash. | ||||||
1732 | |||||||
1733 | See also L, L, L, L and L. | ||||||
1734 | |||||||
1735 | =head2 header_type([$option]) | ||||||
1736 | |||||||
1737 | Sets and gets the type of HTTP headers to output. | ||||||
1738 | |||||||
1739 | Here, the [] indicate an optional parameter. | ||||||
1740 | |||||||
1741 | Returns the current header type. | ||||||
1742 | |||||||
1743 | Possible values for $option: | ||||||
1744 | |||||||
1745 | =over 4 | ||||||
1746 | |||||||
1747 | =item o 'header' | ||||||
1748 | |||||||
1749 | The default. Uses the hash returned by L to generate a set of HTTP headers to send to the HTTP client. | ||||||
1750 | |||||||
1751 | =item o 'none' | ||||||
1752 | |||||||
1753 | Don't output any headers. See also the L method. | ||||||
1754 | |||||||
1755 | In this case the HTTP status is set to 200. | ||||||
1756 | |||||||
1757 | =item o 'redirect' | ||||||
1758 | |||||||
1759 | Generates a redirection header to send to the HTTP client. | ||||||
1760 | |||||||
1761 | =back | ||||||
1762 | |||||||
1763 | =head2 log($level, $string) | ||||||
1764 | |||||||
1765 | If a logger object exists, then this calls the log() method of that object, passing it $level and $string. | ||||||
1766 | |||||||
1767 | Returns nothing. | ||||||
1768 | |||||||
1769 | So, the body of this method consists of this 1 line: | ||||||
1770 | |||||||
1771 | $self -> logger -> log($level => $string) if ($self && $self -> logger); | ||||||
1772 | |||||||
1773 | Up until V 1.03, this used to call $self -> logger -> $level($s), but the change was made to allow | ||||||
1774 | simpler loggers, meaning they did not have to implement all the methods covered by $level(). | ||||||
1775 | See CHANGES for details. For more on log levels, see L |
||||||
1776 | |||||||
1777 | =head2 logger([$logger_object]) | ||||||
1778 | |||||||
1779 | Sets and gets the logger object (of type L |
||||||
1780 | |||||||
1781 | Here, the [] indicate an optional parameter. | ||||||
1782 | |||||||
1783 | 'logger' is a parameter to L. See L for details. | ||||||
1784 | |||||||
1785 | Also, see L. | ||||||
1786 | |||||||
1787 | =head2 mode_param([@new_options]) | ||||||
1788 | |||||||
1789 | Sets and gets the option which defines how to determine the run mode. | ||||||
1790 | |||||||
1791 | Returns the current setting. | ||||||
1792 | |||||||
1793 | Here, the [] indicate an optional parameter. | ||||||
1794 | |||||||
1795 | There are various values which @new_options can take: | ||||||
1796 | |||||||
1797 | =over 4 | ||||||
1798 | |||||||
1799 | =item o Not specified | ||||||
1800 | |||||||
1801 | Just returns the current setting. | ||||||
1802 | |||||||
1803 | =item o A string | ||||||
1804 | |||||||
1805 | The value of that string ($new_options[0]) is the name of the CGI form field, and the value of this form field will be the name of the run mode. | ||||||
1806 | |||||||
1807 | So, mode_param('rm') means the CGI form field called 'rm' contains the name of the run mode. This is the default. | ||||||
1808 | |||||||
1809 | =item o A subref | ||||||
1810 | |||||||
1811 | If $new_options[0] is a reference to a callback (method), call that method when appropriate to determine the run mode. | ||||||
1812 | |||||||
1813 | See t/run.modes.pl's test_7() for an example of this. It uses t/lib/CGI/Snapp/RunModes.pm. | ||||||
1814 | |||||||
1815 | =item o 2 * N parameters, specified as a arrayref, hashref or array | ||||||
1816 | |||||||
1817 | Here, 2 * N means there must be an even number of parameters, or the code calls L |
||||||
1818 | |||||||
1819 | The array is expected to be of the form: (path_info => $integer[, param => $string]). | ||||||
1820 | |||||||
1821 | Use (path_info => $integer) to set the run mode from the value of $ENV{PATH_INFO}, which in turn is set by the web server from the path info sent by the HTTP client. | ||||||
1822 | (path_info => 0) means $ENV{PATH_INFO} is ignored. The $integer is explained in full just below. | ||||||
1823 | |||||||
1824 | If the optional (param => $string) part is supplied, then $string will be name of the CGI form field to use if there is no $ENV{PATH_INFO}. | ||||||
1825 | |||||||
1826 | =back | ||||||
1827 | |||||||
1828 | The usage of (path_info => $integer): | ||||||
1829 | |||||||
1830 | Let's say $ENV{PATH_INFO} is 'a/b/c/d/e'. Then here's how to use $integer to select various components of that path info: | ||||||
1831 | |||||||
1832 | =over 4 | ||||||
1833 | |||||||
1834 | =item o (path_info => 1): 'a' will be the run mode. | ||||||
1835 | |||||||
1836 | =item o (path_info => 2): 'b' will be the run mode. And so on... | ||||||
1837 | |||||||
1838 | =item o (path_info => -1): 'e' will be the run mode. | ||||||
1839 | |||||||
1840 | =item o (path_info => -2): 'd' will be the run mode. And so on... | ||||||
1841 | |||||||
1842 | =back | ||||||
1843 | |||||||
1844 | Summary: | ||||||
1845 | |||||||
1846 | In all cases, the name of the run mode determined - during a call to L - by your chosen mechanism I |
||||||
1847 | L method, since that hash is used to find the name of the method to call to process the given run mode. If it's not a key, the code calls L |
||||||
1848 | croak($message). | ||||||
1849 | |||||||
1850 | =head2 new() | ||||||
1851 | |||||||
1852 | See L for details on the parameters accepted by L. | ||||||
1853 | |||||||
1854 | Returns an object of type L |
||||||
1855 | |||||||
1856 | =head2 new_hook($hook) | ||||||
1857 | |||||||
1858 | Reserves a slot in the dispatch table for the named hook. $hook is forced to be lower-case. | ||||||
1859 | |||||||
1860 | Returns 1, since that's what L |
||||||
1861 | |||||||
1862 | The pre-defined slots are called 'error', 'init', 'prerun', 'postrun' and 'teardown', so there is no need to call new_hook() for those. | ||||||
1863 | |||||||
1864 | For help populating this slot, see L. | ||||||
1865 | |||||||
1866 | =head2 param([@params]) | ||||||
1867 | |||||||
1868 | Sets and gets application-specific ($key => $value) pairs. | ||||||
1869 | |||||||
1870 | I.e. implements a hash of private storage for your app, which can be initialized via new(PARAMS => {...}) or by calls to param(...). | ||||||
1871 | |||||||
1872 | Here, the [] indicate an optional parameter. | ||||||
1873 | |||||||
1874 | Use this to store special values, and retrieve them later. | ||||||
1875 | |||||||
1876 | Thus, you can at any stage do this: | ||||||
1877 | |||||||
1878 | $app -> param($key => $value); | ||||||
1879 | ... | ||||||
1880 | my($value) = $app -> param($key); | ||||||
1881 | |||||||
1882 | Or, in your CGI script, start with: | ||||||
1883 | |||||||
1884 | #!/usr/bin/env perl | ||||||
1885 | use KillerApp; | ||||||
1886 | my($config_file) = '/web/server/private/config/dir/config.ini'; | ||||||
1887 | KillerApp -> new(PARAMS => {config_file => $config_file}) -> run; | ||||||
1888 | |||||||
1889 | where your config file looks like: | ||||||
1890 | |||||||
1891 | [template_stuff] | ||||||
1892 | template_path = /web/server/private/template/dir/web.page.tx | ||||||
1893 | [other_stuff] | ||||||
1894 | ... | ||||||
1895 | |||||||
1896 | Then, in the L method, or the L method, in your sub-class of L |
||||||
1897 | |||||||
1898 | use Config::Plugin::Tiny; # Uses Config::Tiny. | ||||||
1899 | ... | ||||||
1900 | $self -> param(config => config_tiny($self -> param('config_file') ) ); | ||||||
1901 | ... | ||||||
1902 | my($template_path) = ${$self -> param('config')}{template_stuff}{template_path}; | ||||||
1903 | |||||||
1904 | In this way a set of 4-line CGI scripts with different config file names can run the same code. | ||||||
1905 | |||||||
1906 | Possible values for @params: | ||||||
1907 | |||||||
1908 | =over 4 | ||||||
1909 | |||||||
1910 | =item o Not specified | ||||||
1911 | |||||||
1912 | Returns an array of the names of the parameters previously set. | ||||||
1913 | |||||||
1914 | my(@names) = $self -> param; | ||||||
1915 | |||||||
1916 | =item o 1 parameter | ||||||
1917 | |||||||
1918 | Returns the value of the named parameter, or undef if it has not had a value set. | ||||||
1919 | |||||||
1920 | my($value) = $self -> param($name); | ||||||
1921 | |||||||
1922 | =item o 2 * N parameters, specified as a arrayref, hashref or array | ||||||
1923 | |||||||
1924 | Sets the N (key => value) pairs, for later retrieval. | ||||||
1925 | |||||||
1926 | Here, 2 * N means there must be an even number of parameters, or the code calls L |
||||||
1927 | |||||||
1928 | Further, if N == 1, returns the value supplied. | ||||||
1929 | |||||||
1930 | my($value) = $self -> param(key_1 => 'value_1'); # Returns 'value_1'. | ||||||
1931 | |||||||
1932 | $self -> param(key_1 => 'value_1', key_2 => 'value_2', ...); # Returns undef. | ||||||
1933 | |||||||
1934 | =back | ||||||
1935 | |||||||
1936 | =head2 prerun_mode($string) | ||||||
1937 | |||||||
1938 | Set the name of the run mode which is about to be executed. | ||||||
1939 | |||||||
1940 | Returns the current run mode. | ||||||
1941 | |||||||
1942 | prerun_mode($string) can only be called from with your L method. | ||||||
1943 | |||||||
1944 | Despite that restriction, L can use any information whatsoever to determine a run mode. | ||||||
1945 | |||||||
1946 | For example, it could get parameters from the query object, and use those, perhaps together with config data, to get yet more data from a database. | ||||||
1947 | |||||||
1948 | =head2 psgi_app($args_to_new) | ||||||
1949 | |||||||
1950 | Returns a L |
||||||
1951 | as a L |
||||||
1952 | |||||||
1953 | $args_to_new is a hashref of arguments that are passed into the constructor (L) of your application. | ||||||
1954 | |||||||
1955 | You can supply you own query object, with psgi_app({QUERY => Some::Object -> new}). But really there's no point. | ||||||
1956 | Just let the code create the default query object, which will be of type L |
||||||
1957 | |||||||
1958 | L |
||||||
1959 | |||||||
1960 | Note: This method, psgi_app(), is very similar to L |
||||||
1961 | this line (amongst other logic): | ||||||
1962 | |||||||
1963 | $app -> mode_param(sub {return $rm}) if ($rm); | ||||||
1964 | |||||||
1965 | where the current method does not. This means L |
||||||
1966 | sent from the web client, whereas if you use psgi_app(), your sub-class of L |
||||||
1967 | required to determine the run mode. | ||||||
1968 | |||||||
1969 | =head2 query([$q]) | ||||||
1970 | |||||||
1971 | Sets and gets the L |
||||||
1972 | |||||||
1973 | Here, the [] indicate an optional parameter. | ||||||
1974 | |||||||
1975 | Alternately, you can pass in such an object via the 'QUERY' parameter to L. | ||||||
1976 | |||||||
1977 | =head2 redirect($url[, $status]) | ||||||
1978 | |||||||
1979 | Interrupts the current request, and redirects to the given (external) $url, optionally setting the HTTP status to $status. | ||||||
1980 | |||||||
1981 | Here, the [] indicate an optional parameter. | ||||||
1982 | |||||||
1983 | The redirect happens even if you are inside a method attached to the 'prerun' hook when you call redirect(). | ||||||
1984 | |||||||
1985 | Specifically, this method does these 3 things: | ||||||
1986 | |||||||
1987 | =over 4 | ||||||
1988 | |||||||
1989 | =item o Sets the HTTP header 'location' to the given $url | ||||||
1990 | |||||||
1991 | =item o Sets the HTTP 'status' (if provided) to $status | ||||||
1992 | |||||||
1993 | =item o Sets the L |
||||||
1994 | |||||||
1995 | =back | ||||||
1996 | |||||||
1997 | See t/redirect.t and t/lib/CGI/Snapp/RedirectTest.pm for sample code. | ||||||
1998 | |||||||
1999 | If you just want to display the results of another run mode within the same application, then the | ||||||
2000 | L method is probably what you want. | ||||||
2001 | |||||||
2002 | =head2 run() | ||||||
2003 | |||||||
2004 | Returns the output generated by the run mode method. | ||||||
2005 | |||||||
2006 | See L for controlling whether or not this output is also sent to the HTTP client. | ||||||
2007 | |||||||
2008 | You must call the L method before anything useful can possibly happen. Here is a typical L |
||||||
2009 | |||||||
2010 | #!/usr/bin/env perl | ||||||
2011 | |||||||
2012 | use KillerApp; | ||||||
2013 | KillerApp -> new -> run; | ||||||
2014 | |||||||
2015 | See L for details of the many things which happen during the call to run(). | ||||||
2016 | |||||||
2017 | =head2 run_modes([$option]) | ||||||
2018 | |||||||
2019 | Sets and gets the dispatch table, which is just a hash mapping run mode names to method names. | ||||||
2020 | |||||||
2021 | Returns the dispatch table as a hash. | ||||||
2022 | |||||||
2023 | Here, the [] indicate an optional parameter. | ||||||
2024 | |||||||
2025 | When you call L the code firstly determines the run mode, and then calls run_modes() to get the dispatch table, | ||||||
2026 | and then calls a method by getting the method name from the value in this dispatch table corresponding to that run mode. | ||||||
2027 | |||||||
2028 | The parameter list passed to your run mode method is discussed in L. | ||||||
2029 | |||||||
2030 | There are 3 values which $option can take: | ||||||
2031 | |||||||
2032 | =over 4 | ||||||
2033 | |||||||
2034 | =item o An arrayref | ||||||
2035 | |||||||
2036 | This is an abbreviated way of specifying the dispatch table. The arrayref's elements are strings, each of which specifies a run mode and a method I |
||||||
2037 | |||||||
2038 | $app -> run_modes([qw/one two/]); | ||||||
2039 | |||||||
2040 | defines 2 run modes, 'one' and 'two', and these are automatically mapped (by L |
||||||
2041 | |||||||
2042 | It's very simple, and is, at least at first, probably all you'll need. It just requires you to implement the methods 'one' and 'two' in your sub-class of L |
||||||
2043 | |||||||
2044 | =item o A hashref | ||||||
2045 | |||||||
2046 | Use this to specify both the run modes and their corresponding method names. Thus, something like: | ||||||
2047 | |||||||
2048 | $app -> run_modes({one => 'sub_1', two => sub {}, three => \&sub_3}); | ||||||
2049 | |||||||
2050 | says you'll implement 3 methods: The first is a method called 'sub_1', the second is an anonymous sub, and the 3rd is the named subref. | ||||||
2051 | |||||||
2052 | =item o A hash | ||||||
2053 | |||||||
2054 | If $option is neither an arrayref nor a hashref, it is assumed to be an array (i.e. a hash!) and treated as though it were a hashref. | ||||||
2055 | |||||||
2056 | =back | ||||||
2057 | |||||||
2058 | Here's how the dispatch table is initialized: | ||||||
2059 | |||||||
2060 | =over 4 | ||||||
2061 | |||||||
2062 | =item o After calling new() | ||||||
2063 | |||||||
2064 | Since the default start mode is 'start', the dispatch table defaults to (start => 'dump_html'), where the L method is implemented in L |
||||||
2065 | Of course, you can override that in your sub-class. | ||||||
2066 | |||||||
2067 | =item o After calling new() and start_mode('first') | ||||||
2068 | |||||||
2069 | This time the dispatch table will still be (start => 'dump_html'), from calling L, but now if the code cannot determine a run mode from the L |
||||||
2070 | default to 'first', I |
||||||
2071 | |||||||
2072 | That means that if you call L, it only makes sense if you also call L where $option is {$run_mode => 'some sub name'}. | ||||||
2073 | |||||||
2074 | =back | ||||||
2075 | |||||||
2076 | Lastly, note that calling L does I |
||||||
2077 | See sub test_4 in t/run.modes.pl for instance. | ||||||
2078 | |||||||
2079 | =head2 send_output([$Boolean]) | ||||||
2080 | |||||||
2081 | Sets and gets the flag which determines whether or not the HTML output generated by your code is actually sent to the HTTP client. | ||||||
2082 | |||||||
2083 | Here, the [] indicate an optional parameter. | ||||||
2084 | |||||||
2085 | The default is 1, meaning yes, send the output to the HTTP client. | ||||||
2086 | |||||||
2087 | During your call to L, this code is executed: | ||||||
2088 | |||||||
2089 | $self -> send_output(0) if ($ENV{CGI_SNAPP_RETURN_ONLY}); | ||||||
2090 | |||||||
2091 | which means backward-compatible behaviour is supported for those people wishing to stick with L |
||||||
2092 | |||||||
2093 | And yes, any value which Perl regards as true will suffice for both this method and the value of that environment variable, not just the value 1. | ||||||
2094 | |||||||
2095 | The tests which ship with this mode, for example, almost always turn this flag off to stop output appearing which would confuse the test harness. | ||||||
2096 | The one time in testing when the flag is not reset is when I'm testing the default value of this flag. | ||||||
2097 | |||||||
2098 | 'send_output' is a parameter to L. See L for details. | ||||||
2099 | |||||||
2100 | =head2 setup() | ||||||
2101 | |||||||
2102 | Does nothing. You implement it in a sub-class, if desired. | ||||||
2103 | |||||||
2104 | Defaults to returning nothing. | ||||||
2105 | |||||||
2106 | =head2 start_mode([$run_mode]) | ||||||
2107 | |||||||
2108 | Sets and gets the name of the run mode to start from. | ||||||
2109 | |||||||
2110 | Returns the current start mode. | ||||||
2111 | |||||||
2112 | Here, the [] indicate an optional parameter. | ||||||
2113 | |||||||
2114 | Default: 'start'. | ||||||
2115 | |||||||
2116 | You're always going to need a start mode, because when your user first sends a request, to, say: | ||||||
2117 | |||||||
2118 | http://my.web.site/cgi-bin/script.cgi | ||||||
2119 | |||||||
2120 | there is no L |
||||||
2121 | |||||||
2122 | So, your code (script.cgi, which uses a sub-class of L |
||||||
2123 | |||||||
2124 | That is, your code must default to something, and the default is a run mode called 'start', which defaults to calling a method called L (within L |
||||||
2125 | |||||||
2126 | In other words, in the very simplest case, you don't have to change the name of the initial run mode ('start'), you just have to implement a suitable method, and then call L to tell | ||||||
2127 | L |
||||||
2128 | |||||||
2129 | =head2 teardown() | ||||||
2130 | |||||||
2131 | Does nothing. You implement it in a sub-class, if desired. | ||||||
2132 | |||||||
2133 | Defaults to returning nothing. | ||||||
2134 | |||||||
2135 | Typically, teardown() is where you put the code which saves session state, closes logs, disconnects from databases, etc. | ||||||
2136 | |||||||
2137 | You may find it is mandatory for you to override teardown() in your sub-class, especially in persistent environments. | ||||||
2138 | |||||||
2139 | In particular, you are I |
||||||
2140 | L |
||||||
2141 | |||||||
2142 | =head1 FAQ | ||||||
2143 | |||||||
2144 | =head2 Do I need to output a header when using Ajax? | ||||||
2145 | |||||||
2146 | Yes. At least, when I use jQuery I must do this in a run mode: | ||||||
2147 | |||||||
2148 | $self -> add_header(Status => 200, 'Content-Type' => 'text/html; charset=utf-8'); | ||||||
2149 | |||||||
2150 | return $self -> param('view') -> search -> display($name, $row); | ||||||
2151 | |||||||
2152 | Here, display() returns a HTML table wrapped in 2 divs in the jQuery style, which becomes the return value | ||||||
2153 | of the run mode. | ||||||
2154 | |||||||
2155 | The quoted code is in L |
||||||
2156 | display() method being called above is in L |
||||||
2157 | matter which Perl app you're running. | ||||||
2158 | |||||||
2159 | =head2 Does CGI::Snapp V 1.01 support PSGI? | ||||||
2160 | |||||||
2161 | Yes. See L and L |
||||||
2162 | |||||||
2163 | =head2 Is there any sample code? | ||||||
2164 | |||||||
2165 | Yes. See t/*.pl and all the modules in t/lib/*. | ||||||
2166 | |||||||
2167 | See also L |
||||||
2168 | |||||||
2169 | =head2 Why did you fork CGI::Application? | ||||||
2170 | |||||||
2171 | In order to study the code. I want to understand how L |
||||||
2172 | can put my forks of those modules into production - I |
||||||
2173 | |||||||
2174 | Also - obviously - it allows me to implement what I think are code cleanups. And lastly, it allows me to indulge myself in a user-friendly release strategy. | ||||||
2175 | |||||||
2176 | Clearly, those are the same reasons which motivated me to fork L |
||||||
2177 | |||||||
2178 | As a byproduct of forking, rewriting the documentation has also allowed me to cut about 20,000 bytes from the source file Snapp.pm compared to Application.pm. | ||||||
2179 | |||||||
2180 | =head2 What version is the fork of CGI::Application based on? | ||||||
2181 | |||||||
2182 | CGI::Snapp V 1.00 is based on CGI::Application V 4.31. CGI::Snapp V 1.01 is based on CGI::Application V 4.50. | ||||||
2183 | |||||||
2184 | =head2 How does CGI::Snapp differ from CGI::Application? | ||||||
2185 | |||||||
2186 | My usage of the latter's features was always minimalistic, so - at least initially - I will only support a basic set of L |
||||||
2187 | |||||||
2188 | These are the major differences: | ||||||
2189 | |||||||
2190 | =head3 Clean up 'run_mode' 'v' runmode | ||||||
2191 | |||||||
2192 | Except for method calls where 'runmode' is unfortunately used, e.g L, 'run_mode' and 'run mode' have been adopted as the norm. | ||||||
2193 | |||||||
2194 | =head3 Always call croak and not a combination of croak and die | ||||||
2195 | |||||||
2196 | Also, every message passed to croak matches /^Error/ and ends with "\n". | ||||||
2197 | |||||||
2198 | =head3 No global variables (except for the inescapable dispatch table of class-level callbacks) | ||||||
2199 | |||||||
2200 | This means things like $$self{__CURRENT_RUNMODE} and $$self{__PRERUN_MODE_LOCKED} etc are only be available via method calls. | ||||||
2201 | |||||||
2202 | Here is a list of the global variables in L |
||||||
2203 | |||||||
2204 | =over 4 | ||||||
2205 | |||||||
2206 | =item o __CALLBACK_CLASSES => %callback_classes | ||||||
2207 | |||||||
2208 | =item o __CURRENT_RUNMODE => L | ||||||
2209 | |||||||
2210 | =item o __CURRENT_TMPL_EXTENSION => Not implemented | ||||||
2211 | |||||||
2212 | =item o __ERROR_MODE => L | ||||||
2213 | |||||||
2214 | =item o __HEADER_PROPS => L | ||||||
2215 | |||||||
2216 | =item o __HEADER_TYPE => L | ||||||
2217 | |||||||
2218 | =item o __HTML_TMPL_CLASS => Not implemented | ||||||
2219 | |||||||
2220 | =item o __INSTALLED_CALLBACKS => L | ||||||
2221 | |||||||
2222 | =item o __IS_PSGI => _psgi() | ||||||
2223 | |||||||
2224 | =item o __MODE_PARAM => L | ||||||
2225 | |||||||
2226 | =item o __PARAMS => L | ||||||
2227 | |||||||
2228 | =item o __PRERUN_MODE => L | ||||||
2229 | |||||||
2230 | =item o __PRERUN_MODE_LOCKED => _prerun_mode_lock([$Boolean]) | ||||||
2231 | |||||||
2232 | =item o __QUERY_OBJ => L | ||||||
2233 | |||||||
2234 | =item o __RUN_MODES => L | ||||||
2235 | |||||||
2236 | =item o __START_MODE => L | ||||||
2237 | |||||||
2238 | =item o __TMPL_PATH => Not implemented | ||||||
2239 | |||||||
2240 | =back | ||||||
2241 | |||||||
2242 | The leading '_' on some CGI::Snapp method names means all such methods are for the exclusive use of the author of this module. | ||||||
2243 | |||||||
2244 | =head3 New methods | ||||||
2245 | |||||||
2246 | =over 4 | ||||||
2247 | |||||||
2248 | =item o L | ||||||
2249 | |||||||
2250 | =item o L | ||||||
2251 | |||||||
2252 | =item o L | ||||||
2253 | |||||||
2254 | =item o L | ||||||
2255 | |||||||
2256 | =item o L | ||||||
2257 | |||||||
2258 | =back | ||||||
2259 | |||||||
2260 | =head3 Deprecated methods | ||||||
2261 | |||||||
2262 | =over 4 | ||||||
2263 | |||||||
2264 | =item o L | ||||||
2265 | |||||||
2266 | See L. | ||||||
2267 | |||||||
2268 | =back | ||||||
2269 | |||||||
2270 | =head3 Unsupported methods | ||||||
2271 | |||||||
2272 | =over 4 | ||||||
2273 | |||||||
2274 | =item o html_tmpl_class() | ||||||
2275 | |||||||
2276 | =item o load_tmpl() | ||||||
2277 | |||||||
2278 | =item o run_as_psgi() | ||||||
2279 | |||||||
2280 | =item o tmpl_path() | ||||||
2281 | |||||||
2282 | =back | ||||||
2283 | |||||||
2284 | See below for details. | ||||||
2285 | |||||||
2286 | =head3 Enchanced features | ||||||
2287 | |||||||
2288 | =over 4 | ||||||
2289 | |||||||
2290 | =item o Use of utf8::downgrade() to turn off utf8 bit on headers | ||||||
2291 | |||||||
2292 | =item o Use of Try::Tiny rather than eval | ||||||
2293 | |||||||
2294 | Ideally, this won't be detectable, and hence won't matter. | ||||||
2295 | |||||||
2296 | =item o call_hook(...) returns a hashref - keys are 'class' and 'object' - of counts of hooks actually called | ||||||
2297 | |||||||
2298 | =item o delete_header(A list) | ||||||
2299 | |||||||
2300 | See L for how to delete any number of HTTP headers. | ||||||
2301 | |||||||
2302 | =item o Calling the error_mode() method | ||||||
2303 | |||||||
2304 | This call is protected by Try::Tiny. | ||||||
2305 | |||||||
2306 | =item o Calling mode_param([...]) | ||||||
2307 | |||||||
2308 | mode_param() can be called with an arrayref, as in $self -> mode_param([qw/path_info -2/]). See t/run.modes.pl for details. | ||||||
2309 | |||||||
2310 | =item o Calling param([...]) | ||||||
2311 | |||||||
2312 | param() can be called with an arrayref, as in $self -> param([qw/six 6 seven 7/]). See t/params.pl for details. | ||||||
2313 | |||||||
2314 | =back | ||||||
2315 | |||||||
2316 | =head3 No special code for Apache, mod_perl or plugins | ||||||
2317 | |||||||
2318 | I suggest that sort of stuff is best put in sub-classes. | ||||||
2319 | |||||||
2320 | For the record, I don't use Apache or mod_perl. For web servers I use L |
||||||
2321 | As it happens, I don't use any plugins (for L |
||||||
2322 | |||||||
2323 | So, it's not that I refuse to support them, it's just that I won't put any special code in place unless asked to do so. And then, only if it fits into my philosophy | ||||||
2324 | of where this code is headed. And that includes potential re-writes of L |
||||||
2325 | |||||||
2326 | =head3 Upper-case parameters to L | ||||||
2327 | |||||||
2328 | Yes, I know SHOUTING parameter names is ugly, but I |
||||||
2329 | |||||||
2330 | =head3 Template Mangement | ||||||
2331 | |||||||
2332 | L |
||||||
2333 | |||||||
2334 | There is no support because I see L |
||||||
2335 | |||||||
2336 | That is, one of the methods in your sub-class - cgiapp_init(), cgiapp_prerun() or setup(), or a hook - should load a config file, and in that file is the place to put a template path, | ||||||
2337 | along with all those other things typically needed: Paths to CSS and Javascript libraries, database connexion parameters, etc. | ||||||
2338 | |||||||
2339 | Then, each different sub-class can load a different config file, if necessary, and hence use a different set of templates. Likewise, testing and production versions of config files | ||||||
2340 | can be deployed, and so on. | ||||||
2341 | |||||||
2342 | For example, first read in a hashref of config options (see L |
||||||
2343 | |||||||
2344 | use Config::Plugin::Tiny; # For config_tiny(). | ||||||
2345 | use Text::Xslate; | ||||||
2346 | ... | ||||||
2347 | $self -> param | ||||||
2348 | ( | ||||||
2349 | config => config_tiny('/some/dir/some.file.ini'); | ||||||
2350 | ); | ||||||
2351 | $self -> param | ||||||
2352 | ( | ||||||
2353 | renderer => Text::Xslate -> new | ||||||
2354 | ( | ||||||
2355 | input_layer => '', | ||||||
2356 | path => ${$self -> param('config')}{template_path}, | ||||||
2357 | ) | ||||||
2358 | ); | ||||||
2359 | |||||||
2360 | Then, later, use the renderer like this (in a View component of the MVC style): | ||||||
2361 | |||||||
2362 | my($output) = | ||||||
2363 | { | ||||||
2364 | div => 'order_message_div', | ||||||
2365 | content => $self -> param('renderer') -> render('note.tx', $param), | ||||||
2366 | }; | ||||||
2367 | |||||||
2368 | return JSON::XS -> new -> utf8 -> encode($output); | ||||||
2369 | |||||||
2370 | =head2 How does add_header() differ from header_add()? | ||||||
2371 | |||||||
2372 | Firstly, a note about the name of header_add(). It really should have been called add_header() in the first place, just like add_callback(). | ||||||
2373 | After 70 years of programming, programmers should have learned that I |
||||||
2374 | I do understand the choice of header_add(): It's by analogy with header_props() and header_type(). I used to argue like that myself :-(. | ||||||
2375 | |||||||
2376 | OK, here's how they differ. Consider this code. | ||||||
2377 | |||||||
2378 | $app -> header_add(a => 1, b => [2], c => 3, d => [4]) or call add_header(same params) | ||||||
2379 | $app -> header_add(a => 11, b => 22, c => [33], d => [44]) or call add_header(same params) | ||||||
2380 | |||||||
2381 | Output: | ||||||
2382 | |||||||
2383 | (a => 11, b => 22, c => [3, 33], d => [4, 44]) - header_add() - CGI::Snapp and CGI::Application | ||||||
2384 | (a => [1, 11], b => [2, 22], c => [3, 33], d => [4, 44]) - add_header() - CGI::Snapp | ||||||
2385 | |||||||
2386 | You can see, for both modules, L I |
||||||
2387 | L |
||||||
2388 | |||||||
2389 | But, if you want to add headers without violating the L |
||||||
2390 | Also, L is the counterpart of L. | ||||||
2391 | |||||||
2392 | For this reason, L is deprecated. | ||||||
2393 | |||||||
2394 | =head2 I'm confused because you called your tests t/*.pl | ||||||
2395 | |||||||
2396 | Well, not really. t/test.t is I |
||||||
2397 | |||||||
2398 | You can run any single test helper script - e.g. t/defaults.pl - like this: shell> prove -Ilib -v t/defaults.pl | ||||||
2399 | |||||||
2400 | =head2 Do you expect authors of plugins for CGI::App to re-write their code? | ||||||
2401 | |||||||
2402 | Nope. But they are free to do so... | ||||||
2403 | |||||||
2404 | =head2 Are you going to release any plugins? | ||||||
2405 | |||||||
2406 | Yes. Check out L. | ||||||
2407 | |||||||
2408 | =head2 How do I sub-class CGI::Snapp? | ||||||
2409 | |||||||
2410 | There is an example in t/subclass.pl, which uses t/lib/CGI/Snapp/SubClass.pm. The latter is: | ||||||
2411 | |||||||
2412 | package CGI::Snapp::SubClass; | ||||||
2413 | |||||||
2414 | use parent 'CGI::Snapp'; | ||||||
2415 | use strict; | ||||||
2416 | use warnings; | ||||||
2417 | |||||||
2418 | use Moo; | ||||||
2419 | |||||||
2420 | has => verbose | ||||||
2421 | ( | ||||||
2422 | is => 'rw', | ||||||
2423 | default => sub{return 0}, | ||||||
2424 | required => 0, | ||||||
2425 | ); | ||||||
2426 | |||||||
2427 | our $VERSION = '1.08'; | ||||||
2428 | |||||||
2429 | # -------------------------------------------------- | ||||||
2430 | |||||||
2431 | 1; | ||||||
2432 | |||||||
2433 | The steps are: | ||||||
2434 | |||||||
2435 | =over 4 | ||||||
2436 | |||||||
2437 | =item o Create the file | ||||||
2438 | |||||||
2439 | Just copy t/lib/CGI/Snapp/SubClass.pm to get started. | ||||||
2440 | |||||||
2441 | =item o Declare the accessors | ||||||
2442 | |||||||
2443 | fieldhash my %verbose => 'verbose'; | ||||||
2444 | |||||||
2445 | is how it's done. This means you can now have all these features available: | ||||||
2446 | |||||||
2447 | =over 4 | ||||||
2448 | |||||||
2449 | =item o Use verbose when calling new() | ||||||
2450 | |||||||
2451 | CGI::Snapp::SubClass -> new(verbose => 1); | ||||||
2452 | |||||||
2453 | =item o Use verbose() as a getter | ||||||
2454 | |||||||
2455 | my($verbosity) = $self -> verbose; | ||||||
2456 | |||||||
2457 | =item o Use verbose($Boolean) as a setter | ||||||
2458 | |||||||
2459 | $self -> verbose(1); | ||||||
2460 | |||||||
2461 | =back | ||||||
2462 | |||||||
2463 | =back | ||||||
2464 | |||||||
2465 | See t/subclass.pl for how it works in practice. | ||||||
2466 | |||||||
2467 | =head2 How do I use my own logger object? | ||||||
2468 | |||||||
2469 | Study the sample code in L |
||||||
2470 | L |
||||||
2471 | |||||||
2472 | Also, see any test script, e.g. t/basic.pl. | ||||||
2473 | |||||||
2474 | =head2 What else do I need to know about logging? | ||||||
2475 | |||||||
2476 | The effect of logging varies depending on the stage at which it is activated. | ||||||
2477 | |||||||
2478 | And, your logger must be compatible with L |
||||||
2479 | |||||||
2480 | If you call your sub-class of CGI::Snapp as My::App -> new(logger => $logging), then logging is turned on at the | ||||||
2481 | earliest possible time. This means calls within L, to L (which calls cgiapp_init() ) | ||||||
2482 | and L, are logged. And since you have probably overridden setup(), you can do this in your setup(): | ||||||
2483 | |||||||
2484 | $self -> log($level => $message); # Log anything... | ||||||
2485 | |||||||
2486 | Alternately, you could override L or L, and create your own logger object | ||||||
2487 | within one of those. | ||||||
2488 | |||||||
2489 | Then you just do $self -> logger($my_logger), after which logging is immediately activated. But obviously that | ||||||
2490 | means the calls to call_hook() and setup() (in new() ) will not produce any log output, because by now they have | ||||||
2491 | already been run. | ||||||
2492 | |||||||
2493 | Nevertheless, after this point (e.g. in cgiapp_init() ), since a logger is now set up, logging will produce output. | ||||||
2494 | |||||||
2495 | Remember the prefix 'Local::Wines::Controller' mentioned in L |
||||||
2496 | |||||||
2497 | Here's what it's cgiapp_prerun() looks like: | ||||||
2498 | |||||||
2499 | sub cgiapp_prerun | ||||||
2500 | { | ||||||
2501 | my($self) = @_; | ||||||
2502 | |||||||
2503 | # Can't call, since logger not yet set up. | ||||||
2504 | # Well, could, but it's pointless... | ||||||
2505 | |||||||
2506 | #$self -> log(debug => 'cgiapp_prerun()'); | ||||||
2507 | |||||||
2508 | $self -> param(config => Local::Config -> new(module_name => 'Local::Wines') -> get_config); | ||||||
2509 | $self -> set_connector; # The dreaded DBIx::Connector. | ||||||
2510 | $self -> logger(Local::Logger -> new(config => $self -> param('config') ) ); | ||||||
2511 | |||||||
2512 | # Log the CGI form parameters. | ||||||
2513 | |||||||
2514 | my($q) = $self -> query; | ||||||
2515 | |||||||
2516 | $self -> log(info => ''); | ||||||
2517 | $self -> log(info => $q -> url(-full => 1, -path => 1) ); | ||||||
2518 | $self -> log(info => "Param: $_: " . $q -> param($_) ) for $q -> param; | ||||||
2519 | |||||||
2520 | # Other controllers add their own run modes. | ||||||
2521 | |||||||
2522 | $self -> run_modes([qw/display/]); | ||||||
2523 | $self -> log(debug => 'tmpl_path: ' . ${$self -> param('config')}{template_path}); | ||||||
2524 | |||||||
2525 | # Set up the database, the templater and the viewer. | ||||||
2526 | # We pass the templater into the viewer so all views share it. | ||||||
2527 | |||||||
2528 | # A newer design has the controller created in the db class. | ||||||
2529 | |||||||
2530 | $self -> param | ||||||
2531 | ( | ||||||
2532 | db => Local::Wines::Database -> new | ||||||
2533 | ( | ||||||
2534 | dbh => $self -> param('connector') -> dbh, | ||||||
2535 | logger => $self -> logger, | ||||||
2536 | query => $q, | ||||||
2537 | ) | ||||||
2538 | ); | ||||||
2539 | |||||||
2540 | $self -> param | ||||||
2541 | ( | ||||||
2542 | templater => Text::Xslate -> new | ||||||
2543 | ( | ||||||
2544 | input_layer => '', | ||||||
2545 | path => ${$self -> param('config')}{template_path}, | ||||||
2546 | ) | ||||||
2547 | ); | ||||||
2548 | |||||||
2549 | $self -> param | ||||||
2550 | ( | ||||||
2551 | view => Local::Wines::View -> new | ||||||
2552 | ( | ||||||
2553 | db => $self -> param('db'), | ||||||
2554 | logger => $self -> logger, | ||||||
2555 | templater => $self -> param('templater'), | ||||||
2556 | ) | ||||||
2557 | ); | ||||||
2558 | |||||||
2559 | # Output this here so we know how far we got. | ||||||
2560 | |||||||
2561 | $self -> log(info => 'Session id: ' . $self -> param('db') -> session -> id); | ||||||
2562 | |||||||
2563 | } # End of cgiapp_prerun. | ||||||
2564 | |||||||
2565 | =head2 So, should I upgrade from CGI::Application to CGI::Snapp? | ||||||
2566 | |||||||
2567 | Well, that's up to you. Of course, if your code is not broken, don't fix it. But, as I said above, L |
||||||
2568 | |||||||
2569 | The biggest problem for you will almost certainly be lack of support for load_tmp() and tmpl_path(). | ||||||
2570 | |||||||
2571 | Still, you're welcome to sub-class L |
||||||
2572 | |||||||
2573 | =head1 Troubleshooting | ||||||
2574 | |||||||
2575 | =head2 It doesn't work! | ||||||
2576 | |||||||
2577 | Hmmm. Things to consider: | ||||||
2578 | |||||||
2579 | =over 4 | ||||||
2580 | |||||||
2581 | =item o Run the *.cgi script from the command line | ||||||
2582 | |||||||
2583 | shell> perl httpd/cgi-bin/cgi.snapp.one.cgi | ||||||
2584 | |||||||
2585 | If that doesn't work, you're in b-i-g trouble. Keep reading for suggestions as to what to do next. | ||||||
2586 | |||||||
2587 | =item o Did you try using a logger to trace the method calls? | ||||||
2588 | |||||||
2589 | Pass a logger to your sub-class of L |
||||||
2590 | |||||||
2591 | my($logger) = Log::Handler -> new; | ||||||
2592 | |||||||
2593 | $logger -> add | ||||||
2594 | ( | ||||||
2595 | screen => | ||||||
2596 | { | ||||||
2597 | maxlevel => 'debug', | ||||||
2598 | message_layout => '%m', | ||||||
2599 | minlevel => 'error', | ||||||
2600 | newline => 1, # When running from the command line. | ||||||
2601 | } | ||||||
2602 | ); | ||||||
2603 | CGI::Snapp -> new(logger => $logger, ...) -> run; | ||||||
2604 | |||||||
2605 | Then, in your methods, just use: | ||||||
2606 | |||||||
2607 | $self -> log(debug => 'A string'); | ||||||
2608 | |||||||
2609 | The entry to each method in CGI::Snapp and L |
||||||
2610 | although only when maxlevel is 'debug'. Lower levels for maxlevel do not trigger logging. | ||||||
2611 | See the source for details. | ||||||
2612 | |||||||
2613 | =item o The system Perl 'v' perlbrew | ||||||
2614 | |||||||
2615 | Are you using perlbrew? If so, recall that your web server will use the first line of your L |
||||||
2616 | and that line probably says something like #!/usr/bin/env perl. | ||||||
2617 | |||||||
2618 | So, perhaps you'd better turn perlbrew off and install L |
||||||
2619 | |||||||
2620 | =item o Generic advice | ||||||
2621 | |||||||
2622 | L |
||||||
2623 | |||||||
2624 | =back | ||||||
2625 | |||||||
2626 | =head1 See Also | ||||||
2627 | |||||||
2628 | L |
||||||
2629 | |||||||
2630 | The following are all part of this set of distros: | ||||||
2631 | |||||||
2632 | L |
||||||
2633 | |||||||
2634 | L |
||||||
2635 | |||||||
2636 | L |
||||||
2637 | |||||||
2638 | L |
||||||
2639 | |||||||
2640 | L |
||||||
2641 | |||||||
2642 | L |
||||||
2643 | |||||||
2644 | L |
||||||
2645 | |||||||
2646 | L |
||||||
2647 | |||||||
2648 | L |
||||||
2649 | |||||||
2650 | L |
||||||
2651 | |||||||
2652 | L |
||||||
2653 | |||||||
2654 | L |
||||||
2655 | |||||||
2656 | =head1 Machine-Readable Change Log | ||||||
2657 | |||||||
2658 | The file Changes was converted into Changelog.ini by L |
||||||
2659 | |||||||
2660 | =head1 Version Numbers | ||||||
2661 | |||||||
2662 | Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions. | ||||||
2663 | |||||||
2664 | =head1 Credits | ||||||
2665 | |||||||
2666 | Please read L |
||||||
2667 | |||||||
2668 | =head1 Repository | ||||||
2669 | |||||||
2670 | L |
||||||
2671 | |||||||
2672 | =head1 Support | ||||||
2673 | |||||||
2674 | Email the author, or log a bug on RT: | ||||||
2675 | |||||||
2676 | L |
||||||
2677 | |||||||
2678 | =head1 Author | ||||||
2679 | |||||||
2680 | L |
||||||
2681 | |||||||
2682 | Home page: L |
||||||
2683 | |||||||
2684 | =head1 Copyright | ||||||
2685 | |||||||
2686 | Australian copyright (c) 2012, Ron Savage. | ||||||
2687 | |||||||
2688 | All Programs of mine are 'OSI Certified Open Source Software'; | ||||||
2689 | you can redistribute them and/or modify them under the terms of | ||||||
2690 | The Artistic License, a copy of which is available at: | ||||||
2691 | http://www.opensource.org/licenses/index.html | ||||||
2692 | |||||||
2693 | =cut |