view release on metacpan or  search on metacpan

lib/CGI/Application/URIMapping.pm  view on Meta::CPAN

package CGI::Application::URIMapping;

use strict;
use warnings;

use CGI;
use CGI::Application;
use List::MoreUtils qw(uniq);
use URI::Escape;

use base qw/CGI::Application::Dispatch Exporter/;

our %EXPORT_TAGS = (
    constants => [
        qw/URI_IS_PERMALINK URI_UNKNOWN_PARAM URI_PATH_PARAM_IN_QUERY/,
        qw/URI_PARAM_NOT_IN_ORDER URI_OMITTABLE_PARAM/,
    ],
);
$EXPORT_TAGS{all} = [ uniq map { @$_ } values %EXPORT_TAGS ];
our @EXPORT_OK = @{$EXPORT_TAGS{all}};

our $VERSION = 0.04;

use constant URI_IS_PERMALINK        => 0;
use constant URI_UNKNOWN_PARAM       => 1;
use constant URI_PATH_PARAM_IN_QUERY => 2;
use constant URI_PARAM_NOT_IN_ORDER  => 3;
use constant URI_OMITTABLE_PARAM     => 4;

our %dispatch_table;
our %uri_table;
our %app_init_map;

sub register {
    my ($self, @entries) = @_;

    my $dispatch_table = ($dispatch_table{ref($self) || $self} ||= {});
    my $uri_table = ($uri_table{ref($self) || $self} ||= {});
    
    foreach my $entry (@entries) {
        $entry = {
            path => $entry,
        } unless ref $entry;
        my $app = $entry->{app} || (caller)[0];
        my $host = $entry->{host} || '*';
        my $proto = $entry->{protocol} || 'http';
        my $uri_table_entry;
        my $rm;
        unless ($rm = $entry->{rm}) {
            unless (ref $entry->{path}) {
                (split '/:', $entry->{path}, 2)[0] =~ m|([^/]+)/?$|
                    and $rm = $1;
            }
        }
        die "no 'rm'\n" unless $rm;
        if (ref($entry->{path}) eq 'ARRAY') {
            die "unexpected number of elements in 'path'\n"
                unless @{$entry->{path}} && @{$entry->{path}} % 2 == 0;
            while (@{$entry->{path}}) {
                my $path = shift @{$entry->{path}};
                my $action = shift @{$entry->{path}};
                $action->{app} = $app;
                $action->{rm} = $rm;
                my $host2 = delete $action->{host} || $host;
                my $proto2 = delete $action->{protocol} || $proto;
                $dispatch_table->{$host} ||= [];
                push @{$dispatch_table->{$host2}}, $path, $action;
                $uri_table_entry ||= _build_uri_table_entry({
                    %$entry,
                    protocol => $proto2,
                    host     => $host2,
                    path     => $path,
                    query    => delete $action->{query} || [],
                    action   => $action,
                });
            }
        } else {
            my $action = {
                app => $app,
                rm  => $rm,
            };
            $dispatch_table->{$host} ||= [];
            push @{$dispatch_table->{$host}}, $entry->{path}, $action;
            $uri_table_entry ||= _build_uri_table_entry({
                %$entry,
                protocol => $proto,
                host     => $host,
                path     => $entry->{path},
                query    => $entry->{query} || [],
                action   => $action,
            });
        }
        $uri_table_entry->{build_uri} = $entry->{build_uri} || undef;
        $uri_table->{"$app/$rm"} = $uri_table_entry;
        unless ($app_init_map{$app}) {
            $app_init_map{$app} = 1;
            no strict 'refs';
            my $self_klass = ref($self) || $self;
            $app->add_callback(
                'prerun',
                sub {
                    my $app = shift;
                    _setup_runmodes($app, $self_klass);
                },