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     ( my $name = $path ) =~ s/(\W)/'X' . sprintf( '%x', ord($1) )/eg;
  96
  97     return $name, \%p, $sub;
  98 }
  99
 100 sub _maybe_add_rest_route {
 101     my $meta  = shift;
 102     my $name  = shift;
 103     my $attrs = shift;
 104
 105     return if $meta->has_method($name);
 106
 107     # This could be done by Moose::Exporter, but that would require that the
 108     # module has already inherited from Cat::Controller when it calls "use
 109     # CatalystX::Routes".
 110     unless ( $meta->does_role('CatalystX::Routes::Role::Controller') ) {
 111         apply_all_roles(
 112             $meta->name(),
 113             'CatalystX::Routes::Role::Controller'
 114         );
 115     }
 116
 117     $meta->add_method( $name => sub { } );
 118
 119     $meta->add_route( $name => [ $attrs, $meta->get_method($name) ] );
 120
 121     return;
 122 }
 123
 124 # XXX - this should be added to Params::Util
 125 sub _STRINGLIKE0 ($) {
 126     return _STRING( $_[0] )
 127         || ( defined $_[0]
 128         && $_[0] eq q{} )
 129         || ( blessed $_[0]
 130         && overload::Method( $_[0], q{""} )
 131         && length "$_[0]" );
 132 }
 133
 134 1;