local-lib5/lib/perl5/HTTP/Cookies/Netscape.pm

   1 package HTTP::Cookies::Netscape;
   2
   3 use strict;
   4 use vars qw(@ISA $VERSION);
   5
   6 $VERSION = "5.832";
   7
   8 require HTTP::Cookies;
   9 @ISA=qw(HTTP::Cookies);
  10
  11 sub load
  12 {
  13     my($self, $file) = @_;
  14     $file ||= $self->{'file'} || return;
  15     local(*FILE, $_);
  16     local $/ = "\n";  # make sure we got standard record separator
  17     my @cookies;
  18     open(FILE, $file) || return;
  19     my $magic = <FILE>;
  20     unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
  21         warn "$file does not look like a netscape cookies file" if $^W;
  22         close(FILE);
  23         return;
  24     }
  25     my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
  26     while (<FILE>) {
  27         next if /^\s*\#/;
  28         next if /^\s*$/;
  29         tr/\n\r//d;
  30         my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
  31         $secure = ($secure eq "TRUE");
  32         $self->set_cookie(undef,$key,$val,$path,$domain,undef,
  33                           0,$secure,$expires-$now, 0);
  34     }
  35     close(FILE);
  36     1;
  37 }
  38
  39 sub save
  40 {
  41     my($self, $file) = @_;
  42     $file ||= $self->{'file'} || return;
  43     local(*FILE, $_);
  44     open(FILE, ">$file") || return;
  45
  46     # Use old, now broken link to the old cookie spec just in case something
  47     # else (not us!) requires the comment block exactly this way.
  48     print FILE <<EOT;
  49 # Netscape HTTP Cookie File
  50 # http://www.netscape.com/newsref/std/cookie_spec.html
  51 # This is a generated file!  Do not edit.
  52
  53 EOT
  54
  55     my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
  56     $self->scan(sub {
  57         my($version,$key,$val,$path,$domain,$port,
  58            $path_spec,$secure,$expires,$discard,$rest) = @_;
  59         return if $discard && !$self->{ignore_discard};
  60         $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
  61         return if $now > $expires;
  62         $secure = $secure ? "TRUE" : "FALSE";
  63         my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
  64         print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
  65     });
  66     close(FILE);
  67     1;
  68 }
  69
  70 1;
  71 __END__
  72
  73 =head1 NAME
  74
  75 HTTP::Cookies::Netscape - access to Netscape cookies files
  76
  77 =head1 SYNOPSIS
  78
  79  use LWP;
  80  use HTTP::Cookies::Netscape;
  81  $cookie_jar = HTTP::Cookies::Netscape->new(
  82    file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
  83  );
  84  my $browser = LWP::UserAgent->new;
  85  $browser->cookie_jar( $cookie_jar );
  86
  87 =head1 DESCRIPTION
  88
  89 This is a subclass of C<HTTP::Cookies> that reads (and optionally
  90 writes) Netscape/Mozilla cookie files.
  91
  92 See the documentation for L<HTTP::Cookies>.
  93
  94 =head1 CAVEATS
  95
  96 Please note that the Netscape/Mozilla cookie file format can't store
  97 all the information available in the Set-Cookie2 headers, so you will
  98 probably lose some information if you save in this format.
  99
 100 At time of writing, this module seems to work fine with Mozilla
 101 Phoenix/Firebird.
 102
 103 =head1 SEE ALSO
 104
 105 L<HTTP::Cookies::Microsoft>
 106
 107 =head1 COPYRIGHT
 108
 109 Copyright 2002-2003 Gisle Aas
 110
 111 This library is free software; you can redistribute it and/or
 112 modify it under the same terms as Perl itself.
 113
 114 =cut