File Coverage

blib/lib/CGI/Application/Dispatch/PSGI.pm

Criterion	Covered	Total	%
statement	145	173	83.8
branch	83	118	70.3
condition	42	58	72.4
subroutine	13	13	100.0
pod	4	5	80.0
total	287	367	78.2

package CGI::Application::Dispatch::PSGI;
use strict;
use warnings;
use Carp 'carp';
use HTTP::Exception;

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

=pod

=head1 NAME

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

=head1 SYNOPSIS

=head2 Out of Box

Under mod_perl:

  # change "Apache1" to "Apache2" as needed.


  SetHandler perl-script
  PerlHandler Plack::Handler::Apache1
  PerlSetVar psgi_app /path/to/app.psgi



  use Plack::Handler::Apache1;
  Plack::Handler::Apache1->preload("/path/to/app.psgi");


Under CGI:

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

    ### in your dispatch.psgi:
    # ( in a persistent environment, use FindBin::Real instead. )
    use FindBin 'Bin';
    use lib "$Bin/../perllib';
    use Your::Application::Dispatch;
    Your::Application::Dispatch->as_psgi;

    ### In Your::Application::Dispatch;
    package Your::Application::Dispatch;
    use base 'CGI::Application::Dispatch::PSGI';


=head2 With a dispatch table

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

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

The C<< .psgi >> file is constructed as above.

=head2 With a custom query object

If you want to supply your own PSGI object, something like this in
your .psgi file will work:

    sub {
        my $env = shift;
        my $app = CGI::Application::Dispatch::PSGI->as_psgi(
            table => [
                '/:rm'    =>    { app => 'TestApp' }
            ],
            args_to_new => {
                QUERY    => CGI::PSGI->new($env)
            }
        );
        return $app->($env);
    }


=head1 DESCRIPTION

This module provides a way to look at the path (as returned by C<<
$env->{PATH_INFO} >>) of the incoming request, parse off the desired
module and its run mode, create an instance of that module and run it.

It will translate a URI like this (in a persistent environment)

    /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

=cut

sub as_psgi {
    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');
        die "Passing extra args ('$_') to as_psgi() is not supported! Did you mean to use 'args_to_new' ?";
        $args{args_to_new}->{$_} = delete $args{$_};
    }

    return sub {
        my $env = shift;

        # get the PATH_INFO
        my $path_info = $env->{PATH_INFO};

        # 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);
        # take args from path
        my $named_args;
        eval {
            $named_args = $self->_parse_path($path_info, $args{table},$env)
                or HTTP::Exception->throw(404, status_message => 'Resource not found');
        };
        if (my $e = HTTP::Exception->caught) {
            return $self->http_error($e);
        }

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

        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?";
            HTTP::Exception->throw(500, status_message => 'PARAMS and TMPL_PATH not allowed');
        }

        # eval and catch any exceptions that might be thrown
        my ($output, @final_dispatch_args);
        my $psgi_app;
        eval {
            ($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 HTTP::Exception->throw(500, status_message => '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 = $env->{REQUEST_METHOD};
                $http_method = lc $http_method if $method_lc;
                $rm .= "_$http_method";
            }
            # load and run the module
            @final_dispatch_args = ($module, $rm, $local_args_to_new);
            $self->require_module($module);
            $psgi_app =  $self->_run_app($module, $rm, $local_args_to_new,$env);
        };
        if (my $e = HTTP::Exception->caught) {
            return $self->http_error($e);
        }
        elsif ($e = Exception::Class->caught) {
            ref $e ? $e->rethrow : die $e;
        }
        return $psgi_app;
    }
}

=head2 as_psgi(%args)

This is the primary method used during dispatch.

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

    CGI::Application::Dispatch::PSGI->as_psgi(
        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 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 http_error {
    my ($self, $e) = @_;

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

    my $errno  = $e->isa('HTTP::Exception::Base') ? $e->code           : 500;
    my $output = $e->isa('HTTP::Exception::Base') ? $e->status_message : "Internal Server Error";

    # The custom status message was most useful for logging. Return
    # generic messages to the user.
    $output = 'Not Found'             if ($e->code == 404);
    $output = 'Internal Server Error' if ($e->code == 500);


    return [ $errno, [], [ $output ] ];
}

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

    # 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($env->{REQUEST_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 _run_app {
    my ($self, $module, $rm, $args,$env) = @_;

    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']+)$/);
        HTTP::Exception->throw(400, status_message => "Invalid characters in runmode name") unless $rm;

    }

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

    my $psgi;
    eval {
        my $app = do {
            if (ref($args) eq 'HASH' and not defined $args->{QUERY}) {
                require CGI::PSGI;
                $args->{QUERY} = CGI::PSGI->new($env);
                $module->new($args);
            }
            elsif (ref($args) eq 'HASH') {
                $module->new($args);
            }
            else {
                $module->new();
            }
        };
        $app->mode_param(sub { return $rm }) if($rm);
        $psgi = $app->run_as_psgi;
    };

    # App threw an HTTP::Exception? Cool. Bubble it up.
    my $e;
    if ($e = HTTP::Exception->caught) {
        $e->rethrow;
    }
    else {
          $e = Exception::Class->caught();

          # catch invalid run-mode stuff
          if (not ref $e and  $e =~ /No such run mode/) {
              HTTP::Exception->throw(404, status_message => "RM '$rm' not found");
          }
          # otherwise, it's an internal server error.
          elsif (defined $e and length $e) {
              HTTP::Exception->throw(500, status_message => "Unknown error: $e");
              #return $psgi;
          }
          else {
              # no exception
              return $psgi;
          }
    }
}

=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. 




522




 





 





 





 





 





 



   




523




 





 





 





 





 





 



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




524




 





 





 





 





 





 



 of args passed into L. 




525




 





 





 





 





 





 



   




526




 





 





 





 





 





 



 =cut 




527




 





 





 





 





 





 



   




528




 





 





 





 





 





 



 sub dispatch_args { 




529




10





 





 




  
10
  



  
1
  




25



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




530




 





 





 





 





 





 



     return { 




531




10





 




  
100
  




 





 





183



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




 




 





 




  
100
  




 





 





 



   




 




 





 




  
100
  




 





 





 



   




532




 





 





 





 





 





 



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




533




 





 





 





 





 





 



         args_to_new => ($args->{args_to_new} || {}), 




534




 





 





 





 





 





 



         table       => [ 




535




 





 





 





 





 





 



             ':app'     => {}, 




536




 





 





 





 





 





 



             ':app/:rm' => {}, 




537




 





 





 





 





 





 



         ], 




538




 





 





 





 





 





 



     }; 




539




 





 





 





 





 





 



 } 




540




 





 





 





 





 





 



   




541




 





 





 





 





 





 



 =head2 translate_module_name($input) 




542




 





 





 





 





 





 



   




543




 





 





 





 





 





 



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




544




 





 





 





 





 





 



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




545




 





 





 





 





 





 



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




546




 





 





 





 





 





 



 doesn't do exactly what you want. 




547




 





 





 





 





 





 



   




548




 





 





 





 





 





 



 The following transformations are performed on the input: 




549




 





 





 





 





 





 



   




550




 





 





 





 





 





 



 =over 




551




 





 





 





 





 





 



   




552




 





 





 





 





 





 



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




553




 





 





 





 





 





 



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




554




 





 





 





 





 





 



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




555




 





 





 





 





 





 



   




556




 





 





 





 





 





 



   




557




 





 





 





 





 





 



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




558




 





 





 





 





 





 



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




559




 





 





 





 





 





 



 back together and each instance of a hyphen removed. 




560




 





 





 





 





 





 



   




561




 





 





 





 





 





 



 =back 




562




 





 





 





 





 





 



   




563




 





 





 





 





 





 



 Here are some examples to make it even clearer: 




564




 





 





 





 





 





 



   




565




 





 





 





 





 





 



     module_name         => Module::Name 




566




 





 





 





 





 





 



     module-name         => ModuleName 




567




 





 





 





 





 





 



     admin_top-scores    => Admin::TopScores 




568




 





 





 





 





 





 



   




569




 





 





 





 





 





 



 =cut 




570




 





 





 





 





 





 



   




571




 





 





 





 





 





 



 sub translate_module_name { 




572




25





 





 




  
25
  



  
1
  




46



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




573




 





 





 





 





 





 



   




574




25





 





 





 





 





85



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




 




47





 





 





 





 





156



   




575




25





 





 





 





 





82



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




 




25





 





 





 





 





65



   




576




 





 





 





 





 





 



   




577




25





 





 





 





 





72



     return $input; 




578




 





 





 





 





 





 



 } 




579




 





 





 





 





 





 



   




580




 





 





 





 





 





 



 =head2 require_module($module_name) 




581




 





 





 





 





 





 



   




582




 





 





 





 





 





 



 This class method is used internally to take a module name (supplied 




583




 





 





 





 





 





 



 by L) and require it in a secure fashion. It is 




584




 





 





 





 





 





 



 provided as a public class method so that if you override other 




585




 





 





 





 





 





 



 functionality of this module, you can still safely require user 




586




 





 





 





 





 





 



 specified modules. If there are any problems requiring the named 




587




 





 





 





 





 





 



 module, then we will C. 




588




 





 





 





 





 





 



   




589




 





 





 





 





 





 



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




590




 





 





 





 





 





 



   




591




 





 





 





 





 





 



 =cut 




592




 





 





 





 





 





 



   




593




 





 





 





 





 





 



 sub require_module { 




594




26





 





 




  
26
  



  
1
  




49



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




595




 





 





 





 





 





 



   




596




26




  
 50
  




 





 





 





62



     $module or HTTP::Exception->throw(404, status_message => "Can't define module name"); 




597




 





 





 





 





 





 



   




598




 





 





 





 





 





 



     #untaint the module name 




599




26





 





 





 





 





123



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




600




 





 





 





 





 





 



   




601




26




  
 50
  




 





 





 





63



     unless($module) { 




602




0





 





 





 





 





0



         HTTP::Exception->throw(400, status_message => "Invalid characters in module name"); 




603




 





 





 





 





 





 



     } 




604




 





 





 





 





 





 



   




605




26




  
 50
  




 





 





 





61



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




606




26





 





 





 





 





1770



     eval "require $module"; 




607




26




  
100
  




 





 





 





434



     return unless $@; 




608




 





 





 





 





 





 



   




609




2





 





 





 





 





4



     my $module_path = $module; 




610




2





 





 





 





 





7



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




611




 





 





 





 





 





 



   




612




2




  
 50
  




 





 





 





32



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




613




2





 





 





 





 





23



         HTTP::Exception->throw(404, status_message => "Can't find module $module"); 




614




 





 





 





 





 





 



     } 




615




 





 





 





 





 





 



     else { 




616




0





 





 





 





 





 



         HTTP::Exception->throw(500, status_message => "Unable to load module '$module': $@"); 




617




 





 





 





 





 





 



     } 




618




 





 





 





 





 





 



 } 




619




 





 





 





 





 





 



   




620




 





 





 





 





 





 



 1; 




621




 





 





 





 





 





 



   




622




 





 





 





 





 





 



 __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 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::PSGI->require_module('MyApp::Module::Name');

=cut

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

    $module or HTTP::Exception->throw(404, status_message => "Can't define module name");

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

    unless($module) {
        HTTP::Exception->throw(400, status_message => "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/) {
        HTTP::Exception->throw(404, status_message => "Can't find module $module");
    }
    else {
        HTTP::Exception->throw(500, status_message => "Unable to load module '$module': $@");
    }
}

1;

__END__