File Coverage

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 . "\n

Query environment:

\n" .
530             "
    \n";
531              
532 0         0 for my $key (sort keys %ENV)
533             {
534 0         0 $output .= '
  • ' . $q -> escapeHTML($key) . ' => ' . $q -> escapeHTML($ENV{$key}) . "
  • \n";
    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, except for the differences discussed in L.
    1087              
    1088             But be warned, load_tmp() and tmp_path() in particular are not supported, because they're too tied to the L way of doing things, and I prefer L.
    1089              
    1090             =head1 Description
    1091              
    1092             A fork of L (later L etc) in order to understand how they work in sufficient detail that I can put L etc into
    1093             production - I - as replacements for those modules.
    1094              
    1095             You are I encouraged to peruse L for details of the differences between L and L.
    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 or similar.
    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 uses 'start' to find which method to run to handle that run mode. The default run mode 'start' runs a method called L' implemented in 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 a string or stringref of HTML to be sent to the HTTP client. You code must never write to STDOUT - that's the classic mistake most beginners make.
    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 script is something like:
    1143              
    1144             #!/usr/bin/env perl
    1145              
    1146             use KillerApp;
    1147             KillerApp -> new -> run;
    1148              
    1149             Here's what happens as L runs firstly 'new()' and then 'run()':
    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 and re-implementing either or both of these methods.
    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 form field parameter whose name defaults to 'rm'.
    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 or a sub-class.
    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's forward(@args), then those parameters you pass to forward() will be passed to the run mode method (after $self).
    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's croak($message).
    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 is called. If it returns a defined value, that value is used as the name of a method to call.
    1263              
    1264             =item o Fallback
    1265              
    1266             Finally, if L does not return a method name, or calling that method also fails, the code calls L's croak($message).
    1267              
    1268             =back
    1269              
    1270             Aren't you glad that was the I view?
    1271              
    1272             =head2 A More Complex View
    1273              
    1274             L and before it L are designed in such a way that some of those methods are actually I aka I, and their names are looked up via hook names.
    1275              
    1276             See the Wikipedia article L for a long explanation of hooks.
    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 as you would for any C module:
    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 is called as C<< my($app) = CGI::Snapp -> new(k1 => v1, k2 => v2, ...) >>.
    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 and 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 via the L method.
    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's use of $ENV{CGI_APP_RETURN_ONLY}. But check the spelling in the next line.
    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-compatible object.
    1413              
    1414             Default: ''.
    1415              
    1416             However, a new L object is created at run-time if needed. See 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 or your sub-class), by surviving for the duration of the Perl process, which, in a persistent
    1449             environment like L, L, etc, can be long enough to serve many HTTP client requests.
    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. So, if you use your own name in calling new_hook($name), you are also responsible for triggering the calls to that hook.
    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-level callbacks are added for the same hook by different classes, they will be executed in reverse-class-hierarchy order.
    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-level callbacks are added for the same hook by the same class, they will be executed in the order added, since they are pushed onto a stack (as are object-level
    1490             callbacks).
    1491              
    1492             If multiple I-level callbacks are added for the same hook, they are run in the order they are registered, i.e. in the order of calls to L.
    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) to attach
    1497             a callback to this hook.
    1498              
    1499             The way around this is to write a class which is I a sub-class of L, and whose import() method is triggered when you 'use' this class in your sub-class of L.
    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 for another way to do things, although it uses 'forward_prerun' rather than 'init'.
    1504              
    1505             =back
    1506              
    1507             To summarize, you are I advised to examine t/hook.test.pl and all the modules it uses to gain a deeper understanding of this complex issue. In particular, the order of 'use'
    1508             statements in your sub-class of L will determine the order in which class-level callbacks are triggered.
    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 when a query object is needed.
    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-compatible object, such as a L object, or similar. If not using L, note:
    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 object.
    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) is called, which in turn calls the Dump() and escapeHTML() methods of your object.
    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 headers from the list which will be sent to the HTTP client.
    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-compatible HTTP header properties.
    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's croak($message).
    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 be a key in the dispatch table (hash) returned by the
    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's
    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 does, for some reason.
    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 (L's read() returns a hashref):
    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's croak($message).
    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-compatible coderef which, when called, runs your sub-class of L
    1951             as a L app.
    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 also provides sub run_as_psgi(), but we have no need of that.
    1959              
    1960             Note: This method, psgi_app(), is very similar to L, but the latter contains
    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 can determine the run mode from the path info
    1966             sent from the web client, whereas if you use psgi_app(), your sub-class of L must contain all the logic
    1967             required to determine the run mode.
    1968              
    1969             =head2 query([$q])
    1970              
    1971             Sets and gets the L-compatible object used to retrieve the CGI form field names and values. This object also needs to be able to generate HTTP headers. See 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 header type to 'redirect'
    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 script:
    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. Hence:
    2037              
    2038             $app -> run_modes([qw/one two/]);
    2039              
    2040             defines 2 run modes, 'one' and 'two', and these are automatically mapped (by L) to 2 methods called 'one' and 'two', respectively.
    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 parameters, it will
    2070             default to 'first', I. So, the code calls L's croak($message).
    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 remove the default (start => 'dump_html') entry from the dispatch table. The code just ignores it. It affects test code, though.
    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's (negative logic) mechanism to turn off transmission.
    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 form data submitted with that request.
    2121              
    2122             So, your code (script.cgi, which uses a sub-class of L), must determine and execute a run mode (a method) without the user having indicated which run mode to use.
    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 the name of your method.
    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 encouraged to read L and
    2140             L before writing your own teardown() method.
    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's display (the run mode), and the
    2156             display() method being called above is in L, but it will be the same no
    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 and its t/psi.args.t.
    2168              
    2169             =head2 Why did you fork CGI::Application?
    2170              
    2171             In order to study the code. I want to understand how L, L and L work in sufficient detail that I
    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 into 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's features.
    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, and the corresponding methods in L, in alphabetical order:
    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, L, L and (for development) L.
    2321             As it happens, I don't use any plugins (for L) either.
    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, L and L.
    2325              
    2326             =head3 Upper-case parameters to L
    2327              
    2328             Yes, I know SHOUTING parameter names is ugly, but I back-compat feautures must be supported, right?. Hence L accepts PARAMS and QUERY.
    2329              
    2330             =head3 Template Mangement
    2331              
    2332             L contains no special processing for L, or indeed any templating system. Rationale:
    2333              
    2334             There is no support because I see L's usage as a manifestation of an (understandable) design fault. If anything, TMPL_PATH should have been CONFIG_PATH.
    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), and then set up a rendering engine:
    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 in function/method/sub names.
    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 a pre-exising header when the incoming header's value is a scalar.
    2387             L's L emulates L's weird L logic here.
    2388              
    2389             But, if you want to add headers without violating the L, use 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 test script. It runs all t/*.pl helper scripts. Run it thusly: shell> prove -Ilib -v t/
    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, which shows how to supply a L *.ini file to configure the logger via the wrapper class
    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 will be going in to production in my work.
    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 and fix that...
    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 like this:
    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 is logged using this technique,
    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 script to find a Perl,
    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 and this module under the system Perl, before trying again.
    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 - A almost back-compat fork of CGI::Application
    2633              
    2634             L and L - Dispatch requests to CGI::Snapp-based objects
    2635              
    2636             L - A template-free demo of CGI::Snapp using just 1 run mode
    2637              
    2638             L - A template-free demo of CGI::Snapp using N run modes
    2639              
    2640             L - A template-free demo of CGI::Snapp using the forward() method
    2641              
    2642             L - A template-free demo of CGI::Snapp using Log::Handler::Plugin::DBI
    2643              
    2644             L - A wrapper around CGI::Snapp::Demo::Four, to simplify using Log::Handler::Plugin::DBI
    2645              
    2646             L - A plugin which uses Config::Tiny
    2647              
    2648             L - A plugin which uses Config::Tiny with 1 of N sections
    2649              
    2650             L - Persistent session data management
    2651              
    2652             L - A plugin for Log::Handler using Log::Hander::Output::DBI
    2653              
    2654             L - A helper for Log::Hander::Output::DBI to create your 'log' table
    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 and L, since a great deal of work has gone into both of those modules.
    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 was written by Ron Savage Iron@savage.net.auE> in 2012.
    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