[Bps-public-commit] r16364 - in Path-Dispatcher/trunk: lib/Path/Dispatcher lib/Path/Dispatcher/Rule t

[sartak at bestpractical.com]

Author: sartak
Date: Sun Oct 19 06:17:04 2008
New Revision: 16364

Added:
   Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule/Under.pm
   Path-Dispatcher/trunk/t/012-under.t
Modified:
   Path-Dispatcher/trunk/   (props changed)
   Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule.pm

Log:
 r74129 at onn:  sartak | 2008-10-19 06:16:43 -0400
 "under" rules


Modified: Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule.pm
==============================================================================
--- Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule.pm	(original)
+++ Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule.pm	Sun Oct 19 06:17:04 2008
@@ -68,6 +68,7 @@
 require Path::Dispatcher::Rule::CodeRef;
 require Path::Dispatcher::Rule::Regex;
 require Path::Dispatcher::Rule::Tokens;
+require Path::Dispatcher::Rule::Under;
 
 1;
 

Added: Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule/Under.pm
==============================================================================
--- (empty file)
+++ Path-Dispatcher/trunk/lib/Path/Dispatcher/Rule/Under.pm	Sun Oct 19 06:17:04 2008
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+package Path::Dispatcher::Rule::Under;
+use Moose;
+use MooseX::AttributeHelpers;
+extends 'Path::Dispatcher::Rule';
+
+has predicate => (
+    is  => 'ro',
+    isa => 'Path::Dispatcher::Rule',
+);
+
+has _rules => (
+    metaclass => 'Collection::Array',
+    is        => 'rw',
+    isa       => 'ArrayRef[Path::Dispatcher::Rule]',
+    init_arg  => 'rules',
+    default   => sub { [] },
+    provides  => {
+        push     => 'add_rule',
+        elements => 'rules',
+    },
+);
+
+sub match {
+    my $self = shift;
+    my $path = shift;
+
+    my $prefix_match = $self->predicate->match($path)
+        or return;
+
+    my $suffix = $prefix_match->leftover;
+
+    return grep { defined } map { $_->match($suffix) } $self->rules;
+}
+
+1;
+

Added: Path-Dispatcher/trunk/t/012-under.t
==============================================================================
--- (empty file)
+++ Path-Dispatcher/trunk/t/012-under.t	Sun Oct 19 06:17:04 2008
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 9;
+use Path::Dispatcher;
+
+my @calls;
+
+my $predicate = Path::Dispatcher::Rule::Tokens->new(
+    tokens => ['ticket'],
+    prefix => 1,
+);
+
+my $create = Path::Dispatcher::Rule::Tokens->new(
+    tokens => ['create'],
+    block  => sub { push @calls, "ticket create" },
+);
+
+my $update = Path::Dispatcher::Rule::Tokens->new(
+    tokens => ['update'],
+    block  => sub { push @calls, "ticket update" },
+);
+
+my $under = Path::Dispatcher::Rule::Under->new(
+    predicate => $predicate,
+    rules     => [$create, $update],
+);
+
+my ($ticket_create) = $under->match("ticket create");
+ok($ticket_create, "matched 'ticket create'");
+