Commit | Line | Data |
c4057ce2 |
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; |