File Coverage

blib/lib/Catalyst/Plugin/SmartURI.pm
Criterion Covered Total %
statement 86 87 98.8
branch 24 32 75.0
condition 8 22 36.3
subroutine 17 17 100.0
pod 4 7 57.1
total 139 165 84.2


line stmt bran cond sub pod time code
1             package Catalyst::Plugin::SmartURI;
2             our $AUTHORITY = 'cpan:RKITOVER';
3             $Catalyst::Plugin::SmartURI::VERSION = '0.041';
4 4     4   7077886 use Moose;
  4         9  
  4         32  
5 4     4   23610 use mro 'c3';
  4         8  
  4         36  
6              
7 4     4   216 use 5.008001;
  4         13  
8 4     4   3186 use Class::C3::Componentised;
  4         4884  
  4         116  
9 4     4   22 use Scalar::Util 'weaken';
  4         6  
  4         240  
10 4     4   21 use Catalyst::Exception ();
  4         8  
  4         57  
11 4     4   17 use Class::Load ();
  4         8  
  4         72  
12              
13 4     4   20 use namespace::clean -except => 'meta';
  4         8  
  4         46  
14              
15             has uri_disposition => (is => 'rw', isa => 'Str');
16             has uri_class => (is => 'rw', isa => 'Str');
17              
18             my $context; # keep a weakend copy for the Request class to use
19              
20             my ($conf_disposition, $conf_uri_class); # configured values
21              
22             =head1 NAME
23              
24             Catalyst::Plugin::SmartURI - Configurable URIs for Catalyst
25              
26             =head1 SYNOPSIS
27              
28             In your lib/MyApp.pm, load the plugin and your other plugins, for example:
29              
30             use Catalyst qw/
31             -Debug
32             ConfigLoader
33             Static::Simple
34             Session
35             Session::Store::Memcached
36             Session::State::Cookie
37             Authentication
38             Authorization::Roles
39             +CatalystX::SimpleLogin
40             SmartURI
41             /;
42              
43             In your .conf:
44              
45             <Plugin::SmartURI>
46             disposition host-header # application-wide
47             uri_class URI::SmartURI # by default
48             </Plugin::SmartURI>
49              
50             Per request:
51              
52             $c->uri_disposition('absolute');
53              
54             Methods on URIs:
55              
56             <a href="[% c.uri_for('/foo').relative %]" ...
57              
58             =head1 DESCRIPTION
59              
60             Configure whether C<< $c->uri_for >> and C<< $c->req->uri_with >> return absolute, hostless or
61             relative URIs, or URIs based on the 'Host' header. Also allows configuring which
62             URI class to use. Works on application-wide or per-request basis.
63              
64             This is useful in situations where you're for example, redirecting to a lighttpd
65             from a firewall rule, instead of a real proxy, and you want your links and
66             redirects to still work correctly.
67              
68             To use your own URI class, just subclass L<URI::SmartURI> and set
69             C<uri_class>, or write a class that follows the same interface.
70              
71             This plugin installs a custom C<< $c->request_class >>, however it does so in a way
72             that won't break if you've already set C<< $c->request_class >> yourself, ie. by
73             using L<Catalyst::Action::REST> (thanks mst!).
74              
75             There is a minor performance penalty in perls older than 5.10, due to
76             L<Class::C3>, but only at initialization time.
77              
78             =head1 METHODS
79              
80             =head2 $c->uri_for
81              
82             =head2 $c->req->uri_with
83              
84             Returns a C<< $c->uri_class >> object (L<URI::SmartURI> by default) in the configured
85             C<< $c->uri_disposition >>.
86              
87             =head2 $c->req->uri
88              
89             Returns a C<< $c->uri_class >> object. If the context hasn't been prepared yet, uses
90             the configured value for C<uri_class>.
91              
92             C<< $c->req->uri->relative >> will be relative to C<< $c->req->base >>.
93              
94             =head2 $c->req->referer
95              
96             Returns a C<< $c->uri_class >> object for the referer (or configured C<uri_class> if
97             there's no context) with reference set to C<< $c->req->uri >> if it comes from
98             C<< $c->req->base >>.
99              
100             In other words, if referer is your app, you can do
101             C<< $c->req->referer->relative >> and it will do the right thing.
102              
103             =head1 CONFIGURATION
104              
105             In myapp.conf:
106              
107             <Plugin::SmartURI>
108             disposition absolute
109             uri_class URI::SmartURI
110             </Plugin::SmartURI>
111              
112             =over
113              
114             =item disposition
115              
116             One of 'absolute', 'hostless', 'relative' or 'host-header'. Defaults to
117             'absolute'.
118              
119             The special disposition 'host-header' uses the value of your 'Host:' header.
120              
121             =item uri_class
122              
123             The class to use for URIs, defaults to L<URI::SmartURI>.
124              
125             =back
126              
127             =head1 PER REQUEST
128              
129             package MyAPP::Controller::RSSFeed;
130              
131             ...
132              
133             sub begin : Private {
134             my ($self, $c) = @_;
135              
136             $c->uri_class('Your::URI::Class::For::Request');
137             $c->uri_disposition('absolute');
138             }
139              
140             =over
141              
142             =item $c->uri_disposition('absolute'|'hostless'|'relative'|'host-header')
143              
144             Set URI disposition to use for the duration of the request.
145              
146             =item $c->uri_class($class)
147              
148             Set the URI class to use for C<< $c->uri_for >> and C<< $c->req->uri_with >> for the
149             duration of the request.
150              
151             =back
152              
153             =head1 EXTENDING
154              
155             C<< $c->prepare_uri >> actually creates the URI, which you can override.
156              
157             =cut
158              
159             sub uri_for {
160 6     6 1 10130 my $c = shift;
161              
162 6         27 $c->prepare_uri($c->next::method(@_))
163             }
164              
165             {
166             package Catalyst::Request::SmartURI;
167             our $AUTHORITY = 'cpan:RKITOVER';
168             $Catalyst::Request::SmartURI::VERSION = '0.041';
169 4     4   1516 use Moose;
  4         6  
  4         26  
170             extends 'Catalyst::Request';
171 4     4   22802 use namespace::clean -except => 'meta';
  4         11  
  4         23  
172              
173             sub uri_with {
174 2     2 1 8083 my $req = shift;
175              
176 2         10 $context->prepare_uri($req->next::method(@_))
177             }
178              
179             sub uri {
180 46     46 1 147888 my $req = shift;
181              
182 46 100       788 my $uri_class = $context ? $context->uri_class : $conf_uri_class;
183              
184 46         182 my $uri = $req->next::method(@_);
185              
186 46 100       1819 return $uri if not defined $uri;
187              
188             $req->next::method(
189             $uri_class->new(
190             $req->next::method(@_),
191 45 100       153 ($req->{base} ? { reference => $req->base } : ())
192             )
193             )
194             }
195              
196             sub referer {
197 4     4 1 12883 my $req = shift;
198              
199 4 50       146 my $uri_class = $context ? $context->uri_class : $conf_uri_class;
200              
201 4         19 my $referer = $req->next::method(@_);
202              
203 4 100       318 return $referer if not defined $referer;
204              
205 3         84 my $base = $req->base;
206 3         24 my $uri = $req->uri;
207              
208 3 50       699 if ($referer =~ /^$base/) {
209 0         0 return $uri_class->new($referer, { reference => $uri })
210             } else {
211 3         549 return $uri_class->new($referer);
212             }
213             }
214              
215             __PACKAGE__->meta->make_immutable;
216             }
217              
218             sub setup {
219 4     4 0 1089297 my $app = shift;
220 4   33     39 my $config =$app->config->{'Plugin::SmartURI'} || $app->config->{smarturi};
221              
222 4         463 ($conf_uri_class, $conf_disposition) = @$config{qw/uri_class disposition/};
223 4   50     17 $conf_uri_class ||= 'URI::SmartURI';
224 4   50     22 $conf_disposition ||= 'absolute';
225              
226 4         12 eval { Class::Load::load_class($conf_uri_class) };
  4         30  
227 4 50       160298 Catalyst::Exception->throw(
228             message => "Could not load configured uri_class $conf_uri_class: $@"
229             ) if $@;
230              
231 4         104 my $request_class = $app->request_class;
232              
233 4 50       354 unless ($request_class->isa('Catalyst::Request::SmartURI')) {
234 4         15 my $new_request_class = $app.'::Request::SmartURI';
235              
236             my $inject_rest = (not $request_class->isa('Catalyst::Request::REST'))
237 4   33     44 && eval { Class::Load::load_class('Catalyst::Request::REST') };
238              
239 4 50       249207 Class::C3::Componentised->inject_base(
240             $new_request_class,
241             'Catalyst::Request::SmartURI',
242             ($inject_rest ?
243             'Catalyst::Request::REST' : ()),
244             $request_class,
245             );
246 4         666 Class::C3::reinitialize();
247              
248 4         45 $app->request_class($new_request_class);
249             }
250              
251 4         177 $app->next::method(@_)
252             }
253              
254             sub prepare_uri {
255 8     8 0 3417 my ($c, $uri) = @_;
256 8   33     315 my $disposition = $c->uri_disposition || $conf_disposition;
257 8   33     298 my $uri_class = $c->uri_class || $conf_uri_class;
258             # Need the || for $c->welcome_message, otherwise initialization works fine.
259              
260 8         16 eval { Class::Load::load_class($uri_class) };
  8         40  
261 8 50       448 Catalyst::Exception->throw(
262             message => "Could not load configured uri_class $uri_class: $@"
263             ) if $@;
264              
265 8         17 my $res;
266 8 100       33 if ($disposition eq 'host-header') {
267 2         10 $res = $uri_class->new($uri, { reference => $c->req->uri })->absolute;
268 2         1408 my $host = $c->req->header('Host');
269 2 100       940 my $port = $host =~ s/:(\d+)$// ? $1 : '';
270              
271 2 100       7 if ($port) {
272 1 50 33     4 $port = '' if $c->req->uri->scheme eq 'http' && $port == 80;
273 1 50 33     289 $port = '' if $c->req->uri->scheme eq 'https' && $port == 443;
274             }
275              
276 2         278 $res->host($host);
277 2 100       659 $res->port($port) if $port;
278             } else {
279 6         28 $res = $uri_class->new($uri, { reference => $c->req->uri })->$disposition
280             }
281              
282 8         10843 $res
283             }
284              
285             # Reset accessors to configured values at beginning of request.
286             sub prepare {
287 13     13 0 79761 my $app = shift;
288              
289             # Also save a copy of the context for the Request class to use.
290 13         94 my $c = $context = $app->next::method(@_);
291 13         25844 weaken $context;
292              
293 13         573 $c->uri_class($conf_uri_class);
294 13         526 $c->uri_disposition($conf_disposition);
295              
296 13         39 $c
297             }
298              
299             __PACKAGE__->meta->make_immutable;
300              
301             =head1 SEE ALSO
302              
303             L<URI::SmartURI>, L<Catalyst>, L<URI>
304              
305             =head1 AUTHOR
306              
307             Rafael Kitover, C<< <rkitover at cpan.org> >>
308              
309             =head1 BUGS
310              
311             Please report any bugs or feature requests to
312             C<bug-catalyst-plugin-smarturi at rt.cpan.org>, or through the web
313             interface at
314             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Plugin-SmartURI>. I
315             will be notified, and then you'll automatically be notified of progress on your
316             bug as I make changes.
317              
318             =head1 SUPPORT
319              
320             You can find documentation for this module with the perldoc command.
321              
322             perldoc Catalyst::Plugin::SmartURI
323              
324             You can also look for information at:
325              
326             =over 4
327              
328             =item * RT: CPAN's request tracker
329              
330             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Plugin-SmartURI>
331              
332             =item * AnnoCPAN: Annotated CPAN documentation
333              
334             L<http://annocpan.org/dist/Catalyst-Plugin-SmartURI>
335              
336             =item * CPAN Ratings
337              
338             L<http://cpanratings.perl.org/d/Catalyst-Plugin-SmartURI>
339              
340             =item * Search CPAN
341              
342             L<http://search.cpan.org/dist/Catalyst-Plugin-SmartURI>
343              
344             =back
345              
346             =head1 ACKNOWLEDGEMENTS
347              
348             from #catalyst:
349              
350             vipul came up with the idea
351              
352             mst came up with the design and implementation details for the current version
353              
354             kd reviewed my code and offered suggestions
355              
356             =head1 TODO
357              
358             I'd like to extend on L<Catalyst::Plugin::RequireSSL>, and make a plugin that
359             rewrites URIs for actions with an SSL attribute.
360              
361             =head1 COPYRIGHT & LICENSE
362              
363             Copyright (c) 2008 Rafael Kitover
364              
365             This program is free software; you can redistribute it and/or modify it under
366             the same terms as Perl itself.
367              
368             =cut
369              
370             __PACKAGE__; # End of Catalyst::Plugin::SmartURI
371              
372             # vim: expandtab shiftwidth=4 tw=80: