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; |
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{^/}{} ) { |
102 | $part = $meta->name()->action_namespace('FakeConfig') . q{/} . $part; |
103 | } |
104 | |
69d9fc4e |
105 | $p{PathPart} = [$part]; |
106 | } |
107 | } |
108 | |
c71f7ddd |
109 | unless ( $p{Args} ) { |
69d9fc4e |
110 | $p{Args} = [0]; |
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 | |
142 | # XXX - this should be added to Params::Util |
143 | sub _STRINGLIKE0 ($) { |
144 | return _STRING( $_[0] ) |
145 | || ( defined $_[0] |
146 | && $_[0] eq q{} ) |
147 | || ( blessed $_[0] |
148 | && overload::Method( $_[0], q{""} ) |
149 | && length "$_[0]" ); |
150 | } |
151 | |
77d62699 |
152 | { |
153 | # This is a nasty hack around some weird back compat code in |
154 | # Catalyst::Controller->action_namespace |
155 | package FakeConfig; |
156 | |
157 | sub config { |
158 | return { case_sensitive => 0 }; |
159 | } |
160 | } |
161 | |
c4057ce2 |
162 | 1; |