1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
package CGI::Application::Dispatch::Regexp;
use strict;
use base 'CGI::Application::Dispatch';
our $VERSION = '3.04';
=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 one to use flexible and
powerful Perl regular expressions to transform a path 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 COPYRIGHT & LICENSE
Copyright Michael Peters and Mark Stosberg 2008, all rights reserved.
=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;
|
