File Coverage

blib/lib/CGI/Application.pm
Criterion Covered Total %
statement 356 379 93.9
branch 158 184 85.8
condition 17 27 62.9
subroutine 41 44 93.1
pod 29 31 93.5
total 601 665 90.3


line stmt bran cond sub pod time code
1             package CGI::Application;
2 17     17   1056737 use Carp;
  17         157  
  17         1191  
3 17     17   106 use strict;
  17         35  
  17         391  
4 17     17   8694 use Class::ISA;
  17         32643  
  17         526  
5 17     17   128 use Scalar::Util;
  17         36  
  17         81395  
6              
7             $CGI::Application::VERSION = '4.60_1';
8              
9             my %INSTALLED_CALLBACKS = (
10             # hook name package sub
11             init => { 'CGI::Application' => [ 'cgiapp_init' ] },
12             prerun => { 'CGI::Application' => [ 'cgiapp_prerun' ] },
13             postrun => { 'CGI::Application' => [ 'cgiapp_postrun' ] },
14             teardown => { 'CGI::Application' => [ 'teardown' ] },
15             load_tmpl => { },
16             error => { },
17             );
18              
19             ###################################
20             #### INSTANCE SCRIPT METHODS ####
21             ###################################
22              
23             sub new {
24 69     69 1 113901 my $class = shift;
25              
26 69         190 my @args = @_;
27              
28 69 50       238 if (ref($class)) {
29             # No copy constructor yet!
30 0         0 $class = ref($class);
31             }
32              
33             # Create our object!
34 69         150 my $self = {};
35 69         156 bless($self, $class);
36              
37             ### SET UP DEFAULT VALUES ###
38             #
39             # We set them up here and not in the setup() because a subclass
40             # which implements setup() still needs default values!
41              
42 69         317 $self->header_type('header');
43 69         307 $self->mode_param('rm');
44 69         284 $self->start_mode('start');
45              
46             # Process optional new() parameters
47 69         102 my $rprops;
48 69 100       197 if (ref($args[0]) eq 'HASH') {
49 1         6 $rprops = $self->_cap_hash($args[0]);
50             } else {
51 68         329 $rprops = $self->_cap_hash({ @args });
52             }
53              
54             # Set tmpl_path()
55 69 100       258 if (exists($rprops->{TMPL_PATH})) {
56 4         21 $self->tmpl_path($rprops->{TMPL_PATH});
57             }
58              
59             # Set CGI query object
60 69 100       189 if (exists($rprops->{QUERY})) {
61 20         74 $self->query($rprops->{QUERY});
62             }
63              
64             # Set up init param() values
65 69 100       204 if (exists($rprops->{PARAMS})) {
66 2 100       200 croak("PARAMS is not a hash ref") unless (ref($rprops->{PARAMS}) eq 'HASH');
67 1         2 my $rparams = $rprops->{PARAMS};
68 1         7 while (my ($k, $v) = each(%$rparams)) {
69 2         9 $self->param($k, $v);
70             }
71             }
72              
73             # Lock prerun_mode from being changed until cgiapp_prerun()
74 68         166 $self->{__PRERUN_MODE_LOCKED} = 1;
75              
76             # Call cgiapp_init() method, which may be implemented in the sub-class.
77             # Pass all constructor args forward. This will allow flexible usage
78             # down the line.
79 68         304 $self->call_hook('init', @args);
80              
81             # Call setup() method, which should be implemented in the sub-class!
82 68         274 $self->setup();
83              
84 67         339 return $self;
85             }
86              
87             sub __get_runmode {
88 61     61   132 my $self = shift;
89 61         128 my $rm_param = shift;
90              
91 61         102 my $rm;
92             # Support call-back instead of CGI mode param
93 61 100       211 if (ref($rm_param) eq 'CODE') {
    100          
94             # Get run mode from subref
95 4         11 $rm = $rm_param->($self);
96             }
97             # support setting run mode from PATH_INFO
98             elsif (ref($rm_param) eq 'HASH') {
99 4         7 $rm = $rm_param->{run_mode};
100             }
101             # Get run mode from CGI param
102             else {
103 53         128 $rm = $self->query->param($rm_param);
104             }
105              
106             # If $rm undefined, use default (start) mode
107 61 100 100     1615 $rm = $self->start_mode unless defined($rm) && length($rm);
108              
109 61         153 return $rm;
110             }
111              
112             sub __get_runmeth {
113 61     61   121 my $self = shift;
114 61         124 my $rm = shift;
115              
116 61         96 my $rmeth;
117              
118 61         99 my $is_autoload = 0;
119              
120 61         144 my %rmodes = ($self->run_modes());
121 61 100       229 if (exists($rmodes{$rm})) {
122 58         130 $rmeth = $rmodes{$rm};
123             }
124             else {
125             # Look for run mode "AUTOLOAD" before dieing
126 3 100       15 unless (exists($rmodes{'AUTOLOAD'})) {
127 1         144 croak("No such run mode '$rm'");
128             }
129 2         5 $rmeth = $rmodes{'AUTOLOAD'};
130 2         5 $is_autoload = 1;
131             }
132              
133 60         218 return ($rmeth, $is_autoload);
134             }
135              
136             sub __get_body {
137 61     61   109 my $self = shift;
138 61         102 my $rm = shift;
139              
140 61         188 my ($rmeth, $is_autoload) = $self->__get_runmeth($rm);
141              
142 60         122 my $body;
143 60         102 eval {
144 60 100       273 $body = $is_autoload ? $self->$rmeth($rm) : $self->$rmeth();
145             };
146 60 100       1010 if ($@) {
147 3         8 my $error = $@;
148 3         12 $self->call_hook('error', $error);
149 3 100       17 if (my $em = $self->error_mode) {
150 2         9 $body = $self->$em( $error );
151             } else {
152 1         78 croak("Error executing run mode '$rm': $error");
153             }
154             }
155              
156             # Make sure that $body is not undefined (suppress 'uninitialized value'
157             # warnings)
158 58 100       249 return defined $body ? $body : '';
159             }
160              
161              
162             sub run {
163 61     61 1 1019 my $self = shift;
164 61         197 my $q = $self->query();
165              
166 61         177 my $rm_param = $self->mode_param();
167              
168 61         250 my $rm = $self->__get_runmode($rm_param);
169              
170             # Set get_current_runmode() for access by user later
171 61         142 $self->{__CURRENT_RUNMODE} = $rm;
172              
173             # Allow prerun_mode to be changed
174 61         127 delete($self->{__PRERUN_MODE_LOCKED});
175              
176             # Call PRE-RUN hook, now that we know the run mode
177             # This hook can be used to provide run mode specific behaviors
178             # before the run mode actually runs.
179 61         229 $self->call_hook('prerun', $rm);
180              
181             # Lock prerun_mode from being changed after cgiapp_prerun()
182 61         133 $self->{__PRERUN_MODE_LOCKED} = 1;
183              
184             # If prerun_mode has been set, use it!
185 61         214 my $prerun_mode = $self->prerun_mode();
186 61 100       156 if (length($prerun_mode)) {
187 1         4 $rm = $prerun_mode;
188 1         3 $self->{__CURRENT_RUNMODE} = $rm;
189             }
190              
191             # Process run mode!
192 61         208 my $body = $self->__get_body($rm);
193              
194             # Support scalar-ref for body return
195 58 100       182 $body = $$body if ref $body eq 'SCALAR';
196              
197             # Call cgiapp_postrun() hook
198 58         206 $self->call_hook('postrun', \$body);
199              
200 58         102 my $return_value;
201 58 100       152 if ($self->{__IS_PSGI}) {
202 1         5 my ($status, $headers) = $self->_send_psgi_headers();
203              
204 1 50 33     118 if (ref($body) eq 'GLOB' || (Scalar::Util::blessed($body) && $body->can('getline'))) {
    50 33        
205             # body a file handle - return it
206 0         0 $return_value = [ $status, $headers, $body];
207             }
208             elsif (ref($body) eq 'CODE') {
209              
210             # body is a subref, or an explicit callback method is set
211             $return_value = sub {
212 0     0   0 my $respond = shift;
213              
214 0         0 my $writer = $respond->([ $status, $headers ]);
215              
216 0         0 &$body($writer);
217 0         0 };
218             }
219             else {
220              
221 1         4 $return_value = [ $status, $headers, [ $body ]];
222             }
223             }
224             else {
225             # Set up HTTP headers non-PSGI responses
226 57         213 my $headers = $self->_send_headers();
227              
228             # Build up total output
229 57         16439 $return_value = $headers.$body;
230 57 100       250 print $return_value unless $ENV{CGI_APP_RETURN_ONLY};
231             }
232              
233             # clean up operations
234 58         198 $self->call_hook('teardown');
235              
236 58         241 return $return_value;
237             }
238              
239              
240             sub psgi_app {
241 0     0 1 0 my $class = shift;
242 0         0 my $args_to_new = shift;
243              
244             return sub {
245 0     0   0 my $env = shift;
246            
247             # PR from alter https://github.com/markstos/CGI--Application/pull/17
248             #if (not defined $args_to_new->{QUERY}) {
249 0         0 require CGI::PSGI;
250 0         0 $args_to_new->{QUERY} = CGI::PSGI->new($env);
251             #}
252              
253 0         0 my $webapp = $class->new($args_to_new);
254 0         0 return $webapp->run_as_psgi;
255             }
256 0         0 }
257              
258             sub run_as_psgi {
259 1     1 1 25 my $self = shift;
260 1         5 $self->{__IS_PSGI} = 1;
261              
262             # Run doesn't officially support any args, but pass them through in case some sub-class uses them.
263 1         11 return $self->run(@_);
264             }
265              
266              
267             ############################
268             #### OVERRIDE METHODS ####
269             ############################
270              
271             sub cgiapp_get_query {
272 14     14 1 30 my $self = shift;
273              
274             # Include CGI.pm and related modules
275 14         5913 require CGI;
276              
277             # Get the query object
278 14         196636 my $q = CGI->new();
279              
280 14         4503 return $q;
281             }
282              
283              
284             sub cgiapp_init {
285 45     45 1 96 my $self = shift;
286 45         147 my @args = (@_);
287              
288             # Nothing to init, yet!
289             }
290              
291              
292             sub cgiapp_prerun {
293 53     53 1 101 my $self = shift;
294 53         111 my $rm = shift;
295              
296             # Nothing to prerun, yet!
297             }
298              
299              
300             sub cgiapp_postrun {
301 51     51 1 101 my $self = shift;
302 51         99 my $bodyref = shift;
303              
304             # Nothing to postrun, yet!
305             }
306              
307              
308             sub setup {
309 11     11 1 20 my $self = shift;
310             }
311              
312              
313             sub teardown {
314 39     39 1 136 my $self = shift;
315              
316             # Nothing to shut down, yet!
317             }
318              
319              
320              
321              
322             ######################################
323             #### APPLICATION MODULE METHODS ####
324             ######################################
325              
326             sub dump {
327 2     2 1 4 my $self = shift;
328 2         4 my $output = '';
329              
330             # Dump run mode
331 2         5 my $current_runmode = $self->get_current_runmode();
332 2 100       8 $current_runmode = "" unless (defined($current_runmode));
333 2         6 $output .= "Current Run mode: '$current_runmode'\n";
334              
335             # Dump Params
336             # updated ->param to ->multi_param to silence CGI.pm warning
337 2         3 $output .= "\nQuery Parameters:\n";
338 2         6 my @params = $self->query->multi_param();
339 2         44 foreach my $p (sort(@params)) {
340 1         3 my @data = $self->query->multi_param($p);
341 1         31 my $data_str = "'".join("', '", @data)."'";
342 1         4 $output .= "\t$p => $data_str\n";
343             }
344              
345             # Dump ENV
346 2         5 $output .= "\nQuery Environment:\n";
347 2         31 foreach my $ek (sort(keys(%ENV))) {
348 58         115 $output .= "\t$ek => '".$ENV{$ek}."'\n";
349             }
350              
351 2         11 return $output;
352             }
353              
354              
355             sub dump_html {
356 1     1 1 3 my $self = shift;
357 1         2 my $query = $self->query();
358 1         2 my $output = '';
359              
360             # Dump run-mode
361 1         3 my $current_runmode = $self->get_current_runmode();
362 1         4 $output .= "

Current Run-mode:

363             '$current_runmode'

\n";
364              
365             # Dump Params
366 1         2 $output .= "

Query Parameters:

\n";
367 1         26 $output .= $query->Dump;
368              
369             # Dump ENV
370 1         230 $output .= "

Query Environment:

\n
    \n";
371 1         26 foreach my $ek ( sort( keys( %ENV ) ) ) {
372             $output .= sprintf(
373             "
  • %s => '%s'
  • \n",
    374             $query->escapeHTML( $ek ),
    375 29         3164 $query->escapeHTML( $ENV{$ek} )
    376             );
    377             }
    378 1         95 $output .= "\n";
    379              
    380 1         15 return $output;
    381             }
    382              
    383              
    384             sub no_runmodes {
    385              
    386 9     9 0 20 my $self = shift;
    387 9         27 my $query = $self->query();
    388 9         36 my $output = $query->start_html;
    389            
    390             # If no runmodes specified by app return error message
    391 9         22625 my $current_runmode = $self->get_current_runmode();
    392 9         31 my $query_params = $query->Dump;
    393            
    394 9         465 $output .= qq{
    395            

    Error - No runmodes specified.

    396            

    Runmode called: $current_runmode"

    397            

    Query paramaters:

    $query_params
    398            

    Your application has not specified any runmodes.

    399            

    Please read the

    400             CGI::Application documentation.

    401             };
    402            
    403 9         30 $output .= $query->end_html();
    404 9         49 return $output;
    405             }
    406              
    407              
    408             sub header_add {
    409 5     5 1 669 my $self = shift;
    410 5         20 return $self->_header_props_update(\@_,add=>1);
    411             }
    412              
    413             sub header_props {
    414 67     67 1 4066 my $self = shift;
    415 67         265 return $self->_header_props_update(\@_,add=>0);
    416             }
    417              
    418             # used by header_props and header_add to update the headers
    419             sub _header_props_update {
    420 72     72   167 my $self = shift;
    421 72         143 my $data_ref = shift;
    422 72         224 my %in = @_;
    423              
    424 72         138 my @data = @$data_ref;
    425              
    426             # First use? Create new __HEADER_PROPS!
    427 72 100       232 $self->{__HEADER_PROPS} = {} unless (exists($self->{__HEADER_PROPS}));
    428              
    429 72         109 my $props;
    430              
    431             # If data is provided, set it!
    432 72 100       178 if (scalar(@data)) {
    433 19 100       42 if ($self->header_type eq 'none') {
    434 1         15 warn "header_props called while header_type set to 'none', headers will NOT be sent!"
    435             }
    436             # Is it a hash, or hash-ref?
    437 19 100       76 if (ref($data[0]) eq 'HASH') {
        100          
    438             # Make a copy
    439 4         7 %$props = %{$data[0]};
      4         15  
    440             } elsif ((scalar(@data) % 2) == 0) {
    441             # It appears to be a possible hash (even # of elements)
    442 13         51 %$props = @data;
    443             } else {
    444 2 100       7 my $meth = $in{add} ? 'add' : 'props';
    445 2         268 croak("Odd number of elements passed to header_$meth(). Not a valid hash")
    446             }
    447              
    448             # merge in new headers, appending new values passed as array refs
    449 17 100       46 if ($in{add}) {
    450 4         23 for my $key_set_to_aref (grep { ref $props->{$_} eq 'ARRAY'} keys %$props) {
      4         22  
    451 2         7 my $existing_val = $self->{__HEADER_PROPS}->{$key_set_to_aref};
    452 2 100       11 next unless defined $existing_val;
    453 1 50       8 my @existing_val_array = (ref $existing_val eq 'ARRAY') ? @$existing_val : ($existing_val);
    454 1         4 $props->{$key_set_to_aref} = [ @existing_val_array, @{ $props->{$key_set_to_aref} } ];
      1         6  
    455             }
    456 4         12 $self->{__HEADER_PROPS} = { %{ $self->{__HEADER_PROPS} }, %$props };
      4         22  
    457             }
    458             # Set new headers, clobbering existing values
    459             else {
    460 13         32 $self->{__HEADER_PROPS} = $props;
    461             }
    462              
    463             }
    464              
    465             # If we've gotten this far, return the value!
    466 70         140 return (%{ $self->{__HEADER_PROPS}});
      70         375  
    467             }
    468              
    469              
    470             sub header_type {
    471 157     157 1 294 my $self = shift;
    472 157         303 my ($header_type) = @_;
    473              
    474 157         390 my @allowed_header_types = qw(header redirect none);
    475              
    476             # First use? Create new __HEADER_TYPE!
    477 157 100       520 $self->{__HEADER_TYPE} = 'header' unless (exists($self->{__HEADER_TYPE}));
    478              
    479             # If data is provided, set it!
    480 157 100       381 if (defined($header_type)) {
    481 80         212 $header_type = lc($header_type);
    482             croak("Invalid header_type '$header_type'")
    483 80 50       177 unless(grep { $_ eq $header_type } @allowed_header_types);
      240         674  
    484 80         191 $self->{__HEADER_TYPE} = $header_type;
    485             }
    486              
    487             # If we've gotten this far, return the value!
    488 157         394 return $self->{__HEADER_TYPE};
    489             }
    490              
    491              
    492             sub param {
    493 106     106 1 20975 my $self = shift;
    494 106         247 my (@data) = (@_);
    495              
    496             # First use? Create new __PARAMS!
    497 106 100       299 $self->{__PARAMS} = {} unless (exists($self->{__PARAMS}));
    498              
    499 106         174 my $rp = $self->{__PARAMS};
    500              
    501             # If data is provided, set it!
    502 106 100       257 if (scalar(@data)) {
    503             # Is it a hash, or hash-ref?
    504 98 100       334 if (ref($data[0]) eq 'HASH') {
        100          
        50          
    505             # Make a copy, which augments the existing contents (if any)
    506 1         3 %$rp = (%$rp, %{$data[0]});
      1         9  
    507             } elsif ((scalar(@data) % 2) == 0) {
    508             # It appears to be a possible hash (even # of elements)
    509 62         244 %$rp = (%$rp, @data);
    510             } elsif (scalar(@data) > 1) {
    511 0         0 croak("Odd number of elements passed to param(). Not a valid hash");
    512             }
    513             } else {
    514             # Return the list of param keys if no param is specified.
    515 8         65 return (keys(%$rp));
    516             }
    517              
    518             # If exactly one parameter was sent to param(), return the value
    519 98 100       283 if (scalar(@data) <= 2) {
    520 96         168 my $param = $data[0];
    521 96         366 return $rp->{$param};
    522             }
    523 2         5 return; # Otherwise, return undef
    524             }
    525              
    526              
    527             sub delete {
    528 3     3 1 14 my $self = shift;
    529 3         6 my ($param) = @_;
    530              
    531             # return undef it the param name isn't given
    532 3 100       13 return undef unless defined $param;
    533              
    534             #simply delete this param from $self->{__PARAMS}
    535 2         6 delete $self->{__PARAMS}->{$param};
    536             }
    537              
    538              
    539             sub query {
    540 247     247 1 10537 my $self = shift;
    541 247         465 my ($query) = @_;
    542              
    543             # If data is provided, set it! Otherwise, create a new one.
    544 247 100       543 if (defined($query)) {
    545 44         112 $self->{__QUERY_OBJ} = $query;
    546             } else {
    547             # We're only allowed to create a new query object if one does not yet exist!
    548 203 100       516 unless (exists($self->{__QUERY_OBJ})) {
    549 15         82 $self->{__QUERY_OBJ} = $self->cgiapp_get_query();
    550             }
    551             }
    552              
    553 247         34582 return $self->{__QUERY_OBJ};
    554             }
    555              
    556              
    557             sub run_modes {
    558 131     131 1 527 my $self = shift;
    559 131         311 my (@data) = (@_);
    560              
    561             # First use? Create new __RUN_MODES!
    562 131 100       453 $self->{__RUN_MODES} = { 'start' => 'no_runmodes' } unless (exists($self->{__RUN_MODES}));
    563              
    564 131         260 my $rr_m = $self->{__RUN_MODES};
    565              
    566             # If data is provided, set it!
    567 131 100       389 if (scalar(@data)) {
    568             # Is it a hash, hash-ref, or array-ref?
    569 70 100       310 if (ref($data[0]) eq 'HASH') {
        100          
        100          
    570             # Make a copy, which augments the existing contents (if any)
    571 1         4 %$rr_m = (%$rr_m, %{$data[0]});
      1         4  
    572             } elsif (ref($data[0]) eq 'ARRAY') {
    573             # Convert array-ref into hash table
    574 12         17 foreach my $rm (@{$data[0]}) {
      12         27  
    575 26         54 $rr_m->{$rm} = $rm;
    576             }
    577             } elsif ((scalar(@data) % 2) == 0) {
    578             # It appears to be a possible hash (even # of elements)
    579 56         362 %$rr_m = (%$rr_m, @data);
    580             } else {
    581 1         122 croak("Odd number of elements passed to run_modes(). Not a valid hash");
    582             }
    583             }
    584              
    585             # If we've gotten this far, return the value!
    586 130         593 return (%$rr_m);
    587             }
    588              
    589              
    590             sub start_mode {
    591 145     145 1 409 my $self = shift;
    592 145         345 my ($start_mode) = @_;
    593              
    594             # First use? Create new __START_MODE
    595 145 100       405 $self->{__START_MODE} = 'start' unless (exists($self->{__START_MODE}));
    596              
    597             # If data is provided, set it
    598 145 100       339 if (defined($start_mode)) {
    599 119         224 $self->{__START_MODE} = $start_mode;
    600             }
    601              
    602 145         318 return $self->{__START_MODE};
    603             }
    604              
    605              
    606             sub error_mode {
    607 5     5 1 29 my $self = shift;
    608 5         13 my ($error_mode) = @_;
    609              
    610             # First use? Create new __ERROR_MODE
    611 5 100       22 $self->{__ERROR_MODE} = undef unless (exists($self->{__ERROR_MODE}));
    612              
    613             # If data is provided, set it.
    614 5 100       16 if (defined($error_mode)) {
    615 2         6 $self->{__ERROR_MODE} = $error_mode;
    616             }
    617              
    618 5         17 return $self->{__ERROR_MODE};
    619             }
    620              
    621              
    622             sub tmpl_path {
    623 13     13 1 33 my $self = shift;
    624 13         27 my ($tmpl_path) = @_;
    625              
    626             # First use? Create new __TMPL_PATH!
    627 13 100       42 $self->{__TMPL_PATH} = '' unless (exists($self->{__TMPL_PATH}));
    628              
    629             # If data is provided, set it!
    630 13 100       26 if (defined($tmpl_path)) {
    631 5         9 $self->{__TMPL_PATH} = $tmpl_path;
    632             }
    633              
    634             # If we've gotten this far, return the value!
    635 13         40 return $self->{__TMPL_PATH};
    636             }
    637              
    638              
    639             sub prerun_mode {
    640 64     64 1 131 my $self = shift;
    641 64         135 my ($prerun_mode) = @_;
    642              
    643             # First use? Create new __PRERUN_MODE
    644 64 100       200 $self->{__PRERUN_MODE} = '' unless (exists($self->{__PRERUN_MODE}));
    645              
    646             # Was data provided?
    647 64 100       175 if (defined($prerun_mode)) {
    648             # Are we allowed to set prerun_mode?
    649 3 100       12 if (exists($self->{__PRERUN_MODE_LOCKED})) {
    650             # Not allowed! Throw an exception.
    651 2         395 croak("prerun_mode() can only be called within cgiapp_prerun()! Error");
    652             } else {
    653             # If data is provided, set it!
    654 1         4 $self->{__PRERUN_MODE} = $prerun_mode;
    655             }
    656             }
    657              
    658             # If we've gotten this far, return the value!
    659 62         136 return $self->{__PRERUN_MODE};
    660             }
    661              
    662              
    663             sub get_current_runmode {
    664 22     22 1 1675 my $self = shift;
    665              
    666             # It's OK if we return undef if this method is called too early
    667 22         65 return $self->{__CURRENT_RUNMODE};
    668             }
    669              
    670              
    671              
    672              
    673              
    674             ###########################
    675             #### PRIVATE METHODS ####
    676             ###########################
    677              
    678              
    679             # return headers as a string
    680             sub _send_headers {
    681 57     57   159 my $self = shift;
    682 57         158 my $q = $self->query;
    683 57         206 my $type = $self->header_type;
    684              
    685             return
    686 57 50       319 $type eq 'redirect' ? $q->redirect( $self->header_props )
        100          
        100          
    687             : $type eq 'header' ? $q->header ( $self->header_props )
    688             : $type eq 'none' ? ''
    689             : croak "Invalid header_type '$type'"
    690             }
    691              
    692             # return a 2 element array modeling the first PSGI redirect values: status code and arrayref of header pairs
    693             sub _send_psgi_headers {
    694 1     1   9 my $self = shift;
    695 1         16 my $q = $self->query;
    696 1         3 my $type = $self->header_type;
    697              
    698             return
    699 1 0       11 $type eq 'redirect' ? $q->psgi_redirect( $self->header_props )
        50          
        50          
    700             : $type eq 'header' ? $q->psgi_header ( $self->header_props )
    701             : $type eq 'none' ? ''
    702             : croak "Invalid header_type '$type'"
    703              
    704             }
    705              
    706              
    707             # Make all hash keys CAPITAL
    708             # although this method is internal, some other extensions
    709             # have come to rely on it, so any changes here should be
    710             # made with great care or avoided.
    711             sub _cap_hash {
    712 69     69   137 my $self = shift;
    713 69         109 my $rhash = shift;
    714             my %hash = map {
    715 26         57 my $k = $_;
    716 26         50 my $v = $rhash->{$k};
    717 26         68 $k =~ tr/a-z/A-Z/;
    718 26         114 $k => $v;
    719 69         116 } keys(%{$rhash});
      69         225  
    720 69         208 return \%hash;
    721             }
    722              
    723              
    724              
    725             1;
    726              
    727              
    728              
    729              
    730             =pod
    731              
    732             =head1 NAME
    733              
    734             CGI::Application - Framework for building reusable web-applications
    735              
    736             =head1 SYNOPSIS
    737              
    738             # In "WebApp.pm"...
    739             package WebApp;
    740             use base 'CGI::Application';
    741              
    742             # ( setup() can even be skipped for common cases. See docs below. )
    743             sub setup {
    744             my $self = shift;
    745             $self->start_mode('mode1');
    746             $self->mode_param('rm');
    747             $self->run_modes(
    748             'mode1' => 'do_stuff',
    749             'mode2' => 'do_more_stuff',
    750             'mode3' => 'do_something_else'
    751             );
    752             }
    753             sub do_stuff { ... }
    754             sub do_more_stuff { ... }
    755             sub do_something_else { ... }
    756             1;
    757              
    758              
    759             ### In "webapp.cgi"...
    760             use WebApp;
    761             my $webapp = WebApp->new();
    762             $webapp->run();
    763              
    764             ### Or, in a PSGI file, webapp.psgi
    765             use WebApp;
    766             WebApp->psgi_app();
    767              
    768             =head1 INTRODUCTION
    769              
    770             CGI::Application makes it easier to create sophisticated, high-performance,
    771             reusable web-based applications. CGI::Application helps makes your web
    772             applications easier to design, write, and evolve.
    773              
    774             CGI::Application judiciously avoids employing technologies and techniques which
    775             would bind a developer to any one set of tools, operating system or web server.
    776              
    777             It is lightweight in terms of memory usage, making it suitable for common CGI
    778             environments, and a high performance choice in persistent environments like
    779             FastCGI or mod_perl.
    780              
    781             By adding L as your needs grow, you can add advanced and complex
    782             features when you need them.
    783              
    784             First released in 2000 and used and expanded by a number of professional
    785             website developers, CGI::Application is a stable, reliable choice.
    786              
    787             =head1 USAGE EXAMPLE
    788              
    789             Imagine you have to write an application to search through a database
    790             of widgets. Your application has three screens:
    791              
    792             1. Search form
    793             2. List of results
    794             3. Detail of a single record
    795              
    796             To write this application using CGI::Application you will create two files:
    797              
    798             1. WidgetView.pm -- Your "Application Module"
    799             2. widgetview.cgi -- Your "Instance Script"
    800              
    801             The Application Module contains all the code specific to your
    802             application functionality, and it exists outside of your web server's
    803             document root, somewhere in the Perl library search path.
    804              
    805             The Instance Script is what is actually called by your web server. It is
    806             a very small, simple file which simply creates an instance of your
    807             application and calls an inherited method, run(). Following is the
    808             entirety of "widgetview.cgi":
    809              
    810             #!/usr/bin/perl -w
    811             use WidgetView;
    812             my $webapp = WidgetView->new();
    813             $webapp->run();
    814              
    815             As you can see, widgetview.cgi simply "uses" your Application module
    816             (which implements a Perl package called "WidgetView"). Your Application Module,
    817             "WidgetView.pm", is somewhat more lengthy:
    818              
    819             package WidgetView;
    820             use base 'CGI::Application';
    821             use strict;
    822              
    823             # Needed for our database connection
    824             use CGI::Application::Plugin::DBH;
    825              
    826             sub setup {
    827             my $self = shift;
    828             $self->start_mode('mode1');
    829             $self->run_modes(
    830             'mode1' => 'showform',
    831             'mode2' => 'showlist',
    832             'mode3' => 'showdetail'
    833             );
    834              
    835             # Connect to DBI database, with the same args as DBI->connect();
    836             $self->dbh_config();
    837             }
    838              
    839             sub teardown {
    840             my $self = shift;
    841              
    842             # Disconnect when we're done, (Although DBI usually does this automatically)
    843             $self->dbh->disconnect();
    844             }
    845              
    846             sub showform {
    847             my $self = shift;
    848              
    849             # Get CGI query object
    850             my $q = $self->query();
    851              
    852             my $output = '';
    853             $output .= $q->start_html(-title => 'Widget Search Form');
    854             $output .= $q->start_form();
    855             $output .= $q->textfield(-name => 'widgetcode');
    856             $output .= $q->hidden(-name => 'rm', -value => 'mode2');
    857             $output .= $q->submit();
    858             $output .= $q->end_form();
    859             $output .= $q->end_html();
    860              
    861             return $output;
    862             }
    863              
    864             sub showlist {
    865             my $self = shift;
    866              
    867             # Get our database connection
    868             my $dbh = $self->dbh();
    869              
    870             # Get CGI query object
    871             my $q = $self->query();
    872             my $widgetcode = $q->param("widgetcode");
    873              
    874             my $output = '';
    875             $output .= $q->start_html(-title => 'List of Matching Widgets');
    876              
    877             ## Do a bunch of stuff to select "widgets" from a DBI-connected
    878             ## database which match the user-supplied value of "widgetcode"
    879             ## which has been supplied from the previous HTML form via a
    880             ## CGI.pm query object.
    881             ##
    882             ## Each row will contain a link to a "Widget Detail" which
    883             ## provides an anchor tag, as follows:
    884             ##
    885             ## "widgetview.cgi?rm=mode3&widgetid=XXX"
    886             ##
    887             ## ...Where "XXX" is a unique value referencing the ID of
    888             ## the particular "widget" upon which the user has clicked.
    889              
    890             $output .= $q->end_html();
    891              
    892             return $output;
    893             }
    894              
    895             sub showdetail {
    896             my $self = shift;
    897              
    898             # Get our database connection
    899             my $dbh = $self->dbh();
    900              
    901             # Get CGI query object
    902             my $q = $self->query();
    903             my $widgetid = $q->param("widgetid");
    904              
    905             my $output = '';
    906             $output .= $q->start_html(-title => 'Widget Detail');
    907              
    908             ## Do a bunch of things to select all the properties of
    909             ## the particular "widget" upon which the user has
    910             ## clicked. The key id value of this widget is provided
    911             ## via the "widgetid" property, accessed via the CGI.pm
    912             ## query object.
    913              
    914             $output .= $q->end_html();
    915              
    916             return $output;
    917             }
    918              
    919             1; # Perl requires this at the end of all modules
    920              
    921              
    922             CGI::Application takes care of implementing the new() and the run()
    923             methods. Notice that at no point do you call print() to send any
    924             output to STDOUT. Instead, all output is returned as a scalar.
    925              
    926             CGI::Application's most significant contribution is in managing
    927             the application state. Notice that all which is needed to push
    928             the application forward is to set the value of a HTML form
    929             parameter 'rm' to the value of the "run mode" you wish to handle
    930             the form submission. This is the key to CGI::Application.
    931              
    932              
    933             =head1 ABSTRACT
    934              
    935             The guiding philosophy behind CGI::Application is that a web-based
    936             application can be organized into a specific set of "Run Modes."
    937             Each Run Mode is roughly analogous to a single screen (a form, some
    938             output, etc.). All the Run Modes are managed by a single "Application
    939             Module" which is a Perl module. In your web server's document space
    940             there is an "Instance Script" which is called by the web server as a
    941             CGI (or an Apache::Registry script if you're using Apache + mod_perl).
    942              
    943             This methodology is an inversion of the "Embedded" philosophy (ASP, JSP,
    944             EmbPerl, Mason, etc.) in which there are "pages" for each state of the
    945             application, and the page drives functionality. In CGI::Application,
    946             form follows function -- the Application Module drives pages, and the
    947             code for a single application is in one place; not spread out over
    948             multiple "pages". If you feel that Embedded architectures are
    949             confusing, unorganized, difficult to design and difficult to manage,
    950             CGI::Application is the methodology for you!
    951              
    952             Apache is NOT a requirement for CGI::Application. Web applications based on
    953             CGI::Application will run equally well on NT/IIS or any other
    954             CGI-compatible environment. CGI::Application-based projects
    955             are, however, ripe for use on Apache/mod_perl servers, as they
    956             naturally encourage Good Programming Practices and will often work
    957             in persistent environments without modification.
    958              
    959             For more information on using CGI::Application with mod_perl, please see our
    960             website at http://www.cgi-app.org/, as well as
    961             L, which integrates with L.
    962              
    963             =head1 DESCRIPTION
    964              
    965             It is intended that your Application Module will be implemented as a sub-class
    966             of CGI::Application. This is done simply as follows:
    967              
    968             package My::App;
    969             use base 'CGI::Application';
    970              
    971             B
    972              
    973             For the purpose of this document, we will refer to the
    974             following conventions:
    975              
    976             WebApp.pm The Perl module which implements your Application Module class.
    977             WebApp Your Application Module class; a sub-class of CGI::Application.
    978             webapp.cgi The Instance Script which implements your Application Module.
    979             $webapp An instance (object) of your Application Module class.
    980             $c Same as $webapp, used in instance methods to pass around the
    981             current object. (Sometimes referred as "$self" in other code)
    982              
    983              
    984              
    985              
    986             =head2 Instance Script Methods
    987              
    988             By inheriting from CGI::Application you have access to a
    989             number of built-in methods. The following are those which
    990             are expected to be called from your Instance Script.
    991              
    992             =head3 new()
    993              
    994             The new() method is the constructor for a CGI::Application. It returns
    995             a blessed reference to your Application Module package (class). Optionally,
    996             new() may take a set of parameters as key => value pairs:
    997              
    998             my $webapp = WebApp->new(
    999             TMPL_PATH => 'App/',
    1000             PARAMS => {
    1001             'custom_thing_1' => 'some val',
    1002             'another_custom_thing' => [qw/123 456/]
    1003             }
    1004             );
    1005              
    1006             This method may take some specific parameters:
    1007              
    1008             B - This optional parameter defines a path to a directory of templates.
    1009             This is used by the load_tmpl() method (specified below), and may also be used
    1010             for the same purpose by other template plugins. This run-time parameter allows
    1011             you to further encapsulate instantiating templates, providing potential for
    1012             more re-usability. It can be either a scalar or an array reference of multiple
    1013             paths.
    1014              
    1015             B - This optional parameter allows you to specify an
    1016             already-created CGI.pm query object. Under normal use,
    1017             CGI::Application will instantiate its own CGI.pm query object.
    1018             Under certain conditions, it might be useful to be able to use
    1019             one which has already been created.
    1020              
    1021             B - This parameter, if used, allows you to set a number
    1022             of custom parameters at run-time. By passing in different
    1023             values in different instance scripts which use the same application
    1024             module you can achieve a higher level of re-usability. For instance,
    1025             imagine an application module, "Mailform.pm". The application takes
    1026             the contents of a HTML form and emails it to a specified recipient.
    1027             You could have multiple instance scripts throughout your site which
    1028             all use this "Mailform.pm" module, but which set different recipients
    1029             or different forms.
    1030              
    1031             One common use of instance scripts is to provide a path to a config file. This
    1032             design allows you to define project wide configuration objects used by many
    1033             several instance scripts. There are several plugins which simplify the syntax
    1034             for this and provide lazy loading. Here's an example using
    1035             L, which uses L to support
    1036             many configuration file formats.
    1037              
    1038             my $app = WebApp->new(PARAMS => { cfg_file => 'config.pl' });
    1039              
    1040             # Later in your app:
    1041             my %cfg = $self->cfg()
    1042             # or ... $self->cfg('HTML_ROOT_DIR');
    1043              
    1044             See the list of plugins below for more config file integration solutions.
    1045              
    1046             =head3 run()
    1047              
    1048             The run() method is called upon your Application Module object, from
    1049             your Instance Script. When called, it executes the functionality
    1050             in your Application Module.
    1051              
    1052             my $webapp = WebApp->new();
    1053             $webapp->run();
    1054              
    1055             This method first determines the application state by looking at the
    1056             value of the CGI parameter specified by mode_param() (defaults to
    1057             'rm' for "Run Mode"), which is expected to contain the name of the mode of
    1058             operation. If not specified, the state defaults to the value
    1059             of start_mode().
    1060              
    1061             Once the mode has been determined, run() looks at the dispatch
    1062             table stored in run_modes() and finds the function pointer which
    1063             is keyed from the mode name. If found, the function is called and the
    1064             data returned is print()'ed to STDOUT and to the browser. If
    1065             the specified mode is not found in the run_modes() table, run() will
    1066             croak().
    1067              
    1068             =head2 PSGI support
    1069              
    1070             CGI::Application offers native L support. The default query object
    1071             for this is L, which simply wrappers CGI.pm to provide PSGI
    1072             support to it.
    1073              
    1074             =head3 psgi_app()
    1075              
    1076             $psgi_coderef = WebApp->psgi_app({ ... args to new() ... });
    1077              
    1078             The simplest way to create and return a PSGI-compatible coderef. Pass in
    1079             arguments to a hashref just as would to new. This returns a PSGI-compatible
    1080             coderef, using L as the query object. To use a different query
    1081             object, construct your own object using C<< run_as_psgi() >>, as shown below.
    1082              
    1083             It's possible that we'll change from CGI::PSGI to a different-but-compatible
    1084             query object for PSGI support in the future, perhaps if CGI.pm adds native
    1085             PSGI support.
    1086              
    1087             =head3 run_as_psgi()
    1088              
    1089             my $psgi_aref = $webapp->run_as_psgi;
    1090              
    1091             Just like C<< run >>, but prints no output and returns the data structure
    1092             required by the L specification. Use this if you want to run the
    1093             application on top of a PSGI-compatible handler, such as L provides.
    1094              
    1095             If you are just getting started, just use C<< run() >>. It's easy to switch to using
    1096             C<< run_as_psgi >> later.
    1097              
    1098             Why use C<< run_as_psgi() >>? There are already solutions to run
    1099             CGI::Application-based projects on several web servers with dozens of plugins.
    1100             Running as a PSGI-compatible application provides the ability to run on
    1101             additional PSGI-compatible servers, as well as providing access to all of the
    1102             "Middleware" solutions available through the L project.
    1103              
    1104             The structure returned is an arrayref, containing the status code, an arrayref
    1105             of header key/values and an arrayref containing the body.
    1106              
    1107             [ 200, [ 'Content-Type' => 'text/html' ], [ $body ] ]
    1108              
    1109             By default the body is a single scalar, but plugins may modify this to return
    1110             other value PSGI values. See L for details about the
    1111             response format.
    1112              
    1113             Note that calling C<< run_as_psgi >> only handles the I portion of the
    1114             PSGI spec. to handle the input, you need to use a CGI.pm-like query object that
    1115             is PSGI-compliant, such as L. This query object must provide L
    1116             and L methods.
    1117              
    1118             The final result might look like this:
    1119              
    1120             use WebApp;
    1121             use CGI::PSGI;
    1122              
    1123             my $handler = sub {
    1124             my $env = shift;
    1125             my $webapp = WebApp->new({ QUERY => CGI::PSGI->new($env) });
    1126             $webapp->run_as_psgi;
    1127             };
    1128              
    1129             =head2 Additional PSGI Return Values
    1130              
    1131             The PSGI Specification allows for returning a file handle or a subroutine reference instead of byte strings. In PSGI mode this is supported directly by CGI::Application. Have your run mode return a file handle or compatible subref as follows:
    1132              
    1133             sub returning_a_file_handle {
    1134             my $self = shift;
    1135              
    1136             $self->header_props(-type => 'text/plain');
    1137              
    1138             open my $fh, "<", 'test_file.txt' or die "OOPS! $!";
    1139              
    1140             return $fh;
    1141             }
    1142              
    1143             sub returning_a_subref {
    1144             my $self = shift;
    1145              
    1146             $self->header_props(-type => 'text/plain');
    1147             return sub {
    1148             my $writer = shift;
    1149             foreach my $i (1..10) {
    1150             #sleep 1;
    1151             $writer->write("check $i: " . time . "\n");
    1152             }
    1153             };
    1154             }
    1155              
    1156             =head2 Methods to possibly override
    1157              
    1158             CGI::Application implements some methods which are expected to be overridden
    1159             by implementing them in your sub-class module. These methods are as follows:
    1160              
    1161             =head3 setup()
    1162              
    1163             This method is called by the inherited new() constructor method. The
    1164             setup() method should be used to define the following property/methods:
    1165              
    1166             mode_param() - set the name of the run mode CGI param.
    1167             start_mode() - text scalar containing the default run mode.
    1168             error_mode() - text scalar containing the error mode.
    1169             run_modes() - hash table containing mode => function mappings.
    1170             tmpl_path() - text scalar or array reference containing path(s) to template files.
    1171              
    1172             Your setup() method may call any of the instance methods of your application.
    1173             This function is a good place to define properties specific to your application
    1174             via the $webapp->param() method.
    1175              
    1176             Your setup() method might be implemented something like this:
    1177              
    1178             sub setup {
    1179             my $self = shift;
    1180             $self->tmpl_path('/path/to/my/templates/');
    1181             $self->start_mode('putform');
    1182             $self->error_mode('my_error_rm');
    1183             $self->run_modes({
    1184             'putform' => 'my_putform_func',
    1185             'postdata' => 'my_data_func'
    1186             });
    1187             $self->param('myprop1');
    1188             $self->param('myprop2', 'prop2value');
    1189             $self->param('myprop3', ['p3v1', 'p3v2', 'p3v3']);
    1190             }
    1191              
    1192             However, often times all that needs to be in setup() is defining your run modes
    1193             and your start mode. L allows you to do
    1194             this with a simple syntax, using run mode attributes:
    1195              
    1196             use CGI::Application::Plugin::AutoRunmode;
    1197              
    1198             sub show_first : StartRunmode { ... };
    1199             sub do_next : Runmode { ... }
    1200              
    1201             =head3 teardown()
    1202              
    1203             If implemented, this method is called automatically after your application runs. It
    1204             can be used to clean up after your operations. A typical use of the
    1205             teardown() function is to disconnect a database connection which was
    1206             established in the setup() function. You could also use the teardown()
    1207             method to store state information about the application to the server.
    1208              
    1209              
    1210             =head3 cgiapp_init()
    1211              
    1212             If implemented, this method is called automatically right before the
    1213             setup() method is called. This method provides an optional initialization
    1214             hook, which improves the object-oriented characteristics of
    1215             CGI::Application. The cgiapp_init() method receives, as its parameters,
    1216             all the arguments which were sent to the new() method.
    1217              
    1218             An example of the benefits provided by utilizing this hook is
    1219             creating a custom "application super-class" from which all
    1220             your web applications would inherit, instead of CGI::Application.
    1221              
    1222             Consider the following:
    1223              
    1224             # In MySuperclass.pm:
    1225             package MySuperclass;
    1226             use base 'CGI::Application';
    1227             sub cgiapp_init {
    1228             my $self = shift;
    1229             # Perform some project-specific init behavior
    1230             # such as to load settings from a database or file.
    1231             }
    1232              
    1233              
    1234             # In MyApplication.pm:
    1235             package MyApplication;
    1236             use base 'MySuperclass';
    1237             sub setup { ... }
    1238             sub teardown { ... }
    1239             # The rest of your CGI::Application-based follows...
    1240              
    1241              
    1242             By using CGI::Application and the cgiapp_init() method as illustrated,
    1243             a suite of applications could be designed to share certain
    1244             characteristics. This has the potential for much cleaner code
    1245             built on object-oriented inheritance.
    1246              
    1247              
    1248             =head3 cgiapp_prerun()
    1249              
    1250             If implemented, this method is called automatically right before the
    1251             selected run mode method is called. This method provides an optional
    1252             pre-runmode hook, which permits functionality to be added at the point
    1253             right before the run mode method is called. To further leverage this
    1254             hook, the value of the run mode is passed into cgiapp_prerun().
    1255              
    1256             Another benefit provided by utilizing this hook is
    1257             creating a custom "application super-class" from which all
    1258             your web applications would inherit, instead of CGI::Application.
    1259              
    1260             Consider the following:
    1261              
    1262             # In MySuperclass.pm:
    1263             package MySuperclass;
    1264             use base 'CGI::Application';
    1265             sub cgiapp_prerun {
    1266             my $self = shift;
    1267             # Perform some project-specific init behavior
    1268             # such as to implement run mode specific
    1269             # authorization functions.
    1270             }
    1271              
    1272              
    1273             # In MyApplication.pm:
    1274             package MyApplication;
    1275             use base 'MySuperclass';
    1276             sub setup { ... }
    1277             sub teardown { ... }
    1278             # The rest of your CGI::Application-based follows...
    1279              
    1280              
    1281             By using CGI::Application and the cgiapp_prerun() method as illustrated,
    1282             a suite of applications could be designed to share certain
    1283             characteristics. This has the potential for much cleaner code
    1284             built on object-oriented inheritance.
    1285              
    1286             It is also possible, within your cgiapp_prerun() method, to change the
    1287             run mode of your application. This can be done via the prerun_mode()
    1288             method, which is discussed elsewhere in this POD.
    1289              
    1290             =head3 cgiapp_postrun()
    1291              
    1292             If implemented, this hook will be called after the run mode method
    1293             has returned its output, but before HTTP headers are generated. This
    1294             will give you an opportunity to modify the body and headers before they
    1295             are returned to the web browser.
    1296              
    1297             A typical use for this hook is pipelining the output of a CGI-Application
    1298             through a series of "filter" processors. For example:
    1299              
    1300             * You want to enclose the output of all your CGI-Applications in
    1301             an HTML table in a larger page.
    1302              
    1303             * Your run modes return structured data (such as XML), which you
    1304             want to transform using a standard mechanism (such as XSLT).
    1305              
    1306             * You want to post-process CGI-App output through another system,
    1307             such as HTML::Mason.
    1308              
    1309             * You want to modify HTTP headers in a particular way across all
    1310             run modes, based on particular criteria.
    1311              
    1312             The cgiapp_postrun() hook receives a reference to the output from
    1313             your run mode method, in addition to the CGI-App object. A typical
    1314             cgiapp_postrun() method might be implemented as follows:
    1315              
    1316             sub cgiapp_postrun {
    1317             my $self = shift;
    1318             my $output_ref = shift;
    1319              
    1320             # Enclose output HTML table
    1321             my $new_output = ""; "; ";
    1322             $new_output .= "
    Hello, World!
    1323             $new_output .= "
    ". $$output_ref ."
    1324             $new_output .= "
    ";
    1325              
    1326             # Replace old output with new output
    1327             $$output_ref = $new_output;
    1328             }
    1329              
    1330              
    1331             Obviously, with access to the CGI-App object you have full access to use all
    1332             the methods normally available in a run mode. You could, for example, use
    1333             C to replace the static HTML in this example with HTML::Template.
    1334             You could change the HTTP headers (via C and C
    1335             methods) to set up a redirect. You could also use the objects properties
    1336             to apply changes only under certain circumstance, such as a in only certain run
    1337             modes, and when a C is a particular value.
    1338              
    1339              
    1340             =head3 cgiapp_get_query()
    1341              
    1342             my $q = $webapp->cgiapp_get_query;
    1343              
    1344             Override this method to retrieve the query object if you wish to use a
    1345             different query interface instead of CGI.pm.
    1346              
    1347             CGI.pm is only loaded if it is used on a given request.
    1348              
    1349             If you can use an alternative to CGI.pm, it needs to have some compatibility
    1350             with the CGI.pm API. For normal use, just having a compatible C method
    1351             should be sufficient.
    1352              
    1353             If you use the C option to the mode_param() method, then we will call
    1354             the C method on the query object.
    1355              
    1356             If you use the C method in CGI::Application, we will call the C and
    1357             C methods on the query object.
    1358              
    1359             =head2 Essential Application Methods
    1360              
    1361             The following methods are inherited from CGI::Application, and are
    1362             available to be called by your application within your Application
    1363             Module. They are called essential because you will use all are most
    1364             of them to get any application up and running. These functions are listed in alphabetical order.
    1365              
    1366             =head3 load_tmpl()
    1367              
    1368             my $tmpl_obj = $webapp->load_tmpl;
    1369             my $tmpl_obj = $webapp->load_tmpl('some.html');
    1370             my $tmpl_obj = $webapp->load_tmpl( \$template_content );
    1371             my $tmpl_obj = $webapp->load_tmpl( FILEHANDLE );
    1372              
    1373             This method takes the name of a template file, a reference to template data
    1374             or a FILEHANDLE and returns an HTML::Template object. If the filename is undefined or missing, CGI::Application will default to trying to use the current run mode name, plus the extension ".html".
    1375              
    1376             If you use the default template naming system, you should also use
    1377             L, which simply helps to keep the current
    1378             name accurate when you pass control from one run mode to another.
    1379              
    1380             ( For integration with other template systems
    1381             and automated template names, see "Alternatives to load_tmpl() below. )
    1382              
    1383             When you pass in a filename, the HTML::Template->new_file() constructor
    1384             is used for create the object. When you pass in a reference to the template
    1385             content, the HTML::Template->new_scalar_ref() constructor is used and
    1386             when you pass in a filehandle, the HTML::Template->new_filehandle()
    1387             constructor is used.
    1388              
    1389             Refer to L for specific usage of HTML::Template.
    1390              
    1391             If tmpl_path() has been specified, load_tmpl() will set the
    1392             HTML::Template C option to the path(s) provided. This further
    1393             assists in encapsulating template usage.
    1394              
    1395             The load_tmpl() method will pass any extra parameters sent to it directly to
    1396             HTML::Template->new_file() (or new_scalar_ref() or new_filehandle()).
    1397             This will allow the HTML::Template object to be further customized:
    1398              
    1399             my $tmpl_obj = $webapp->load_tmpl('some_other.html',
    1400             die_on_bad_params => 0,
    1401             cache => 1
    1402             );
    1403              
    1404             Note that if you want to pass extra arguments but use the default template
    1405             name, you still need to provide a name of C:
    1406              
    1407             my $tmpl_obj = $webapp->load_tmpl(undef,
    1408             die_on_bad_params => 0,
    1409             cache => 1
    1410             );
    1411              
    1412             B
    1413              
    1414             If your application requires more specialized behavior than this, you can
    1415             always replace it by overriding load_tmpl() by implementing your own
    1416             load_tmpl() in your CGI::Application sub-class application module.
    1417              
    1418             First, you may want to check out the template related plugins.
    1419              
    1420             L focuses just on Template Toolkit integration,
    1421             and features pre-and-post features, singleton support and more.
    1422              
    1423             L can help if you want to return a stream and
    1424             not a file. It features a simple syntax and MIME-type detection.
    1425              
    1426             B
    1427              
    1428             You may specify an API-compatible alternative to L by setting
    1429             a new C:
    1430              
    1431             $self->html_tmpl_class('HTML::Template::Dumper');
    1432              
    1433             The default is "HTML::Template". The alternate class should
    1434             provide at least the following parts of the HTML::Template API:
    1435              
    1436             $t = $class->new( scalarref => ... ); # If you use scalarref templates
    1437             $t = $class->new( filehandle => ... ); # If you use filehandle templates
    1438             $t = $class->new( filename => ... );
    1439             $t->param(...);
    1440              
    1441             Here's an example case allowing you to precisely test what's sent to your
    1442             templates:
    1443              
    1444             $ENV{CGI_APP_RETURN_ONLY} = 1;
    1445             my $webapp = WebApp->new;
    1446             $webapp->html_tmpl_class('HTML::Template::Dumper');
    1447             my $out_str = $webapp->run;
    1448             my $tmpl_href = eval "$out_str";
    1449              
    1450             # Now Precisely test what would be set to the template
    1451             is ($tmpl_href->{pet_name}, 'Daisy', "Daisy is sent template");
    1452              
    1453             This is a powerful technique because HTML::Template::Dumper loads and considers
    1454             the template file that would actually be used. If the 'pet_name' token was missing
    1455             in the template, the above test would fail. So, you are testing both your code
    1456             and your templates in a much more precise way than using simple regular
    1457             expressions to see if the string "Daisy" appeared somewhere on the page.
    1458              
    1459             B
    1460              
    1461             Plugin authors will be interested to know that you can register a callback that
    1462             will be executed just before load_tmpl() returns:
    1463              
    1464             $self->add_callback('load_tmpl',\&your_method);
    1465              
    1466             When C is executed, it will be passed three arguments:
    1467              
    1468             1. A hash reference of the extra params passed into C
    1469             2. Followed by a hash reference to template parameters.
    1470             With both of these, you can modify them by reference to affect
    1471             values that are actually passed to the new() and param() methods of the
    1472             template object.
    1473             3. The name of the template file.
    1474              
    1475             Here's an example stub for a load_tmpl() callback:
    1476              
    1477             sub my_load_tmpl_callback {
    1478             my ($c, $ht_params, $tmpl_params, $tmpl_file) = @_
    1479             # modify $ht_params or $tmpl_params by reference...
    1480             }
    1481              
    1482             =head3 param()
    1483              
    1484             $webapp->param('pname', $somevalue);
    1485              
    1486             The param() method provides a facility through which you may set
    1487             application instance properties which are accessible throughout
    1488             your application.
    1489              
    1490             The param() method may be used in two basic ways. First, you may use it
    1491             to get or set the value of a parameter:
    1492              
    1493             $webapp->param('scalar_param', '123');
    1494             my $scalar_param_values = $webapp->param('some_param');
    1495              
    1496             Second, when called in the context of an array, with no parameter name
    1497             specified, param() returns an array containing all the parameters which
    1498             currently exist:
    1499              
    1500             my @all_params = $webapp->param();
    1501              
    1502             The param() method also allows you to set a bunch of parameters at once
    1503             by passing in a hash (or hashref):
    1504              
    1505             $webapp->param(
    1506             'key1' => 'val1',
    1507             'key2' => 'val2',
    1508             'key3' => 'val3',
    1509             );
    1510              
    1511             The param() method enables a very valuable system for
    1512             customizing your applications on a per-instance basis.
    1513             One Application Module might be instantiated by different
    1514             Instance Scripts. Each Instance Script might set different values for a
    1515             set of parameters. This allows similar applications to share a common
    1516             code-base, but behave differently. For example, imagine a mail form
    1517             application with a single Application Module, but multiple Instance
    1518             Scripts. Each Instance Script might specify a different recipient.
    1519             Another example would be a web bulletin boards system. There could be
    1520             multiple boards, each with a different topic and set of administrators.
    1521              
    1522             The new() method provides a shortcut for specifying a number of run-time
    1523             parameters at once. Internally, CGI::Application calls the param()
    1524             method to set these properties. The param() method is a powerful tool for
    1525             greatly increasing your application's re-usability.
    1526              
    1527             =head3 query()
    1528              
    1529             my $q = $webapp->query();
    1530             my $remote_user = $q->remote_user();
    1531              
    1532             This method retrieves the CGI.pm query object which has been created
    1533             by instantiating your Application Module. For details on usage of this
    1534             query object, refer to L. CGI::Application is built on the CGI
    1535             module. Generally speaking, you will want to become very familiar
    1536             with CGI.pm, as you will use the query object whenever you want to
    1537             interact with form data.
    1538              
    1539             When the new() method is called, a CGI query object is automatically created.
    1540             If, for some reason, you want to use your own CGI query object, the new()
    1541             method supports passing in your existing query object on construction using
    1542             the QUERY attribute.
    1543              
    1544             There are a few rare situations where you want your own query object to be
    1545             used after your Application Module has already been constructed. In that case
    1546             you can pass it to c like this:
    1547              
    1548             $webapp->query($new_query_object);
    1549             my $q = $webapp->query(); # now uses $new_query_object
    1550              
    1551             =head3 run_modes()
    1552              
    1553             # The common usage: an arrayref of run mode names that exactly match subroutine names
    1554             $webapp->run_modes([qw/
    1555             form_display
    1556             form_process
    1557             /]);
    1558              
    1559             # With a hashref, use a different name or a code ref
    1560             $webapp->run_modes(
    1561             'mode1' => 'some_sub_by_name',
    1562             'mode2' => \&some_other_sub_by_ref
    1563             );
    1564              
    1565             This accessor/mutator specifies the dispatch table for the
    1566             application states, using the syntax examples above. It returns
    1567             the dispatch table as a hash.
    1568              
    1569             The run_modes() method may be called more than once. Additional values passed
    1570             into run_modes() will be added to the run modes table. In the case that an
    1571             existing run mode is re-defined, the new value will override the existing value.
    1572             This behavior might be useful for applications which are created via inheritance
    1573             from another application, or some advanced application which modifies its
    1574             own capabilities based on user input.
    1575              
    1576             The run() method uses the data in this table to send the application to the
    1577             correct function as determined by reading the CGI parameter specified by
    1578             mode_param() (defaults to 'rm' for "Run Mode"). These functions are referred
    1579             to as "run mode methods".
    1580              
    1581             The hash table set by this method is expected to contain the mode
    1582             name as a key. The value should be either a hard reference (a subref)
    1583             to the run mode method which you want to be called when the application enters
    1584             the specified run mode, or the name of the run mode method to be called:
    1585              
    1586             'mode_name_by_ref' => \&mode_function
    1587             'mode_name_by_name' => 'mode_function'
    1588              
    1589             The run mode method specified is expected to return a block of text (e.g.:
    1590             HTML) which will eventually be sent back to the web browser. The run mode
    1591             method may return its block of text as a scalar or a scalar-ref.
    1592              
    1593             An advantage of specifying your run mode methods by name instead of
    1594             by reference is that you can more easily create derivative applications
    1595             using inheritance. For instance, if you have a new application which is
    1596             exactly the same as an existing application with the exception of one
    1597             run mode, you could simply inherit from that other application and override
    1598             the run mode method which is different. If you specified your run mode
    1599             method by reference, your child class would still use the function
    1600             from the parent class.
    1601              
    1602             An advantage of specifying your run mode methods by reference instead of by name
    1603             is performance. Dereferencing a subref is faster than eval()-ing
    1604             a code block. If run-time performance is a critical issue, specify
    1605             your run mode methods by reference and not by name. The speed differences
    1606             are generally small, however, so specifying by name is preferred.
    1607              
    1608             Specifying the run modes by array reference:
    1609              
    1610             $webapp->run_modes([ 'mode1', 'mode2', 'mode3' ]);
    1611              
    1612             This is the same as using a hash, with keys equal to values
    1613              
    1614             $webapp->run_modes(
    1615             'mode1' => 'mode1',
    1616             'mode2' => 'mode2',
    1617             'mode3' => 'mode3'
    1618             );
    1619              
    1620             Often, it makes good organizational sense to have your run modes map to
    1621             methods of the same name. The array-ref interface provides a shortcut
    1622             to that behavior while reducing verbosity of your code.
    1623              
    1624             Note that another importance of specifying your run modes in either a
    1625             hash or array-ref is to assure that only those Perl methods which are
    1626             specifically designated may be called via your application. Application
    1627             environments which don't specify allowed methods and disallow all others
    1628             are insecure, potentially opening the door to allowing execution of
    1629             arbitrary code. CGI::Application maintains a strict "default-deny" stance
    1630             on all method invocation, thereby allowing secure applications
    1631             to be built upon it.
    1632              
    1633             B
    1634              
    1635             Your application should *NEVER* print() to STDOUT.
    1636             Using print() to send output to STDOUT (including HTTP headers) is
    1637             exclusively the domain of the inherited run() method. Breaking this
    1638             rule is a common source of errors. If your program is erroneously
    1639             sending content before your HTTP header, you are probably breaking this rule.
    1640              
    1641              
    1642             B
    1643              
    1644             If CGI::Application is asked to go to a run mode which doesn't exist
    1645             it will usually croak() with errors. If this is not your desired
    1646             behavior, it is possible to catch this exception by implementing
    1647             a run mode with the reserved name "AUTOLOAD":
    1648              
    1649             $self->run_modes(
    1650             "AUTOLOAD" => \&catch_my_exception
    1651             );
    1652              
    1653             Before CGI::Application calls croak() it will check for the existence
    1654             of a run mode called "AUTOLOAD". If specified, this run mode will in
    1655             invoked just like a regular run mode, with one exception: It will
    1656             receive, as an argument, the name of the run mode which invoked it:
    1657              
    1658             sub catch_my_exception {
    1659             my $self = shift;
    1660             my $intended_runmode = shift;
    1661              
    1662             my $output = "Looking for '$intended_runmode', but found 'AUTOLOAD' instead";
    1663             return $output;
    1664             }
    1665              
    1666             This functionality could be used for a simple human-readable error
    1667             screen, or for more sophisticated application behaviors.
    1668              
    1669              
    1670             =head3 start_mode()
    1671              
    1672             $webapp->start_mode('mode1');
    1673              
    1674             The start_mode contains the name of the mode as specified in the run_modes()
    1675             table. Default mode is "start". The mode key specified here will be used
    1676             whenever the value of the CGI form parameter specified by mode_param() is
    1677             not defined. Generally, this is the first time your application is executed.
    1678              
    1679             =head3 tmpl_path()
    1680              
    1681             $webapp->tmpl_path('/path/to/some/templates/');
    1682              
    1683             This access/mutator method sets the file path to the directory (or directories)
    1684             where the templates are stored. It is used by load_tmpl() to find the template
    1685             files, using HTML::Template's C option. To set the path you can either
    1686             pass in a text scalar or an array reference of multiple paths.
    1687              
    1688              
    1689              
    1690             =head2 More Application Methods
    1691              
    1692             You can skip this section if you are just getting started.
    1693              
    1694             The following additional methods are inherited from CGI::Application, and are
    1695             available to be called by your application within your Application Module.
    1696             These functions are listed in alphabetical order.
    1697              
    1698             =head3 delete()
    1699              
    1700             $webapp->delete('my_param');
    1701              
    1702             The delete() method is used to delete a parameter that was previously
    1703             stored inside of your application either by using the PARAMS hash that
    1704             was passed in your call to new() or by a call to the param() method.
    1705             This is similar to the delete() method of CGI.pm. It is useful if your
    1706             application makes decisions based on the existence of certain params that
    1707             may have been removed in previous sections of your app or simply to
    1708             clean-up your param()s.
    1709              
    1710              
    1711             =head3 dump()
    1712              
    1713             print STDERR $webapp->dump();
    1714              
    1715             The dump() method is a debugging function which will return a
    1716             chunk of text which contains all the environment and web form
    1717             data of the request, formatted nicely for human readability.
    1718             Useful for outputting to STDERR.
    1719              
    1720              
    1721             =head3 dump_html()
    1722              
    1723             my $output = $webapp->dump_html();
    1724              
    1725             The dump_html() method is a debugging function which will return
    1726             a chunk of text which contains all the environment and web form
    1727             data of the request, formatted nicely for human readability via
    1728             a web browser. Useful for outputting to a browser. Please consider
    1729             the security implications of using this in production code.
    1730              
    1731             =head3 error_mode()
    1732              
    1733             $webapp->error_mode('my_error_rm');
    1734              
    1735             If the runmode dies for whatever reason, C see if you have set a
    1736             value for C. If you have, C will call that method
    1737             as a run mode, passing $@ as the only parameter.
    1738              
    1739             Plugins authors will be interested to know that just before C is
    1740             called, the C hook will be executed, with the error message passed in as
    1741             the only parameter.
    1742              
    1743             No C is defined by default. The death of your C run
    1744             mode is not trapped, so you can also use it to die in your own special way.
    1745              
    1746             For a complete integrated logging solution, check out L.
    1747              
    1748             =head3 get_current_runmode()
    1749              
    1750             $webapp->get_current_runmode();
    1751              
    1752             The C method will return a text scalar containing
    1753             the name of the run mode which is currently being executed. If the
    1754             run mode has not yet been determined, such as during setup(), this method
    1755             will return undef.
    1756              
    1757             =head3 header_add()
    1758              
    1759             # add or replace the 'type' header
    1760             $webapp->header_add( -type => 'image/png' );
    1761              
    1762             - or -
    1763              
    1764             # add an additional cookie
    1765             $webapp->header_add(-cookie=>[$extra_cookie]);
    1766              
    1767             The C method is used to add one or more headers to the outgoing
    1768             response headers. The parameters will eventually be passed on to the CGI.pm
    1769             header() method, so refer to the L docs for exact usage details.
    1770              
    1771             Unlike calling C, C will preserve any existing
    1772             headers. If a scalar value is passed to C it will replace
    1773             the existing value for that key.
    1774              
    1775             If an array reference is passed as a value to C, values in
    1776             that array ref will be appended to any existing values for that key.
    1777             This is primarily useful for setting an additional cookie after one has already
    1778             been set.
    1779              
    1780             =head3 header_props()
    1781              
    1782             # Set a complete set of headers
    1783             %set_headers = $webapp->header_props(-type=>'image/gif',-expires=>'+3d');
    1784              
    1785             # clobber / reset all headers
    1786             %set_headers = $webapp->header_props({});
    1787              
    1788             # Just retrieve the headers
    1789             %set_headers = $webapp->header_props();
    1790              
    1791             The C method expects a hash of CGI.pm-compatible
    1792             HTTP header properties. These properties will be passed directly
    1793             to the C or C methods of the query() object. Refer
    1794             to the docs of your query object for details. (Be default, it's L.pm).
    1795              
    1796             Calling header_props with an empty hashref clobber any existing headers that have
    1797             previously set.
    1798              
    1799             C returns a hash of all the headers that have currently been
    1800             set. It can be called with no arguments just to get the hash current headers
    1801             back.
    1802              
    1803             To add additional headers later without clobbering the old ones,
    1804             see C.
    1805              
    1806             B
    1807              
    1808             It is through the C and C method that you may modify the outgoing
    1809             HTTP headers. This is necessary when you want to set a cookie, set the mime
    1810             type to something other than "text/html", or perform a redirect. The
    1811             header_props() method works in conjunction with the header_type() method.
    1812             The value contained in header_type() determines if we use CGI::header() or
    1813             CGI::redirect(). The content of header_props() is passed as an argument to
    1814             whichever CGI.pm function is called.
    1815              
    1816             Understanding this relationship is important if you wish to manipulate
    1817             the HTTP header properly.
    1818              
    1819             =head3 header_type()
    1820              
    1821             $webapp->header_type('redirect');
    1822             $webapp->header_type('none');
    1823              
    1824             This method used to declare that you are setting a redirection header,
    1825             or that you want no header to be returned by the framework.
    1826              
    1827             The value of 'header' is almost never used, as it is the default.
    1828              
    1829             B:
    1830              
    1831             sub some_redirect_mode {
    1832             my $self = shift;
    1833             # do stuff here....
    1834             $self->header_type('redirect');
    1835             $self->header_props(-url=> "http://site/path/doc.html" );
    1836             }
    1837              
    1838             To simplify that further, use L:
    1839              
    1840             return $self->redirect('http://www.example.com/');
    1841              
    1842             Setting the header to 'none' may be useful if you are streaming content.
    1843             In other contexts, it may be more useful to set C<$ENV{CGI_APP_RETURN_ONLY} = 1;>,
    1844             which suppresses all printing, including headers, and returns the output instead.
    1845              
    1846             That's commonly used for testing, or when using L as a controller
    1847             for a cron script!
    1848              
    1849             =cut
    1850              
    1851             sub html_tmpl_class {
    1852 7     7 0 13 my $self = shift;
    1853 7         12 my $tmpl_class = shift;
    1854              
    1855             # First use? Create new __ERROR_MODE
    1856 7 100       27 $self->{__HTML_TMPL_CLASS} = 'HTML::Template' unless (exists($self->{__HTML_TMPL_CLASS}));
    1857              
    1858 7 50       21 if (defined $tmpl_class) {
    1859 0         0 $self->{__HTML_TMPL_CLASS} = $tmpl_class;
    1860             }
    1861              
    1862 7         18 return $self->{__HTML_TMPL_CLASS};
    1863             }
    1864              
    1865             sub load_tmpl {
    1866 7     7 1 1442 my $self = shift;
    1867 7         17 my ($tmpl_file, @extra_params) = @_;
    1868              
    1869             # add tmpl_path to path array if one is set, otherwise add a path arg
    1870 7 100       33 if (my $tmpl_path = $self->tmpl_path) {
    1871 6 100       26 my @tmpl_paths = (ref $tmpl_path eq 'ARRAY') ? @$tmpl_path : $tmpl_path;
    1872 6         10 my $found = 0;
    1873 6         21 for( my $x = 0; $x < @extra_params; $x += 2 ) {
    1874 2 50 33     11 if ($extra_params[$x] eq 'path' and
    1875             ref $extra_params[$x+1] eq 'ARRAY') {
    1876 0         0 unshift @{$extra_params[$x+1]}, @tmpl_paths;
      0         0  
    1877 0         0 $found = 1;
    1878 0         0 last;
    1879             }
    1880             }
    1881 6 50       35 push(@extra_params, path => [ @tmpl_paths ]) unless $found;
    1882             }
    1883              
    1884 7         18 my %tmpl_params = ();
    1885 7         19 my %ht_params = @extra_params;
    1886 7 100       24 %ht_params = () unless keys %ht_params;
    1887              
    1888             # Define our extension if doesn't already exist;
    1889 7 100       27 $self->{__CURRENT_TMPL_EXTENSION} = '.html' unless defined $self->{__CURRENT_TMPL_EXTENSION};
    1890              
    1891             # Define a default template name based on the current run mode
    1892 7 50       55 unless (defined $tmpl_file) {
    1893 0         0 $tmpl_file = $self->get_current_runmode . $self->{__CURRENT_TMPL_EXTENSION};
    1894             }
    1895              
    1896 7         30 $self->call_hook('load_tmpl', \%ht_params, \%tmpl_params, $tmpl_file);
    1897              
    1898 7         25 my $ht_class = $self->html_tmpl_class;
    1899 7 50       516 eval "require $ht_class;" || die "require $ht_class failed: $@";
    1900              
    1901             # let's check $tmpl_file and see what kind of parameter it is - we
    1902             # now support 3 options: scalar (filename), ref to scalar (the
    1903             # actual html/template content) and reference to FILEHANDLE
    1904 7         45940 my $t = undef;
    1905 7 50       37 if ( ref $tmpl_file eq 'SCALAR' ) {
        50          
    1906 0         0 $t = $ht_class->new( scalarref => $tmpl_file, %ht_params );
    1907             } elsif ( ref $tmpl_file eq 'GLOB' ) {
    1908 0         0 $t = $ht_class->new( filehandle => $tmpl_file, %ht_params );
    1909             } else {
    1910 7         50 $t = $ht_class->new( filename => $tmpl_file, %ht_params);
    1911             }
    1912              
    1913 7 100       4286 if (keys %tmpl_params) {
    1914 1         5 $t->param(%tmpl_params);
    1915             }
    1916              
    1917 7         68 return $t;
    1918             }
    1919              
    1920             =pod
    1921              
    1922             =head3 mode_param()
    1923              
    1924             # Name the CGI form parameter that contains the run mode name.
    1925             # This is the default behavior, and is often sufficient.
    1926             $webapp->mode_param('rm');
    1927              
    1928             # Set the run mode name directly from a code ref
    1929             $webapp->mode_param(\&some_method);
    1930              
    1931             # Alternate interface, which allows you to set the run
    1932             # mode name directly from $ENV{PATH_INFO}.
    1933             $webapp->mode_param(
    1934             path_info=> 1,
    1935             param =>'rm'
    1936             );
    1937              
    1938             This accessor/mutator method is generally called in the setup() method.
    1939             It is used to help determine the run mode to call. There are three options for calling it.
    1940              
    1941             $webapp->mode_param('rm');
    1942              
    1943             Here, a CGI form parameter is named that will contain the name of the run mode
    1944             to use. This is the default behavior, with 'rm' being the parameter named used.
    1945              
    1946             $webapp->mode_param(\&some_method);
    1947              
    1948             Here a code reference is provided. It will return the name of the run mode
    1949             to use directly. Example:
    1950              
    1951             sub some_method {
    1952             my $self = shift;
    1953             return 'run_mode_x';
    1954             }
    1955              
    1956             This would allow you to programmatically set the run mode based on arbitrary logic.
    1957              
    1958             $webapp->mode_param(
    1959             path_info=> 1,
    1960             param =>'rm'
    1961             );
    1962              
    1963             This syntax allows you to easily set the run mode from $ENV{PATH_INFO}. It
    1964             will try to set the run mode from the first part of $ENV{PATH_INFO} (before the
    1965             first "/"). To specify that you would rather get the run mode name from the 2nd
    1966             part of $ENV{PATH_INFO}:
    1967              
    1968             $webapp->mode_param( path_info=> 2 );
    1969              
    1970             This also demonstrates that you don't need to pass in the C hash key. It will
    1971             still default to C.
    1972              
    1973             You can also set C to a negative value. This works just like a negative
    1974             list index: if it is -1 the run mode name will be taken from the last part of
    1975             $ENV{PATH_INFO}, if it is -2, the one before that, and so on.
    1976              
    1977              
    1978             If no run mode is found in $ENV{PATH_INFO}, it will fall back to looking in the
    1979             value of a the CGI form field defined with 'param', as described above. This
    1980             allows you to use the convenient $ENV{PATH_INFO} trick most of the time, but
    1981             also supports the edge cases, such as when you don't know what the run mode
    1982             will be ahead of time and want to define it with JavaScript.
    1983              
    1984             B.
    1985              
    1986             Using $ENV{PATH_INFO} to name your run mode creates a clean separation between
    1987             the form variables you submit and how you determine the processing run mode. It
    1988             also creates URLs that are more search engine friendly. Let's look at an
    1989             example form submission using this syntax:
    1990              
    1991            
    1992            
    1993              
    1994             Here the run mode would be set to "edit_form". Here's another example with a
    1995             query string:
    1996              
    1997             /cgi-bin/instance.cgi/edit_form?breed_id=2
    1998              
    1999             This demonstrates that you can use $ENV{PATH_INFO} and a query string together
    2000             without problems. $ENV{PATH_INFO} is defined as part of the CGI specification
    2001             should be supported by any web server that supports CGI scripts.
    2002              
    2003             =cut
    2004              
    2005             sub mode_param {
    2006 172     172 1 408 my $self = shift;
    2007 172         296 my $mode_param;
    2008              
    2009             # First use? Create new __MODE_PARAM
    2010 172 100       490 $self->{__MODE_PARAM} = 'rm' unless (exists($self->{__MODE_PARAM}));
    2011              
    2012 172         304 my %p;
    2013             # expecting a scalar or code ref
    2014 172 100       479 if ((scalar @_) == 1) {
    2015 104         344 $mode_param = $_[0];
    2016             }
    2017             # expecting hash style params
    2018             else {
    2019 68 50       209 croak("CGI::Application->mode_param() : You gave me an odd number of parameters to mode_param()!")
    2020             unless ((@_ % 2) == 0);
    2021 68         137 %p = @_;
    2022 68         128 $mode_param = $p{param};
    2023              
    2024 68 100 100     222 if ( $p{path_info} && $self->query->path_info() ) {
    2025 4         213 my $pi = $self->query->path_info();
    2026              
    2027 4         46 my $idx = $p{path_info};
    2028             # two cases: negative or positive index
    2029             # negative index counts from the end of path_info
    2030             # positive index needs to be fixed because
    2031             # computer scientists like to start counting from zero.
    2032 4 100       10 $idx -= 1 if ($idx > 0) ;
    2033              
    2034             # remove the leading slash
    2035 4         19 $pi =~ s!^/!!;
    2036              
    2037             # grab the requested field location
    2038 4   50     18 $pi = (split q'/', $pi)[$idx] || '';
    2039              
    2040 4 50       17 $mode_param = (length $pi) ? { run_mode => $pi } : $mode_param;
    2041             }
    2042              
    2043             }
    2044              
    2045             # If data is provided, set it
    2046 172 100 66     764 if (defined $mode_param and length $mode_param) {
    2047 109         200 $self->{__MODE_PARAM} = $mode_param;
    2048             }
    2049              
    2050 172         401 return $self->{__MODE_PARAM};
    2051             }
    2052              
    2053              
    2054             =head3 prerun_mode()
    2055              
    2056             $webapp->prerun_mode('new_run_mode');
    2057              
    2058             The prerun_mode() method is an accessor/mutator which can be used within
    2059             your cgiapp_prerun() method to change the run mode which is about to be executed.
    2060             For example, consider:
    2061              
    2062             # In WebApp.pm:
    2063             package WebApp;
    2064             use base 'CGI::Application';
    2065             sub cgiapp_prerun {
    2066             my $self = shift;
    2067              
    2068             # Get the web user name, if any
    2069             my $q = $self->query();
    2070             my $user = $q->remote_user();
    2071              
    2072             # Redirect to login, if necessary
    2073             unless ($user) {
    2074             $self->prerun_mode('login');
    2075             }
    2076             }
    2077              
    2078              
    2079             In this example, the web user will be forced into the "login" run mode
    2080             unless they have already logged in. The prerun_mode() method permits
    2081             a scalar text string to be set which overrides whatever the run mode
    2082             would otherwise be.
    2083              
    2084             The use of prerun_mode() within cgiapp_prerun() differs from setting
    2085             mode_param() to use a call-back via subroutine reference. It differs
    2086             because cgiapp_prerun() allows you to selectively set the run mode based
    2087             on some logic in your cgiapp_prerun() method. The call-back facility of
    2088             mode_param() forces you to entirely replace CGI::Application's mechanism
    2089             for determining the run mode with your own method. The prerun_mode()
    2090             method should be used in cases where you want to use CGI::Application's
    2091             normal run mode switching facility, but you want to make selective
    2092             changes to the mode under specific conditions.
    2093              
    2094             B The prerun_mode() method may ONLY be called in the context of
    2095             a cgiapp_prerun() method. Your application will die() if you call
    2096             prerun_mode() elsewhere, such as in setup() or a run mode method.
    2097              
    2098             =head2 Dispatching Clean URIs to run modes
    2099              
    2100             Modern web frameworks dispense with cruft in URIs, providing in clean
    2101             URIs instead. Instead of:
    2102              
    2103             /cgi-bin/item.cgi?rm=view&id=15
    2104              
    2105             A clean URI to describe the same resource might be:
    2106              
    2107             /item/15/view
    2108              
    2109             The process of mapping these URIs to run modes is called dispatching and is
    2110             handled by L. Dispatching is not required and is a
    2111             layer you can fairly easily add to an application later.
    2112              
    2113             =head2 Offline website development
    2114              
    2115             You can work on your CGI::Application project on your desktop or laptop without
    2116             installing a full-featured web-server like Apache. Instead, install
    2117             L from CPAN. After a few minutes of setup, you'll
    2118             have your own private application server up and running.
    2119              
    2120             =head2 Automated Testing
    2121              
    2122             L allows functional testing of a CGI::App-based project
    2123             without starting a web server. L could be used to test the app
    2124             through a real web server.
    2125              
    2126             Direct testing is also easy. CGI::Application will normally print the output of it's
    2127             run modes directly to STDOUT. This can be suppressed with an environment variable,
    2128             CGI_APP_RETURN_ONLY. For example:
    2129              
    2130             $ENV{CGI_APP_RETURN_ONLY} = 1;
    2131             $output = $webapp->run();
    2132             like($output, qr/good/, "output is good");
    2133              
    2134             Examples of this style can be seen in our own test suite.
    2135              
    2136             =head1 PLUG-INS
    2137              
    2138             CGI::Application has a plug-in architecture that is easy to use and easy
    2139             to develop new plug-ins for.
    2140              
    2141             =head2 Recommended Plug-ins
    2142              
    2143             The following plugins are recommended for general purpose web/db development:
    2144              
    2145             =over 4
    2146              
    2147             =item *
    2148              
    2149             L - is a simple plugin to provide a shorter syntax for executing a redirect.
    2150              
    2151             =item *
    2152              
    2153             L - Keeping your config details in a separate file is recommended for every project. This one integrates with L. Several more config plugin options are listed below.
    2154              
    2155             =item *
    2156              
    2157             L - Provides easy management of one or more database handles and can delay making the database connection until the moment it is actually used.
    2158              
    2159             =item *
    2160              
    2161             L - makes it a breeze to fill in an HTML form from data originating from a CGI query or a database record.
    2162              
    2163             =item *
    2164              
    2165             L - For a project that requires session
    2166             management, this plugin provides a useful wrapper around L
    2167              
    2168             =item *
    2169              
    2170             L - Integration with Data::FormValidator and HTML::FillInForm
    2171              
    2172             =back
    2173              
    2174             =head2 More plug-ins
    2175              
    2176             Many more plugins are available as alternatives and for specific uses. For a
    2177             current complete list, please consult CPAN:
    2178              
    2179             http://search.cpan.org/search?m=dist&q=CGI%2DApplication%2DPlugin
    2180              
    2181             =over 4
    2182              
    2183             =item *
    2184              
    2185             L - Use any templating system from within CGI::Application using a unified interface
    2186              
    2187             =item *
    2188              
    2189             L - Use Apache::* modules without interference
    2190              
    2191             =item *
    2192              
    2193             L - Automatically register runmodes
    2194              
    2195              
    2196             =item *
    2197              
    2198             L - Integration with L.
    2199              
    2200             =item *
    2201              
    2202             L - Integration with L.
    2203              
    2204             =item *
    2205              
    2206             L - Integration with L.
    2207              
    2208             =item *
    2209              
    2210             L - Add Gzip compression
    2211              
    2212              
    2213             =item *
    2214              
    2215             L - Integration with L
    2216              
    2217             =item *
    2218              
    2219             L - Help stream files to the browser
    2220              
    2221             =item *
    2222              
    2223             L - Allows for more of an ASP-style
    2224             code structure, with the difference that code and HTML for each screen are in
    2225             separate files.
    2226              
    2227             =item *
    2228              
    2229             L - Use L as an alternative to HTML::Template.
    2230              
    2231              
    2232             =back
    2233              
    2234              
    2235              
    2236             Consult each plug-in for the exact usage syntax.
    2237              
    2238             =head2 Writing Plug-ins
    2239              
    2240             Writing plug-ins is simple. Simply create a new package, and export the
    2241             methods that you want to become part of a CGI::Application project. See
    2242             L for an example.
    2243              
    2244             In order to avoid namespace conflicts within a CGI::Application object,
    2245             plugin developers are recommended to use a unique prefix, such as the
    2246             name of plugin package, when storing information. For instance:
    2247              
    2248             $app->{__PARAM} = 'foo'; # BAD! Could conflict.
    2249             $app->{'MyPlugin::Module::__PARAM'} = 'foo'; # Good.
    2250             $app->{'MyPlugin::Module'}{__PARAM} = 'foo'; # Good.
    2251              
    2252             =head2 Writing Advanced Plug-ins - Using callbacks
    2253              
    2254             When writing a plug-in, you may want some action to happen automatically at a
    2255             particular stage, such as setting up a database connection or initializing a
    2256             session. By using these 'callback' methods, you can register a subroutine
    2257             to run at a particular phase, accomplishing this goal.
    2258              
    2259             B
    2260              
    2261             # register a callback to the standard CGI::Application hooks
    2262             # one of 'init', 'prerun', 'postrun', 'teardown' or 'load_tmpl'
    2263             # As a plug-in author, this is probably the only method you need.
    2264              
    2265             # Class-based: callback will persist for all runs of the application
    2266             $class->add_callback('init', \&some_other_method);
    2267              
    2268             # Object-based: callback will only last for lifetime of this object
    2269             $self->add_callback('prerun', \&some_method);
    2270              
    2271             # If you want to create a new hook location in your application,
    2272             # You'll need to know about the following two methods to create
    2273             # the hook and call it.
    2274              
    2275             # Create a new hook
    2276             $self->new_hook('pretemplate');
    2277              
    2278             # Then later execute all the callbacks registered at this hook
    2279             $self->call_hook('pretemplate');
    2280              
    2281             B
    2282              
    2283             =head3 add_callback()
    2284              
    2285             $self->add_callback ('teardown', \&callback);
    2286             $class->add_callback('teardown', 'method');
    2287              
    2288             The add_callback method allows you to register a callback
    2289             function that is to be called at the given stage of execution.
    2290             Valid hooks include 'init', 'prerun', 'postrun' and 'teardown',
    2291             'load_tmpl', and any other hooks defined using the C
    2292             method.
    2293              
    2294             The callback should be a reference to a subroutine or the name of a
    2295             method.
    2296              
    2297             If multiple callbacks are added to the same hook, they will all be
    2298             executed one after the other. The exact order depends on which class
    2299             installed each callback, as described below under B.
    2300              
    2301             Callbacks can either be I or I, depending
    2302             upon whether you call C as an object method or a class
    2303             method:
    2304              
    2305             # add object-based callback
    2306             $self->add_callback('teardown', \&callback);
    2307              
    2308             # add class-based callbacks
    2309             $class->add_callback('teardown', \&callback);
    2310             My::Project->add_callback('teardown', \&callback);
    2311              
    2312             Object-based callbacks are stored in your web application's C<$c>
    2313             object; at the end of the request when the C<$c> object goes out of
    2314             scope, the callbacks are gone too.
    2315              
    2316             Object-based callbacks are useful for one-time tasks that apply only to
    2317             the current running application. For instance you could install a
    2318             C callback to trigger a long-running process to execute at the
    2319             end of the current request, after all the HTML has been sent to the
    2320             browser.
    2321              
    2322             Class-based callbacks survive for the duration of the running Perl
    2323             process. (In a persistent environment such as C or
    2324             C, a single Perl process can serve many web requests.)
    2325              
    2326             Class-based callbacks are useful for plugins to add features to all web
    2327             applications.
    2328              
    2329             Another feature of class-based callbacks is that your plugin can create
    2330             hooks and add callbacks at any time - even before the web application's
    2331             C<$c> object has been initialized. A good place to do this is in
    2332             your plugin's C subroutine:
    2333              
    2334             package CGI::Application::Plugin::MyPlugin;
    2335             use base 'Exporter';
    2336             sub import {
    2337             my $caller = scalar(caller);
    2338             $caller->add_callback('init', 'my_setup');
    2339             goto &Exporter::import;
    2340             }
    2341              
    2342             Notice that C<< $caller->add_callback >> installs the callback
    2343             on behalf of the module that contained the line:
    2344              
    2345             use CGI::Application::Plugin::MyPlugin;
    2346              
    2347             =cut
    2348              
    2349             sub add_callback {
    2350 44     44 1 1860 my ($c_or_class, $hook, $callback) = @_;
    2351              
    2352 44         66 $hook = lc $hook;
    2353              
    2354 44 50       84 die "no callback provided when calling add_callback" unless $callback;
    2355 44 50       84 die "Unknown hook ($hook)" unless exists $INSTALLED_CALLBACKS{$hook};
    2356              
    2357 44 100       79 if (ref $c_or_class) {
    2358             # Install in object
    2359 5         8 my $self = $c_or_class;
    2360 5         7 push @{ $self->{__INSTALLED_CALLBACKS}{$hook} }, $callback;
      5         17  
    2361             }
    2362             else {
    2363             # Install in class
    2364 39         53 my $class = $c_or_class;
    2365 39         46 push @{ $INSTALLED_CALLBACKS{$hook}{$class} }, $callback;
      39         121  
    2366             }
    2367              
    2368             }
    2369              
    2370             =head3 new_hook(HOOK)
    2371              
    2372             $self->new_hook('pretemplate');
    2373              
    2374             The C method can be used to create a new location for developers to
    2375             register callbacks. It takes one argument, a hook name. The hook location is
    2376             created if it does not already exist. A true value is always returned.
    2377              
    2378             For an example, L adds hooks before and after every
    2379             template is processed.
    2380              
    2381             See C for more details about how hooks are called.
    2382              
    2383             =cut
    2384              
    2385             sub new_hook {
    2386 5     5 1 470 my ($class, $hook) = @_;
    2387 5   100     29 $INSTALLED_CALLBACKS{$hook} ||= {};
    2388 5         12 return 1;
    2389             }
    2390              
    2391             =head3 call_hook(HOOK)
    2392              
    2393             $self->call_hook('pretemplate', @args);
    2394              
    2395             The C method is used to executed the callbacks that have been registered
    2396             at the given hook. It is used in conjunction with the C method which
    2397             allows you to create a new hook location.
    2398              
    2399             The first argument to C is the hook name. Any remaining arguments
    2400             are passed to every callback executed at the hook location. So, a stub for a
    2401             callback at the 'pretemplate' hook would look like this:
    2402              
    2403             sub my_hook {
    2404             my ($c,@args) = @_;
    2405             # ....
    2406             }
    2407              
    2408             Note that hooks are semi-public locations. Calling a hook means executing
    2409             callbacks that were registered to that hook by the current object and also
    2410             those registered by any of the current object's parent classes. See below for
    2411             the exact ordering.
    2412              
    2413             =cut
    2414              
    2415             sub call_hook {
    2416 261     261 1 526 my $self = shift;
    2417 261   33     661 my $app_class = ref $self || $self;
    2418 261         547 my $hook = lc shift;
    2419 261         551 my @args = @_;
    2420              
    2421 261 50       620 die "Unknown hook ($hook)" unless exists $INSTALLED_CALLBACKS{$hook};
    2422              
    2423 261         390 my %executed_callback;
    2424              
    2425             # First, run callbacks installed in the object
    2426 261         392 foreach my $callback (@{ $self->{__INSTALLED_CALLBACKS}{$hook} }) {
      261         855  
    2427 5 50       14 next if $executed_callback{$callback};
    2428 5         8 eval { $self->$callback(@args); };
      5         20  
    2429 5         50 $executed_callback{$callback} = 1;
    2430 5 50       15 die "Error executing object callback in $hook stage: $@" if $@;
    2431             }
    2432              
    2433             # Next, run callbacks installed in class hierarchy
    2434              
    2435             # Cache this value as a performance boost
    2436 261   100     896 $self->{__CALLBACK_CLASSES} ||= [ Class::ISA::self_and_super_path($app_class) ];
    2437              
    2438             # Get list of classes that the current app inherits from
    2439 261         3525 foreach my $class (@{ $self->{__CALLBACK_CLASSES} }) {
      261         572  
    2440              
    2441             # skip those classes that contain no callbacks
    2442 521 100       1215 next unless exists $INSTALLED_CALLBACKS{$hook}{$class};
    2443              
    2444             # call all of the callbacks in the class
    2445 277         415 foreach my $callback (@{ $INSTALLED_CALLBACKS{$hook}{$class} }) {
      277         602  
    2446 305 100       690 next if $executed_callback{$callback};
    2447 295         485 eval { $self->$callback(@args); };
      295         1075  
    2448 295         1082 $executed_callback{$callback} = 1;
    2449 295 50       1007 die "Error executing class callback in $hook stage: $@" if $@;
    2450             }
    2451             }
    2452              
    2453             }
    2454              
    2455             =pod
    2456              
    2457             B
    2458              
    2459             Object-based callbacks are run before class-based callbacks.
    2460              
    2461             The order of class-based callbacks is determined by the inheritance tree of the
    2462             running application. The built-in methods of C, C,
    2463             C, and C are also executed this way, according to the
    2464             ordering below.
    2465              
    2466             In a persistent environment, there might be a lot of applications
    2467             in memory at the same time. For instance:
    2468              
    2469             CGI::Application
    2470             Other::Project # uses CGI::Application::Plugin::Baz
    2471             Other::App # uses CGI::Application::Plugin::Bam
    2472              
    2473             My::Project # uses CGI::Application::Plugin::Foo
    2474             My::App # uses CGI::Application::Plugin::Bar
    2475              
    2476             Suppose that each of the above plugins each added a callback to be run
    2477             at the 'init' stage:
    2478              
    2479             Plugin init callback
    2480             ------ -------------
    2481             CGI::Application::Plugin::Baz baz_startup
    2482             CGI::Application::Plugin::Bam bam_startup
    2483              
    2484             CGI::Application::Plugin::Foo foo_startup
    2485             CGI::Application::Plugin::Bar bar_startup
    2486              
    2487             When C runs, only C and C will
    2488             run. The other callbacks are skipped.
    2489              
    2490             The C<@ISA> list of C is:
    2491              
    2492             My::App
    2493             My::Project
    2494             CGI::Application
    2495              
    2496             This order determines the order of callbacks run.
    2497              
    2498             When C is run on a C application, callbacks
    2499             installed by these modules are run in order, resulting in:
    2500             C, C, and then finally C.
    2501              
    2502             If a single class installs more than one callback at the same hook, then
    2503             these callbacks are run in the order they were registered (FIFO).
    2504              
    2505              
    2506              
    2507             =cut
    2508              
    2509              
    2510             =head1 COMMUNITY
    2511              
    2512             Therese are primary resources available for those who wish to learn more
    2513             about CGI::Application and discuss it with others.
    2514              
    2515             B
    2516              
    2517             This is a community built and maintained resource that anyone is welcome to
    2518             contribute to. It contains a number of articles of its own and links
    2519             to many other CGI::Application related pages:
    2520              
    2521             L
    2522              
    2523             B
    2524              
    2525             If you have any questions, comments, bug reports or feature suggestions,
    2526             post them to the support mailing list! To join the mailing list, visit
    2527             http://lists.openlib.org/mailman/listinfo/cgiapp
    2528              
    2529             B
    2530              
    2531             This project is managed using git and is available on Github:
    2532              
    2533             L
    2534              
    2535             =head1 SEE ALSO
    2536              
    2537             =over 4
    2538              
    2539             =item o
    2540              
    2541             L
    2542              
    2543             =item o
    2544              
    2545             L
    2546              
    2547             =item o
    2548              
    2549             B - A full-featured web application based on
    2550             CGI::Application. http://www.cafweb.org/
    2551              
    2552             =back
    2553              
    2554             =head1 MORE READING
    2555              
    2556             If you're interested in finding out more about CGI::Application, the
    2557             following articles are available on Perl.com:
    2558              
    2559             Using CGI::Application
    2560             http://www.perl.com/pub/a/2001/06/05/cgi.html
    2561              
    2562             Rapid Website Development with CGI::Application
    2563             http://www.perl.com/pub/a/2006/10/19/cgi_application.html
    2564              
    2565             Thanks to O'Reilly for publishing these articles, and for the incredible value
    2566             they provide to the Perl community!
    2567              
    2568             =head1 AUTHOR
    2569              
    2570             Jesse Erlbaum
    2571              
    2572             Mark Stosberg has served as a co-maintainer since version 3.2, Martin McGrath
    2573             became a co-maintainer as of version 4.51, with the help of the numerous
    2574             contributors documented in the Changes file.
    2575              
    2576             =head1 CREDITS
    2577              
    2578             CGI::Application was originally developed by The Erlbaum Group, a software
    2579             engineering and consulting firm in New York City.
    2580              
    2581             Thanks to Vanguard Media (http://www.vm.com) for funding the initial
    2582             development of this library and for encouraging Jesse Erlbaum to release it to
    2583             the world.
    2584              
    2585             Many thanks to Sam Tregar (author of the most excellent
    2586             HTML::Template module!) for his innumerable contributions
    2587             to this module over the years, and most of all for getting
    2588             me off my ass to finally get this thing up on CPAN!
    2589              
    2590             Many other people have contributed specific suggestions or patches,
    2591             which are documented in the C file.
    2592              
    2593             Thanks also to all the members of the CGI-App mailing list!
    2594             Your ideas, suggestions, insights (and criticism!) have helped
    2595             shape this module immeasurably. (To join the mailing list, visit
    2596             http://lists.openlib.org/mailman/listinfo/cgiapp )
    2597              
    2598             =head1 LICENSE
    2599              
    2600             CGI::Application : Framework for building reusable web-applications
    2601             Copyright (C) 2000-2003 Jesse Erlbaum
    2602              
    2603             This module is free software; you can redistribute it and/or modify it
    2604             under the terms of either:
    2605              
    2606             a) the GNU General Public License as published by the Free Software
    2607             Foundation; either version 1, or (at your option) any later version,
    2608              
    2609             or
    2610              
    2611             b) the "Artistic License" which comes with this module.
    2612              
    2613             This program is distributed in the hope that it will be useful,
    2614             but WITHOUT ANY WARRANTY; without even the implied warranty of
    2615             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
    2616             the GNU General Public License or the Artistic License for more details.
    2617              
    2618             You should have received a copy of the Artistic License with this
    2619             module, in the file ARTISTIC. If not, I'll be glad to provide one.
    2620              
    2621             You should have received a copy of the GNU General Public License
    2622             along with this program; if not, write to the Free Software
    2623             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
    2624             USA
    2625              
    2626              
    2627             =cut
    2628