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