This file is indexed.

/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