1package CGI::Application::Dispatch::Regexp;
2use strict;
3use base 'CGI::Application::Dispatch';
4
5our $VERSION = '3.04';
6
7=pod
8
9=head1 NAME
10
11CGI::Application::Dispatch::Regexp - Dispatch requests to
12CGI::Application based objects using regular expressions
13
14=head1 SYNOPSIS
15
16    use CGI::Application::Dispatch::Regexp;
17
18    CGI::Application::Dispatch::Regexp->dispatch(
19        prefix  => 'MyApp',
20        table   => [
21            ''                                    => { app => 'Welcome',
22                                                       rm  => 'start',
23                                                     },
24            qr|/([^/]+)/?|                        => { names => ['app'],
25                                                     },
26            qr|/([^/]+)/([^/]+)/?|                => { names =>
27                                                         [qw(app rm)]
28                                                     },
29            qr|/([^/]+)/([^/]+)/page(\d+)\.html?| => { names =>
30                                                         [qw(app rm page)]
31                                                     },
32        ],
33    );
34
35
36=head1 DESCRIPTION
37
38L<CGI::Application::Dispatch> uses its own syntax dispatch table.
39C<CGI::Application::Dispatch::Regexp> allows one to use flexible and
40powerful Perl regular expressions to transform a path into argument
41list.
42
43=head1 DISPATCH TABLE
44
45The dispatch table should contain list of regular expressions with hashref of
46corresponding parameters. Hash element 'names' is a list of names of regular
47expression groups. The default table looks like this:
48
49        table       => [
50            qr|/([^/]+)/?|          => { names => ['app']      },
51            qr|/([^/]+)/([^/]+)/?|  => { names => [qw(app rm)] },
52        ],
53
54Here's an example of defining a custom 'page' parameter:
55
56        qr|/([^/]+)/([^/]+)/page(\d+)\.html/?| => {
57            names => [qw(app rm page)],
58        },
59
60
61=head1 COPYRIGHT & LICENSE
62
63Copyright Michael Peters and Mark Stosberg 2008, all rights reserved.
64
65=head1 SEE ALSO
66
67L<CGI::Application>, L<CGI::Application::Dispatch>
68
69
70=cut
71
72# protected method - designed to be used by sub classes, not by end users
73sub _parse_path {
74    my ($self, $path, $table) = @_;
75
76    # get the module name from the table
77    return unless defined($path);
78
79    unless(ref($table) eq 'ARRAY') {
80        warn "Invalid or no dispatch table!\n";
81        return;
82    }
83
84    for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {
85
86        # translate the rule into a regular expression, but remember
87        # where the named args are
88        my $rule = $table->[$i];
89
90        warn
91          "[Dispatch::Regexp] Trying to match '$path' against rule '$table->[$i]' using regex '$rule'\n"
92          if $CGI::Application::Dispatch::DEBUG;
93
94        # if we found a match, then run with it
95        if(my @values = ($path =~ m|^$rule$|)) {
96
97            warn "[Dispatch::Regexp] Matched!\n" if $CGI::Application::Dispatch::DEBUG;
98
99            my %named_args = %{$table->[++$i]};
100            my $names      = delete($named_args{names});
101
102            @named_args{@$names} = @values if(ref($names) eq 'ARRAY');
103
104            return \%named_args;
105
106        }
107
108    }
109
110    return;
111}
112
113sub dispatch_args {
114    my ($self, $args) = @_;
115    return {
116        default     => ($args->{default}     || ''),
117        prefix      => ($args->{prefix}      || ''),
118        args_to_new => ($args->{args_to_new} || {}),
119
120        table => [
121            qr|/([^/]+)/?|         => {names => ['app']},
122            qr|/([^/]+)/([^/]+)/?| => {names => [qw(app rm)]},
123        ],
124
125    };
126}
127
1281;
129