File Coverage

blib/lib/CGI/Easy/URLconf.pm

Criterion	Covered	Total	%
statement	143	148	96.6
branch	40	54	74.0
condition	12	16	75.0
subroutine	21	21	100.0
pod	6	6	100.0
total	222	245	90.6

package CGI::Easy::URLconf;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use Export::Attrs;
use URI::Escape qw( uri_escape_utf8 );


my %PATH2VIEW;
my %VIEW2PATH;


sub setup_path :Export {
    my (@data) = @_;
    my $method = ref $data[0] || $data[0] =~ m{\A/}xms ? q{} : shift @data;
    for (my $i = 0; $i <= $#data; $i++) {
        my $match = $data[$i];
        if (ref $match) {
            croak "expect SCALAR or Regexp at parameter $i" if ref $match ne 'Regexp';
        } else {
            croak "path at parameter $i must begin with /"  if $match !~ m{\A/}xms;
        }
        croak 'not enough params'               if $i == $#data;
        my @code = ($data[++$i]);
        croak "expect CODE at parameter $i"     if ref $code[0] ne 'CODE';
        while (ref $data[$i+1] eq 'CODE') {
            push @code, $data[++$i];
        }
        my $view = pop @code;
        push @{ $PATH2VIEW{$method} }, {
            match   => $match,
            view    => $view,
            prepare => \@code,
        };
    }
    return;
}

sub path2view :Export {
    my ($r) = @_;
    my $path = $r->{path};
    my $view;
    my $for_method = $PATH2VIEW{ $r->{ENV}{REQUEST_METHOD} } || [];
    my $for_any    = $PATH2VIEW{ q{}                       } || [];
    for my $path2view (@{$for_method}, @{$for_any}) {
        my @match;
        my $match = $path2view->{match};
        if (!ref $match) {
            next if $path ne $match;
        } else {
            next if $path !~ /$match/xms;
            for my $i (0 .. $#-) {
                if (defined $-[$i]) {
                    push @match, substr $path, $-[$i], $+[$i] - $-[$i];
                }
                else {
                    push @match, undef;
                }
            }
        }
        for my $prepare (@{ $path2view->{prepare} }) {
            $prepare->($r, \@match);
        }
        return $path2view->{view};
    }
    return;
}

sub set_param :Export {
    my (@names) = @_;
    return sub {
        my ($r, $values) = @_;
        for my $i (0 .. $#names) {
            if (defined $values->[$i+1]) {
                if (ref $r->{GET}{ $names[$i] }) {
                    $r->{GET}{ $names[$i] } = [ $values->[$i+1] ];
                } else {
                    $r->{GET}{ $names[$i] } = $values->[$i+1];
                }
            }
            else {
                delete $r->{GET}{ $names[$i] };
            }
        }
        return;
    };
}

###

sub setup_view :Export {
    my (@data) = @_;
    for (my $i = 0; $i <= $#data; $i++) {
        my $view = $data[$i];
        croak "expect CODE at parameter $i"         if ref $view ne 'CODE';
        croak "already exists CODE at parameter $i" if exists $VIEW2PATH{$view};
        croak 'not enough params'                   if $i == $#data;
        my $path = $data[++$i];
        croak "expect SCALAR or ARRAY at parameter $i"  if ref $path && ref $path ne 'ARRAY';
        croak "expect even elements in parameter $i"    if ref $path && @{$path} % 2;
        $VIEW2PATH{$view} = $path;
    }
    return;
}

sub view2path :Export {
    my ($view, %p) = @_;
    my $path = $VIEW2PATH{$view};
    if (!defined $path) {
        my @path = grep { $_->{view} eq $view } map { @{$_} } values %PATH2VIEW;
        if (@path == 1 && !ref $path[0]{match}) {
            $path = $path[0]{match};
        }
    }
    croak 'unknown CODE, use setup_view first'  if !defined $path;
    if (ref $path) {
        my @try = @{$path};
        $path = undef;
        while (@try) {
            my $try = shift @try;
            my $tmpl= shift @try;
            my $values = $try->(\%p) or next;
            if (@{$values} != ($tmpl =~ tr/?//)) {
                croak "incorrect values amount for template '$tmpl'";
            }
            # WARNING apache doesn't allow %2F in path (nginx allow)
            for (@{$values}) {
                $_ = uri_escape_utf8($_);
                s/%2F/\//msg;
            }
            $tmpl =~ s/[?]/shift @{$values}/xmsge;
            $path = $tmpl;
            last;
        }
        croak 'these parameters do not match configured urls' if !defined $path;
    }
    my @params;
    for my $n (keys %p) {
        my @v = ref $p{$n} ? @{ $p{$n} } : $p{$n};
        for my $v (@v) {
            push @params, uri_escape_utf8($n).q{=}.uri_escape_utf8($v);
        }
    }
    if (@params) {
        $path .= q{?} . join q{&}, @params;
    }
    return $path;
}

sub with_params :Export {
    my (@names) = @_;
    return sub {
        my ($p) = @_;
        my @values;
        for my $name (@names) {
            return if !defined $p->{ $name };
            push @values, $p->{ $name };
        }
        for (@names) {
            delete $p->{$_};
        }
        return \@values;
    };
}


1; # Magic true value required at end of module
__END__