[Bps-public-commit] Path-Dispatcher branch, master, updated. e4e2d6c627c38c90df51d070aaf4b2b178259308
sartak at bestpractical.com
sartak at bestpractical.com
Fri Mar 6 19:50:34 EST 2009
The branch, master has been updated
via e4e2d6c627c38c90df51d070aaf4b2b178259308 (commit)
via 3df85e36f351e8093b7ab45f541aac6478da65b8 (commit)
from adb2b2565c9c68bd7381f977d59e44ed92906d70 (commit)
Summary of changes:
lib/Path/Dispatcher/Builder.pm | 290 ++++++++++++++++++++++++++++++++++++
lib/Path/Dispatcher/Declarative.pm | 87 +++++++++++
2 files changed, 377 insertions(+), 0 deletions(-)
create mode 100644 lib/Path/Dispatcher/Builder.pm
- Log -----------------------------------------------------------------
commit 3df85e36f351e8093b7ab45f541aac6478da65b8
Author: robertkrimen <robertkrimen at gmail.com>
Date: Wed Feb 25 17:30:52 2009 -0800
Created Path::Dispatcher::Builder
Refactored Path::Dispatcher::Declarative to use ::Builder
diff --git a/lib/Path/Dispatcher/Builder.pm b/lib/Path/Dispatcher/Builder.pm
new file mode 100644
index 0000000..be34489
--- /dev/null
+++ b/lib/Path/Dispatcher/Builder.pm
@@ -0,0 +1,290 @@
+package Path::Dispatcher::Builder;
+
+use strict;
+use warnings;
+
+use Any::Moose;
+
+has dispatcher => (
+ is => 'ro',
+ isa => 'Path::Dispatcher',
+ required => 1,
+ lazy => 1,
+ default => sub {
+ return Path::Dispatcher->new
+ },
+);
+
+has case_sensitive_tokens => (
+ is => 'rw',
+ isa => 'Bool|CodeRef',
+ default => 0,
+);
+
+has token_delimiter => (
+ is => 'rw',
+ isa => 'Str|CodeRef',
+ default => ' ',
+);
+
+#sub token_delimiter {
+# my $self = shift;
+# my $value = $self->_token_delimiter;
+# return ref $value eq 'CODE' ? $value->() : $value;
+#}
+## What the magic with coderefs? Because this is based off of ::Declarative, and the caller might not be available at import
+## time (when the sugar is loaded)
+
+#has case_sensitive_tokens => (
+# reader => '_case_sensitive_tokens',
+## is => 'rw',
+# isa => 'Bool|CodeRef',
+# default => 0,
+#);
+#sub case_sensitive_tokens {
+# my $self = shift;
+# my $value = $self->_case_sensitive_tokens;
+# return ref $value eq 'CODE' ? $value->() : $value;
+#}
+
+#has token_delimiter => (
+# reader => '_token_delimiter',
+## is => 'rw',
+# isa => 'Str|CodeRef',
+# default => ' ',
+#);
+#sub token_delimiter {
+# my $self = shift;
+# my $value = $self->_token_delimiter;
+# return ref $value eq 'CODE' ? $value->() : $value;
+#}
+
+no Any::Moose; # We're gonna use before/after below
+
+our $OUTERMOST_DISPATCHER;
+our $UNDER_RULE;
+
+sub _next_rule () {
+ die "Path::Dispatcher next rule\n";
+}
+
+sub _last_rule () {
+ die "Path::Dispatcher abort\n";
+}
+
+sub dispatch {
+ my $self = shift;
+
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+
+ $OUTERMOST_DISPATCHER->dispatch(@_);
+}
+
+sub run {
+ my $self = shift;
+
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+
+ $OUTERMOST_DISPATCHER->run(@_);
+}
+
+sub rewrite {
+ my $self = shift;
+ my ($from, $to) = @_;
+ my $rewrite = sub {
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+ my $path = ref($to) eq 'CODE' ? $to->() : $to;
+ $OUTERMOST_DISPATCHER->run($path, @_);
+ };
+ $self->_add_rule('on', $from, $rewrite);
+}
+
+sub on {
+ my $self = shift;
+ $self->_add_rule('on', @_);
+}
+
+sub before {
+ my $self = shift;
+ $self->_add_rule('before_on', @_);
+}
+
+sub after {
+ my $self = shift;
+ $self->_add_rule('after_on', @_);
+}
+
+sub then {
+ my $self = shift;
+ my $block = shift;
+ my $rule = Path::Dispatcher::Rule::Always->new(
+ stage => 'on',
+ block => sub {
+ $block->(@_);
+ _next_rule;
+ },
+ );
+ $self->_add_rule($rule);
+}
+
+sub chain {
+ my $self = shift;
+ my $block = shift;
+ my $rule = Path::Dispatcher::Rule::Chain->new(
+ stage => 'on',
+ block => $block,
+ );
+ $self->_add_rule($rule);
+}
+
+sub under {
+ my $self = shift;
+ my ($matcher, $rules) = @_;
+
+ my $predicate = $self->_create_rule('on', $matcher);
+ $predicate->prefix(1);
+
+ my $under = Path::Dispatcher::Rule::Under->new(
+ predicate => $predicate,
+ );
+
+ $self->_add_rule($under, @_);
+
+ do {
+ local $UNDER_RULE = $under;
+ $rules->();
+ };
+}
+
+sub redispatch_to {
+ my $self = shift;
+ my $dispatcher = shift;
+
+ # assume it's a declarative dispatcher
+ if (!ref($dispatcher)) {
+ $dispatcher = $dispatcher->dispatcher;
+ }
+
+ my $redispatch = Path::Dispatcher::Rule::Dispatch->new(
+ dispatcher => $dispatcher,
+ );
+
+ $self->_add_rule($redispatch);
+}
+
+my %rule_creators = (
+ ARRAY => sub {
+ my ($self, $stage, $tokens, $block) = @_;
+ my $case_sensitive = $self->case_sensitive_tokens;
+
+ Path::Dispatcher::Rule::Tokens->new(
+ tokens => $tokens,
+ delimiter => $self->token_delimiter,
+ defined $case_sensitive ? (case_sensitive => $case_sensitive) : (),
+ $block ? (block => $block) : (),
+ ),
+ },
+ HASH => sub {
+ my ($self, $stage, $metadata_matchers, $block) = @_;
+
+ if (keys %$metadata_matchers == 1) {
+ my ($field) = keys %$metadata_matchers;
+ my ($value) = values %$metadata_matchers;
+ my $matcher = $self->_create_rule($stage, $value);
+
+ return Path::Dispatcher::Rule::Metadata->new(
+ field => $field,
+ matcher => $matcher,
+ $block ? (block => $block) : (),
+ );
+ }
+
+ die "Doesn't support multiple metadata rules yet";
+ },
+ CODE => sub {
+ my ($self, $stage, $matcher, $block) = @_;
+ Path::Dispatcher::Rule::CodeRef->new(
+ matcher => $matcher,
+ $block ? (block => $block) : (),
+ ),
+ },
+ Regexp => sub {
+ my ($self, $stage, $regex, $block) = @_;
+ Path::Dispatcher::Rule::Regex->new(
+ regex => $regex,
+ $block ? (block => $block) : (),
+ ),
+ },
+ empty => sub {
+ my ($self, $stage, $undef, $block) = @_;
+ Path::Dispatcher::Rule::Empty->new(
+ $block ? (block => $block) : (),
+ ),
+ },
+);
+
+sub _create_rule {
+ my ($self, $stage, $matcher, $block) = @_;
+
+ my $rule_creator;
+
+ if ($matcher eq '') {
+ $rule_creator = $rule_creators{empty};
+ }
+ elsif (!ref($matcher)) {
+ $rule_creator = $rule_creators{ARRAY};
+ $matcher = [$matcher];
+ }
+ else {
+ $rule_creator = $rule_creators{ ref $matcher };
+ }
+
+ $rule_creator or die "I don't know how to create a rule for type $matcher";
+
+ return $rule_creator->($self, $stage, $matcher, $block);
+}
+
+sub _add_rule {
+ my $self = shift;
+ my $rule;
+
+ if (!ref($_[0])) {
+ my ($stage, $matcher, $block) = splice @_, 0, 3;
+ $rule = $self->_create_rule($stage, $matcher, $block);
+ }
+ else {
+ $rule = shift;
+ }
+
+ # FIXME: broken since move from ::Declarative
+ # XXX: caller level should be closer to $Test::Builder::Level
+# my (undef, $file, $line) = caller(1);
+ my (undef, $file, $line) = caller(2);
+ my $rule_name = "$file:$line";
+
+ if (!defined(wantarray)) {
+ if ($UNDER_RULE) {
+ $UNDER_RULE->add_rule($rule);
+
+ my $full_name = $UNDER_RULE->has_name
+ ? "(" . $UNDER_RULE->name . " - rule $rule_name)"
+ : "(anonymous Under - rule $rule_name)";
+
+ $rule->name($full_name);
+ }
+ else {
+ $self->dispatcher->add_rule($rule);
+ $rule->name("(" . $self->dispatcher->name . " - rule $rule_name)");
+ }
+ }
+ else {
+ $rule->name($rule_name);
+ return $rule, @_;
+ }
+}
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/Path/Dispatcher/Declarative.pm b/lib/Path/Dispatcher/Declarative.pm
index a8a3dd5..3c09df2 100644
--- a/lib/Path/Dispatcher/Declarative.pm
+++ b/lib/Path/Dispatcher/Declarative.pm
@@ -2,10 +2,97 @@ package Path::Dispatcher::Declarative;
use strict;
use warnings;
use Path::Dispatcher;
+use Path::Dispatcher::Builder;
use Sub::Exporter;
our $CALLER; # Sub::Exporter doesn't make this available
+
+my $exporter = Sub::Exporter::build_exporter({
+ into_level => 1,
+ groups => {
+ default => \&build_sugar,
+ },
+});
+
+*_next_rule = \&Path::Dispatcher::Builder::_next_rule;
+*_last_rule = \&Path::Dispatcher::Builder::_last_rule;
+
+sub token_delimiter { ' ' }
+sub case_sensitive_tokens { undef }
+
+sub import {
+ my $self = shift;
+ my $pkg = caller;
+
+ my @args = grep { !/^-[bB]ase$/ } @_;
+
+ # just loading the class..
+ return if @args == @_;
+
+ do {
+ no strict 'refs';
+ push @{ $pkg . '::ISA' }, $self;
+ };
+
+ local $CALLER = $pkg;
+
+ $exporter->($self, @args);
+}
+
+sub build_sugar {
+ my ($class, $group, $arg) = @_;
+
+ my $into = $CALLER;
+
+# my $dispatcher = Path::Dispatcher->new(
+# name => $into,
+# );
+# my $builder = Path::Dispatcher::Builder->new(
+# token_delimiter => sub { $into->token_delimiter },
+# case_sensitive_tokens => sub { $into->case_sensitive_tokens },
+# dispatcher => $dispatcher,
+# );
+
+ # Why the lazy_builder shenanigans? Because token_delimiter/case_sensitive_tokens subroutines
+ # are probably not ready at import time.
+ my ($builder, $dispatcher);
+ my $lazy_builder = sub {
+ return $builder if $builder;
+ $dispatcher = Path::Dispatcher->new(
+ name => $into,
+ );
+ $builder = Path::Dispatcher::Builder->new(
+ token_delimiter => $into->token_delimiter,
+ case_sensitive_tokens => $into->case_sensitive_tokens,
+ dispatcher => $dispatcher,
+ );
+ return $builder;
+ };
+
+ return {
+ dispatcher => sub { $lazy_builder->()->dispatcher },
+
+ # NOTE on shift if $into: if caller is $into, then this function is being used as sugar
+ # otherwise, it's probably a method call, so discard the invocant
+ dispatch => sub { shift if caller ne $into; $lazy_builder->()->dispatch(@_) },
+ run => sub { shift if caller ne $into; $lazy_builder->()->run(@_) },
+
+ rewrite => sub { $lazy_builder->()->rewrite(@_) },
+ on => sub { $lazy_builder->()->on(@_) },
+ before => sub { $lazy_builder->()->before(@_) },
+ after => sub { $lazy_builder->()->after(@_) },
+ then => sub (&) { $lazy_builder->()->then(@_) },
+ chain => sub (&) { $lazy_builder->()->chain(@_) },
+ under => sub { $lazy_builder->()->under(@_) },
+ redispatch_to => sub { $lazy_builder->()->redispatch_to(@_) },
+ next_rule => \&_next_rule,
+ last_rule => \&_last_rule,
+ };
+}
+__END__
+
+our $CALLER; # Sub::Exporter doesn't make this available
our $OUTERMOST_DISPATCHER;
our $UNDER_RULE;
commit e4e2d6c627c38c90df51d070aaf4b2b178259308
Merge: adb2b25... 3df85e3...
Author: Shawn M Moore <sartak at gmail.com>
Date: Fri Mar 6 19:49:52 2009 -0500
Merge branch 'builder' of git://github.com/robertkrimen/path-dispatcher
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list