home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _306d81a17af3bc20c0787b755d5d8de8 < prev    next >
Text File  |  2000-03-15  |  21KB  |  759 lines
  1. package HTTP::Cookies;
  2.  
  3. # Based on draft-ietf-http-state-man-mec-08.txt and
  4. # http://www.netscape.com/newsref/std/cookie_spec.html
  5.  
  6. use strict;
  7. use HTTP::Date qw(str2time time2str);
  8. use HTTP::Headers::Util qw(split_header_words join_header_words);
  9. use LWP::Debug ();
  10.  
  11. use vars qw($VERSION);
  12. $VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
  13.  
  14. my $EPOCH_OFFSET = 0;  # difference from Unix epoch
  15. if ($^O eq "MacOS") {
  16.     require Time::Local;
  17.     $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
  18. }
  19.  
  20. =head1 NAME
  21.  
  22. HTTP::Cookies - Cookie storage and management
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.  use HTTP::Cookies;
  27.  $cookie_jar = HTTP::Cookies->new;
  28.  
  29.  $cookie_jar->add_cookie_header($request);
  30.  $cookie_jar->extract_cookies($response);
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. Cookies are a general mechanism which server side connections can use
  35. to both store and retrieve information on the client side of the
  36. connection.  For more information about cookies refer to
  37. <URL:http://www.netscape.com/newsref/std/cookie_spec.html> and
  38. <URL:http://www.cookiecentral.com/>.  This module also implements the
  39. new style cookies described in I<draft-ietf-http-state-man-mec-08.txt>.
  40. The two variants of cookies are supposed to be able to coexist happily.
  41.  
  42. Instances of the class I<HTTP::Cookies> are able to store a collection
  43. of Set-Cookie2: and Set-Cookie: headers and are able to use this
  44. information to initialize Cookie-headers in I<HTTP::Request> objects.
  45. The state of a I<HTTP::Cookies> object can be saved in and restored from
  46. files.
  47.  
  48. =head1 METHODS
  49.  
  50. The following methods are provided:
  51.  
  52. =over 4
  53.  
  54. =cut
  55.  
  56. # A HTTP::Cookies object is a hash.  The main attribute is the
  57. # COOKIES 3 level hash:  $self->{COOKIES}{$domain}{$path}{$key}.
  58.  
  59.  
  60. =item $cookie_jar = HTTP::Cookies->new;
  61.  
  62. The constructor takes hash style parameters.  The following
  63. parameters are recognized:
  64.  
  65.   file:            name of the file to restore cookies from and save cookies to
  66.   autosave:        save during destruction (bool)
  67.   ignore_discard:  save even cookies that are requested to be discarded (bool)
  68.  
  69. Future parameters might include (not yet implemented):
  70.  
  71.   max_cookies               300
  72.   max_cookies_per_domain    20
  73.   max_cookie_size           4096
  74.  
  75.   no_cookies   list of domain names that we never return cookies to
  76.  
  77. =cut
  78.  
  79. sub new
  80. {
  81.     my $class = shift;
  82.     my $self = bless {
  83.     COOKIES => {},
  84.     }, $class;
  85.     my %cnf = @_;
  86.     for (keys %cnf) {
  87.     $self->{lc($_)} = $cnf{$_};
  88.     }
  89.     $self->load;
  90.     $self;
  91. }
  92.  
  93.  
  94. =item $cookie_jar->add_cookie_header($request);
  95.  
  96. The add_cookie_header() method will set the appropriate Cookie:-header
  97. for the I<HTTP::Request> object given as argument.  The $request must
  98. have a valid url attribute before this method is called.
  99.  
  100. =cut
  101.  
  102. sub add_cookie_header
  103. {
  104.     my $self = shift;
  105.     my $request = shift || return;
  106.     my $url = $request->url;
  107.     my $domain = $url->host;
  108.     $domain = "$domain.local" unless $domain =~ /\./;
  109.     my $secure_request = ($url->scheme eq "https");
  110.     my $req_path = $url->epath;
  111.     my $req_port = $url->port;
  112.     my $now = time();
  113.     $self->_normalize_path($req_path) if $req_path =~ /%/;
  114.  
  115.     my @cval;    # cookie values for the "Cookie" header
  116.     my $set_ver;
  117.     my $netscape_only = 0; # An exact domain match applies to any cookie
  118.  
  119.     while (($domain =~ tr/././) >= 2 || # must be at least 2 dots
  120.            $domain =~ /\.local$/)
  121.     {
  122.  
  123.         LWP::Debug::debug("Checking $domain for cookies");
  124.     my $cookies = $self->{COOKIES}{$domain};
  125.     next unless $cookies;
  126.  
  127.     # Want to add cookies corresponding to the most specific paths
  128.     # first (i.e. longest path first)
  129.     my $path;
  130.     for $path (sort {length($b) <=> length($a) } keys %$cookies) {
  131.             LWP::Debug::debug("- checking cookie path=$path");
  132.         if (index($req_path, $path) != 0) {
  133.             LWP::Debug::debug("  path $path:$req_path does not fit");
  134.         next;
  135.         }
  136.  
  137.         my($key,$array);
  138.         while (($key,$array) = each %{$cookies->{$path}}) {
  139.         my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
  140.             LWP::Debug::debug(" - checking cookie $key=$val");
  141.         if ($secure && !$secure_request) {
  142.             LWP::Debug::debug("   not a secure requests");
  143.             next;
  144.         }
  145.         if ($expires && $expires < $now) {
  146.             LWP::Debug::debug("   expired");
  147.             next;
  148.         }
  149.         if ($port) {
  150.             my $found;
  151.             if ($port =~ s/^_//) {
  152.             # The correponding Set-Cookie attribute was empty
  153.             $found++ if $port eq $req_port;
  154.             $port = "";
  155.             } else {
  156.             my $p;
  157.             for $p (split(/,/, $port)) {
  158.                 $found++, last if $p eq $req_port;
  159.             }
  160.             }
  161.             unless ($found) {
  162.                 LWP::Debug::debug("   port $port:$req_port does not fit");
  163.             next;
  164.             }
  165.         }
  166.         if ($version > 0 && $netscape_only) {
  167.             LWP::Debug::debug("   domain $domain applies to " .
  168.                       "Netscape-style cookies only");
  169.             next;
  170.         }
  171.         
  172.             LWP::Debug::debug("   it's a match");
  173.  
  174.         # set version number of cookie header.
  175.             # XXX: What should it be if multiple matching
  176.                 #      Set-Cookie headers have different versions themselves
  177.         if (!$set_ver++) {
  178.             if ($version >= 1) {
  179.             push(@cval, "\$Version=$version");
  180.             } else {
  181.             $request->header(Cookie2 => "\$Version=1");
  182.             }
  183.         }
  184.  
  185.         # do we need to quote the value
  186.         if ($val =~ /\W/ && $version) {
  187.             $val =~ s/([\\\"])/\\$1/g;
  188.             $val = qq("$val");
  189.         }
  190.  
  191.         # and finally remember this cookie
  192.         push(@cval, "$key=$val");
  193.         if ($version >= 1) {
  194.             push(@cval, qq(\$Path="$path"))     if $path_spec;
  195.             push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
  196.             if (defined $port) {
  197.             my $p = '$Port';
  198.             $p .= qq(="$port") if length $port;
  199.             push(@cval, $p);
  200.             }
  201.         }
  202.  
  203.         }
  204.         }
  205.  
  206.     } continue {
  207.     # Try with a more general domain, alternately stripping
  208.     # leading name components and leading dots.  When this
  209.     # results in a domain with no leading dot, it is for
  210.     # Netscape cookie compatibility only:
  211.     #   
  212.     # a.b.c.net    Any cookie
  213.     # .b.c.net    Any cookie
  214.     # b.c.net    Netscape cookie only
  215.     # .c.net    Any cookie
  216.  
  217.     if ($domain =~ s/^\.+//) {
  218.         $netscape_only = 1;
  219.     } else {
  220.         $domain =~ s/[^.]*//;
  221.         $netscape_only = 0;
  222.     }
  223.     }
  224.  
  225.     $request->header(Cookie => join("; ", @cval)) if @cval;
  226.  
  227.     $request;
  228. }
  229.  
  230.  
  231. =item $cookie_jar->extract_cookies($response);
  232.  
  233. The extract_cookies() method will look for Set-Cookie: and
  234. Set-Cookie2: headers in the I<HTTP::Response> object passed as
  235. argument.  Any of these headers that are found are used to update
  236. the state of the $cookie_jar.
  237.  
  238. =cut
  239.  
  240. sub extract_cookies
  241. {
  242.     my $self = shift;
  243.     my $response = shift || return;
  244.     my @set = split_header_words($response->_header("Set-Cookie2"));
  245.     my $netscape_cookies;
  246.     unless (@set) {
  247.     @set = $response->_header("Set-Cookie");
  248.     return $response unless @set;
  249.     $netscape_cookies++;
  250.     }
  251.  
  252.     my $url = $response->request->url;
  253.     my $req_host = $url->host;
  254.     $req_host = "$req_host.local" unless $req_host =~ /\./;
  255.     my $req_port = $url->port;
  256.     my $req_path = $url->epath;
  257.     $self->_normalize_path($req_path) if $req_path =~ /%/;
  258.     
  259.     if ($netscape_cookies) {
  260.     # The old Netscape cookie format for Set-Cookie
  261.         # http://www.netscape.com/newsref/std/cookie_spec.html
  262.     # can for instance contain an unquoted "," in the expires
  263.     # field, so we have to use this ad-hoc parser.
  264.     my $now = time();
  265.     my @old = @set;
  266.     @set = ();
  267.     my $set;
  268.     for $set (@old) {
  269.         my @cur;
  270.         my $param;
  271.         my $expires;
  272.         for $param (split(/\s*;\s*/, $set)) {
  273.         my($k,$v) = split(/\s*=\s*/, $param, 2);
  274.         #print "$k => $v\n";
  275.         my $lc = lc($k);
  276.         if ($lc eq "expires") {
  277.             my $etime = str2time($v);
  278.             if ($etime) {
  279.             push(@cur, "Max-Age" => str2time($v) - $now);
  280.             $expires++;
  281.             }
  282.         } else {
  283.             push(@cur, $k => $v);
  284.         }
  285.         }
  286. #        push(@cur, "Port" => $req_port);
  287.         push(@cur, "Discard" => undef) unless $expires;
  288.         push(@cur, "Version" => 0);
  289.         push(@set, \@cur);
  290.     }
  291.     }
  292.  
  293.   SET_COOKIE:
  294.     for my $set (@set) {
  295.     next unless @$set >= 2;
  296.  
  297.     my $key = shift @$set;
  298.     my $val = shift @$set;
  299.  
  300.         LWP::Debug::debug("Set cookie $key => $val");
  301.  
  302.     my %hash;
  303.     while (@$set) {
  304.         my $k = shift @$set;
  305.         my $v = shift @$set;
  306.         my $lc = lc($k);
  307.         # don't loose case distinction for unknown fields
  308.         $k = $lc if $lc =~ /^(?:discard|domain|max-age|
  309.                                     path|port|secure|version)$/x;
  310.         if ($k eq "discard" || $k eq "secure") {
  311.         $v = 1 unless defined $v;
  312.         }
  313.         next if exists $hash{$k};  # only first value is signigicant
  314.         $hash{$k} = $v;
  315.     };
  316.  
  317.     my %orig_hash = %hash;
  318.     my $version   = delete $hash{version};
  319.     $version = 1 unless defined($version);
  320.     my $discard   = delete $hash{discard};
  321.     my $secure    = delete $hash{secure};
  322.     my $maxage    = delete $hash{'max-age'};
  323.  
  324.     # Check domain
  325.     my $domain  = delete $hash{domain};
  326.     if (defined($domain) && $domain ne $req_host) {
  327.         if ($domain !~ /\./ && $domain ne "local") {
  328.             LWP::Debug::debug("Domain $domain contains no dot");
  329.         next SET_COOKIE;
  330.         }
  331.         $domain = ".$domain" unless $domain =~ /^\./;
  332.         if ($domain =~ /\.\d+$/) {
  333.             LWP::Debug::debug("IP-address $domain illeagal as domain");
  334.         next SET_COOKIE;
  335.         }
  336.         my $len = length($domain);
  337.         unless (substr($req_host, -$len) eq $domain) {
  338.             LWP::Debug::debug("Domain $domain does not match host $req_host");
  339.         next SET_COOKIE;
  340.         }
  341.         my $hostpre = substr($req_host, 0, length($req_host) - $len);
  342.         if ($hostpre =~ /\./ && !$netscape_cookies) {
  343.             LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain");
  344.         next SET_COOKIE;
  345.         }
  346.     } else {
  347.         $domain = $req_host;
  348.     }
  349.  
  350.     my $path = delete $hash{path};
  351.     my $path_spec;
  352.     if (defined $path) {
  353.         $path_spec++;
  354.         $self->_normalize_path($path) if $path =~ /%/;
  355.         if (!$netscape_cookies &&
  356.                 substr($req_path, 0, length($path)) ne $path) {
  357.             LWP::Debug::debug("Path $path is not a prefix of $req_path");
  358.         next SET_COOKIE;
  359.         }
  360.     } else {
  361.         $path = $req_path;
  362.         $path =~ s,/[^/]*$,,;
  363.         $path = "/" unless length($path);
  364.     }
  365.  
  366.     my $port;
  367.     if (exists $hash{port}) {
  368.         $port = delete $hash{port};
  369.         if (defined $port) {
  370.         $port =~ s/\s+//g;
  371.         my $found;
  372.         for my $p (split(/,/, $port)) {
  373.             unless ($p =~ /^\d+$/) {
  374.               LWP::Debug::debug("Bad port $port (not numeric)");
  375.             next SET_COOKIE;
  376.             }
  377.             $found++ if $p eq $req_port;
  378.         }
  379.         unless ($found) {
  380.             LWP::Debug::debug("Request port ($req_port) not found in $port");
  381.             next SET_COOKIE;
  382.         }
  383.         } else {
  384.         $port = "_$req_port";
  385.         }
  386.     }
  387.     $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
  388.         if $self->set_cookie_ok(\%orig_hash);
  389.     }
  390.  
  391.     $response;
  392. }
  393.  
  394. sub set_cookie_ok { 1 };
  395.  
  396. =item $cookie_jar->set_cookie($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest)
  397.  
  398. The set_cookie() method updates the state of the $cookie_jar.  The
  399. $key, $val, $domain, $port and $path arguments are strings.  The
  400. $path_spec, $secure, $discard arguments are boolean values. The $maxage
  401. value is a number indicating number of seconds that this cookie will
  402. live.  A value <= 0 will delete this cookie.  %rest defines
  403. various other attributes like "Comment" and "CommentURL".
  404.  
  405. =cut
  406.  
  407. sub set_cookie
  408. {
  409.     my $self = shift;
  410.     my($version,
  411.        $key, $val, $path, $domain, $port,
  412.        $path_spec, $secure, $maxage, $discard, $rest) = @_;
  413.  
  414.     # there must always be at least 2 dots in a domain
  415.     return $self if ($domain =~ tr/././) < 2 &&
  416.                      $domain !~ /\.local$/;
  417.  
  418.     # path and key can not be empty (key can't start with '$')
  419.     return $self if !defined($path) || $path !~ m,^/, ||
  420.                 !defined($key)  || $key  !~ m,[^\$],;
  421.  
  422.     # ensure legal port
  423.     if (defined $port) {
  424.     return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
  425.     }
  426.  
  427.     my $expires;
  428.     if (defined $maxage) {
  429.     if ($maxage <= 0) {
  430.         delete $self->{COOKIES}{$domain}{$path}{$key};
  431.         return $self;
  432.     }
  433.     $expires = time() + $maxage;
  434.     }
  435.     $version = 0 unless defined $version;
  436.  
  437.     my @array = ($version, $val,$port,
  438.          $path_spec,
  439.          $secure, $expires, $discard);
  440.     push(@array, {%$rest}) if defined($rest) && %$rest;
  441.     # trim off undefined values at end
  442.     pop(@array) while !defined $array[-1];
  443.  
  444.     $self->{COOKIES}{$domain}{$path}{$key} = \@array;
  445.     $self;
  446. }
  447.  
  448. =item $cookie_jar->save( [$file] );
  449.  
  450. This method file saves the state of the $cookie_jar to a file.
  451. The state can then be restored later using the load() method.  If a
  452. filename is not specified we will use the name specified during
  453. construction.  If the attribute I<ignore_discared> is set, then we
  454. will even save cookies that are marked to be discarded.
  455.  
  456. The default is to save a sequence of "Set-Cookie3" lines.
  457. "Set-Cookie3" is a proprietary LWP format, not known to be compatible
  458. with any browser.  The I<HTTP::Cookies::Netscape> sub-class can
  459. be used to save in a format compatible with Netscape.
  460.  
  461. =cut
  462.  
  463. sub save
  464. {
  465.     my $self = shift;
  466.     my $file = shift || $self->{'file'} || return;
  467.     local(*FILE);
  468.     open(FILE, ">$file") or die "Can't open $file: $!";
  469.     print FILE "#LWP-Cookies-1.0\n";
  470.     print FILE $self->as_string(!$self->{ignore_discard});
  471.     close(FILE);
  472.     1;
  473. }
  474.  
  475. =item $cookie_jar->load( [$file] );
  476.  
  477. This method reads the cookies from the file and adds them to the
  478. $cookie_jar.  The file must be in the format written by the save()
  479. method.
  480.  
  481. =cut
  482.  
  483. sub load
  484. {
  485.     my $self = shift;
  486.     my $file = shift || $self->{'file'} || return;
  487.     local(*FILE, $_);
  488.     local $/ = "\n";  # make sure we got standard record separator
  489.     open(FILE, $file) or return;
  490.     my $magic = <FILE>;
  491.     unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
  492.     warn "$file does not seem to contain cookies";
  493.     return;
  494.     }
  495.     while (<FILE>) {
  496.     next unless s/^Set-Cookie3:\s*//;
  497.     chomp;
  498.     my $cookie;
  499.     for $cookie (split_header_words($_)) {
  500.         my($key,$val) = splice(@$cookie, 0, 2);
  501.         my %hash;
  502.         while (@$cookie) {
  503.         my $k = shift @$cookie;
  504.         my $v = shift @$cookie;
  505.         $hash{$k} = $v;
  506.         }
  507.         my $version   = delete $hash{version};
  508.         my $path      = delete $hash{path};
  509.         my $domain    = delete $hash{domain};
  510.         my $port      = delete $hash{port};
  511.         my $expires   = str2time(delete $hash{expires});
  512.  
  513.         my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
  514.         my $secure    = exists $hash{secure};    delete $hash{secure};
  515.         my $discard   = exists $hash{discard};   delete $hash{discard};
  516.  
  517.         my @array =    ($version,$val,$port,
  518.              $path_spec,$secure,$expires,$discard);
  519.         push(@array, \%hash) if %hash;
  520.         $self->{COOKIES}{$domain}{$path}{$key} = \@array;
  521.     }
  522.     }
  523.     close(FILE);
  524.     1;
  525. }
  526.  
  527. =item $cookie_jar->revert;
  528.  
  529. This method empties the $cookie_jar and re-loads the $cookie_jar
  530. from the last save file.
  531.  
  532. =cut
  533.  
  534. sub revert
  535. {
  536.     my $self = shift;
  537.     $self->clear->load;
  538.     $self;
  539. }
  540.  
  541. =item $cookie_jar->clear( [$domain, [$path, [$key] ] ]);
  542.  
  543. Invoking this method without arguments will empty the whole
  544. $cookie_jar.  If given a single argument only cookies belonging to
  545. that domain will be removed.  If given two arguments, cookies
  546. belonging to the specified path within that domain are removed.  If
  547. given three arguments, then the cookie with the specified key, path
  548. and domain is removed.
  549.  
  550. =cut
  551.  
  552. sub clear
  553. {
  554.     my $self = shift;
  555.     if (@_ == 0) {
  556.     $self->{COOKIES} = {};
  557.     } elsif (@_ == 1) {
  558.     delete $self->{COOKIES}{$_[0]};
  559.     } elsif (@_ == 2) {
  560.     delete $self->{COOKIES}{$_[0]}{$_[1]};
  561.     } elsif (@_ == 3) {
  562.     delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
  563.     } else {
  564.     require Carp;
  565.         Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
  566.     }
  567.     $self;
  568. }
  569.  
  570. sub DESTROY
  571. {
  572.     my $self = shift;
  573.     $self->save if $self->{'autosave'};
  574. }
  575.  
  576.  
  577. =item $cookie_jar->scan( \&callback );
  578.  
  579. The argument is a subroutine that will be invoked for each cookie
  580. stored in the $cookie_jar.  The subroutine will be invoked with
  581. the following arguments:
  582.  
  583.   0  version
  584.   1  key
  585.   2  val
  586.   3  path
  587.   4  domain
  588.   5  port
  589.   6  path_spec
  590.   7  secure
  591.   8  expires
  592.   9  discard
  593.  10  hash
  594.  
  595. =cut
  596.  
  597. sub scan
  598. {
  599.     my($self, $cb) = @_;
  600.     my($domain,$path,$key);
  601.     for $domain (sort keys %{$self->{COOKIES}}) {
  602.     for $path (sort keys %{$self->{COOKIES}{$domain}}) {
  603.         for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
  604.         my($version,$val,$port,$path_spec,
  605.            $secure,$expires,$discard,$rest) =
  606.                @{$self->{COOKIES}{$domain}{$path}{$key}};
  607.         $rest = {} unless defined($rest);
  608.         &$cb($version,$key,$val,$path,$domain,$port,
  609.              $path_spec,$secure,$expires,$discard,$rest);
  610.         }
  611.     }
  612.     }
  613. }
  614.  
  615. =item $cookie_jar->as_string( [$skip_discard] );
  616.  
  617. The as_string() method will return the state of the $cookie_jar
  618. represented as a sequence of "Set-Cookie3" header lines separated by
  619. "\n".  If $skip_discard is TRUE, it will not return lines for
  620. cookies with the I<Discard> attribute.
  621.  
  622. =cut
  623.  
  624. sub as_string
  625. {
  626.     my($self, $skip_discard) = @_;
  627.     my @res;
  628.     $self->scan(sub {
  629.     my($version,$key,$val,$path,$domain,$port,
  630.        $path_spec,$secure,$expires,$discard,$rest) = @_;
  631.     return if $discard && $skip_discard;
  632.     my @h = ($key, $val);
  633.     push(@h, "path", $path);
  634.     push(@h, "domain" => $domain);
  635.     push(@h, "port" => $port) if defined $port;
  636.     push(@h, "path_spec" => undef) if $path_spec;
  637.     push(@h, "secure" => undef) if $secure;
  638.     push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
  639.     push(@h, "discard" => undef) if $discard;
  640.     my $k;
  641.     for $k (sort keys %$rest) {
  642.         push(@h, $k, $rest->{$k});
  643.     }
  644.     push(@h, "version" => $version);
  645.     push(@res, "Set-Cookie3: " . join_header_words(\@h));
  646.     });
  647.     join("\n", @res, "");
  648. }
  649.  
  650.  
  651. sub _normalize_path  # so that plain string compare can be used
  652. {
  653.     shift;  # $self
  654.     my $x;
  655.     $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
  656.              $x = uc($1);
  657.                  $x eq "2F" || $x eq "25" ? "%$x" :
  658.                                             pack("c", hex($x));
  659.               /eg;
  660.     $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
  661. }
  662.  
  663.  
  664.  
  665. =back
  666.  
  667. =head1 SUB CLASSES
  668.  
  669. We also provide a subclass called I<HTTP::Cookies::Netscape> which
  670. loads and saves Netscape compatible cookie files.  You
  671. should be able to have LWP share Netscape's cookies by constructing
  672. your $cookie_jar like this:
  673.  
  674.  $cookie_jar = HTTP::Cookies::Netscape->new(
  675.                    File     => "$ENV{HOME}/.netscape/cookies",
  676.                    AutoSave => 1,
  677.                );
  678.  
  679. Please note that the Netscape cookie file format is not able to store
  680. all the information available in the Set-Cookie2 headers, so you will
  681. probably loose some information if you save in this format.
  682.  
  683. =cut
  684.  
  685. package HTTP::Cookies::Netscape;
  686.  
  687. use vars qw(@ISA);
  688. @ISA=qw(HTTP::Cookies);
  689.  
  690. sub load
  691. {
  692.     my($self, $file) = @_;
  693.     $file ||= $self->{'file'} || return;
  694.     local(*FILE, $_);
  695.     local $/ = "\n";  # make we got standard record separator
  696.     my @cookies;
  697.     open(FILE, $file) || return;
  698.     my $magic = <FILE>;
  699.     unless ($magic =~ /^\# Netscape HTTP Cookie File/) {
  700.     warn "$file does not look like a netscape cookies file" if $^W;
  701.     close(FILE);
  702.     return;
  703.     }
  704.     my $now = time() - $EPOCH_OFFSET;
  705.     while (<FILE>) {
  706.     next if /^\s*\#/;
  707.     next if /^\s*$/;
  708.     chomp;
  709.     my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
  710.     $secure = ($secure eq "TRUE");
  711.     $self->set_cookie(undef,$key,$val,$path,$domain,undef,
  712.               0,$secure,$expires-$now, 0);
  713.     }
  714.     close(FILE);
  715.     1;
  716. }
  717.  
  718. sub save
  719. {
  720.     my($self, $file) = @_;
  721.     $file ||= $self->{'file'} || return;
  722.     local(*FILE, $_);
  723.     open(FILE, ">$file") || return;
  724.  
  725.     print FILE <<EOT;
  726. # Netscape HTTP Cookie File
  727. # http://www.netscape.com/newsref/std/cookie_spec.html
  728. # This is a generated file!  Do not edit.
  729.  
  730. EOT
  731.  
  732.     my $now = time - $EPOCH_OFFSET;
  733.     $self->scan(sub {
  734.     my($version,$key,$val,$path,$domain,$port,
  735.        $path_spec,$secure,$expires,$discard,$rest) = @_;
  736.     return if $discard && !$self->{ignore_discard};
  737.     $expires = $expires ? $expires - $EPOCH_OFFSET : 0;
  738.     return if $now > $expires;
  739.     $secure = $secure ? "TRUE" : "FALSE";
  740.     my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
  741.     print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
  742.     });
  743.     close(FILE);
  744.     1;
  745. }
  746.  
  747. 1;
  748.  
  749. __END__
  750.  
  751. =head1 COPYRIGHT
  752.  
  753. Copyright 1997-1999 Gisle Aas
  754.  
  755. This library is free software; you can redistribute it and/or
  756. modify it under the same terms as Perl itself.
  757.  
  758. =cut
  759.