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