File Coverage

blib/lib/CGI/Application/Dispatch.pm

Criterion	Covered	Total	%
statement	152	225	67.5
branch	73	152	48.0
condition	40	66	60.6
subroutine	21	24	87.5
pod	6	7	85.7
total	292	474	61.6

package CGI::Application::Dispatch;
use strict;
use warnings;
use Carp 'carp';
use Try::Tiny;

our $VERSION = '3.12';
our $DEBUG   = 0;

BEGIN {
    use constant IS_MODPERL => exists($ENV{MOD_PERL});
    use constant IS_MODPERL2 =>
      (IS_MODPERL() and exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2);

    if(IS_MODPERL2()) {
        require Apache2::RequestUtil;
        require Apache2::RequestRec;
        require APR::Table;
        require Apache2::Const;
        Apache2::Const->import(qw(OK SERVER_ERROR HTTP_BAD_REQUEST NOT_FOUND REDIRECT));
    } elsif(IS_MODPERL()) {
        require Apache::Constants;
        Apache::Constants->import(qw(OK SERVER_ERROR BAD_REQUEST NOT_FOUND REDIRECT));
    }
}

# these return values have different values used in different ENV
use Exception::Class (
    'CGI::Application::Dispatch::Exception',
    'CGI::Application::Dispatch::ERROR' => {
        isa         => 'CGI::Application::Dispatch::Exception',
        alias       => 'throw_error',
        description => 500,
    },
    'CGI::Application::Dispatch::NOT_FOUND' => {
        isa         => 'CGI::Application::Dispatch::Exception',
        alias       => 'throw_not_found',
        description => 404,
    },
    'CGI::Application::Dispatch::BAD_REQUEST' => {
        isa         => 'CGI::Application::Dispatch::Exception',
        alias       => 'throw_bad_request',
        description => 400,
    },
);

=pod

=head1 NAME

CGI::Application::Dispatch - Dispatch requests to CGI::Application based objects

=head1 SYNOPSIS

=head2 Out of Box

Under mod_perl:


        SetHandler perl-script
        PerlHandler CGI::Application::Dispatch


Under normal cgi:

This would be the instance script for your application, such
as /cgi-bin/dispatch.cgi:

    #!/usr/bin/perl
    use FindBin::Real 'Bin';
    use lib Bin() . '/../../rel/path/to/my/perllib';
    use CGI::Application::Dispatch;
    CGI::Application::Dispatch->dispatch();

=head2 With a dispatch table

    package MyApp::Dispatch;
    use base 'CGI::Application::Dispatch';

    sub dispatch_args {
        return {
            prefix  => 'MyApp',
            table   => [
                ''                => { app => 'Welcome', rm => 'start' },
                ':app/:rm'        => { },
                'admin/:app/:rm'  => { prefix   => 'MyApp::Admin' },
            ],
        };
    }

Under mod_perl:


        SetHandler perl-script
        PerlHandler MyApp::Dispatch


Under normal cgi:

This would be the instance script for your application, such
as /cgi-bin/dispatch.cgi:

    #!/usr/bin/perl
    use FindBin::Real 'Bin';
    use lib Bin() . '/../../rel/path/to/my/perllib';
    use MyApp::Dispatch;
    MyApp::Dispatch->dispatch();

=head1 DESCRIPTION

This module provides a way (as a mod_perl handler or running under
vanilla CGI) to look at the path (as returned by L) of
the incoming request, parse off the desired module and its run mode,
create an instance of that module and run it.

It currently supports both generations of mod_perl (1.x and
2.x). Although, for simplicity, all examples involving Apache
configuration and mod_perl code will be shown using mod_perl 1.x.
This may change as mp2 usage increases.

It will translate a URI like this (under mod_perl):

    /app/module_name/run_mode

or this (vanilla cgi)

    /app/index.cgi/module_name/run_mode

into something that will be functionally similar to this

    my $app = Module::Name->new(..);
    $app->mode_param(sub {'run_mode'}); #this will set the run mode

=head1 METHODS

=head2 dispatch(%args)

This is the primary method used during dispatch. Even under mod_perl,
the L method uses this under the hood.

    #!/usr/bin/perl
    use strict;
    use CGI::Application::Dispatch;

    CGI::Application::Dispatch->dispatch(
        prefix  => 'MyApp',
        default => 'module_name',
    );

This method accepts the following name value pairs:

=over

=item default

Specify a value to use for the path if one is not available.
This could be the case if the default page is selected (eg: "/" ).

=item prefix

This option will set the string that will be prepended to the name of
the application module before it is loaded and created. So to use our
previous example request of

    /app/index.cgi/module_name/run_mode

This would by default load and create a module named
'Module::Name'. But let's say that you have all of your application
specific modules under the 'My' namespace. If you set this option to
'My' then it would instead load the 'My::Module::Name' application
module instead.

=item args_to_new

This is a hash of arguments that are passed into the C
constructor of the application.

=item table

In most cases, simply using Dispatch with the C and C
is enough to simplify your application and your URLs, but there are
many cases where you want more power. Enter the dispatch table. Since
this table can be slightly complicated, a whole section exists on its
use. Please see the L section.

=item debug

Set to a true value to send debugging output for this module to
STDERR. Off by default.

=item error_document

This string is similar to Apache ErrorDocument directive. If this value is not
present, then Dispatch will return a NOT FOUND error either to the browser with
simple hardcoded message (under CGI) or to Apache (under mod_perl).

This value can be one of the following:

B
- if it starts with a single double-quote character (C<">). This double-quote
character will be trimmed from final output.

B
- if it starts with less-than sign (C<<>). First character will be excluded
as well. Path of this file should be relative to server DOCUMENT_ROOT.

B - if no leading C<"> or
C<<> will be found.

Custom messages will be displayed I. (Under
mod_perl, please use ErrorDocument directive in Apache configuration files.)
This value can contain C<%s> placeholder for L Perl function. This
placeholder will be replaced with numeric HTTP error code. Currently
CGI::Application::Dispatch uses three HTTP errors:

B<400 Bad Request>
- If there are invalid characters in module name (parameter :app) or
runmode name (parameter :rm).

B<404 Not Found>
- When the path does not match anything in the L,
or module could not be found in @INC, or run mode did not exist.

B<500 Internal Server Error>
- If application error occurs.

Examples of using error_document (assume error 404 have been returned):

    # return in browser 'Opss... HTTP Error #404'
    error_document => '"Opss... HTTP Error #%s'

    # return contents of file $ENV{DOCUMENT_ROOT}/errors/error404.html
    error_document => '

    # internal redirect to /errors/error404.html
    error_document => '/errors/error%s.html'

    # external redirect to
    # http://host.domain/cgi-bin/errors.cgi?error=404
    error_document => 'http://host.domain/cgi-bin/errors.cgi?error=%s'

=item auto_rest

This tells Dispatch that you are using REST by default and that you
care about which HTTP method is being used. Dispatch will append the
HTTP method name (upper case by default) to the run mode that is
determined after finding the appropriate dispatch rule. So a GET
request that translates into C<< MyApp::Module->foo >> will become
C<< MyApp::Module->foo_GET >>.

This can be overridden on a per-rule basis in a custom dispatch table.

=item auto_rest_lc

In combinaion with L this tells Dispatch that you prefer
lower cased HTTP method names.  So instead of C and
C you'll have C and C.

=back

=cut

sub dispatch {
    my ($self, %args) = @_;

    # merge dispatch_args() and %args with %args taking precendence
    my $dispatch_args = $self->dispatch_args(\%args);
    for my $arg (keys %$dispatch_args) {

        # args_to_new should be merged
        if($arg eq 'args_to_new') {
            $args{args_to_new} ||= {};

            # merge the PARAMS hash
            if($dispatch_args->{args_to_new}->{PARAMS}) {

                # merge the hashes
                $args{args_to_new}->{PARAMS} = {
                    %{$dispatch_args->{args_to_new}->{PARAMS}},
                    %{$args{args_to_new}->{PARAMS} || {}},
                };
            }

            # combine any TMPL_PATHs
            if($dispatch_args->{args_to_new}->{TMPL_PATH}) {

                # make sure the orginial is an array ref
                if($args{args_to_new}->{TMPL_PATH}) {
                    if(!ref $args{args_to_new}->{TMPL_PATH}) {
                        $args{args_to_new}->{TMPL_PATH} = [$args{args_to_new}->{TMPL_PATH}];
                    }
                } else {
                    $args{args_to_new}->{TMPL_PATH} = [];
                }

                # now add the rest to the end
                if(ref $dispatch_args->{args_to_new}->{TMPL_PATH}) {
                    push(
                        @{$args{args_to_new}->{TMPL_PATH}},
                        @{$dispatch_args->{args_to_new}->{TMPL_PATH}},
                    );
                } else {
                    push(
                        @{$args{args_to_new}->{TMPL_PATH}},
                        $dispatch_args->{args_to_new}->{TMPL_PATH},
                    );
                }
            }

            # now merge the args_to_new hashes
            $args{args_to_new} = {%{$dispatch_args->{args_to_new}}, %{$args{args_to_new}},};
        } else {

            # anything else should override
            $args{$arg} = $dispatch_args->{$arg} unless exists $args{$arg};
        }
    }

    $DEBUG = $args{debug} ? 1 : 0;

    # check for extra args (for backwards compatibility)
    for (keys %args) {
        next
          if(  $_ eq 'prefix'
            or $_ eq 'default'
            or $_ eq 'debug'
            or $_ eq 'rm'
            or $_ eq 'args_to_new'
            or $_ eq 'table'
            or $_ eq 'auto_rest'
            or $_ eq 'auto_rest_lc'
            or $_ eq 'not_found'
            or $_ eq 'error_document');
        carp "Passing extra args ('$_') to dispatch() is deprecated! Please use 'args_to_new'";
        $args{args_to_new}->{$_} = delete $args{$_};
    }

    # TODO: delete this block some time later
    if(exists $args{not_found}) {
        carp 'Passing not_found to dispatch() is deprecated! Please use error_document instead';
        $args{error_document} = delete($args{not_found})
          unless exists($args{error_document});
    }

    %args = map { lc $_ => $args{$_} } keys %args;    # lc for backwards
                                                      # compatability

    # get the PATH_INFO
    my $path_info = $self->dispatch_path();

    # use the 'default' if we need to
    $path_info = $args{default} || '' if(!$path_info || $path_info eq '/');

    # make sure they all start and end with a '/', to correspond with
    # the RE we'll make
    $path_info = "/$path_info" unless(index($path_info, '/') == 0);
    $path_info = "$path_info/" unless(substr($path_info, -1) eq '/');

    my ($module, $rm, $local_prefix, $local_args_to_new, $output);

    # take args from path
    my $named_args;
    try {
        $named_args = $self->_parse_path($path_info, $args{table})
          or throw_not_found("Resource not found");
    } catch {
        $output = $self->http_error($_, $args{error_document});
    };
    return $output if $output;

    if($DEBUG) {
        require Data::Dumper;
        warn "[Dispatch] Named args from match: " . Data::Dumper::Dumper($named_args) . "\n";
    }

    # eval and catch any exceptions that might be thrown
    try {
        if(exists($named_args->{PARAMS}) || exists($named_args->{TMPL_PATH})) {
            carp "PARAMS and TMPL_PATH are not allowed here. Did you mean to use args_to_new?";
            throw_error("PARAMS and TMPL_PATH not allowed");
        }

        ($module, $local_prefix, $rm, $local_args_to_new) =
          delete @{$named_args}{qw(app prefix rm args_to_new)};

        # If another name for dispatch_url_remainder has been set move
        # the value to the requested name
        if($$named_args{'*'}) {
            $$named_args{$$named_args{'*'}} = $$named_args{'dispatch_url_remainder'};
            delete $$named_args{'*'};
            delete $$named_args{'dispatch_url_remainder'};
        }

        $module or throw_error("App not defined");
        $module = $self->translate_module_name($module);

        $local_prefix ||= $args{prefix};
        $module = $local_prefix . '::' . $module if($local_prefix);

        $local_args_to_new ||= $args{args_to_new};

        # add the rest of the named_args to PARAMS
        @{$local_args_to_new->{PARAMS}}{keys %$named_args} = values %$named_args;

        my $auto_rest =
          defined $named_args->{auto_rest} ? $named_args->{auto_rest} : $args{auto_rest};
        if($auto_rest && defined $rm && length $rm) {
            my $method_lc =
              defined $named_args->{auto_rest_lc}
              ? $named_args->{auto_rest_lc}
              : $args{auto_rest_lc};
            my $http_method = $self->_http_method;
            $http_method = lc $http_method if $method_lc;
            $rm .= "_$http_method";
        }

        # load and run the module
        $self->require_module($module);
        $output = $self->_run_app($module, $rm, $local_args_to_new);
    } catch {
        my $e = $_;
        unless ( ref $e && $e->isa('Exception::Class::Base') ) {
            $e = Exception::Class::Base->new($e);
        }
        $output = $self->http_error($e, $args{error_document});
    };
    return $output;
}


=pod

=head2 dispatch_path()

This method returns the path that is to be processed.

By default it returns the value of C<$ENV{PATH_INFO}>
(or C<< $r->path_info >> under mod_perl) which should work for
most cases.  It allows the ability for subclasses to override the value if
they need to do something more specific.

=cut

sub dispatch_path {
    return $ENV{PATH_INFO};
}

sub http_error {
    my ($self, $e, $errdoc) = @_;

    warn '[Dispatch] ERROR'
      . ($ENV{REQUEST_URI} ? " for request '$ENV{REQUEST_URI}': " : ': ')
      . $e->error . "\n";

    my $errno =
        $e->isa('CGI::Application::Dispatch::Exception')
      ? $e->description
      : 500;

    my ($url, $output);

    if($errdoc) {
        my $str = sprintf($errdoc, $errno);
        if(IS_MODPERL) {    #compile out all other stuff
            $url = $str;    # no messages, please
        } elsif(index($str, '"') == 0) {    # Error message
            $output = substr($str, 1);
        } elsif(index($str, '<') == 0) {    # Local file
                                            # Is it secure?
            require File::Spec;
            $str = File::Spec->catdir($ENV{DOCUMENT_ROOT}, substr($str, 1));
            local *FH;
            if(-f $str && open(FH, '<', $str)) {
                local $/ = undef;
                $output = ;
                close FH;
            } else {
                warn "[Dispatch] Error opening error document '$str'.\n";
            }
        } else {                            # Last case is url
            $url = $str;
        }

        if($DEBUG) {
            warn "[Dispatch] Redirection for HTTP error #$errno to $url\n"
              if $url;
            warn "[Dispatch] Displaying message for HTTP error #$errno\n"
              if $output;
        }

    }

    # if we're under mod_perl
    if(IS_MODPERL) {
        my $r = $self->_r;
        $r->status($errno);

        # if we just want to redirect
        $r->headers_out->{'Location'} = $url if $url;
        return '';
    } else {    # else print the HTTP stuff ourselves

        # stolen from http_protocol.c in Apache sources
        # we don't actually use anything other than 200, 307, 400, 404 and 500

        my %status_lines = (

            #    100 => 'Continue',
            #    101 => 'Switching Protocols',
            #    102 => 'Processing',
            200 => 'OK',

            #    201 => 'Created',
            #    202 => 'Accepted',
            #    203 => 'Non-Authoritative Information',
            #    204 => 'No Content',
            #    205 => 'Reset Content',
            #    206 => 'Partial Content',
            #    207 => 'Multi-Status',
            #    300 => 'Multiple Choices',
            #    301 => 'Moved Permanently',
            #    302 => 'Found',
            #    303 => 'See Other',
            #    304 => 'Not Modified',
            #    305 => 'Use Proxy',
            307 => 'Temporary Redirect',
            400 => 'Bad Request',

            #    401 => 'Authorization Required',
            #    402 => 'Payment Required',
            #    403 => 'Forbidden',
            404 => 'Not Found',

            #    405 => 'Method Not Allowed',
            #    406 => 'Not Acceptable',
            #    407 => 'Proxy Authentication Required',
            #    408 => 'Request Time-out',
            #    409 => 'Conflict',
            #    410 => 'Gone',
            #    411 => 'Length Required',
            #    412 => 'Precondition Failed',
            #    413 => 'Request Entity Too Large',
            #    414 => 'Request-URI Too Large',
            #    415 => 'Unsupported Media Type',
            #    416 => 'Requested Range Not Satisfiable',
            #    417 => 'Expectation Failed',
            #    422 => 'Unprocessable Entity',
            #    423 => 'Locked',
            #    424 => 'Failed Dependency',
            500 => 'Internal Server Error',

            #    501 => 'Method Not Implemented',
            #    502 => 'Bad Gateway',
            #    503 => 'Service Temporarily Unavailable',
            #    504 => 'Gateway Time-out',
            #    505 => 'HTTP Version Not Supported',
            #    506 => 'Variant Also Negotiates',
            #    507 => 'Insufficient Storage',
            #    510 => 'Not Extended',
        );

        $errno = 500 if(!exists $status_lines{$errno});

        if($url) {

            # somewhat mailformed header, no errors in access.log, but browsers
            # display contents of $url document and old URI in address bar.
            $output = "HTTP/1.0 $errno $status_lines{$errno}\n";
            $output .= "Location: $url\n\n";
        } else {

            unless($output) {

                # TODO: possibly provide more feedback in a way that
                # is XSS safe.  (I'm not sure that passing through the
                # raw ENV variable directly is safe.)
                # We tried: $ENV{REQUEST_URI}";
                $output = qq(


                $errno $status_lines{$errno}
                )
                  . (
                    $DEBUG
                    ? '' . __PACKAGE__ . ' error!'
                    : ''
                  )
                  . qq($status_lines{$errno}
                )
                  . ($ENV{SERVER_ADMIN} ? "($ENV{SERVER_ADMIN})" : '') . qq(
                )
                  . ($ENV{SERVER_SIGNATURE} || '') . qq();
            }

            # Apache will report $errno in access.log
            my $header .= "Status: $errno $status_lines{$errno}\n";

            # try to guess, what a crap we get here
            $header .=
              $output =~ /
              ? "Content-type: text/html\n\n"
              : "Content-type: text/plain\n\n";

            # Workaround for IE error document 512 byte size "feature"
            $output .= ' ' x (520 - length($output))
              if(length($output) < 520);

            $output = $header . $output;
        }

        # Send output to browser (unless we're in serious debug mode!)
        print $output unless $ENV{CGI_APP_RETURN_ONLY};

        return $output;
    }
}

# protected method - designed to be used by sub classes, not by end users
sub _parse_path {
    my ($self, $path, $table) = @_;

    # get the module name from the table
    return unless defined($path);

    unless(ref($table) eq 'ARRAY') {
        warn "[Dispatch] Invalid or no dispatch table!\n";
        return;
    }

    # look at each rule and stop when we get a match
    for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {

        my $rule = $table->[$i];

        # are we trying to dispatch based on HTTP_METHOD?
        my $http_method_regex = qr/\[([^\]]+)\]$/;
        if($rule =~ /$http_method_regex/) {
            my $http_method = $1;

            # go ahead to the next rule
            next unless lc($1) eq lc($self->_http_method);

            # remove the method portion from the rule
            $rule =~ s/$http_method_regex//;
        }

        # make sure they start and end with a '/' to match how
        # PATH_INFO is formatted
        $rule = "/$rule" unless(index($rule, '/') == 0);
        $rule = "$rule/" if(substr($rule, -1) ne '/');

        my @names = ();

        # translate the rule into a regular expression, but remember
        # where the named args are
        # '/:foo' will become '/([^\/]*)'
        # and
        # '/:bar?' will become '/?([^\/]*)?'
        # and then remember which position it matches

        $rule =~ s{
            (^|/)                 # beginning or a /
            (:([^/\?]+)(\?)?)     # stuff in between
        }{
            push(@names, $3);
            $1 . ($4 ? '?([^/]*)?' : '([^/]*)')
        }gxe;

        # '/*/' will become '/(.*)/$' the end / is added to the end of
        # both $rule and $path elsewhere
        if($rule =~ m{/\*/$}) {
            $rule =~ s{/\*/$}{/(.*)/\$};
            push(@names, 'dispatch_url_remainder');
        }

        warn
          "[Dispatch] Trying to match '${path}' against rule '$table->[$i]' using regex '${rule}'\n"
          if $DEBUG;

        # if we found a match, then run with it
        if(my @values = ($path =~ m#^$rule$#)) {

            warn "[Dispatch] Matched!\n" if $DEBUG;

            my %named_args = %{$table->[++$i]};
            @named_args{@names} = @values if @names;

            return \%named_args;
        }
    }

    return;
}

sub _http_method {
    IS_MODPERL ? shift->_r->method : ($ENV{HTTP_REQUEST_METHOD} || $ENV{REQUEST_METHOD});
}

sub _r { IS_MODPERL2 ? Apache2::RequestUtil->request: Apache->request; }

sub _run_app {
    my ($self, $module, $rm, $args) = @_;

    if($DEBUG) {
        require Data::Dumper;
        warn "[Dispatch] Final args to pass to new(): " . Data::Dumper::Dumper($args) . "\n";
    }

    if($rm) {

        # check runmode name
        ($rm) = ($rm =~ /^([a-zA-Z_][\w']+)$/);
        throw_bad_request("Invalid characters in runmode name") unless $rm;
    }

    # now create and run then application object
    warn "[Dispatch] creating instance of $module\n" if($DEBUG);

    my $output;
    eval {
        my $app = ref($args) eq 'HASH' ? $module->new($args) : $module->new();
        $app->mode_param(sub { return $rm }) if($rm);
        $output = $app->run();
    };

    if($@) {

        # catch invalid run-mode stuff
        if(not ref $@ and  $@ =~ /No such run mode/) {
            throw_not_found("RM '$rm' not found")

              # otherwise, just pass it up the chain
        } else {
            die $@;
        }
    }

    return $output;
}

=head2 handler()

This method is used so that this module can be run as a mod_perl handler.
When it creates the application module it passes the $r argument into the PARAMS
hash of new()


        SetHandler perl-script
        PerlHandler CGI::Application::Dispatch
        PerlSetVar  CGIAPP_DISPATCH_PREFIX  MyApp
        PerlSetVar  CGIAPP_DISPATCH_DEFAULT /module_name


The above example would tell apache that any url beginning with /app
will be handled by CGI::Application::Dispatch. It also sets the prefix
used to create the application module to 'MyApp' and it tells
CGI::Application::Dispatch that it shouldn't set the run mode but that
it will be determined by the application module as usual (through the
query string). It also sets a default application module to be used if
there is no path.  So, a url of C would create an
instance of C.

Using this method will add the Crequest> object to your
application's C as 'r'.

    # inside your app
    my $request = $self->param('r');

If you need more customization than can be accomplished with just
L and L, then it would be best to just subclass
CGI::Application::Dispatch and override L since
C uses L to do the heavy lifting.

    package MyApp::Dispatch;
    use base 'CGI::Application::Dispatch';

    sub dispatch_args {
        return {
            prefix  => 'MyApp',
            table   => [
                ''                => { app => 'Welcome', rm => 'start' },
                ':app/:rm'        => { },
                'admin/:app/:rm'  => { prefix   => 'MyApp::Admin' },
            ],
            args_to_new => {
                PARAMS => {
                    foo => 'bar',
                    baz => 'bam',
                },
            }
        };
    }

    1;

And then in your httpd.conf


        SetHandler perl-script
        PerlHandler MyApp::Dispatch


=cut

sub handler : method {
    my ($self, $r) = @_;

    # set the PATH_INFO
    $ENV{PATH_INFO} = $r->path_info();

    # setup our args to dispatch()
    my %args;
    my $config_args = $r->dir_config();
    for my $var (qw(DEFAULT PREFIX ERROR_DOCUMENT)) {
        my $dir_var = "CGIAPP_DISPATCH_$var";
        $args{lc($var)} = $config_args->{$dir_var}
          if($config_args->{$dir_var});
    }

    # add $r to the args_to_new's PARAMS
    $args{args_to_new}->{PARAMS}->{r} = $r;

    # set debug if we need to
    $DEBUG = 1 if($config_args->{CGIAPP_DISPATCH_DEBUG});
    if($DEBUG) {
        require Data::Dumper;
        warn "[Dispatch] Calling dispatch() with the following arguments: "
          . Data::Dumper::Dumper(\%args) . "\n";
    }

    $self->dispatch(%args);

    if($r->status == 404) {
        return NOT_FOUND();
    } elsif($r->status == 500) {
        return SERVER_ERROR();
    } elsif($r->status == 400) {
        return IS_MODPERL2() ? HTTP_BAD_REQUEST() : BAD_REQUEST();
    } else {
        return OK();
    }
}

=head2 dispatch_args()

Returns a hashref of args that will be passed to L(). It
will return the following structure by default.

    {
        prefix      => '',
        args_to_new => {},
        table       => [
            ':app'      => {},
            ':app/:rm'  => {},
        ],
    }

This is the perfect place to override when creating a subclass to
provide a richer dispatch L. 




860




 





 





 





 





 





 



   




861




 





 





 





 





 





 



 When called, it receives 1 argument, which is a reference to the hash 




862




 





 





 





 





 





 



 of args passed into L. 




863




 





 





 





 





 





 



   




864




 





 





 





 





 





 



 =cut 




865




 





 





 





 





 





 



   




866




 





 





 





 





 





 



 sub dispatch_args { 




867




13





 





 




  
13
  



  
1
  




23



     my ($self, $args) = @_; 




868




 





 





 





 





 





 



     return { 




869




13





 




  
100
  




 





 





202



         default     => ($args->{default}     || ''), 




 




 





 




  
100
  




 





 





 



   




 




 





 




  
100
  




 





 





 



   




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




 





 





 





 





 





 



   




881




 





 





 





 





 





 



 This method is used to control how the module name is translated from 




882




 





 





 





 





 





 



 the matching section of the path (see L<"Path Parsing">). 




883




 





 





 





 





 





 



 The main 




884




 





 





 





 





 





 



 reason that this method exists is so that it can be overridden if it 




885




 





 





 





 





 





 



 doesn't do exactly what you want. 




886




 





 





 





 





 





 



   




887




 





 





 





 





 





 



 The following transformations are performed on the input: 




888




 





 





 





 





 





 



   




889




 





 





 





 





 





 



 =over 




890




 





 





 





 





 





 



   




891




 





 





 





 





 





 



 =item The text is split on '_'s (underscores) 




892




 





 





 





 





 





 



 and each word has its first letter capitalized. The words are then joined 




893




 





 





 





 





 





 



 back together and each instance of an underscore is replaced by '::'. 




894




 





 





 





 





 





 



   




895




 





 





 





 





 





 



   




896




 





 





 





 





 





 



 =item The text is split on '-'s (hyphens) 




897




 





 





 





 





 





 



 and each word has its first letter capitalized. The words are then joined 




898




 





 





 





 





 





 



 back together and each instance of a hyphen removed. 




899




 





 





 





 





 





 



   




900




 





 





 





 





 





 



 =back 




901




 





 





 





 





 





 



   




902




 





 





 





 





 





 



 Here 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




 





 





 





 





 





 



   




910




 





 





 





 





 





 



 sub translate_module_name { 




911




19





 





 




  
19
  



  
1
  




105



     my ($self, $input) = @_; 




912




 





 





 





 





 





 



   




913




19





 





 





 





 





54



     $input = join('::', map { ucfirst($_) } split(/_/, $input)); 




 




36





 





 





 





 





87



   




914




19





 





 





 





 





48



     $input = join('',   map { ucfirst($_) } split(/-/, $input)); 




 




19





 





 





 





 





38



   




915




 





 





 





 





 





 



   




916




19





 





 





 





 





51



     return $input; 




917




 





 





 





 





 





 



 } 




918




 





 





 





 





 





 



   




919




 





 





 





 





 





 



 =head2 require_module($module_name) 




920




 





 





 





 





 





 



   




921




 





 





 





 





 





 



 This class method is used internally by CGI::Application::Dispatch to 




922




 





 





 





 





 





 



 take a module name (supplied by L) and require it in 




923




 





 





 





 





 





 



 a secure fashion. It is provided as a public class method so that if 




924




 





 





 





 





 





 



 you override other functionality of this module, you can still safely 




925




 





 





 





 





 





 



 require user specified modules. If there are any problems requiring 




926




 





 





 





 





 





 



 the named module, then we will C. 




927




 





 





 





 





 





 



   




928




 





 





 





 





 





 



     CGI::Application::Dispatch->require_module('MyApp::Module::Name'); 




929




 





 





 





 





 





 



   




930




 





 





 





 





 





 



 =cut 




931




 





 





 





 





 





 



   




932




 





 





 





 





 





 



 sub require_module { 




933




20





 





 




  
20
  



  
1
  




32



     my ($self, $module) = @_; 




934




 





 





 





 





 





 



   




935




20




  
 50
  




 





 





 





38



     $module or throw_not_found("Can't define module name"); 




936




 





 





 





 





 





 



   




937




 





 





 





 





 





 



     #untaint the module name 




938




20





 





 





 





 





90



     ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/); 




939




 





 





 





 





 





 



   




940




20




  
 50
  




 





 





 





42



     unless($module) { 




941




0





 





 





 





 





0



         throw_bad_request("Invalid characters in module name"); 




942




 





 





 





 





 





 



     } 




943




 





 





 





 





 





 



   




944




20




  
 50
  




 





 





 





43



     warn "[Dispatch] loading module $module\n" if($DEBUG); 




945




20





 





 





 





 





1178



     eval "require $module"; 




946




20




  
100
  




 





 





 





87



     return unless $@; 




947




 





 





 





 





 





 



   




948




1





 





 





 





 





3



     my $module_path = $module; 




949




1





 





 





 





 





3



     $module_path =~ s/::/\//g; 




950




 





 





 





 





 





 



   




951




1




  
 50
  




 





 





 





16



     if($@ =~ /Can't locate $module_path.pm/) { 




952




1





 





 





 





 





9



         throw_not_found("Can't find module $module"); 




953




 





 





 





 





 





 



     } else { 




954




0





 





 





 





 





 



         throw_error("Unable to load module '$module': $@"); 




955




 





 





 





 





 





 



     } 




956




 





 





 





 





 





 



 } 




957




 





 





 





 





 





 



   




958




 





 





 





 





 





 



 1; 




959




 





 





 





 





 





 



   




960




 





 





 





 





 





 



 __END__

When called, it receives 1 argument, which is a reference to the hash
of args passed into L.

=cut

sub dispatch_args {
    my ($self, $args) = @_;
    return {
        default     => ($args->{default}     || ''),
        prefix      => ($args->{prefix}      || ''),
        args_to_new => ($args->{args_to_new} || {}),
        table       => [
            ':app'     => {},
            ':app/:rm' => {},
        ],
    };
}

=head2 translate_module_name($input)

This method is used to control how the module name is translated from
the matching section of the path (see L<"Path Parsing">).
The main
reason that this method exists is so that it can be overridden if it
doesn't do exactly what you want.

The following transformations are performed on the input:

=over

=item The text is split on '_'s (underscores)
and each word has its first letter capitalized. The words are then joined
back together and each instance of an underscore is replaced by '::'.


=item The text is split on '-'s (hyphens)
and each word has its first letter capitalized. The words are then joined
back together and each instance of a hyphen removed.

=back

Here are some examples to make it even clearer:

    module_name         => Module::Name
    module-name         => ModuleName
    admin_top-scores    => Admin::TopScores

=cut

sub translate_module_name {
    my ($self, $input) = @_;

    $input = join('::', map { ucfirst($_) } split(/_/, $input));
    $input = join('',   map { ucfirst($_) } split(/-/, $input));

    return $input;
}

=head2 require_module($module_name)

This class method is used internally by CGI::Application::Dispatch to
take a module name (supplied by L) and require it in
a secure fashion. It is provided as a public class method so that if
you override other functionality of this module, you can still safely
require user specified modules. If there are any problems requiring
the named module, then we will C.

    CGI::Application::Dispatch->require_module('MyApp::Module::Name');

=cut

sub require_module {
    my ($self, $module) = @_;

    $module or throw_not_found("Can't define module name");

    #untaint the module name
    ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/);

    unless($module) {
        throw_bad_request("Invalid characters in module name");
    }

    warn "[Dispatch] loading module $module\n" if($DEBUG);
    eval "require $module";
    return unless $@;

    my $module_path = $module;
    $module_path =~ s/::/\//g;

    if($@ =~ /Can't locate $module_path.pm/) {
        throw_not_found("Can't find module $module");
    } else {
        throw_error("Unable to load module '$module': $@");
    }
}

1;

__END__