File Coverage

blib/lib/Pinwheel/Mapper.pm

Criterion	Covered	Total	%
statement	153	153	100.0
branch	80	80	100.0
condition	50	51	98.0
subroutine	14	14	100.0
pod	6	6	100.0
total	303	304	99.6

package Pinwheel::Mapper;

use strict;
use warnings;


sub new
{
    my $class = shift;
    my $self = bless({}, $class);
    $self->reset();
    return $self;
}


sub reset
{
    my $self = shift;
    $self->{routes} = [];
    $self->{named} = {};
}


sub connect
{
    my $self = shift;
    my $name = (scalar(@_) & 1) ? undef : shift;
    my $route = _tidy_path(shift);
    my %options = @_;
    my $defaults = delete $options{'defaults'} || {};
    my $requirements = delete $options{'requirements'} || {};
    my $conditions = delete $options{'conditions'} || {};
    my @matchkeys = ();
    my %target = ();
    my $regexp;

    $options{'_static'} = 1 if ($route =~ /^\w+:\/\//);

    while (my ($key, $value) = each(%options)) {
        $defaults->{$key} = $value unless $key =~ /^_/;
    }

    my $subfn = sub {
        my ($prefix, $type, $name) = @_;
        my $pattern;

        push @matchkeys, $name;
        if ($name eq 'controller' || $name eq 'action') {
            $target{$name} = '*';
        } elsif ($name eq 'id') {
            $defaults->{id} ||= undef;
        }
        $prefix = '\.' if ($prefix eq '.');
        if ($type eq '*') {
            $pattern = $prefix . '(.*)';
        } elsif (exists($requirements->{$name})) {
            $pattern = $prefix . '(' . $requirements->{$name} . ')';
        } elsif ($prefix eq '\.') {
            $pattern = $prefix . '([^/.][^/]*)';
        } else {
            $pattern = $prefix . '([^/.]+)';
        }
        $pattern = "(?:$pattern)?" if exists($defaults->{$name});
        return $pattern;
    };

    $regexp = $route;
    $regexp =~ s!([/.]?)([:*])\(?([a-z][a-z0-9_]*)\)?!&$subfn($1, $2, $3)!ge;
    $defaults->{'controller'} ||= 'content';
    $defaults->{'action'} ||= 'index';
    if (!$target{'controller'}) {
        $target{'controller'} = $defaults->{'controller'};
    }
    if (!$target{'action'}) {
        $target{'action'} = $defaults->{'action'};
    }

    foreach (keys %$requirements) {
        $requirements->{$_} = qr/^$requirements->{$_}$/;
    }
    if ($conditions->{method} && $conditions->{method} eq 'any') {
        $conditions->{method} = undef;
    }

    my $r = {
        name => $name,
        route => $route,
        regexp => qr/^${regexp}$/,
        matchkeys => \@matchkeys,
        defaults => $defaults,
        requirements => $requirements,
        conditions => $conditions,
        target => \%target,
        options => \%options
    };
    push @{$self->{routes}}, $r unless $options{'_static'};
    $self->{named}{$name} = $r if defined($name);
}


sub match
{
    my ($self, $path, $method) = @_;
    my ($k, $v, %params, @matches, $route);

    $path = _tidy_path($path);
    $method = undef if $method && $method eq 'any';

    foreach $route (@{$self->{routes}}) {
        @matches = ($path =~ /$route->{regexp}/);
        next if scalar(@matches) == 0;
        if (defined($method) && defined($route->{conditions}{method})) {
            next if $method ne $route->{conditions}{method};
        }
        foreach $k (@{$route->{matchkeys}}) {
            $v = shift @matches;
            $v =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge if $v;
            $params{$k} = $v;
        }
        while (($k, $v) = each(%{$route->{defaults}})) {
            $params{$k} = $v unless defined($params{$k});
        }
        return \%params;
    }
    return undef;
}


sub generate
{
    my $self = shift;
    my $name = (scalar(@_) & 1) ? shift : undef;
    my %params = @_;
    my ($base, $k, $v, $route, $url);

    # If the controller and action are the same as the base set of parameters,
    # inherit any missing keys
    $base = delete $params{_base};
    if (!$name && _compare_targets($base, \%params)) {
        while (($k, $v) = each(%$base)) {
            $params{$k} = $v unless exists($params{$k});
        }
    }

    # A controller and action are always required
    $params{controller} ||= 'content';
    $params{action} ||= 'index';

    # Expand any objects supplied as route parameters
    foreach (keys(%params)) {
        next unless ref($v = $params{$_});
        $v = $v->route_param;
        if (ref $v) {
            delete $params{$_};
            %params = (%params, %$v);
        } else {
            $params{$_} = $v;
        }
    }

    # Find the appropriate route
    if ($name) {
        # Quick: find the named route
        $route = $self->{named}{$name};
    } else {
        # Slower: scan routes for the first valid parameter match
        foreach my $r (@{$self->{routes}}) {
            next unless _compare_targets($r->{target}, \%params);
            next unless _validate_route_params($r, \%params);
            $route = $r;
            last;
        }
    }
    return undef unless $route;

    # Fill in missing parameters with the defaults from the matched route
    while (($k, $v) = each(%{$route->{defaults}})) {
        $params{$k} = $v unless exists($params{$k});
    }

    return _insert_route_params($route, \%params);
}


sub names
{
    return [sort keys %{$_[0]->{named}}];
}


sub _tidy_path
{
    my ($path) = @_;
    # 1. Remove trailing slashes
    $path =~ s/\/+$//;
    # 2. Remove leading slashes before a /
    $path =~ s/(?
    # 3. Ensure leading '/' unless it's a full URL
    $path = '/' . $path if ($path !~ /^\// && $path !~ /^\w+:\/\//);
    return $path;
}

# Does this route match these params?
# The route matches if the controller and the action match.
# controller/action are matched as follows: it matches if it's specified in
# the route, and the corresponding param is either missing, or the same as
# that on the route, or "*".

sub _compare_targets
{
    my ($base, $params) = @_;
    my ($key, $b, $p);

    foreach $key ('controller', 'action') {
        $b = $base->{$key};
        return 0 unless defined($b);
        $p = $params->{$key};
        return 0 if ($p && $p ne $b && $b ne '*');
    }
    return 1;
}

# Is this set of params OK for this route?
# Tests defaults and requirements (regexp).

sub _validate_route_params
{
    my ($route, $params) = @_;
    my ($key, $value, $regexp);
    my $requirements = $route->{requirements};
    my $defaults = $route->{defaults};

    foreach $key (@{$route->{matchkeys}}) {
        $value = $params->{$key};
        return 0 unless (defined($value) || exists($defaults->{$key}));
        $regexp = $requirements->{$key};
        return 0 if (defined($value) && $regexp && $value !~ /${regexp}/);
    }
    return 1;
}

sub _insert_route_params
{
    my ($route, $params) = @_;
    my ($filter, $fn, $url);

    # Run any requested filters on the parameters before inserting them
    $filter = $route->{options}{_filter} || [];
    $filter = [$filter] if (ref($filter) eq 'CODE');
    &$_($params) foreach (@$filter);

    return unless _validate_route_params($route, $params);

    # Insert the parameters into the URL
    $url = $route->{route};
    $url =~ s!([/.]?)\*\(?([a-z][a-z0-9_]*)\)?!_param($1, $params->{$2}, 1)!ge;
    $url =~ s!([/.]?):\(?([a-z][a-z0-9_]*)\)?!_param($1, $params->{$2}, 0)!ge;

    return $url;
}

sub _param
{
    my ($prefix, $s, $keep_slash) = @_;
    return '' if !defined($s);
    $s =~ s/([^A-Za-z0-9\/_.-])/sprintf('%%%02X', ord($1))/ge;
    $s =~ s/\//%2F/g unless $keep_slash;
    return $prefix . $s;
}


1;

__DATA__