lib/CatalystX/Routes.pm

   1 package CatalystX::Routes;
   2
   3 use strict;
   4 use warnings;
   5
   6 use CatalystX::Routes::Role::Class;
   7 use CatalystX::Routes::Role::Controller;
   8 use Moose::Util qw( apply_all_roles );
   9 use Params::Util qw( _STRING _CODELIKE );
  10 use Scalar::Util qw( blessed );
  11
  12 use Moose::Exporter;
  13
  14 Moose::Exporter->setup_import_methods(
  15     with_meta => [qw( get get_html post put del )],
  16     as_is     => [qw( chained args capture_args path_part action )],
  17     class_metaroles => {
  18         class => ['CatalystX::Routes::Role::Class'],
  19     },
  20 );
  21
  22 sub get {
  23     _add_route( 'GET', @_ );
  24 }
  25
  26 sub get_html {
  27     _add_route( 'GET_html', @_ );
  28 }
  29
  30 sub post {
  31     _add_route( 'POST', @_ );
  32 }
  33
  34 sub put {
  35     _add_route( 'PUT', @_ );
  36 }
  37
  38 sub del {
  39     _add_route( 'DELETE', @_ );
  40 }
  41
  42 sub _add_route {
  43     my $rest = shift;
  44     my $meta = shift;
  45     my ( $name, $attrs, $sub ) = _process_args(@_);
  46
  47     my $meth_base = '__route__' . $name;
  48
  49     _maybe_add_rest_route( $meta, $meth_base, $attrs );
  50
  51     my $meth_name = $meth_base . q{_} . $rest;
  52
  53     $meta->add_method( $meth_name => sub { goto &$sub } );
  54
  55     return;
  56 }
  57
  58 sub path_part ($) {
  59     return ( PathPart => [ $_[0] ] );
  60 }
  61
  62 sub chained ($) {
  63     return ( Chained => [ $_[0] ] );
  64 }
  65
  66 sub args ($) {
  67     return ( Args => [ $_[0] ] );
  68 }
  69
  70 sub capture_args ($) {
  71     return ( CaptureArgs => [ $_[0] ] );
  72 }
  73
  74 sub action ($) {
  75     return ( ActionClass => [ $_[0] ] );
  76 }
  77
  78 sub _process_args {
  79     my $path = shift;
  80     my $sub  = pop;
  81
  82     my $caller = ( caller(2) )[3];
  83
  84     die
  85         "The $caller keyword expects a path string or regex as its first argument"
  86         unless _STRINGLIKE0($path) || _REGEX($path);
  87
  88     die "The $caller keyword expects a sub ref as its final argument"
  89         unless _CODELIKE($sub);
  90
  91     my %p = @_;
  92
  93     $p{ActionClass} ||= 'REST';
  94
  95     unless ( exists $p{Chained} ) {
  96         $p{Chained} = q{/};
  97
  98         unless ( exists $p{PathPart} ) {
  99             ( my $part = $path ) =~ s{^/}{};
 100             $p{PathPart} = [$part];
 101         }
 102     }
 103
 104     unless ( exists $p{Args} ) {
 105         $p{Args} = [0];
 106     }
 107
 108     ( my $name = $path ) =~ s/(\W)/'X' . sprintf( '%x', ord($1) )/eg;
 109
 110     return $name, \%p, $sub;
 111 }
 112
 113 sub _maybe_add_rest_route {
 114     my $meta  = shift;
 115     my $name  = shift;
 116     my $attrs = shift;
 117
 118     return if $meta->has_method($name);
 119
 120     # This could be done by Moose::Exporter, but that would require that the
 121     # module has already inherited from Cat::Controller when it calls "use
 122     # CatalystX::Routes".
 123     unless ( $meta->does_role('CatalystX::Routes::Role::Controller') ) {
 124         apply_all_roles(
 125             $meta->name(),
 126             'CatalystX::Routes::Role::Controller'
 127         );
 128     }
 129
 130     $meta->add_method( $name => sub { } );
 131
 132     $meta->add_route( $name => [ $attrs, $meta->get_method($name) ] );
 133
 134     return;
 135 }
 136
 137 # XXX - this should be added to Params::Util
 138 sub _STRINGLIKE0 ($) {
 139     return _STRING( $_[0] )
 140         || ( defined $_[0]
 141         && $_[0] eq q{} )
 142         || ( blessed $_[0]
 143         && overload::Method( $_[0], q{""} )
 144         && length "$_[0]" );
 145 }
 146
 147 1;