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         unless ( $p{PathPart} ) {
 100             my $part = $path;
 101             unless ( $part =~ s{^/}{} ) {
 102                 $part = $meta->name()->action_namespace('FakeConfig') . q{/} . $part;
 103             }
 104
 105             $p{PathPart} = [$part];
 106         }
 107     }
 108
 109     unless ( $p{Args} || $p{Local} ) {
 110         $p{Args} = [0];
 111     }
 112
 113     ( my $name = $path ) =~ s/(\W)/'X' . sprintf( '%x', ord($1) )/eg;
 114
 115     return $name, \%p, $sub;
 116 }
 117
 118 sub _maybe_add_rest_route {
 119     my $meta  = shift;
 120     my $name  = shift;
 121     my $attrs = shift;
 122
 123     return if $meta->has_method($name);
 124
 125     # This could be done by Moose::Exporter, but that would require that the
 126     # module has already inherited from Cat::Controller when it calls "use
 127     # CatalystX::Routes".
 128     unless ( $meta->does_role('CatalystX::Routes::Role::Controller') ) {
 129         apply_all_roles(
 130             $meta->name(),
 131             'CatalystX::Routes::Role::Controller'
 132         );
 133     }
 134
 135     $meta->add_method( $name => sub { } );
 136
 137     $meta->add_route( $name => [ $attrs, $meta->get_method($name) ] );
 138
 139     return;
 140 }
 141
 142 # XXX - this should be added to Params::Util
 143 sub _STRINGLIKE0 ($) {
 144     return _STRING( $_[0] )
 145         || ( defined $_[0]
 146         && $_[0] eq q{} )
 147         || ( blessed $_[0]
 148         && overload::Method( $_[0], q{""} )
 149         && length "$_[0]" );
 150 }
 151
 152 {
 153     # This is a nasty hack around some weird back compat code in
 154     # Catalyst::Controller->action_namespace
 155     package FakeConfig;
 156
 157     sub config {
 158         return { case_sensitive => 0 };
 159     }
 160 }
 161
 162 1;