File: LWP.pm

package info (click to toggle)
libhttp-cookiejar-perl 0.008-1%2Bdeb10u1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 264 kB
  • sloc: perl: 430; makefile: 2
file content (126 lines) | stat: -rw-r--r-- 2,603 bytes parent folder | download | duplicates (2)
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
use 5.008001;
use strict;
use warnings;

package HTTP::CookieJar::LWP;
# ABSTRACT: LWP adapter for HTTP::CookieJar
our $VERSION = '0.008';

use parent 'HTTP::CookieJar';

sub add_cookie_header {
    my ( $self, $request ) = @_;

    my $url = _get_url( $request, $request->uri );
    return unless ( $url->scheme =~ /^https?\z/ );

    my $header = $self->cookie_header($url);
    $request->header( Cookie => $header );

    return $request;
}

sub extract_cookies {
    my ( $self, $response ) = @_;

    my $request = $response->request
      or return;

    my $url = _get_url( $request, $request->uri );

    $self->add( $url, $_ ) for $response->_header("Set-Cookie");

    return $response;
}

#--------------------------------------------------------------------------#
# helper subroutines
#--------------------------------------------------------------------------#

sub _get_url {
    my ( $request, $url ) = @_;
    my $new_url = $url->clone;
    if ( my $h = $request->header("Host") ) {
        $h =~ s/:\d+$//; # might have a port as well
        $new_url->host($h);
    }
    return $new_url;
}

sub _url_path {
    my $url = shift;
    my $path;
    if ( $url->can('epath') ) {
        $path = $url->epath; # URI::URL method
    }
    else {
        $path = $url->path;  # URI::_generic method
    }
    $path = "/" unless length $path;
    $path;
}

sub _normalize_path          # so that plain string compare can be used
{
    my $x;
    $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
             $x = uc($1);
                 $x eq "2F" || $x eq "25" ? "%$x" :
                                            pack("C", hex($x));
              /eg;
    $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

HTTP::CookieJar::LWP - LWP adapter for HTTP::CookieJar

=head1 VERSION

version 0.008

=head1 SYNOPSIS

  use LWP::UserAgent;
  use HTTP::CookieJar::LWP;

  my $ua = LWP::UserAgent->new(
    cookie_jar => HTTP::CookieJar::LWP->new
  );

=head1 DESCRIPTION

This module is an experimental adapter to make L<HTTP::CookieJar> work with
L<LWP>.  It implements the two methods that C<LWP> calls from L<HTTP::Cookies>.

It is not a general-purpose drop-in replacement for C<HTTP::Cookies> in any
other way.

=for Pod::Coverage method_names_here
add_cookie_header
extract_cookies

=head1 AUTHOR

David Golden <dagolden@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2013 by David Golden.

This is free software, licensed under:

  The Apache License, Version 2.0, January 2004

=cut