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