1package CGI::Application::Dispatch;
2use strict;
3use warnings;
4use Carp 'carp';
5use Try::Tiny;
6
7our $VERSION = '3.12';
8our $DEBUG   = 0;
9
10BEGIN {
11    use constant IS_MODPERL => exists($ENV{MOD_PERL});
12    use constant IS_MODPERL2 =>
13      (IS_MODPERL() and exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2);
14
15    if(IS_MODPERL2()) {
16        require Apache2::RequestUtil;
17        require Apache2::RequestRec;
18        require APR::Table;
19        require Apache2::Const;
20        Apache2::Const->import(qw(OK SERVER_ERROR HTTP_BAD_REQUEST NOT_FOUND REDIRECT));
21    } elsif(IS_MODPERL()) {
22        require Apache::Constants;
23        Apache::Constants->import(qw(OK SERVER_ERROR BAD_REQUEST NOT_FOUND REDIRECT));
24    }
25}
26
27# these return values have different values used in different ENV
28use Exception::Class (
29    'CGI::Application::Dispatch::Exception',
30    'CGI::Application::Dispatch::ERROR' => {
31        isa         => 'CGI::Application::Dispatch::Exception',
32        alias       => 'throw_error',
33        description => 500,
34    },
35    'CGI::Application::Dispatch::NOT_FOUND' => {
36        isa         => 'CGI::Application::Dispatch::Exception',
37        alias       => 'throw_not_found',
38        description => 404,
39    },
40    'CGI::Application::Dispatch::BAD_REQUEST' => {
41        isa         => 'CGI::Application::Dispatch::Exception',
42        alias       => 'throw_bad_request',
43        description => 400,
44    },
45);
46
47=pod
48
49=head1 NAME
50
51CGI::Application::Dispatch - Dispatch requests to CGI::Application based objects
52
53=head1 SYNOPSIS
54
55=head2 Out of Box
56
57Under mod_perl:
58
59    <Location /app>
60        SetHandler perl-script
61        PerlHandler CGI::Application::Dispatch
62    </Location>
63
64Under normal cgi:
65
66This would be the instance script for your application, such
67as /cgi-bin/dispatch.cgi:
68
69    #!/usr/bin/perl
70    use FindBin::Real 'Bin';
71    use lib Bin() . '/../../rel/path/to/my/perllib';
72    use CGI::Application::Dispatch;
73    CGI::Application::Dispatch->dispatch();
74
75=head2 With a dispatch table
76
77    package MyApp::Dispatch;
78    use base 'CGI::Application::Dispatch';
79
80    sub dispatch_args {
81        return {
82            prefix  => 'MyApp',
83            table   => [
84                ''                => { app => 'Welcome', rm => 'start' },
85                ':app/:rm'        => { },
86                'admin/:app/:rm'  => { prefix   => 'MyApp::Admin' },
87            ],
88        };
89    }
90
91Under mod_perl:
92
93    <Location /app>
94        SetHandler perl-script
95        PerlHandler MyApp::Dispatch
96    </Location>
97
98Under normal cgi:
99
100This would be the instance script for your application, such
101as /cgi-bin/dispatch.cgi:
102
103    #!/usr/bin/perl
104    use FindBin::Real 'Bin';
105    use lib Bin() . '/../../rel/path/to/my/perllib';
106    use MyApp::Dispatch;
107    MyApp::Dispatch->dispatch();
108
109=head1 DESCRIPTION
110
111This module provides a way (as a mod_perl handler or running under
112vanilla CGI) to look at the path (as returned by L<dispatch_path>) of
113the incoming request, parse off the desired module and its run mode,
114create an instance of that module and run it.
115
116It currently supports both generations of mod_perl (1.x and
1172.x). Although, for simplicity, all examples involving Apache
118configuration and mod_perl code will be shown using mod_perl 1.x.
119This may change as mp2 usage increases.
120
121It will translate a URI like this (under mod_perl):
122
123    /app/module_name/run_mode
124
125or this (vanilla cgi)
126
127    /app/index.cgi/module_name/run_mode
128
129into something that will be functionally similar to this
130
131    my $app = Module::Name->new(..);
132    $app->mode_param(sub {'run_mode'}); #this will set the run mode
133
134=head1 METHODS
135
136=head2 dispatch(%args)
137
138This is the primary method used during dispatch. Even under mod_perl,
139the L<handler> method uses this under the hood.
140
141    #!/usr/bin/perl
142    use strict;
143    use CGI::Application::Dispatch;
144
145    CGI::Application::Dispatch->dispatch(
146        prefix  => 'MyApp',
147        default => 'module_name',
148    );
149
150This method accepts the following name value pairs:
151
152=over
153
154=item default
155
156Specify a value to use for the path if one is not available.
157This could be the case if the default page is selected (eg: "/" ).
158
159=item prefix
160
161This option will set the string that will be prepended to the name of
162the application module before it is loaded and created. So to use our
163previous example request of
164
165    /app/index.cgi/module_name/run_mode
166
167This would by default load and create a module named
168'Module::Name'. But let's say that you have all of your application
169specific modules under the 'My' namespace. If you set this option to
170'My' then it would instead load the 'My::Module::Name' application
171module instead.
172
173=item args_to_new
174
175This is a hash of arguments that are passed into the C<new()>
176constructor of the application.
177
178=item table
179
180In most cases, simply using Dispatch with the C<default> and C<prefix>
181is enough to simplify your application and your URLs, but there are
182many cases where you want more power. Enter the dispatch table. Since
183this table can be slightly complicated, a whole section exists on its
184use. Please see the L<DISPATCH TABLE> section.
185
186=item debug
187
188Set to a true value to send debugging output for this module to
189STDERR. Off by default.
190
191=item error_document
192
193This string is similar to Apache ErrorDocument directive. If this value is not
194present, then Dispatch will return a NOT FOUND error either to the browser with
195simple hardcoded message (under CGI) or to Apache (under mod_perl).
196
197This value can be one of the following:
198
199B<A string with error message>
200- if it starts with a single double-quote character (C<">). This double-quote
201character will be trimmed from final output.
202
203B<A file with content of error document>
204- if it starts with less-than sign (C<<>). First character will be excluded
205as well. Path of this file should be relative to server DOCUMENT_ROOT.
206
207B<A URI to which the application will be redirected> - if no leading C<"> or
208C<<> will be found.
209
210Custom messages will be displayed I<in non mod_perl environment only>. (Under
211mod_perl, please use ErrorDocument directive in Apache configuration files.)
212This value can contain C<%s> placeholder for L<sprintf> Perl function. This
213placeholder will be replaced with numeric HTTP error code. Currently
214CGI::Application::Dispatch uses three HTTP errors:
215
216B<400 Bad Request>
217- If there are invalid characters in module name (parameter :app) or
218runmode name (parameter :rm).
219
220B<404 Not Found>
221- When the path does not match anything in the L<DISPATCH TABLE>,
222or module could not be found in @INC, or run mode did not exist.
223
224B<500 Internal Server Error>
225- If application error occurs.
226
227Examples of using error_document (assume error 404 have been returned):
228
229    # return in browser 'Opss... HTTP Error #404'
230    error_document => '"Opss... HTTP Error #%s'
231
232    # return contents of file $ENV{DOCUMENT_ROOT}/errors/error404.html
233    error_document => '</errors/error%s.html'
234
235    # internal redirect to /errors/error404.html
236    error_document => '/errors/error%s.html'
237
238    # external redirect to
239    # http://host.domain/cgi-bin/errors.cgi?error=404
240    error_document => 'http://host.domain/cgi-bin/errors.cgi?error=%s'
241
242=item auto_rest
243
244This tells Dispatch that you are using REST by default and that you
245care about which HTTP method is being used. Dispatch will append the
246HTTP method name (upper case by default) to the run mode that is
247determined after finding the appropriate dispatch rule. So a GET
248request that translates into C<< MyApp::Module->foo >> will become
249C<< MyApp::Module->foo_GET >>.
250
251This can be overridden on a per-rule basis in a custom dispatch table.
252
253=item auto_rest_lc
254
255In combinaion with L<auto_rest> this tells Dispatch that you prefer
256lower cased HTTP method names.  So instead of C<foo_POST> and
257C<foo_GET> you'll have C<foo_post> and C<foo_get>.
258
259=back
260
261=cut
262
263sub dispatch {
264    my ($self, %args) = @_;
265
266    # merge dispatch_args() and %args with %args taking precendence
267    my $dispatch_args = $self->dispatch_args(\%args);
268    for my $arg (keys %$dispatch_args) {
269
270        # args_to_new should be merged
271        if($arg eq 'args_to_new') {
272            $args{args_to_new} ||= {};
273
274            # merge the PARAMS hash
275            if($dispatch_args->{args_to_new}->{PARAMS}) {
276
277                # merge the hashes
278                $args{args_to_new}->{PARAMS} = {
279                    %{$dispatch_args->{args_to_new}->{PARAMS}},
280                    %{$args{args_to_new}->{PARAMS} || {}},
281                };
282            }
283
284            # combine any TMPL_PATHs
285            if($dispatch_args->{args_to_new}->{TMPL_PATH}) {
286
287                # make sure the orginial is an array ref
288                if($args{args_to_new}->{TMPL_PATH}) {
289                    if(!ref $args{args_to_new}->{TMPL_PATH}) {
290                        $args{args_to_new}->{TMPL_PATH} = [$args{args_to_new}->{TMPL_PATH}];
291                    }
292                } else {
293                    $args{args_to_new}->{TMPL_PATH} = [];
294                }
295
296                # now add the rest to the end
297                if(ref $dispatch_args->{args_to_new}->{TMPL_PATH}) {
298                    push(
299                        @{$args{args_to_new}->{TMPL_PATH}},
300                        @{$dispatch_args->{args_to_new}->{TMPL_PATH}},
301                    );
302                } else {
303                    push(
304                        @{$args{args_to_new}->{TMPL_PATH}},
305                        $dispatch_args->{args_to_new}->{TMPL_PATH},
306                    );
307                }
308            }
309
310            # now merge the args_to_new hashes
311            $args{args_to_new} = {%{$dispatch_args->{args_to_new}}, %{$args{args_to_new}},};
312        } else {
313
314            # anything else should override
315            $args{$arg} = $dispatch_args->{$arg} unless exists $args{$arg};
316        }
317    }
318
319    $DEBUG = $args{debug} ? 1 : 0;
320
321    # check for extra args (for backwards compatibility)
322    for (keys %args) {
323        next
324          if(  $_ eq 'prefix'
325            or $_ eq 'default'
326            or $_ eq 'debug'
327            or $_ eq 'rm'
328            or $_ eq 'args_to_new'
329            or $_ eq 'table'
330            or $_ eq 'auto_rest'
331            or $_ eq 'auto_rest_lc'
332            or $_ eq 'not_found'
333            or $_ eq 'error_document');
334        carp "Passing extra args ('$_') to dispatch() is deprecated! Please use 'args_to_new'";
335        $args{args_to_new}->{$_} = delete $args{$_};
336    }
337
338    # TODO: delete this block some time later
339    if(exists $args{not_found}) {
340        carp 'Passing not_found to dispatch() is deprecated! Please use error_document instead';
341        $args{error_document} = delete($args{not_found})
342          unless exists($args{error_document});
343    }
344
345    %args = map { lc $_ => $args{$_} } keys %args;    # lc for backwards
346                                                      # compatability
347
348    # get the PATH_INFO
349    my $path_info = $self->dispatch_path();
350
351    # use the 'default' if we need to
352    $path_info = $args{default} || '' if(!$path_info || $path_info eq '/');
353
354    # make sure they all start and end with a '/', to correspond with
355    # the RE we'll make
356    $path_info = "/$path_info" unless(index($path_info, '/') == 0);
357    $path_info = "$path_info/" unless(substr($path_info, -1) eq '/');
358
359    my ($module, $rm, $local_prefix, $local_args_to_new, $output);
360
361    # take args from path
362    my $named_args;
363    try {
364        $named_args = $self->_parse_path($path_info, $args{table})
365          or throw_not_found("Resource not found");
366    } catch {
367        $output = $self->http_error($_, $args{error_document});
368    };
369    return $output if $output;
370
371    if($DEBUG) {
372        require Data::Dumper;
373        warn "[Dispatch] Named args from match: " . Data::Dumper::Dumper($named_args) . "\n";
374    }
375
376    # eval and catch any exceptions that might be thrown
377    try {
378        if(exists($named_args->{PARAMS}) || exists($named_args->{TMPL_PATH})) {
379            carp "PARAMS and TMPL_PATH are not allowed here. Did you mean to use args_to_new?";
380            throw_error("PARAMS and TMPL_PATH not allowed");
381        }
382
383        ($module, $local_prefix, $rm, $local_args_to_new) =
384          delete @{$named_args}{qw(app prefix rm args_to_new)};
385
386        # If another name for dispatch_url_remainder has been set move
387        # the value to the requested name
388        if($$named_args{'*'}) {
389            $$named_args{$$named_args{'*'}} = $$named_args{'dispatch_url_remainder'};
390            delete $$named_args{'*'};
391            delete $$named_args{'dispatch_url_remainder'};
392        }
393
394        $module or throw_error("App not defined");
395        $module = $self->translate_module_name($module);
396
397        $local_prefix ||= $args{prefix};
398        $module = $local_prefix . '::' . $module if($local_prefix);
399
400        $local_args_to_new ||= $args{args_to_new};
401
402        # add the rest of the named_args to PARAMS
403        @{$local_args_to_new->{PARAMS}}{keys %$named_args} = values %$named_args;
404
405        my $auto_rest =
406          defined $named_args->{auto_rest} ? $named_args->{auto_rest} : $args{auto_rest};
407        if($auto_rest && defined $rm && length $rm) {
408            my $method_lc =
409              defined $named_args->{auto_rest_lc}
410              ? $named_args->{auto_rest_lc}
411              : $args{auto_rest_lc};
412            my $http_method = $self->_http_method;
413            $http_method = lc $http_method if $method_lc;
414            $rm .= "_$http_method";
415        }
416
417        # load and run the module
418        $self->require_module($module);
419        $output = $self->_run_app($module, $rm, $local_args_to_new);
420    } catch {
421        my $e = $_;
422        unless ( ref $e && $e->isa('Exception::Class::Base') ) {
423            $e = Exception::Class::Base->new($e);
424        }
425        $output = $self->http_error($e, $args{error_document});
426    };
427    return $output;
428}
429
430
431=pod
432
433=head2 dispatch_path()
434
435This method returns the path that is to be processed.
436
437By default it returns the value of C<$ENV{PATH_INFO}>
438(or C<< $r->path_info >> under mod_perl) which should work for
439most cases.  It allows the ability for subclasses to override the value if
440they need to do something more specific.
441
442=cut
443
444sub dispatch_path {
445    return $ENV{PATH_INFO};
446}
447
448sub http_error {
449    my ($self, $e, $errdoc) = @_;
450
451    warn '[Dispatch] ERROR'
452      . ($ENV{REQUEST_URI} ? " for request '$ENV{REQUEST_URI}': " : ': ')
453      . $e->error . "\n";
454
455    my $errno =
456        $e->isa('CGI::Application::Dispatch::Exception')
457      ? $e->description
458      : 500;
459
460    my ($url, $output);
461
462    if($errdoc) {
463        my $str = sprintf($errdoc, $errno);
464        if(IS_MODPERL) {    #compile out all other stuff
465            $url = $str;    # no messages, please
466        } elsif(index($str, '"') == 0) {    # Error message
467            $output = substr($str, 1);
468        } elsif(index($str, '<') == 0) {    # Local file
469                                            # Is it secure?
470            require File::Spec;
471            $str = File::Spec->catdir($ENV{DOCUMENT_ROOT}, substr($str, 1));
472            local *FH;
473            if(-f $str && open(FH, '<', $str)) {
474                local $/ = undef;
475                $output = <FH>;
476                close FH;
477            } else {
478                warn "[Dispatch] Error opening error document '$str'.\n";
479            }
480        } else {                            # Last case is url
481            $url = $str;
482        }
483
484        if($DEBUG) {
485            warn "[Dispatch] Redirection for HTTP error #$errno to $url\n"
486              if $url;
487            warn "[Dispatch] Displaying message for HTTP error #$errno\n"
488              if $output;
489        }
490
491    }
492
493    # if we're under mod_perl
494    if(IS_MODPERL) {
495        my $r = $self->_r;
496        $r->status($errno);
497
498        # if we just want to redirect
499        $r->headers_out->{'Location'} = $url if $url;
500        return '';
501    } else {    # else print the HTTP stuff ourselves
502
503        # stolen from http_protocol.c in Apache sources
504        # we don't actually use anything other than 200, 307, 400, 404 and 500
505
506        my %status_lines = (
507
508            #    100 => 'Continue',
509            #    101 => 'Switching Protocols',
510            #    102 => 'Processing',
511            200 => 'OK',
512
513            #    201 => 'Created',
514            #    202 => 'Accepted',
515            #    203 => 'Non-Authoritative Information',
516            #    204 => 'No Content',
517            #    205 => 'Reset Content',
518            #    206 => 'Partial Content',
519            #    207 => 'Multi-Status',
520            #    300 => 'Multiple Choices',
521            #    301 => 'Moved Permanently',
522            #    302 => 'Found',
523            #    303 => 'See Other',
524            #    304 => 'Not Modified',
525            #    305 => 'Use Proxy',
526            307 => 'Temporary Redirect',
527            400 => 'Bad Request',
528
529            #    401 => 'Authorization Required',
530            #    402 => 'Payment Required',
531            #    403 => 'Forbidden',
532            404 => 'Not Found',
533
534            #    405 => 'Method Not Allowed',
535            #    406 => 'Not Acceptable',
536            #    407 => 'Proxy Authentication Required',
537            #    408 => 'Request Time-out',
538            #    409 => 'Conflict',
539            #    410 => 'Gone',
540            #    411 => 'Length Required',
541            #    412 => 'Precondition Failed',
542            #    413 => 'Request Entity Too Large',
543            #    414 => 'Request-URI Too Large',
544            #    415 => 'Unsupported Media Type',
545            #    416 => 'Requested Range Not Satisfiable',
546            #    417 => 'Expectation Failed',
547            #    422 => 'Unprocessable Entity',
548            #    423 => 'Locked',
549            #    424 => 'Failed Dependency',
550            500 => 'Internal Server Error',
551
552            #    501 => 'Method Not Implemented',
553            #    502 => 'Bad Gateway',
554            #    503 => 'Service Temporarily Unavailable',
555            #    504 => 'Gateway Time-out',
556            #    505 => 'HTTP Version Not Supported',
557            #    506 => 'Variant Also Negotiates',
558            #    507 => 'Insufficient Storage',
559            #    510 => 'Not Extended',
560        );
561
562        $errno = 500 if(!exists $status_lines{$errno});
563
564        if($url) {
565
566            # somewhat mailformed header, no errors in access.log, but browsers
567            # display contents of $url document and old URI in address bar.
568            $output = "HTTP/1.0 $errno $status_lines{$errno}\n";
569            $output .= "Location: $url\n\n";
570        } else {
571
572            unless($output) {
573
574                # TODO: possibly provide more feedback in a way that
575                # is XSS safe.  (I'm not sure that passing through the
576                # raw ENV variable directly is safe.)
577                # <P>We tried: $ENV{REQUEST_URI}</P></BODY></HTML>";
578                $output = qq(
579                <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
580                <HTML><HEAD>
581                <TITLE>$errno $status_lines{$errno}</TITLE>
582                </HEAD><BODY>)
583                  . (
584                    $DEBUG
585                    ? '<h1>' . __PACKAGE__ . ' error!</h1>'
586                    : ''
587                  )
588                  . qq(<H1>$status_lines{$errno}</H1>
589                <P><ADDRESS>)
590                  . ($ENV{SERVER_ADMIN} ? "($ENV{SERVER_ADMIN})" : '') . qq(</ADDRESS></P>
591                <HR>)
592                  . ($ENV{SERVER_SIGNATURE} || '') . qq(</BODY></HTML>);
593            }
594
595            # Apache will report $errno in access.log
596            my $header .= "Status: $errno $status_lines{$errno}\n";
597
598            # try to guess, what a crap we get here
599            $header .=
600              $output =~ /<html/i
601              ? "Content-type: text/html\n\n"
602              : "Content-type: text/plain\n\n";
603
604            # Workaround for IE error document 512 byte size "feature"
605            $output .= ' ' x (520 - length($output))
606              if(length($output) < 520);
607
608            $output = $header . $output;
609        }
610
611        # Send output to browser (unless we're in serious debug mode!)
612        print $output unless $ENV{CGI_APP_RETURN_ONLY};
613
614        return $output;
615    }
616}
617
618# protected method - designed to be used by sub classes, not by end users
619sub _parse_path {
620    my ($self, $path, $table) = @_;
621
622    # get the module name from the table
623    return unless defined($path);
624
625    unless(ref($table) eq 'ARRAY') {
626        warn "[Dispatch] Invalid or no dispatch table!\n";
627        return;
628    }
629
630    # look at each rule and stop when we get a match
631    for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {
632
633        my $rule = $table->[$i];
634
635        # are we trying to dispatch based on HTTP_METHOD?
636        my $http_method_regex = qr/\[([^\]]+)\]$/;
637        if($rule =~ /$http_method_regex/) {
638            my $http_method = $1;
639
640            # go ahead to the next rule
641            next unless lc($1) eq lc($self->_http_method);
642
643            # remove the method portion from the rule
644            $rule =~ s/$http_method_regex//;
645        }
646
647        # make sure they start and end with a '/' to match how
648        # PATH_INFO is formatted
649        $rule = "/$rule" unless(index($rule, '/') == 0);
650        $rule = "$rule/" if(substr($rule, -1) ne '/');
651
652        my @names = ();
653
654        # translate the rule into a regular expression, but remember
655        # where the named args are
656        # '/:foo' will become '/([^\/]*)'
657        # and
658        # '/:bar?' will become '/?([^\/]*)?'
659        # and then remember which position it matches
660
661        $rule =~ s{
662            (^|/)                 # beginning or a /
663            (:([^/\?]+)(\?)?)     # stuff in between
664        }{
665            push(@names, $3);
666            $1 . ($4 ? '?([^/]*)?' : '([^/]*)')
667        }gxe;
668
669        # '/*/' will become '/(.*)/$' the end / is added to the end of
670        # both $rule and $path elsewhere
671        if($rule =~ m{/\*/$}) {
672            $rule =~ s{/\*/$}{/(.*)/\$};
673            push(@names, 'dispatch_url_remainder');
674        }
675
676        warn
677          "[Dispatch] Trying to match '${path}' against rule '$table->[$i]' using regex '${rule}'\n"
678          if $DEBUG;
679
680        # if we found a match, then run with it
681        if(my @values = ($path =~ m#^$rule$#)) {
682
683            warn "[Dispatch] Matched!\n" if $DEBUG;
684
685            my %named_args = %{$table->[++$i]};
686            @named_args{@names} = @values if @names;
687
688            return \%named_args;
689        }
690    }
691
692    return;
693}
694
695sub _http_method {
696    IS_MODPERL ? shift->_r->method : ($ENV{HTTP_REQUEST_METHOD} || $ENV{REQUEST_METHOD});
697}
698
699sub _r { IS_MODPERL2 ? Apache2::RequestUtil->request: Apache->request; }
700
701sub _run_app {
702    my ($self, $module, $rm, $args) = @_;
703
704    if($DEBUG) {
705        require Data::Dumper;
706        warn "[Dispatch] Final args to pass to new(): " . Data::Dumper::Dumper($args) . "\n";
707    }
708
709    if($rm) {
710
711        # check runmode name
712        ($rm) = ($rm =~ /^([a-zA-Z_][\w']+)$/);
713        throw_bad_request("Invalid characters in runmode name") unless $rm;
714    }
715
716    # now create and run then application object
717    warn "[Dispatch] creating instance of $module\n" if($DEBUG);
718
719    my $output;
720    eval {
721        my $app = ref($args) eq 'HASH' ? $module->new($args) : $module->new();
722        $app->mode_param(sub { return $rm }) if($rm);
723        $output = $app->run();
724    };
725
726    if($@) {
727
728        # catch invalid run-mode stuff
729        if(not ref $@ and  $@ =~ /No such run mode/) {
730            throw_not_found("RM '$rm' not found")
731
732              # otherwise, just pass it up the chain
733        } else {
734            die $@;
735        }
736    }
737
738    return $output;
739}
740
741=head2 handler()
742
743This method is used so that this module can be run as a mod_perl handler.
744When it creates the application module it passes the $r argument into the PARAMS
745hash of new()
746
747    <Location /app>
748        SetHandler perl-script
749        PerlHandler CGI::Application::Dispatch
750        PerlSetVar  CGIAPP_DISPATCH_PREFIX  MyApp
751        PerlSetVar  CGIAPP_DISPATCH_DEFAULT /module_name
752    </Location>
753
754The above example would tell apache that any url beginning with /app
755will be handled by CGI::Application::Dispatch. It also sets the prefix
756used to create the application module to 'MyApp' and it tells
757CGI::Application::Dispatch that it shouldn't set the run mode but that
758it will be determined by the application module as usual (through the
759query string). It also sets a default application module to be used if
760there is no path.  So, a url of C</app/module_name> would create an
761instance of C<MyApp::Module::Name>.
762
763Using this method will add the C<Apache->request> object to your
764application's C<PARAMS> as 'r'.
765
766    # inside your app
767    my $request = $self->param('r');
768
769If you need more customization than can be accomplished with just
770L<prefix> and L<default>, then it would be best to just subclass
771CGI::Application::Dispatch and override L<dispatch_args> since
772C<handler()> uses L<dispatch> to do the heavy lifting.
773
774    package MyApp::Dispatch;
775    use base 'CGI::Application::Dispatch';
776
777    sub dispatch_args {
778        return {
779            prefix  => 'MyApp',
780            table   => [
781                ''                => { app => 'Welcome', rm => 'start' },
782                ':app/:rm'        => { },
783                'admin/:app/:rm'  => { prefix   => 'MyApp::Admin' },
784            ],
785            args_to_new => {
786                PARAMS => {
787                    foo => 'bar',
788                    baz => 'bam',
789                },
790            }
791        };
792    }
793
794    1;
795
796And then in your httpd.conf
797
798    <Location /app>
799        SetHandler perl-script
800        PerlHandler MyApp::Dispatch
801    </Location>
802
803=cut
804
805sub handler : method {
806    my ($self, $r) = @_;
807
808    # set the PATH_INFO
809    $ENV{PATH_INFO} = $r->path_info();
810
811    # setup our args to dispatch()
812    my %args;
813    my $config_args = $r->dir_config();
814    for my $var (qw(DEFAULT PREFIX ERROR_DOCUMENT)) {
815        my $dir_var = "CGIAPP_DISPATCH_$var";
816        $args{lc($var)} = $config_args->{$dir_var}
817          if($config_args->{$dir_var});
818    }
819
820    # add $r to the args_to_new's PARAMS
821    $args{args_to_new}->{PARAMS}->{r} = $r;
822
823    # set debug if we need to
824    $DEBUG = 1 if($config_args->{CGIAPP_DISPATCH_DEBUG});
825    if($DEBUG) {
826        require Data::Dumper;
827        warn "[Dispatch] Calling dispatch() with the following arguments: "
828          . Data::Dumper::Dumper(\%args) . "\n";
829    }
830
831    $self->dispatch(%args);
832
833    if($r->status == 404) {
834        return NOT_FOUND();
835    } elsif($r->status == 500) {
836        return SERVER_ERROR();
837    } elsif($r->status == 400) {
838        return IS_MODPERL2() ? HTTP_BAD_REQUEST() : BAD_REQUEST();
839    } else {
840        return OK();
841    }
842}
843
844=head2 dispatch_args()
845
846Returns a hashref of args that will be passed to L<dispatch>(). It
847will return the following structure by default.
848
849    {
850        prefix      => '',
851        args_to_new => {},
852        table       => [
853            ':app'      => {},
854            ':app/:rm'  => {},
855        ],
856    }
857
858This is the perfect place to override when creating a subclass to
859provide a richer dispatch L<table>.
860
861When called, it receives 1 argument, which is a reference to the hash
862of args passed into L<dispatch>.
863
864=cut
865
866sub dispatch_args {
867    my ($self, $args) = @_;
868    return {
869        default     => ($args->{default}     || ''),
870        prefix      => ($args->{prefix}      || ''),
871        args_to_new => ($args->{args_to_new} || {}),
872        table       => [
873            ':app'     => {},
874            ':app/:rm' => {},
875        ],
876    };
877}
878
879=head2 translate_module_name($input)
880
881This method is used to control how the module name is translated from
882the matching section of the path (see L<"Path Parsing">).
883The main
884reason that this method exists is so that it can be overridden if it
885doesn't do exactly what you want.
886
887The following transformations are performed on the input:
888
889=over
890
891=item The text is split on '_'s (underscores)
892and each word has its first letter capitalized. The words are then joined
893back together and each instance of an underscore is replaced by '::'.
894
895
896=item The text is split on '-'s (hyphens)
897and each word has its first letter capitalized. The words are then joined
898back together and each instance of a hyphen removed.
899
900=back
901
902Here are some examples to make it even clearer:
903
904    module_name         => Module::Name
905    module-name         => ModuleName
906    admin_top-scores    => Admin::TopScores
907
908=cut
909
910sub translate_module_name {
911    my ($self, $input) = @_;
912
913    $input = join('::', map { ucfirst($_) } split(/_/, $input));
914    $input = join('',   map { ucfirst($_) } split(/-/, $input));
915
916    return $input;
917}
918
919=head2 require_module($module_name)
920
921This class method is used internally by CGI::Application::Dispatch to
922take a module name (supplied by L<get_module_name>) and require it in
923a secure fashion. It is provided as a public class method so that if
924you override other functionality of this module, you can still safely
925require user specified modules. If there are any problems requiring
926the named module, then we will C<croak>.
927
928    CGI::Application::Dispatch->require_module('MyApp::Module::Name');
929
930=cut
931
932sub require_module {
933    my ($self, $module) = @_;
934
935    $module or throw_not_found("Can't define module name");
936
937    #untaint the module name
938    ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/);
939
940    unless($module) {
941        throw_bad_request("Invalid characters in module name");
942    }
943
944    warn "[Dispatch] loading module $module\n" if($DEBUG);
945    eval "require $module";
946    return unless $@;
947
948    my $module_path = $module;
949    $module_path =~ s/::/\//g;
950
951    if($@ =~ /Can't locate $module_path.pm/) {
952        throw_not_found("Can't find module $module");
953    } else {
954        throw_error("Unable to load module '$module': $@");
955    }
956}
957
9581;
959
960__END__
961
962=head1 DISPATCH TABLE
963
964Sometimes it's easiest to explain with an example, so here you go:
965
966  CGI::Application::Dispatch->dispatch(
967    prefix      => 'MyApp',
968    args_to_new => {
969        TMPL_PATH => 'myapp/templates'
970    },
971    table       => [
972        ''                         => { app => 'Blog', rm => 'recent'},
973        'posts/:category'          => { app => 'Blog', rm => 'posts' },
974        ':app/:rm/:id'             => { app => 'Blog' },
975        'date/:year/:month?/:day?' => {
976            app         => 'Blog',
977            rm          => 'by_date',
978            args_to_new => { TMPL_PATH => "events/" },
979        },
980    ]
981  );
982
983So first, this call to L<dispatch> sets the L<prefix> and passes a
984C<TMPL_PATH> into L<args_to_new>. Next it sets the L<table>.
985
986
987=head2 VOCABULARY
988
989Just so we all understand what we're talking about....
990
991A table is an array where the elements are gouped as pairs (similar to
992a hash's key-value pairs, but as an array to preserve order). The
993first element of each pair is called a C<rule>. The second element in
994the pair is called the rule's C<arg list>.  Inside a rule there are
995slashes C</>. Anything set of characters between slashes is called a
996C<token>.
997
998=head2 URL MATCHING
999
1000When a URL comes in, Dispatch tries to match it against each rule in
1001the table in the order in which the rules are given. The first one to
1002match wins.
1003
1004A rule consists of slashes and tokens. A token can one of the following types:
1005
1006=over
1007
1008=item literal
1009
1010Any token which does not start with a colon (C<:>) is taken to be a literal
1011string and must appear exactly as-is in the URL in order to match. In the rule
1012
1013    'posts/:category'
1014
1015C<posts> is a literal token.
1016
1017=item variable
1018
1019Any token which begins with a colon (C<:>) is a variable token. These
1020are simply wild-card place holders in the rule that will match
1021anything in the URL that isn't a slash. These variables can later be
1022referred to by using the C<< $self->param >> mechanism. In the rule
1023
1024    'posts/:category'
1025
1026C<:category> is a variable token. If the URL matched this rule, then
1027you could retrieve the value of that token from whithin your
1028application like so:
1029
1030    my $category = $self->param('category');
1031
1032There are some variable tokens which are special. These can be used to
1033further customize the dispatching.
1034
1035=over
1036
1037=item :app
1038
1039This is the module name of the application. The value of this token
1040will be sent to the L<translate_module_name> method and then prefixed
1041with the L<prefix> if there is one.
1042
1043=item :rm
1044
1045This is the run mode of the application. The value of this token will be the
1046actual name of the run mode used. The run mode can be optional, as
1047noted below. Example:
1048
1049    /foo/:rm?
1050
1051If no run mode is found, it will default to using the C<< start_mode() >>, just like
1052invoking CGI::Application directly. Both of these URLs would end up dispatching
1053to the start mode associated with /foo:
1054
1055    /foo/
1056    /foo
1057
1058=back
1059
1060=item optional-variable
1061
1062Any token which begins with a colon (C<:>) and ends with a question
1063mark (<?>) is considered optional. If the rest of the URL matches the
1064rest of the rule, then it doesn't matter whether it contains this
1065token or not. It's best to only include optional-variable tokens at
1066the end of your rule. In the rule
1067
1068    'date/:year/:month?/:day?'
1069
1070C<:month?> and C<:day?> are optional-variable tokens.
1071
1072Just like with L<variable> tokens, optional-variable tokens' values
1073can also be retrieved by the application, if they existed in the URL.
1074
1075    if( defined $self->param('month') ) {
1076        ...
1077    }
1078
1079=item wildcard
1080
1081The wildcard token "*" allows for partial matches. The token MUST
1082appear at the end of the rule.
1083
1084  'posts/list/*'
1085
1086By default, the C<dispatch_url_remainder> param is set to the
1087remainder of the URL matched by the *. The name of the param can be
1088changed by setting "*" argument in the L<ARG LIST>.
1089
1090  'posts/list/*' => { '*' => 'post_list_filter' }
1091
1092=item method
1093
1094You can also dispatch based on HTTP method. This is similar to using
1095L<auto_rest> but offers more fine grained control. You include the
1096method (case insensitive) at the end of the rule and enclose it in
1097square brackets.
1098
1099  ':app/news[post]'   => { rm => 'add_news'    },
1100  ':app/news[get]'    => { rm => 'news'        },
1101  ':app/news[delete]' => { rm => 'delete_news' },
1102
1103=back
1104
1105The main reason that we don't use regular expressions for dispatch
1106rules is that regular expressions provide no mechanism for named back
1107references, like variable tokens do.
1108
1109=head2 ARG LIST
1110
1111Each rule can have an accompanying arg-list. This arg list can contain
1112special arguments that override something set higher up in L<dispatch>
1113for this particular URL, or just have additional args passed available
1114in C<< $self->param() >>
1115
1116For instance, if you want to override L<prefix> for a specific rule,
1117then you can do so.
1118
1119    'admin/:app/:rm' => { prefix => 'MyApp::Admin' },
1120
1121=head1 Path Parsing
1122
1123This section will describe how the application module and run mode are
1124determined from the path if no L<DISPATCH TABLE> is present, and what
1125options you have to customize the process.  The value for the path to
1126be parsed is retrieved from the L<dispatch_path> method, which by
1127default uses the C<PATH_INFO> environment variable.
1128
1129=head2 Getting the module name
1130
1131To get the name of the application module the path is split on
1132backslahes (C</>).  The second element of the returned list (the first
1133is empty) is used to create the application module. So if we have a
1134path of
1135
1136    /module_name/mode1
1137
1138then the string 'module_name' is used. This is passed through the
1139L<translate_module_name> method. Then if there is a C<prefix> (and
1140there should always be a L<prefix>) it is added to the beginning of
1141this new module name with a double colon C<::> separating the two.
1142
1143If you don't like the exact way that this is done, don't fret you do
1144have a couple of options.  First, you can specify a L<DISPATCH TABLE>
1145which is much more powerful and flexible (in fact this default
1146behavior is actually implemented internally with a dispatch table).
1147Or if you want something a little simpler, you can simply subclass and
1148extend the L<translate_module_name> method.
1149
1150=head2 Getting the run mode
1151
1152Just like the module name is retrieved from splitting the path on
1153slashes, so is the run mode. Only instead of using the second element
1154of the resulting list, we use the third as the run mode. So, using the
1155same example, if we have a path of
1156
1157    /module_name/mode2
1158
1159Then the string 'mode2' is used as the run mode.
1160
1161=head1 MISC NOTES
1162
1163=over 8
1164
1165=item * CGI query strings
1166
1167CGI query strings are unaffected by the use of C<PATH_INFO> to obtain
1168the module name and run mode.  This means that any other modules you
1169use to get access to you query argument (ie, L<CGI>,
1170L<Apache::Request>) should not be affected. But, since the run mode
1171may be determined by CGI::Application::Dispatch having a query
1172argument named 'rm' will be ignored by your application module.
1173
1174=back
1175
1176=head1 CLEAN URLS WITH MOD_REWRITE
1177
1178With a dispatch script, you can fairly clean URLS like this:
1179
1180 /cgi-bin/dispatch.cgi/module_name/run_mode
1181
1182However, including "/cgi-bin/dispatch.cgi" in ever URL doesn't add any
1183value to the URL, so it's nice to remove it. This is easily done if
1184you are using the Apache web server with C<mod_rewrite>
1185available. Adding the following to a C<.htaccess> file would allow you
1186to simply use:
1187
1188 /module_name/run_mode
1189
1190If you have problems with mod_rewrite, turn on debugging to see
1191exactly what's happening:
1192
1193 RewriteLog /home/project/logs/alpha-rewrite.log
1194 RewriteLogLevel 9
1195
1196=head2 mod_rewrite related code in the dispatch script.
1197
1198This seemed necessary to put in the dispatch script to make mod_rewrite happy.
1199Perhaps it's specific to using C<RewriteBase>.
1200
1201  # mod_rewrite alters the PATH_INFO by turning it into a file system path,
1202  # so we repair it.
1203  $ENV{PATH_INFO} =~ s/^$ENV{DOCUMENT_ROOT}// if defined $ENV{PATH_INFO};
1204
1205=head2 Simple Apache Example
1206
1207  RewriteEngine On
1208
1209  # You may want to change the base if you are using the dispatcher within a
1210  # specific directory.
1211  RewriteBase /
1212
1213  # If an actual file or directory is requested, serve directly
1214  RewriteCond %{REQUEST_FILENAME} !-f
1215  RewriteCond %{REQUEST_FILENAME} !-d
1216
1217  # Otherwise, pass everything through to the dispatcher
1218  RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA]
1219
1220=head2 More complex rewrite: dispatching "/" and multiple developers
1221
1222Here is a more complex example that dispatches "/", which would otherwise
1223be treated as a directory, and also supports multiple developer directories,
1224so C</~mark> has its own separate dispatching system beneath it.
1225
1226Note that order matters here! The Location block for "/" needs to come
1227before the user blocks.
1228
1229  <Location />
1230    RewriteEngine On
1231    RewriteBase /
1232
1233    # Run "/" through the dispatcher
1234    RewriteRule ^home/project/www/$ /cgi-bin/dispatch.cgi [L,QSA]
1235
1236    # Don't apply this rule to the users sub directories.
1237    RewriteCond %{REQUEST_URI} !^/~.*$
1238    # If an actual file or directory is requested, serve directly
1239    RewriteCond %{REQUEST_FILENAME} !-f
1240    RewriteCond %{REQUEST_FILENAME} !-d
1241    # Otherwise, pass everything through to the dispatcher
1242    RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA]
1243  </Location>
1244
1245  <Location /~mark>
1246    RewriteEngine On
1247    RewriteBase /~mark
1248
1249    # Run "/" through the dispatcher
1250    RewriteRule ^/home/mark/www/$ /~mark/cgi-bin/dispatch.cgi [L,QSA]
1251
1252    # Otherwise, if an actual file or directory is requested,
1253    # serve directly
1254    RewriteCond %{REQUEST_FILENAME} !-f
1255    RewriteCond %{REQUEST_FILENAME} !-d
1256
1257    # Otherwise, pass everything through to the dispatcher
1258    RewriteRule ^(.*)$ /~mark/cgi-bin/dispatch.cgi/$1 [L,QSA]
1259
1260    # These examples may also be helpful, but are unrelated to dispatching.
1261    SetEnv DEVMODE mark
1262    SetEnv PERL5LIB /home/mark/perllib:/home/mark/config
1263    ErrorDocument 404 /~mark/errdocs/404.html
1264    ErrorDocument 500 /~mark/errdocs/500.html
1265  </Location>
1266
1267=head1 SUBCLASSING
1268
1269While Dispatch tries to be flexible, it won't be able to do everything
1270that people want. Hopefully we've made it flexible enough so that if
1271it doesn't do I<The Right Thing> you can easily subclass it.
1272
1273=cut
1274
1275#=head2 PROTECTED METHODS
1276#
1277#The following methods are intended to be overridden by subclasses if
1278#necessary. They are not part of the public API since end users will
1279#never touch them. However, to ensure that your subclass of Dispatch
1280#does not break with a new release, they are documented here and are
1281#considered to be part of the API and will not be changed without very
1282#good reasons.
1283
1284=head1 AUTHOR
1285
1286Michael Peters <mpeters@plusthree.com>
1287
1288Thanks to Plus Three, LP (http://www.plusthree.com) for sponsoring my
1289work on this module
1290
1291=head1 COMMUNITY
1292
1293This module is a part of the larger L<CGI::Application> community. If
1294you have questions or comments about this module then please join us
1295on the cgiapp mailing list by sending a blank message to
1296"cgiapp-subscribe@lists.erlbaum.net". There is also a community wiki
1297located at L<http://www.cgi-app.org/>
1298
1299=head1 SOURCE CODE REPOSITORY
1300
1301A public source code repository for this project is hosted here:
1302
1303http://code.google.com/p/cgi-app-modules/source/checkout
1304
1305=head1 CONTRIBUTORS
1306
1307
1308=over
1309
1310=item * Shawn Sorichetti
1311
1312=item * Timothy Appnel
1313
1314=item * dsteinbrunner
1315
1316=item * ZACKSE
1317
1318=item * Stew Heckenberg
1319
1320=item * Drew Taylor <drew@drewtaylor.com>
1321
1322=item * James Freeman <james.freeman@smartsurf.org>
1323
1324=item * Michael Graham <magog@the-wire.com>
1325
1326=item * Cees Hek <ceeshek@gmail.com>
1327
1328=item * Mark Stosberg <mark@summersault.com>
1329
1330=item * Viacheslav Sheveliov <slavash@aha.ru>
1331
1332=back
1333
1334=head1 SECURITY
1335
1336Since C::A::Dispatch will dynamically choose which modules to use as
1337the content generators, it may give someone the ability to execute
1338random modules on your system if those modules can be found in you
1339path. Of course those modules would have to behave like
1340L<CGI::Application> based modules, but that still opens up the door
1341more than most want. This should only be a problem if you don't use a
1342L<prefix>. By using this option you are only allowing Dispatch to pick
1343from a namespace of modules to run.
1344
1345=head1 SEE ALSO
1346
1347L<CGI::Application>, L<Apache::Dispatch>
1348
1349=head1 COPYRIGHT & LICENSE
1350
1351Copyright Michael Peters and Mark Stosberg 2008, all rights reserved.
1352
1353This library is free software; you can redistribute it and/or modify
1354it under the same terms as Perl itself.
1355
1356=cut
1357