view release on metacpan or  search on metacpan

lib/Jifty/Dispatcher.pm  view on Meta::CPAN

sub show (;$@)    { _ret @_ }    # render a page
sub dispatch ($@) { _ret @_ }    # run dispatch again with another URI
sub redirect ($@) { _ret @_ }    # web redirect
sub tangent ($@)  { _ret @_ }    # web tangent
sub abort (;$@)   { _ret @_ }    # abort request
sub default ($$@) { _ret @_ }    # set parameter if it's not yet set
sub set ($$@)     { _ret @_ }    # set parameter
sub del ($@)      { _ret @_ }    # remove parameter
sub get ($) {
    my $val = $Request->template_argument( $_[0] );
    return $val if defined $val;
    return $Request->argument( $_[0] );
}

sub _qualify ($@);
sub GET ($)     { _qualify method => @_ }
sub POST ($)    { _qualify method => @_ }
sub PUT ($)     { _qualify method => @_ }
sub HEAD ($)    { _qualify method => @_ }
sub DELETE ($)  { _qualify method => @_ }
sub OPTIONS ($) { _qualify method => @_ }

sub HTTPS ($)   { _qualify https  => @_ }
sub HTTP ($)    { _qualify http   => @_ }

sub plugin ($) { return { plugin => @_ } }
sub app ()     { return { plugin => 'Jifty' } }

our $CURRENT_STAGE;

=head2 import

Jifty::Dispatcher is an L<Exporter>, that is, part of its role is to
blast a bunch of symbols into another package. In this case, that
other package is the dispatcher for your application.

You never call import directly. Just:

    use Jifty::Dispatcher -base;

in C<MyApp::Dispatcher>

=cut

sub import {
    my $class = shift;
    my $pkg   = caller;
    my @args  = grep { !/^-[Bb]ase/ } @_;

    no strict 'refs';
    no warnings 'once';
    for (qw(RULES_RUN RULES_SETUP RULES_CLEANUP RULES_DEFERRED)) {
        @{ $pkg . '::' . $_ } = ();
    }
    if ( @args != @_ ) {

        # User said "-base", let's push ourselves into their @ISA.
        push @{ $pkg . '::ISA' }, $class;

        # Turn on strict and warnings for them too, a la Moose
        strict->import;
        warnings->import;
    }

    $class->export_to_level( 1, @args );
}

###################################################
# Magically figure out the arity based on caller info.
sub _ret (@) {
    my $pkg   = caller(1);
    my $sub   = ( caller(1) )[3];
    my $proto = prototype($sub);
    my $op    = $sub;

    $proto =~ tr/@;//d;
    if ( my $idx = rindex( $op, '::' ) ) {
        $op = substr( $op, $idx + 2 );
    }

    if ($Dispatcher) {

        # We are under an operation -- carry the rule forward
        foreach my $rule ( [ $op => splice( @_, 0, length($proto) ) ], @_ ) {
            $Dispatcher->_handle_rule($rule);
        }
    } elsif (wantarray) {
        ( [ $op => splice( @_, 0, length($proto) ) ], @_ );
    } elsif ( defined wantarray ) {
        [ [ $op => splice( @_, 0, length($proto) ) ], @_ ];
    } else {
        _push_rule($pkg, [ $op => splice( @_, 0, length($proto) ) ] );
    }
}

sub _push_rule($$) {
    my($pkg, $rule) = @_;
    my $op = $rule->[0];
    my $ruleset;
    if ( ($op eq "before" or $op eq "after") and ref $rule->[1] and ref $rule->[1] eq 'HASH' and $rule->[1]{plugin} ) {
        $ruleset = 'RULES_DEFERRED';
    } elsif ( $op eq 'before' ) {
        $ruleset = 'RULES_SETUP';
    } elsif ( $op eq 'after' ) {
        $ruleset = 'RULES_CLEANUP';
    } else {
        $ruleset = 'RULES_RUN';
    }
    no strict 'refs';
    # XXX TODO, need to spec stage here.
    push @{ $pkg . '::' . $ruleset }, $rule;
}

sub _qualify ($@) {
    my $key = shift;
    my $op  = ( caller(1) )[3];
    $op =~ s/.*:://;
    return { $key => $op, '' => $_[0] };
}

=head2 rules STAGE