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( _CODELIKE _REGEX _STRING );
  10 use Scalar::Util qw( blessed );
  11 use Sub::Identify qw( sub_name );
  12
  13 use Moose::Exporter;
  14
  15 Moose::Exporter->setup_import_methods(
  16     with_meta       => [qw( get get_html post put del chain_point )],
  17     as_is           => [qw( chained args capture_args path_part action )],
  18     class_metaroles => {
  19         class => ['CatalystX::Routes::Role::Class'],
  20     },
  21 );
  22
  23 sub get {
  24     _add_route( 'GET', @_ );
  25 }
  26
  27 sub get_html {
  28     _add_route( 'GET_html', @_ );
  29 }
  30
  31 sub post {
  32     _add_route( 'POST', @_ );
  33 }
  34
  35 sub put {
  36     _add_route( 'PUT', @_ );
  37 }
  38
  39 sub del {
  40     _add_route( 'DELETE', @_ );
  41 }
  42
  43 sub _add_route {
  44     my $rest = shift;
  45     my $meta = shift;
  46     my ( $name, $attrs, $sub ) = _process_args( $meta, @_ );
  47
  48     my $meth_base = '__route__' . $name;
  49
  50     _maybe_add_rest_route( $meta, $meth_base, $attrs );
  51
  52     my $meth_name = $meth_base . q{_} . $rest;
  53
  54     $meta->add_method( $meth_name => sub { goto &$sub } );
  55
  56     return;
  57 }
  58
  59 sub chain_point {
  60     my $meta = shift;
  61     my $name = shift;
  62     _add_chain_point( $meta, $name, chain_point => 1, @_ );
  63 }
  64
  65 sub _add_chain_point {
  66     my $meta = shift;
  67     my ( $name, $attrs, $sub ) = _process_args( $meta, @_ );
  68
  69     $meta->add_chain_point( $name => [ $attrs, $sub ] );
  70 }
  71
  72 sub _process_args {
  73     my $meta = shift;
  74     my $path = shift;
  75     my $sub  = pop;
  76
  77     my $caller = ( caller(2) )[3];
  78
  79     die
  80         "The $caller keyword expects a path string or regex as its first argument"
  81         unless _STRINGLIKE0($path) || _REGEX($path);
  82
  83     die "The $caller keyword expects a sub ref as its final argument"
  84         unless _CODELIKE($sub);
  85
  86     my %p = @_;
  87
  88     unless ( delete $p{chain_point} ) {
  89         $p{ActionClass} ||= 'REST::ForBrowsers';
  90     }
  91
  92     unless ( $p{PathPart} ) {
  93         my $part = $path;
  94
  95         unless ( exists $p{Chained} ) {
  96             unless ( $part =~ s{^/}{} ) {
  97                 $part = join q{/},
  98                     $meta->name()->action_namespace('FakeConfig'), $part;
  99             }
 100         }
 101
 102         $p{PathPart} = [$part];
 103     }
 104
 105     unless ( $p{CaptureArgs} || $p{Args} ) {
 106         $p{Args} = [0];
 107     }
 108
 109     unless ( exists $p{Chained} ) {
 110         $p{Chained} = q{/};
 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 sub chained ($) {
 143     return ( Chained => $_[0] );
 144 }
 145
 146 sub args ($) {
 147     return ( Args => [ $_[0] ] );
 148 }
 149
 150 sub capture_args ($) {
 151     return ( CaptureArgs => [ $_[0] ] );
 152 }
 153
 154 sub path_part ($) {
 155     return ( PathPart => [ $_[0] ] );
 156 }
 157
 158 sub action ($) {
 159     return ( ActionClass => [ $_[0] ] );
 160 }
 161
 162 # XXX - this should be added to Params::Util
 163 sub _STRINGLIKE0 ($) {
 164     return _STRING( $_[0] )
 165         || ( defined $_[0]
 166         && $_[0] eq q{} )
 167         || ( blessed $_[0]
 168         && overload::Method( $_[0], q{""} )
 169         && length "$_[0]" );
 170 }
 171
 172 {
 173
 174     # This is a nasty hack around some weird back compat code in
 175     # Catalyst::Controller->action_namespace
 176     package FakeConfig;
 177
 178     sub config {
 179         return { case_sensitive => 0 };
 180     }
 181 }
 182
 183 1;