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 ); |
73bef299 |
9 | use Params::Util qw( _CODELIKE _REGEX _STRING ); |
c4057ce2 |
10 | use Scalar::Util qw( blessed ); |
11 | |
12 | use Moose::Exporter; |
13 | |
14 | Moose::Exporter->setup_import_methods( |
73bef299 |
15 | with_meta => [qw( get get_html post put del chain_point )], |
05ac8ec7 |
16 | as_is => [qw( chained args capture_args path_part action )], |
c4057ce2 |
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; |
77d62699 |
45 | my ( $name, $attrs, $sub ) = _process_args( $meta, @_ ); |
c4057ce2 |
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 | |
73bef299 |
58 | sub chain_point { |
59 | my $meta = shift; |
60 | my $name = shift; |
61 | _add_chain_point( $meta, $name, chain_point => 1, @_ ); |
c4057ce2 |
62 | } |
63 | |
73bef299 |
64 | sub _add_chain_point { |
65 | my $meta = shift; |
66 | my ( $name, $attrs, $sub ) = _process_args( $meta, @_ ); |
77d62699 |
67 | |
73bef299 |
68 | $meta->add_chain_point( $name => [ $attrs, $sub ] ); |
c4057ce2 |
69 | } |
70 | |
71 | sub _process_args { |
77d62699 |
72 | my $meta = shift; |
c4057ce2 |
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 | |
73bef299 |
87 | unless ( delete $p{chain_point} ) { |
88 | $p{ActionClass} ||= 'REST::ForBrowsers'; |
cffed5b1 |
89 | } |
69d9fc4e |
90 | |
cffed5b1 |
91 | unless ( $p{PathPart} ) { |
92 | my $part = $path; |
73bef299 |
93 | |
94 | unless ( exists $p{Chained} ) { |
95 | unless ( $part =~ s{^/}{} ) { |
96 | $part = join q{/}, |
97 | $meta->name()->action_namespace('FakeConfig'), $part; |
98 | } |
69d9fc4e |
99 | } |
cffed5b1 |
100 | |
101 | $p{PathPart} = [$part]; |
69d9fc4e |
102 | } |
103 | |
73bef299 |
104 | unless ( $p{CaptureArgs} || $p{Args} ) { |
69d9fc4e |
105 | $p{Args} = [0]; |
106 | } |
107 | |
73bef299 |
108 | unless ( exists $p{Chained} ) { |
109 | $p{Chained} = q{/}; |
110 | } |
111 | |
c4057ce2 |
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 | |
73bef299 |
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 | |
c4057ce2 |
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 | |
77d62699 |
171 | { |
05ac8ec7 |
172 | |
77d62699 |
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 | |
c4057ce2 |
182 | 1; |