Path::Router - A tool for routing paths

  my $router = Path::Router->new;

  $router->add_route('blog' => (
      defaults => {
          controller => 'blog',
          action     => 'index',
      },
      # you can provide a fixed "target"
      # for a match as well, this can be
      # anything you want it to be ...
      target => My::App->get_controller('blog')->get_action('index')
  ));

  $router->add_route('blog/:year/:month/:day' => (
      defaults => {
          controller => 'blog',
          action     => 'show_date',
      },
      # validate with ...
      validations => {
          # ... raw-Regexp refs
          year       => qr/\d{4}/,
          # ... custom Moose types you created
          month      => 'NumericMonth',
          # ... Moose anon-subtypes created inline
          day        => subtype('Int' => where { $_ <= 31 }),
      }
  ));

  $router->add_route('blog/:action/?:id' => (
      defaults => {
          controller => 'blog',
      },
      validations => {
          action  => qr/\D+/,
          id      => 'Int',  # also use plain Moose types too
      }
  ));

  # even include other routers
  $router->include_router( 'polls/' => $another_router );

  # ... in your dispatcher

  # returns a Path::Router::Route::Match object
  my $match = $router->match('/blog/edit/15');

  # ... in your code

  my $uri = $router->uri_for(
      controller => 'blog',
      action     => 'show_date',
      year       => 2006,
      month      => 10,
      day        => 5,
  );

package Path::Router;
use Moose;

our $VERSION   = '0.10';
our $AUTHORITY = 'cpan:STEVAN';

use File::Spec::Unix ();

use Path::Router::Types;
use Path::Router::Route;
use Path::Router::Route::Match;

use constant DEBUG => exists $ENV{PATH_ROUTER_DEBUG} ? $ENV{PATH_ROUTER_DEBUG} : 0;

has 'routes' => (
    is      => 'ro',
    isa     => 'ArrayRef[Path::Router::Route]',
    default => sub { [] },
);

has 'route_class' => (
    is      => 'ro',
    isa     => 'ClassName',
    default => 'Path::Router::Route',
);

has 'inline' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 1,
    trigger => sub { $_[0]->clear_match_code }
);

has 'match_code' => (
    is         => 'rw',
    isa        => 'CodeRef',
    lazy_build => 1,
    clearer    => 'clear_match_code'
);

sub _build_match_code {
    my $self = shift;

    my @code;
    my $i = 0;
    foreach my $route (@{$self->routes}) {
        push @code, $route->generate_match_code($i++);
    }

    my $code = "sub {\n" .
        "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
        "   my \$self = shift;\n" .
        "   my \$path = shift;\n" .
        "   my \$routes = \$self->routes;\n" .
        join("\n", @code) .
        "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
        "   print STDERR \"match failed\\n\" if DEBUG();\n" .
        "   return ();\n" .
        "}"
    ;
    # print STDERR $code;
    eval $code or warn $@;
}

sub add_route {
    my ($self, $path, %options) = @_;
    push @{$self->routes} => $self->route_class->new(
        path  => $path,
        %options
    );
    $self->clear_match_code;
}

sub insert_route {
    my ($self, $path, %options) = @_;
    my $at = delete $options{at} || 0;

    my $route = $self->route_class->new(
        path  => $path,
        %options
    );
    my $routes = $self->routes;

    if (! $at) {
        unshift @$routes, $route;
    } elsif ($#{$routes} < $at) {
        push @$routes, $route;
    } else {
        splice @$routes, $at, 0, $route;
    }
    $self->clear_match_code;
}

sub include_router {
    my ($self, $path, $router) = @_;

    ($path eq '' || $path =~ /\/$/)
        || confess "Path is either empty of ends with a /";

    push @{ $self->routes } => map {
            $_->clone( path => ($path . $_->path) )
        } @{ $router->routes };
    $self->clear_match_code;
}

sub match {
    my ($self, $url) = @_;

    if ($self->inline) {
        $url =~ s|/{2,}|/|g;                          # xx////xx  -> xx/xx
        $url =~ s{(?:/\.)+(?:/|\z)}{/}g;              # xx/././xx -> xx/xx
        $url =~ s|^(?:\./)+||s unless $url eq "./";   # ./xx      -> xx
        $url =~ s|^/(?:\.\./)+|/|;                    # /../../xx -> xx
        $url =~ s|^/\.\.$|/|;                         # /..       -> /
        $url =~ s|/\z|| unless $url eq "/";           # xx/       -> xx
        $url =~ s|^/||; # Path::Router specific. remove first /

        return $self->match_code->($self, $url);
    } else {
        my @parts = grep { defined $_ and length $_ }
            split '/' => File::Spec::Unix->canonpath($url);

        for my $route (@{$self->routes}) {
            my $match = $route->match(\@parts) or next;
            return $match;
        }
    }
    return;
}

sub uri_for {
    my ($self, %orig_url_map) = @_;

    # anything => undef is useless; ignore it and let the defaults override it
    for (keys %orig_url_map) {
        delete $orig_url_map{$_} unless defined $orig_url_map{$_};
    }

    foreach my $route (@{$self->routes}) {
        my @url;
        eval {

            my %url_map = %orig_url_map;

            my %reverse_url_map = reverse %url_map;

            my %required = map {( $_ => 1 )}
                @{ $route->required_variable_component_names };

            my %optional = map {( $_ => 1 )}
                @{ $route->optional_variable_component_names };

            my %url_defaults;

            my %match = %{$route->defaults || {}};

            for my $component (keys(%required), keys(%optional)) {
                next unless exists $match{$component};
                $url_defaults{$component} = delete $match{$component};
            }
            # any remaining keys in %defaults are 'extra' -- they don't appear
            # in the url, so they need to match exactly rather than being
            # filled in

            %url_map = (%url_defaults, %url_map);

            my @keys = keys %url_map;

            if (DEBUG) {
                warn "> Attempting to match ", $route->path, " to (", (join " / " => @keys), ")";
            }
            (
                @keys >= keys(%required) &&
                @keys <= (keys(%required) + keys(%optional) + keys(%match))
            ) || die "LENGTH DID NOT MATCH\n";

            if (my @missing = grep { ! exists $url_map{$_} } keys %required) {
                warn "missing: @missing" if DEBUG;
                die "MISSING ITEM [@missing]\n";
            }

            if (my @extra = grep {
                    ! $required{$_} && ! $optional{$_} && ! $match{$_}
                } keys %url_map) {
                warn "extra: @extra" if DEBUG;
                die "EXTRA ITEM [@extra]\n";
            }

            if (my @nomatch = grep {
                    exists $url_map{$_} and $url_map{$_} ne $match{$_}
                } keys %match) {
                warn "no match: @nomatch" if DEBUG;
                die "NO MATCH [@nomatch]\n";
            }

            for my $component (@{$route->components}) {
                if ($route->is_component_variable($component)) {
                    warn "\t\t... found a variable ($component)" if DEBUG;
                    my $name = $route->get_component_name($component);

                    push @url => $url_map{$name}
                        unless
                        $route->is_component_optional($component) &&
                        $route->defaults->{$name}                 &&
                        $route->defaults->{$name} eq $url_map{$name};

                }

                else {
                    warn "\t\t... found a constant ($component)" if DEBUG;

                    push @url => $component;
                }

                warn "+++ URL so far ... ", (join "/" => @url) if DEBUG;
            }

        };
        unless ($@) {
            return join "/" => grep { defined } @url;
        }
        else {
            do {
                warn join "/" => @url;
                warn "... ", $@;
            } if DEBUG;
        }

    }

    return undef;
}

__PACKAGE__->meta->make_immutable;

no Moose; 1;

__END__