File Coverage

blib/lib/CGI/Application/URIMapping.pm

Criterion	Covered	Total	%
statement	186	209	89.0
branch	56	78	71.7
condition	42	101	41.5
subroutine	30	31	96.7
pod	2	2	100.0
total	316	421	75.0

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);
                },
            );
            *{"${app}::_uri_mapping"} = sub {
                _uri_mapping_of($self_klass, $app, $_[1]);
            };
        }
    };
}

sub dispatch_args {
    my $self = shift;
    my $dispatch_table = ($dispatch_table{ref($self) || $self} ||= {});

    return {
        prefix => '',
        table  => $dispatch_table->{CGI::virtual_host()}
            || $dispatch_table->{'*'}
                || {},
    };
}

*CGI::Application::all_param = sub {
    my $app = shift;

    if (@_ == 1) {
        my $n = shift;
        my $v = $app->param($n);
        return $v
            if defined $v && $v ne '';
        return $app->query->param($n);
    }

    $app->param(@_);
};

*CGI::Application::uri_mapping = sub {
    my $app = shift;
    my $mapping;

    eval {
        $mapping = $app->_uri_mapping(@_);
    };
    die "no mapping for $app, did you register the class?\n"
        unless $mapping;

    $mapping;
};

*CGI::Application::build_uri = sub {
    my ($app, $args) = @_;
    my $rm = $args->{rm} || undef
        if ref($args) eq 'HASH';

    _build_uri($app->uri_mapping($rm), $args);
};

*CGI::Application::validate_uri = sub {
    my ($app, $args) = @_;
    my $mapping = $app->uri_mapping($args->{rm} || undef);

    return _validate_uri($mapping, $app, $args->{extra} || []);
};

*CGI::Application::normalize_uri = sub {
    my ($app, $args) = @_;
    my $mapping = $app->uri_mapping($args->{rm} || undef);

    return
        if _validate_uri($mapping, $app, $args->{extra} || [])
            == URI_IS_PERMALINK;

    return $app->redirect(_build_uri(
        $mapping,
        {
            rm     => $args->{rm} || undef,
            params => [
                $app,
            ],
        },
    ));
};

sub _run_modes_of {
    my ($self, $app) = @_;
    my $dispatch_table = ($dispatch_table{ref($self) || $self} ||= []);

    $dispatch_table = $dispatch_table->{CGI::virtual_host()}
        || $dispatch_table->{'*'};

    my @rm = uniq map {
        $_->{rm}
    } grep {
        ref($_) && $_->{app} eq $app
    } @$dispatch_table;

    \@rm;
}

sub _uri_mapping_of {
    my ($self, $app, $rm) = @_;

    $rm ||= _pkg2rm($app);

    my $mapping = ($uri_table{ref($self) || $self} ||= {})->{"$app/$rm"}
        or die "mapping for $app/$rm not found, did you register $app?\n";

    $mapping;
}

sub _build_uri {
    my ($prototype, $args) = @_;

    $args = { params => $args }
        if ref($args) eq 'ARRAY';
    my $params = $args->{params} || [];

    ($prototype->{build_uri} || \&_default_build_uri)->(
        {
            %$prototype,
            protocol => $args->{protocol} || $prototype->{protocol},
        },
        sub {
            my $n = shift;
            foreach my $h (@$params) {
                if (ref $h eq 'HASH') {
                    return ($h->{$n}) if exists $h->{$n};
                } else {
                    my @v;
                    local $@ = undef;
                    eval {
                        @v = $h->all_param($n);
                    };
                    @v = $h->param($n)
                        if $@;
                    return wantarray ? @v : $v[0]
                        if @v;
                }
            }
            ();
        });
}

sub _default_build_uri {
    my ($prototype, $get_param) = @_;

    # determine hostport
    my $host = $prototype->{host};
    $host = CGI::virtual_host() if $host eq '*';
    # build path
    my @path;
    foreach my $p (@{$prototype->{path_array}}) {
        if ($p =~ m|^:(.*?)(\??)$|) {
            my ($n, $optional) = ($1, $2);
            my @v = $get_param->($n);
            unless (@v) {
                die "required parameter '$n' is missing\n"
                    unless $optional;
                last;
            }
            die "more than one value assigned for path parameter: '$n'\n"
                if @v != 1;
            push @path, @v;
        } else {
            push @path, $p;
        }
    }
    # build query params
    my @qp;
    foreach my $p (@{$prototype->{query}}) {
        my @v = $get_param->($p->{name});
        foreach my $v (@v) {
            if ($p->{omit}) {
                next if $v eq $p->{omit};
            }
            push @qp, "$p->{name}=" . uri_escape($v);
        }
    }
    # build and return
    my $uri = "$prototype->{protocol}://$host/" . join('/', @path);
    $uri .= '?' . join('&', @qp)
        if @qp;
    $uri;
}

sub _validate_uri {
    my ($mapping, $app, $extra) = @_;
    my $param_map = $mapping->{param_map};
    my $query = $app->query;
    my $meth = $query->request_method || 'GET';
    $extra = { map { $_ => 1 } @$extra };

    return URI_IS_PERMALINK
        unless $meth eq 'GET' || $meth eq 'HEAD';

    my $max_rank = 0;
    foreach my $n (
        map { (split '=', $_, 2)[0] } split(/[&;]/, $query->query_string)
    ) {
        if (my $ref = $param_map->{$n}) {
            return URI_PATH_PARAM_IN_QUERY
                if $ref->{rank} < 0;
            return URI_PARAM_NOT_IN_ORDER
                if $ref->{rank} < $max_rank;
            if (my $omit = $ref->{omit}) {
                foreach my $v ($query->param($n)) {
                    return URI_OMITTABLE_PARAM
                        if $v eq $omit;
                }
            }
            $max_rank = $ref->{rank};
        } else {
            return URI_UNKNOWN_PARAM
                unless $extra->{$n};
        }
    }

    URI_IS_PERMALINK;
}

sub _setup_runmodes {
    my ($app, $mapping) = @_;
    $app->run_modes(_run_modes_of($mapping, ref $app));
}

sub _build_uri_table_entry {
    my $table = shift;

    # setup path_array
    my $p = $table->{path};
    $p =~ s|^/?(.*)/?$|$1|;
    $table->{path_array} = [ split '/', $p ];

    # normalize query array
    $table->{query} ||= [];
    foreach my $p (@{$table->{query}}) {
        $p = {
            name => $p,
        } unless ref $p;
    }

    # setup param_map
    $table->{param_map} = {};
    for (my $i = 0; $i < @{$table->{query}}; $i++) {
        $table->{param_map}->{$table->{query}->[$i]->{name}} = {
            rank => $i + 1,
            omit => $table->{query}->[$i]->{omit} || undef,
        };
    }
    foreach my $e (@{$table->{path_array}}) {
        if ($e =~ /^:(.*?)\??$/) {
            $table->{param_map}->{$1} = {
                rank => -1,
            };
        }
    }

    # set build_uri
    $table->{build_uri} ||= \&_default_build_uri;

    $table;
}

sub _pkg2rm {
    my $pkg = shift;

    $pkg =~ m|[^:]*$|;
    my $rm = $&;
    $rm =~ s/([a-z]?)([A-Z])/($1 ? "$1_" : '') . lc($2)/ego;

    $rm;
}

1;

__END__