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( $meta, @_ );
  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 chained ($) {
  59     return ( Chained => [ $_[0] ] );
  60 }
  61
  62 sub args ($) {
  63     return ( Args => [ $_[0] ] );
  64 }
  65
  66 sub capture_args ($) {
  67     return ( CaptureArgs => [ $_[0] ] );
  68 }
  69
  70 sub path_part ($) {
  71     return ( PathPart => [ $_[0] ] );
  72 }
  73
  74 sub action ($) {
  75     return ( ActionClass => [ $_[0] ] );
  76 }
  77
  78 sub _process_args {
  79     my $meta = shift;
  80     my $path = shift;
  81     my $sub  = pop;
  82
  83     my $caller = ( caller(2) )[3];
  84
  85     die
  86         "The $caller keyword expects a path string or regex as its first argument"
  87         unless _STRINGLIKE0($path) || _REGEX($path);
  88
  89     die "The $caller keyword expects a sub ref as its final argument"
  90         unless _CODELIKE($sub);
  91
  92     my %p = @_;
  93
  94     $p{ActionClass} ||= 'REST::ForBrowsers';
  95
  96     unless ( exists $p{Chained} ) {
  97         $p{Chained} = q{/};
  98     }
  99
 100     unless ( $p{PathPart} ) {
 101         my $part = $path;
 102         unless ( $part =~ s{^/}{} ) {
 103             $part = join q{/},
 104                 $meta->name()->action_namespace('FakeConfig'), $part;
 105         }
 106
 107         $p{PathPart} = [$part];
 108     }
 109
 110     unless ( $p{Args} ) {
 111         $p{Args} = [0];
 112     }
 113
 114     ( my $name = $path ) =~ s/(\W)/'X' . sprintf( '%x', ord($1) )/eg;
 115
 116     return $name, \%p, $sub;
 117 }
 118
 119 sub _maybe_add_rest_route {
 120     my $meta  = shift;
 121     my $name  = shift;
 122     my $attrs = shift;
 123
 124     return if $meta->has_method($name);
 125
 126     # This could be done by Moose::Exporter, but that would require that the
 127     # module has already inherited from Cat::Controller when it calls "use
 128     # CatalystX::Routes".
 129     unless ( $meta->does_role('CatalystX::Routes::Role::Controller') ) {
 130         apply_all_roles(
 131             $meta->name(),
 132             'CatalystX::Routes::Role::Controller'
 133         );
 134     }
 135
 136     $meta->add_method( $name => sub { } );
 137
 138     $meta->add_route( $name => [ $attrs, $meta->get_method($name) ] );
 139
 140     return;
 141 }
 142
 143 # XXX - this should be added to Params::Util
 144 sub _STRINGLIKE0 ($) {
 145     return _STRING( $_[0] )
 146         || ( defined $_[0]
 147         && $_[0] eq q{} )
 148         || ( blessed $_[0]
 149         && overload::Method( $_[0], q{""} )
 150         && length "$_[0]" );
 151 }
 152
 153 {
 154
 155     # This is a nasty hack around some weird back compat code in
 156     # Catalyst::Controller->action_namespace
 157     package FakeConfig;
 158
 159     sub config {
 160         return { case_sensitive => 0 };
 161     }
 162 }
 163
 164 1;