File Coverage

blib/lib/CGI/Snapp.pm
Criterion Covered Total %
statement 239 386 61.9
branch 65 178 36.5
condition 19 49 38.7
subroutine 37 53 69.8
pod 32 32 100.0
total 392 698 56.1


line stmt bran cond sub pod time code
1             package CGI::Snapp;
2              
3 2     2   77184 use strict;
  2         4  
  2         65  
4 2     2   25 use warnings;
  2         4  
  2         55  
5              
6 2     2   11 use Carp;
  2         7  
  2         153  
7              
8 2     2   1697 use Class::ISA;
  2         1184  
  2         54  
9              
10 2     2   1701 use Hash::FieldHash ':all';
  2         1646  
  2         337  
11              
12 2     2   2741 use Log::Handler;
  2         756418  
  2         17  
13              
14 2     2   86 use Try::Tiny;
  2         3  
  2         13808  
15              
16             fieldhash my %_current_run_mode => '_current_run_mode';
17             fieldhash my %_error_mode => '_error_mode';
18             fieldhash my %_headers => '_headers';
19             fieldhash my %_header_type => '_header_type';
20             fieldhash my %logger => 'logger';
21             fieldhash my %_object_callbacks => '_object_callbacks';
22             fieldhash my %PARAMS => 'PARAMS';
23             fieldhash my %_params => '_params';
24             fieldhash my %_prerun_mode_lock => '_prerun_mode_lock';
25             fieldhash my %_psgi => '_psgi';
26             fieldhash my %QUERY => 'QUERY';
27             fieldhash my %_query => '_query';
28             fieldhash my %_run_mode_source => '_run_mode_source';
29             fieldhash my %_run_modes => '_run_modes';
30             fieldhash my %send_output => 'send_output';
31             fieldhash my %_start_mode => '_start_mode';
32              
33             my(%class_callbacks) =
34             (
35             error => {},
36             forward_prerun => {},
37             init => {'CGI::Snapp' => ['cgiapp_init']},
38             prerun => {'CGI::Snapp' => ['cgiapp_prerun']},
39             postrun => {'CGI::Snapp' => ['cgiapp_postrun']},
40             teardown => {'CGI::Snapp' => ['teardown']},
41             );
42              
43             my($myself);
44              
45             our $VERSION = '1.08';
46              
47             # --------------------------------------------------
48              
49             sub add_callback
50             {
51 7     7 1 549 my($self, $hook, $option) = @_;
52              
53 7 50       21 croak "Error: Can't use undef as a hook name\n" if (! defined $hook);
54              
55 7         18 $hook = lc $hook;
56              
57 7         30 $self -> log(debug => "add_callback($hook, ...)");
58              
59 7 50       1024 croak "Error: Unknown hook name '$hook'\n" if (! $class_callbacks{$hook});
60              
61 7 100       21 if (ref $self)
62             {
63             # it's an object-level callback.
64              
65 2         7 my($object_callback) = $self -> _object_callbacks;
66 2 50       8 $$object_callback{$hook} = [] if (! $$object_callback{$hook});
67              
68 2         3 push @{$$object_callback{$hook} }, $option;
  2         4  
69              
70 2         10 $self -> _object_callbacks($object_callback);
71             }
72             else
73             {
74             # It's a class-level callback.
75              
76 5         14 push @{$class_callbacks{$hook}{$self} }, $option;
  5         23  
77             }
78              
79             } # End of add_callback.
80              
81             # --------------------------------------------------
82              
83             sub add_header
84             {
85 0     0 1 0 my($self, @headers) = @_;
86              
87 0         0 $self -> log(debug => 'add_header(...)');
88              
89 0         0 my($old) = $self -> _headers;
90              
91 0 0       0 if (@headers)
92             {
93 0         0 my(%new) = ref $headers[0] eq 'HASH' ? %{$headers[0]}
  0         0  
94 0 0       0 : ref $headers[0] eq 'ARRAY' ? @{$headers[0]}
    0          
    0          
95             : scalar(@headers) % 2 == 0 ? @headers
96             : croak "Error: Odd number of parameters passed to add_header()\n";
97              
98 0         0 my($value);
99              
100 0         0 for my $key (keys %new)
101             {
102 0         0 $value = $$old{$key};
103              
104 0 0       0 if (ref $new{$key} eq 'ARRAY')
105             {
106 0 0       0 if (ref $value eq 'ARRAY')
107             {
108 0         0 $new{$key} = [@$value, @{$new{$key} }];
  0         0  
109             }
110             else
111             {
112 0 0       0 $new{$key} = [$value, @{$new{$key} }] if (defined $value);
  0         0  
113             }
114             }
115             else
116             {
117 0 0       0 if (ref $value eq 'ARRAY')
118             {
119 0         0 $new{$key} = [@$value, $new{$key}];
120             }
121             else
122             {
123 0 0       0 $new{$key} = [$value, $new{$key}] if (defined $value);
124             }
125             }
126             }
127              
128 0         0 $old = {%$old, %new};
129              
130 0         0 $self -> _headers($old);
131             }
132              
133 0         0 return %$old;
134              
135             } # End of add_header.
136              
137             # --------------------------------------------------
138              
139             sub call_hook
140             {
141 29     29 1 101 my($self, $hook, @args) = @_;
142              
143 29 50       94 croak "Error: Can't use undef as a hook name\n" if (! defined $hook);
144              
145 29         52 $hook = lc $hook;
146              
147 29         117 $self -> log(debug => "call_hook($hook, ...)");
148              
149 29         5920 my($count) = {class => 0, object => 0};
150              
151 29         46 my(%seen);
152              
153             # Call object-level hooks.
154              
155 29         45 for my $callback (@{${$self -> _object_callbacks}{$hook} })
  29         31  
  29         179  
156             {
157 1 50       7 next if ($seen{$callback});
158              
159             try
160             {
161 1     1   60 $self -> $callback(@args);
162             }
163             catch
164             {
165 0 0   0   0 croak "Error executing object-level callback for hook '$hook': $@\n" if ($@);
166 1         19 };
167              
168 1         163 $$count{object}++;
169              
170 1         5 $seen{$callback} = 1;
171             }
172              
173             # Call class-level hooks.
174              
175 29   33     184 for my $class (Class::ISA::self_and_super_path(ref $self || $self) )
176             {
177 58 100       1917 next if (! exists $class_callbacks{$hook}{$class});
178              
179 33         37 for my $callback (@{$class_callbacks{$hook}{$class} })
  33         90  
180             {
181 43 100       122 next if ($seen{$callback});
182              
183             try
184             {
185 28     28   1013 $self -> $callback(@args);
186             }
187             catch
188             {
189 0 0   0   0 croak "Error executing class-level callback for class '$class', hook '$hook': $@\n" if ($@);
190 28         267 };
191              
192 28         4561 $$count{class}++;
193              
194 28         115 $seen{$callback} = 1;
195             }
196             }
197              
198 29         110 return $count;
199              
200             } # End of call_hook.
201              
202             # --------------------------------------------------
203              
204             sub cgiapp_get_query
205             {
206 0     0 1 0 my($self) = @_;
207              
208 0         0 $self -> log(debug => 'cgiapp_get_query()');
209              
210 0 0       0 if (! $self -> _query)
211             {
212 0         0 require CGI;
213              
214 0         0 $self -> _query(CGI -> new);
215             }
216              
217 0         0 return $self -> _query;
218              
219             } # End of cgiapp_get_query.
220              
221             # --------------------------------------------------
222              
223             sub cgiapp_init
224             {
225 7     7 1 14 my($self) = @_;
226              
227 7         24 $self -> log(debug => 'cgiapp_init()');
228              
229             } # End of cgiapp_init.
230              
231             # --------------------------------------------------
232              
233             sub cgiapp_prerun
234             {
235 2     2 1 4 my($self) = @_;
236              
237 2         5 $self -> log(debug => 'cgiapp_prerun()');
238              
239             } # End of cgiapp_prerun.
240              
241             # --------------------------------------------------
242              
243             sub cgiapp_postrun
244             {
245 7     7 1 12 my($self) = @_;
246              
247 7         22 $self -> log(debug => 'cgiapp_postrun()');
248              
249             } # End of cgiapp_postrun.
250              
251             # --------------------------------------------------
252              
253             sub delete
254             {
255 0     0 1 0 my($self, $key) = @_;
256              
257 0         0 $self -> log(debug => 'delete()');
258              
259 0         0 my($result);
260              
261 0 0       0 if (defined $key)
262             {
263 0         0 my($param) = $self -> _params;
264 0         0 $result = delete $$param{$key};
265              
266 0         0 $self -> _params($param);
267             }
268              
269 0         0 return $result;
270              
271             } # End of delete.
272              
273             # --------------------------------------------------
274              
275             sub delete_header
276             {
277 0     0 1 0 my($self, @keys) = @_;
278              
279 0         0 $self -> log(debug => 'delete_header()');
280              
281 0         0 my($old) = $self -> _headers;
282              
283 0         0 delete $$old{$_} for (@keys);
284              
285 0         0 $self -> _headers($old);
286              
287 0         0 return %$old;
288              
289             } # End of delete_header.
290              
291             # --------------------------------------------------
292              
293             sub _determine_cgi_header
294             {
295 7     7   16 my($self) = @_;
296              
297 7         19 $self -> log(debug => '_determine_cgi_header()');
298              
299 7         1123 my($q) = $self -> query;
300 7         36 my($type) = $self -> header_type;
301              
302             return
303 7 50       58 $type eq 'header'
    100          
304             ? $q -> header($self -> header_props)
305             : $type eq 'redirect'
306             ? $q -> redirect($self -> header_props)
307             : '';
308              
309             } # End of _determine_cgi_header.
310              
311             # --------------------------------------------------
312              
313             sub _determine_output
314             {
315 7     7   11 my($self) = @_;
316              
317 7         19 $self -> log(debug => '_determine_output()');
318              
319 7         1223 my($run_mode) = $self -> _determine_run_mode;
320              
321 7         50 $self -> _prerun_mode_lock(0);
322 7         26 $self -> call_hook('prerun', $run_mode);
323 7         28 $self -> _prerun_mode_lock(1);
324              
325 7         58 my($output) = $self -> _generate_output;
326 7 50       28 $output = $$output if (ref $output eq 'SCALAR');
327              
328 7         24 $self -> call_hook('postrun', \$output);
329              
330 7         22 return $output;
331              
332             } # End of _determine_output.
333              
334             # --------------------------------------------------
335              
336             sub _determine_psgi_header
337             {
338 0     0   0 my($self) = @_;
339              
340 0         0 $self -> log(debug => '_determine_psgi_header()');
341              
342 0         0 my($q) = $self -> query;
343 0         0 my($type) = $self -> header_type;
344              
345             return
346 0 0       0 $type eq 'header'
    0          
347             ? $q -> psgi_header($self -> header_props)
348             : $type eq 'redirect'
349             ? $q -> psgi_redirect($self -> header_props)
350             : (200, []);
351              
352             } # End of _determine_psgi_header.
353              
354             # --------------------------------------------------
355              
356             sub _determine_run_mode
357             {
358 7     7   12 my($self) = @_;
359 7         25 my($mode_source) = $self -> _run_mode_source;
360              
361 7         9 my($run_mode);
362              
363 7 50       31 if (ref $mode_source eq 'CODE')
    50          
364             {
365 0         0 $run_mode = $mode_source -> ($self);
366             }
367             elsif (ref $mode_source eq 'HASH')
368             {
369 0         0 $run_mode = $$mode_source{run_mode};
370             }
371             else
372             {
373 7 50       19 $self -> cgiapp_get_query if (! $self -> query);
374              
375 7         18 $run_mode = $self -> query -> param($mode_source);
376             }
377              
378 7 50       162 $run_mode = $self -> start_mode if (! defined $run_mode);
379              
380 7         41 $self -> _current_run_mode($run_mode);
381 7         29 $self -> log(debug => "_determine_run_mode() => $run_mode");
382              
383 7         1108 return $run_mode;
384              
385             } # End of _determine_run_mode.
386              
387             # --------------------------------------------------
388              
389             sub dump
390             {
391 0     0 1 0 my($self) = @_;
392              
393 0         0 $self -> log(debug => 'dump()');
394              
395 0         0 my($q) = $self -> query;
396 0   0     0 my($output) = 'Run mode: ' . ($self -> _current_run_mode || ''). "\n" .
397             "Query parameters:\n" . $q -> Dump . "\nQuery environment:\n";
398              
399 0         0 for my $key (sort keys %ENV)
400             {
401 0         0 $output .= $q -> escapeHTML($key) . ' => ' . $q -> escapeHTML($ENV{$key}) . "\n";
402             }
403              
404 0         0 return $output;
405              
406             } # End of dump.
407              
408             # --------------------------------------------------
409              
410             sub dump_html
411             {
412 0     0 1 0 my($self) = @_;
413              
414 0         0 $self -> log(debug => 'dump_html()');
415              
416 0         0 my($q) = $self -> query;
417 0   0     0 my($output) = '

Run mode: ' . ($self -> _current_run_mode || ''). "

\n" .
418             "

Query parameters:

\n" . $q -> Dump . "\n

Query environment:

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