/usr/share/perl5/LWP/Protocol/PSGI.pm is in liblwp-protocol-psgi-perl 0.08-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | package LWP::Protocol::PSGI;
use strict;
use 5.008_001;
our $VERSION = '0.08';
use parent qw(LWP::Protocol);
use HTTP::Message::PSGI qw( req_to_psgi res_from_psgi );
use Guard;
use Carp;
my @protocols = qw( http https );
my %orig;
my @apps;
sub register {
my $class = shift;
my $app = LWP::Protocol::PSGI::App->new(@_);
unshift @apps, $app;
# register this guy (as well as saving original code) once
if (! scalar keys %orig) {
for my $proto (@protocols) {
if (my $orig = LWP::Protocol::implementor($proto)) {
$orig{$proto} = $orig;
LWP::Protocol::implementor($proto, $class);
} else {
Carp::carp("LWP::Protocol::$proto is unavailable. Skip registering overrides for it.") if $^W;
}
}
}
if (defined wantarray) {
return guard {
$class->unregister_app($app);
};
}
}
sub unregister_app {
my ($class, $app) = @_;
my $i = 0;
foreach my $stored_app (@apps) {
if ($app == $stored_app) {
splice @apps, $i, 1;
return;
}
$i++;
}
}
sub unregister {
my $class = shift;
for my $proto (@protocols) {
if ($orig{$proto}) {
LWP::Protocol::implementor($proto, $orig{$proto});
}
}
@apps = ();
}
sub request {
my($self, $request) = @_;
if (my $app = $self->handles($request)) {
my $env = req_to_psgi $request;
res_from_psgi $app->app->($env);
} else {
$orig{$self->{scheme}}->new($self->{scheme}, $self->{ua})->request($request);
}
}
# for testing
sub create {
my $class = shift;
push @apps, LWP::Protocol::PSGI::App->new(@_);
$class->new;
}
sub handles {
my($self, $request) = @_;
foreach my $app (@apps) {
if ($app->match($request)) {
return $app;
}
}
}
package
LWP::Protocol::PSGI::App;
use strict;
sub new {
my ($class, $app, %options) = @_;
bless { app => $app, options => \%options }, $class;
}
sub app { $_[0]->{app} }
sub options { $_[0]->{options} }
sub match {
my ($self, $request) = @_;
my $options = $self->options;
if ($options->{host}) {
my $matcher = $self->_matcher($options->{host});
$matcher->($request->uri->host) || $matcher->($request->uri->host_port);
} elsif ($options->{uri}) {
$self->_matcher($options->{uri})->($request->uri);
} else {
1;
}
}
sub _matcher {
my($self, $stuff) = @_;
if (ref $stuff eq 'Regexp') {
sub { $_[0] =~ $stuff };
} elsif (ref $stuff eq 'CODE') {
$stuff;
} elsif (!ref $stuff) {
sub { $_[0] eq $stuff };
} else {
Carp::croak("Don't know how to match: ", ref $stuff);
}
}
1;
__END__
=encoding utf-8
=for stopwords
=head1 NAME
LWP::Protocol::PSGI - Override LWP's HTTP/HTTPS backend with your own PSGI application
=head1 SYNOPSIS
use LWP::UserAgent;
use LWP::Protocol::PSGI;
# can be Mojolicious, Catalyst, Dancer2 or any PSGI application
my $psgi_app = do {
use Dancer;
set apphandler => 'PSGI';
get '/search' => sub {
return 'googling ' . params->{q};
};
dance;
};
# Register the $psgi_app to handle all LWP requests
LWP::Protocol::PSGI->register($psgi_app);
# can hijack any code or module that uses LWP::UserAgent underneath, with no changes
my $ua = LWP::UserAgent->new;
my $res = $ua->get("http://www.google.com/search?q=bar");
print $res->content; # "googling bar"
# Only hijacks specific host (and port)
LWP::Protocol::PSGI->register($psgi_app, host => 'localhost:3000');
my $ua = LWP::UserAgent->new;
$ua->get("http://localhost:3000/app"); # this routes $psgi_app
$ua->get("http://google.com/api"); # this doesn't - handled with actual HTTP requests
=head1 DESCRIPTION
LWP::Protocol::PSGI is a module to hijack B<any> code that uses
L<LWP::UserAgent> underneath such that any HTTP or HTTPS requests can
be routed to your own PSGI application.
Because it works with any code that uses LWP, you can override various
WWW::*, Net::* or WebService::* modules such as L<WWW::Mechanize>,
without modifying the calling code or its internals.
use WWW::Mechanize;
use LWP::Protocol::PSGI;
LWP::Protocol::PSGI->register($my_psgi_app);
my $mech = WWW::Mechanize->new;
$mech->get("http://amazon.com/"); # $my_psgi_app runs
=head1 METHODS
=over 4
=item register
LWP::Protocol::PSGI->register($app, %options);
my $guard = LWP::Protocol::PSGI->register($app, %options);
Registers an override hook to hijack HTTP requests. If called in a
non-void context, returns a L<Guard> object that automatically resets
the override when it goes out of context.
{
my $guard = LWP::Protocol::PSGI->register($app);
# hijack the code using LWP with $app
}
# now LWP uses the original HTTP implementations
When C<%options> is specified, the option limits which URL and hosts
this handler overrides. You can either pass C<host> or C<uri> to match
requests, and if it doesn't match, the handler falls back to the
original LWP HTTP protocol implementor.
LWP::Protocol::PSGI->register($app, host => 'www.google.com');
LWP::Protocol::PSGI->register($app, host => qr/\.google\.com$/);
LWP::Protocol::PSGI->register($app, uri => sub { my $uri = shift; ... });
The options can take either a string, where it does a complete match, a
regular expression or a subroutine reference that returns boolean
given the value of C<host> (only the hostname) or C<uri> (the whole
URI, including query parameters).
=item unregister
LWP::Protocol::PSGI->unregister;
Resets all the overrides for LWP. If you use the guard interface
described above, it will be automatically called for you.
=back
=head1 DIFFERENCES WITH OTHER MODULES
=head2 Mock vs Protocol handlers
There are similar modules on CPAN that allows you to emulate LWP
requests and responses. Most of them are implemented as a mock
library, which means it doesn't go through the LWP guts and just gives
you a wrapper for receiving HTTP::Request and returning HTTP::Response
back.
LWP::Protocol::PSGI is implemented as an LWP protocol handler and it
allows you to use most of the LWP extensions to add capabilities such
as manipulating headers and parsing cookies.
=head2 Test::LWP::UserAgent
L<Test::LWP::UserAgent> has the similar concept of overriding LWP
request method with particular PSGI applications. It has more features
and options such as passing through the requests to the native LWP
handler, while LWP::Protocol::PSGI only allows to map certain hosts
and ports.
Test::LWP::UserAgent requires you to change the instantiation of
UserAgent from C<< LWP::UserAgent->new >> to C<<
Test::LWP::UserAgent->new >> somehow and it's your responsibility to
do so. This mechanism gives you more control which requests should go
through the PSGI app, and it might not be difficult if the creation is
done in one place in your code base. However it might be hard or even
impossible when you are dealing with third party modules that calls
LWP::UserAgent inside.
LWP::Protocol::PSGI affects the LWP calling code more globally, while
having an option to enable it only in a specific block, thus there's
no need to change the UserAgent object manually, whether it is in your
code or CPAN modules.
=head1 AUTHOR
Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
=head1 COPYRIGHT
Copyright 2011- Tatsuhiko Miyagawa
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
L<Plack::Client> L<LWP::UserAgent>
=cut
|