File Coverage

blib/lib/HTTP/CookieJar/LWP.pm
Criterion Covered Total %
statement 11 41 26.8
branch 0 12 0.0
condition 0 3 0.0
subroutine 4 9 44.4
pod 0 2 0.0
total 15 67 22.3


line stmt bran cond sub pod time code
1 1     1   56351 use 5.008001;
  1         6  
2 1     1   12 use strict;
  1         2  
  1         26  
3 1     1   4 use warnings;
  1         2  
  1         51  
4              
5             package HTTP::CookieJar::LWP;
6             # ABSTRACT: LWP adapter for HTTP::CookieJar
7             our $VERSION = '0.013'; # TRIAL
8              
9 1     1   5 use parent 'HTTP::CookieJar';
  1         2  
  1         4  
10              
11             sub add_cookie_header {
12 0     0 0   my ( $self, $request ) = @_;
13              
14 0           my $url = _get_url( $request, $request->uri );
15 0 0         return unless ( $url->scheme =~ /^https?\z/ );
16              
17 0           my $header = $self->cookie_header($url);
18 0           $request->header( Cookie => $header );
19              
20 0           return $request;
21             }
22              
23             sub extract_cookies {
24 0     0 0   my ( $self, $response ) = @_;
25              
26 0 0         my $request = $response->request
27             or return;
28              
29 0           my $url = _get_url( $request, $request->uri );
30              
31 0           $self->add( $url, $_ ) for $response->_header("Set-Cookie");
32              
33 0           return $response;
34             }
35              
36             #--------------------------------------------------------------------------#
37             # helper subroutines
38             #--------------------------------------------------------------------------#
39              
40             sub _get_url {
41 0     0     my ( $request, $url ) = @_;
42 0           my $new_url = $url->clone;
43 0 0         if ( my $h = $request->header("Host") ) {
44 0           $h =~ s/:\d+$//; # might have a port as well
45 0           $new_url->host($h);
46             }
47 0           return $new_url;
48             }
49              
50             sub _url_path {
51 0     0     my $url = shift;
52 0           my $path;
53 0 0         if ( $url->can('epath') ) {
54 0           $path = $url->epath; # URI::URL method
55             }
56             else {
57 0           $path = $url->path; # URI::_generic method
58             }
59 0 0         $path = "/" unless length $path;
60 0           $path;
61             }
62              
63             sub _normalize_path # so that plain string compare can be used
64             {
65 0     0     my $x;
66 0           $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
67 0           $x = uc($1);
68 0 0 0       $x eq "2F" || $x eq "25" ? "%$x" :
69             pack("C", hex($x));
70             /eg;
71 0           $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
  0            
72             }
73              
74             1;
75              
76              
77             # vim: ts=4 sts=4 sw=4 et:
78              
79             __END__