Fix wrong REQ key in test code

[catagits/CatalystX-Routes.git] / lib / CatalystX / Routes.pm

package CatalystX::Routes;

use strict;
use warnings;

use CatalystX::Routes::Role::Class;
use CatalystX::Routes::Role::Controller;
use Moose::Util qw( apply_all_roles );
use Params::Util qw( _CODELIKE _REGEX _STRING );
use Scalar::Util qw( blessed );

use Moose::Exporter;

Moose::Exporter->setup_import_methods(
    with_meta       => [qw( get get_html post put del chain_point )],
    as_is           => [qw( chained args capture_args path_part action )],
    class_metaroles => {
        class => ['CatalystX::Routes::Role::Class'],
    },
);

sub get {
    _add_route( 'GET', @_ );
}

sub get_html {
    _add_route( 'GET_html', @_ );
}

sub post {
    _add_route( 'POST', @_ );
}

sub put {
    _add_route( 'PUT', @_ );
}

sub del {
    _add_route( 'DELETE', @_ );
}

sub _add_route {
    my $rest = shift;
    my $meta = shift;
    my ( $name, $attrs, $sub ) = _process_args( $meta, @_ );

    my $meth_base = '__route__' . $name;

    _maybe_add_rest_route( $meta, $meth_base, $attrs );

    my $meth_name = $meth_base . q{_} . $rest;

    $meta->add_method( $meth_name => sub { goto &$sub } );

    return;
}

sub chain_point {
    my $meta = shift;
    my $name = shift;
    _add_chain_point( $meta, $name, chain_point => 1, @_ );
}

sub _add_chain_point {
    my $meta = shift;
    my ( $name, $attrs, $sub ) = _process_args( $meta, @_ );

    $meta->add_chain_point( $name => [ $attrs, $sub ] );
}

sub _process_args {
    my $meta = shift;
    my $path = shift;
    my $sub  = pop;

    my $caller = ( caller(2) )[3];

    die
        "The $caller keyword expects a path string or regex as its first argument"
        unless _STRINGLIKE0($path) || _REGEX($path);

    die "The $caller keyword expects a sub ref as its final argument"
        unless _CODELIKE($sub);

    my %p = @_;

    unless ( delete $p{chain_point} ) {
        $p{ActionClass} ||= 'REST::ForBrowsers';
    }

    unless ( $p{PathPart} ) {
        my $part = $path;

        unless ( exists $p{Chained} ) {
            unless ( $part =~ s{^/}{} ) {
                $part = join q{/},
                    $meta->name()->action_namespace('FakeConfig'), $part;
            }
        }

        $p{PathPart} = [$part];
    }

    unless ( $p{CaptureArgs} || $p{Args} ) {
        $p{Args} = [0];
    }

    unless ( exists $p{Chained} ) {
        $p{Chained} = q{/};
    }

    ( my $name = $path ) =~ s/(\W)/'X' . sprintf( '%x', ord($1) )/eg;

    return $name, \%p, $sub;
}

sub _maybe_add_rest_route {
    my $meta  = shift;
    my $name  = shift;
    my $attrs = shift;

    return if $meta->has_method($name);

    # This could be done by Moose::Exporter, but that would require that the
    # module has already inherited from Cat::Controller when it calls "use
    # CatalystX::Routes".
    unless ( $meta->does_role('CatalystX::Routes::Role::Controller') ) {
        apply_all_roles(
            $meta->name(),
            'CatalystX::Routes::Role::Controller'
        );
    }

    $meta->add_method( $name => sub { } );

    $meta->add_route( $name => [ $attrs, $meta->get_method($name) ] );

    return;
}

sub chained ($) {
    return ( Chained => $_[0] );
}

sub args ($) {
    return ( Args => [ $_[0] ] );
}

sub capture_args ($) {
    return ( CaptureArgs => [ $_[0] ] );
}

sub path_part ($) {
    return ( PathPart => [ $_[0] ] );
}

sub action ($) {
    return ( ActionClass => [ $_[0] ] );
}

# XXX - this should be added to Params::Util
sub _STRINGLIKE0 ($) {
    return _STRING( $_[0] )
        || ( defined $_[0]
        && $_[0] eq q{} )
        || ( blessed $_[0]
        && overload::Method( $_[0], q{""} )
        && length "$_[0]" );
}

{

    # This is a nasty hack around some weird back compat code in
    # Catalyst::Controller->action_namespace
    package FakeConfig;

    sub config {
        return { case_sensitive => 0 };
    }
}

1;