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
|
---|