package CGI::Application::Dispatch::Regexp;
use strict;
use base 'CGI::Application::Dispatch';
=pod
=head1 NAME
CGI::Application::Dispatch::Regexp - Dispatch requests to CGI::Application based objects using regular expressions
=head1 SYNOPSIS
use CGI::Application::Dispatch::Regexp;
CGI::Application::Dispatch::Regexp->dispatch(
prefix => 'MyApp',
table => [
'' => { app => 'Welcome', rm => 'start' },
qr|/([^/]+)/?| => { names => ['app'] },
qr|/([^/]+)/([^/]+)/?| => { names => [qw(app rm)] },
qr|/([^/]+)/([^/]+)/page(\d+)\.html?| => { names => [qw(app rm page)] },
],
);
=head1 DESCRIPTION
L<CGI::Application::Dispatch> uses its own syntax dispatch table.
C<CGI::Application::Dispatch::Regexp> allows to use flexible and powerful Perl
regular expressions to transform PATH_INFO into argument list.
=head1 DISPATCH TABLE
The dispatch table should contain list of regular expressions with hashref of
corresponding parameters. Hash element 'names' is a list of names of regular
expression groups. The default table looks like this:
table => [
qr|/([^/]+)/?| => { names => ['app'] },
qr|/([^/]+)/([^/]+)/?| => { names => [qw(app rm)] },
],
Here's an example of defining a custom 'page' parameter:
qr|/([^/]+)/([^/]+)/page(\d+)\.html/?| => { names => [qw(app rm page)] },
=head1 SEE ALSO
L<CGI::Application>, L<CGI::Application::Dispatch>
=cut
# protected method - designed to be used by sub classes, not by end users
sub _parse_path {
my ($self, $path, $table) = @_;
# get the module name from the table
return unless defined($path);
unless(ref($table) eq 'ARRAY') {
warn "Invalid or no dispatch table!\n";
return;
}
for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {
# translate the rule into a regular expression, but remember where the named args are
my $rule = $table->[$i];
warn
"[Dispatch::Regexp] Trying to match '$path' against rule '$table->[$i]' using regex '$rule'\n"
if $CGI::Application::Dispatch::DEBUG;
# if we found a match, then run with it
if(my @values = ($path =~ m|^$rule$|)) {
warn "[Dispatch::Regexp] Matched!\n" if $CGI::Application::Dispatch::DEBUG;
my %named_args = %{$table->[++$i]};
my $names = delete($named_args{names});
@named_args{@$names} = @values if(ref($names) eq 'ARRAY');
return \%named_args;
}
}
return;
}
sub dispatch_args {
my ($self, $args) = @_;
return {
default => ($args->{default} || ''),
prefix => ($args->{prefix} || ''),
args_to_new => ($args->{args_to_new} || {}),
table => [
qr|/([^/]+)/?| => {names => ['app']},
qr|/([^/]+)/([^/]+)/?| => {names => [qw(app rm)]},
],
};
}
1;