/foo/*/... syntax

diff --git a/lib/Web/Simple.pm b/lib/Web/Simple.pm
index c3e5f19..5307bbb 100644 (file)
--- a/lib/Web/Simple.pm
+++ b/lib/Web/Simple.pm
@@ -93,9 +93,11 @@ examples and non-CGI deployment, see below.
 
 =head1 WHY?
 
-While I originally wrote Web::Simple as part of my Antiquated Perl talk for
-Italian Perl Workshop 2009, I've found that having a bare minimum system for
-writing web applications that doesn't drive me insane is rather nice.
+Web::Simple was originally written to form part of my Antiquated Perl talk for
+Italian Perl Workshop 2009, but in writing the bloggery example I realised
+that having a bare minimum system for writing web applications that doesn't
+drive me insane was rather nice and decided to spend my attempt at nanowrimo
+for 2009 improving and documenting it to the point where others could use it.
 
 The philosophy of Web::Simple is to keep to an absolute bare minimum, for
 everything. It is not designed to be used for large scale applications;
@@ -364,6 +366,22 @@ you can do
 to match an arbitrary number of parts up to but not including some final
 part.
 
+Finally,
+
+  sub (/foo/...) {
+
+will match /foo/ on the beginning of the path -and- strip it, much like
+.html strips the extension. This is designed to be used to construct
+nested dispatch structures, but can also prove useful for having e.g. an
+optional language specification at the start of a path.
+
+Note that the '...' is a "maybe something here, maybe not" so the above
+specification will match like this:
+
+  /foo         # no match
+  /foo/        # match and strip path to '/'
+  /foo/bar/baz # match and strip path to '/bar/baz'
+
 =head3 Extension matches
 
   sub (.html) {

diff --git a/lib/Web/Simple/DispatchParser.pm b/lib/Web/Simple/DispatchParser.pm
index c55a231..1882c98 100644 (file)
--- a/lib/Web/Simple/DispatchParser.pm
+++ b/lib/Web/Simple/DispatchParser.pm
@@ -134,14 +134,29 @@ sub _url_path_match {
   my ($self) = @_;
   for ($_[1]) {
     my @path;
-    while (/\G\//gc) {
+    my $full_path = '$';
+    PATH: while (/\G\//gc) {
+      /\G\.\.\./gc
+        and do {
+          $full_path = '';
+          last PATH;
+        };
       push @path, $self->_url_path_segment_match($_)
         or $self->_blam("Couldn't parse path match segment");
     }
-    my $re = '^()'.join('/','',@path).'$';
+    my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
+    $re = qr/$re/;
+    if ($full_path) {
+      return sub {
+        if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
+          $cap[0] = {}; return @cap;
+        }
+        return ();
+      };
+    }
     return sub {
       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
-        $cap[0] = {}; return @cap;
+        $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
       }
       return ();
     };

diff --git a/t/dispatch_parser.t b/t/dispatch_parser.t
index ffde868..28da3b8 100644 (file)
--- a/t/dispatch_parser.t
+++ b/t/dispatch_parser.t
@@ -200,3 +200,23 @@ is_deeply(
   [],
   '!.html+.* does not match /foo'
 );
+
+my $sub = $dp->parse_dispatch_specification('/foo/*/...');
+
+is_deeply(
+  [ $sub->({ PATH_INFO => '/foo/1/bar' }) ],
+  [ { PATH_INFO => '/bar' }, 1 ],
+  '/foo/*/... matches /foo/1/bar and strips to /bar'
+);
+
+is_deeply(
+  [ $sub->({ PATH_INFO => '/foo/1/' }) ],
+  [ { PATH_INFO => '/' }, 1 ],
+  '/foo/*/... matches /foo/1/bar and strips to /'
+);
+
+is_deeply(
+  [ $sub->({ PATH_INFO => '/foo/1' }) ],
+  [],
+  '/foo/*/... does not match /foo/1 (no trailing /)'
+);