package Catalyst::Plugin::SmartURI; our $AUTHORITY = 'cpan:RKITOVER'; $Catalyst::Plugin::SmartURI::VERSION = '0.041'; use Moose; use mro 'c3'; use 5.008001; use Class::C3::Componentised; use Scalar::Util 'weaken'; use Catalyst::Exception (); use Class::Load (); use namespace::clean -except => 'meta'; has uri_disposition => (is => 'rw', isa => 'Str'); has uri_class => (is => 'rw', isa => 'Str'); my $context; # keep a weakend copy for the Request class to use my ($conf_disposition, $conf_uri_class); # configured values =head1 NAME Catalyst::Plugin::SmartURI - Configurable URIs for Catalyst =head1 SYNOPSIS In your lib/MyApp.pm, load the plugin and your other plugins, for example: use Catalyst qw/ -Debug ConfigLoader Static::Simple Session Session::Store::Memcached Session::State::Cookie Authentication Authorization::Roles +CatalystX::SimpleLogin SmartURI /; In your .conf: disposition host-header # application-wide uri_class URI::SmartURI # by default Per request: $c->uri_disposition('absolute'); Methods on URIs: uri_for >> and C<< $c->req->uri_with >> return absolute, hostless or relative URIs, or URIs based on the 'Host' header. Also allows configuring which URI class to use. Works on application-wide or per-request basis. This is useful in situations where you're for example, redirecting to a lighttpd from a firewall rule, instead of a real proxy, and you want your links and redirects to still work correctly. To use your own URI class, just subclass L and set C, or write a class that follows the same interface. This plugin installs a custom C<< $c->request_class >>, however it does so in a way that won't break if you've already set C<< $c->request_class >> yourself, ie. by using L (thanks mst!). There is a minor performance penalty in perls older than 5.10, due to L, but only at initialization time. =head1 METHODS =head2 $c->uri_for =head2 $c->req->uri_with Returns a C<< $c->uri_class >> object (L by default) in the configured C<< $c->uri_disposition >>. =head2 $c->req->uri Returns a C<< $c->uri_class >> object. If the context hasn't been prepared yet, uses the configured value for C. C<< $c->req->uri->relative >> will be relative to C<< $c->req->base >>. =head2 $c->req->referer Returns a C<< $c->uri_class >> object for the referer (or configured C if there's no context) with reference set to C<< $c->req->uri >> if it comes from C<< $c->req->base >>. In other words, if referer is your app, you can do C<< $c->req->referer->relative >> and it will do the right thing. =head1 CONFIGURATION In myapp.conf: disposition absolute uri_class URI::SmartURI =over =item disposition One of 'absolute', 'hostless', 'relative' or 'host-header'. Defaults to 'absolute'. The special disposition 'host-header' uses the value of your 'Host:' header. =item uri_class The class to use for URIs, defaults to L. =back =head1 PER REQUEST package MyAPP::Controller::RSSFeed; ... sub begin : Private { my ($self, $c) = @_; $c->uri_class('Your::URI::Class::For::Request'); $c->uri_disposition('absolute'); } =over =item $c->uri_disposition('absolute'|'hostless'|'relative'|'host-header') Set URI disposition to use for the duration of the request. =item $c->uri_class($class) Set the URI class to use for C<< $c->uri_for >> and C<< $c->req->uri_with >> for the duration of the request. =back =head1 EXTENDING C<< $c->prepare_uri >> actually creates the URI, which you can override. =cut sub uri_for { my $c = shift; $c->prepare_uri($c->next::method(@_)) } { package Catalyst::Request::SmartURI; our $AUTHORITY = 'cpan:RKITOVER'; $Catalyst::Request::SmartURI::VERSION = '0.041'; use Moose; extends 'Catalyst::Request'; use namespace::clean -except => 'meta'; sub uri_with { my $req = shift; $context->prepare_uri($req->next::method(@_)) } sub uri { my $req = shift; my $uri_class = $context ? $context->uri_class : $conf_uri_class; my $uri = $req->next::method(@_); return $uri if not defined $uri; $req->next::method( $uri_class->new( $req->next::method(@_), ($req->{base} ? { reference => $req->base } : ()) ) ) } sub referer { my $req = shift; my $uri_class = $context ? $context->uri_class : $conf_uri_class; my $referer = $req->next::method(@_); return $referer if not defined $referer; my $base = $req->base; my $uri = $req->uri; if ($referer =~ /^$base/) { return $uri_class->new($referer, { reference => $uri }) } else { return $uri_class->new($referer); } } __PACKAGE__->meta->make_immutable; } sub setup { my $app = shift; my $config =$app->config->{'Plugin::SmartURI'} || $app->config->{smarturi}; ($conf_uri_class, $conf_disposition) = @$config{qw/uri_class disposition/}; $conf_uri_class ||= 'URI::SmartURI'; $conf_disposition ||= 'absolute'; eval { Class::Load::load_class($conf_uri_class) }; Catalyst::Exception->throw( message => "Could not load configured uri_class $conf_uri_class: $@" ) if $@; my $request_class = $app->request_class; unless ($request_class->isa('Catalyst::Request::SmartURI')) { my $new_request_class = $app.'::Request::SmartURI'; my $inject_rest = (not $request_class->isa('Catalyst::Request::REST')) && eval { Class::Load::load_class('Catalyst::Request::REST') }; Class::C3::Componentised->inject_base( $new_request_class, 'Catalyst::Request::SmartURI', ($inject_rest ? 'Catalyst::Request::REST' : ()), $request_class, ); Class::C3::reinitialize(); $app->request_class($new_request_class); } $app->next::method(@_) } sub prepare_uri { my ($c, $uri) = @_; my $disposition = $c->uri_disposition || $conf_disposition; my $uri_class = $c->uri_class || $conf_uri_class; # Need the || for $c->welcome_message, otherwise initialization works fine. eval { Class::Load::load_class($uri_class) }; Catalyst::Exception->throw( message => "Could not load configured uri_class $uri_class: $@" ) if $@; my $res; if ($disposition eq 'host-header') { $res = $uri_class->new($uri, { reference => $c->req->uri })->absolute; my $host = $c->req->header('Host'); my $port = $host =~ s/:(\d+)$// ? $1 : ''; if ($port) { $port = '' if $c->req->uri->scheme eq 'http' && $port == 80; $port = '' if $c->req->uri->scheme eq 'https' && $port == 443; } $res->host($host); $res->port($port) if $port; } else { $res = $uri_class->new($uri, { reference => $c->req->uri })->$disposition } $res } # Reset accessors to configured values at beginning of request. sub prepare { my $app = shift; # Also save a copy of the context for the Request class to use. my $c = $context = $app->next::method(@_); weaken $context; $c->uri_class($conf_uri_class); $c->uri_disposition($conf_disposition); $c } __PACKAGE__->meta->make_immutable; =head1 SEE ALSO L, L, L =head1 AUTHOR Rafael Kitover, C<< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Catalyst::Plugin::SmartURI You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS from #catalyst: vipul came up with the idea mst came up with the design and implementation details for the current version kd reviewed my code and offered suggestions =head1 TODO I'd like to extend on L, and make a plugin that rewrites URIs for actions with an SSL attribute. =head1 COPYRIGHT & LICENSE Copyright (c) 2008 Rafael Kitover This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __PACKAGE__; # End of Catalyst::Plugin::SmartURI # vim: expandtab shiftwidth=4 tw=80: