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