libpath-dispatcher-declarative-perl 0.03-1 / usr / share / perl5 / Path / Dispatcher / Declarative.pm

package Path::Dispatcher::Declarative;
use strict;
use warnings;
use 5.008001;

our $VERSION = '0.03';

use Path::Dispatcher;
use Path::Dispatcher::Declarative::Builder;
use Sub::Exporter;

use constant dispatcher_class => 'Path::Dispatcher';
use constant builder_class => 'Path::Dispatcher::Declarative::Builder';

our $CALLER; # Sub::Exporter doesn't make this available

my $exporter = Sub::Exporter::build_exporter({
    into_level => 1,
    groups => {
        default => \&build_sugar,
    },
});

sub import {
    my $self = shift;
    my $pkg  = caller;

    my @args = grep { !/^-base$/i } @_;

    # 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;

    $class->populate_defaults($arg);

    my $dispatcher = $class->dispatcher_class->new(name => $into);

    my $builder = $class->builder_class->new(
        dispatcher => $dispatcher,
        %$arg,
    );

    return {
        dispatcher    => sub { $builder->dispatcher },
        rewrite       => sub { $builder->rewrite(@_) },
        on            => sub { $builder->on(@_) },
        under         => sub { $builder->under(@_) },
        redispatch_to => sub { $builder->redispatch_to(@_) },
        enum          => sub { $builder->enum(@_) },
        next_rule     => sub { $builder->next_rule(@_) },
        last_rule     => sub { $builder->last_rule(@_) },
        complete      => sub { $builder->complete(@_) },

        then  => sub (&) { $builder->then(@_) },
        chain => sub (&) { $builder->chain(@_) },

        # 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; $builder->dispatch(@_) },
        run      => sub { shift if caller ne $into; $builder->run(@_) },
    };
}

sub populate_defaults {
    my $class = shift;
    my $arg  = shift;

    for my $option ('token_delimiter', 'case_sensitive_tokens') {
        next if exists $arg->{$option};
        next unless $class->can($option);

        my $default = $class->$option;
        next unless defined $default; # use the builder's default

        $arg->{$option} = $class->$option;
    }
}


1;

__END__

=head1 NAME

Path::Dispatcher::Declarative - sugary dispatcher

=head1 SYNOPSIS

    package MyApp::Dispatcher;
    use Path::Dispatcher::Declarative -base;

    on score => sub { show_score() };

    on ['wield', qr/^\w+$/] => sub { wield_weapon($2) };

    rewrite qr/^inv/ => "display inventory";

    under display => sub {
        on inventory => sub { show_inventory() };
        on score     => sub { show_score() };
    };

    package Interpreter;
    MyApp::Dispatcher->run($input);

=head1 DESCRIPTION

L<Jifty::Dispatcher> rocks!

=head1 KEYWORDS

=head2 dispatcher -> Dispatcher

Returns the L<Path::Dispatcher> object for this class; the object that the
sugar is modifying. This is useful for adding custom rules through the regular
API, and inspection.

=head2 dispatch path -> Dispatch

Invokes the dispatcher on the given path and returns a
L<Path::Dispatcher::Dispatch> object. Acts as a keyword within the same
package; otherwise as a method (since these declarative dispatchers are
supposed to be used by other packages).

=head2 run path, args

Performs a dispatch then invokes the L<Path::Dispatcher::Dispatch/run> method
on it.

=head2 on path => sub {}

Adds a rule to the dispatcher for the given path. The path may be:

=over 4

=item a string

This is taken to mean a single token; creates an
L<Path::Dispatcher::Rule::Tokens> rule.

=item an array reference

This is creates a L<Path::Dispatcher::Rule::Tokens> rule.

=item a regular expression

This is creates a L<Path::Dispatcher::Rule::Regex> rule.

=item a code reference

This is creates a L<Path::Dispatcher::Rule::CodeRef> rule.

=back

=head2 under path => sub {}

Creates a L<Path::Dispatcher::Rule::Under> rule. The contents of the coderef
should be nothing other L</on> and C<under> calls.

=head2 then sub { }

Creates a L<Path::Dispatcher::Rule::Always> rule that will continue on to the
next rule via C<next_rule>

The only argument is a coderef that processes normally (like L<on>).

NOTE: You *can* avoid running a following rule by using C<last_rule>.

An example:

    under show => sub {
        then {
            print "Displaying ";
        };
        on inventory => sub {
            print "inventory:\n";
            ...
        };
        on score => sub {
            print "score:\n";
            ...
        };

=head1 AUTHOR

Shawn M Moore, C<< <sartak at bestpractical.com> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-path-dispatcher-declarative at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Path-Dispatcher-Declarative>.

=head1 COPYRIGHT & LICENSE

Copyright 2008-2010 Best Practical Solutions.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut