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