summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/HTTP/Cookies
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/HTTP/Cookies')
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm313
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm91
2 files changed, 207 insertions, 197 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
index 9c69fa364cf..bffa587adf9 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
@@ -1,56 +1,56 @@
package HTTP::Cookies::Microsoft;
-
+$HTTP::Cookies::Microsoft::VERSION = '6.03';
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = "6.00";
+$VERSION = "6.01";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
sub load_cookies_from_file
{
- my ($file) = @_;
- my @cookies;
- my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
- my ($lo_create, $hi_create, $sep);
-
- open(COOKIES, $file) || return;
-
- while ($key = <COOKIES>)
- {
- chomp($key);
- chomp($value = <COOKIES>);
- chomp($domain_path= <COOKIES>);
- chomp($flags = <COOKIES>); # 0x0001 bit is for secure
- chomp($lo_expire = <COOKIES>);
- chomp($hi_expire = <COOKIES>);
- chomp($lo_create = <COOKIES>);
- chomp($hi_create = <COOKIES>);
- chomp($sep = <COOKIES>);
-
- if (!defined($key) || !defined($value) || !defined($domain_path) ||
- !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
- !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
- ($sep ne '*'))
- {
- last;
- }
-
- if ($domain_path =~ /^([^\/]+)(\/.*)$/)
- {
- my $domain = $1;
- my $path = $2;
-
- push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
- PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
- LOXP => $lo_expire, HICREATE => $hi_create,
- LOCREATE => $lo_create});
- }
- }
-
- return \@cookies;
+ my ($file) = @_;
+ my @cookies;
+
+ open (my $fh, '<', $file) || return;
+
+ while (my $key = <$fh>) {
+ chomp $key;
+ my ($value, $domain_path, $flags, $lo_expire, $hi_expire);
+ my ($lo_create, $hi_create, $sep);
+ chomp($value = <$fh>);
+ chomp($domain_path= <$fh>);
+ chomp($flags = <$fh>); # 0x0001 bit is for secure
+ chomp($lo_expire = <$fh>);
+ chomp($hi_expire = <$fh>);
+ chomp($lo_create = <$fh>);
+ chomp($hi_create = <$fh>);
+ chomp($sep = <$fh>);
+
+ if (!defined($key) || !defined($value) || !defined($domain_path) ||
+ !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
+ !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
+ ($sep ne '*'))
+ {
+ last;
+ }
+
+ if ($domain_path =~ /^([^\/]+)(\/.*)$/) {
+ my $domain = $1;
+ my $path = $2;
+
+ push @cookies, {
+ KEY => $key, VALUE => $value, DOMAIN => $domain,
+ PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
+ LOXP => $lo_expire, HICREATE => $hi_create,
+ LOCREATE => $lo_create
+ };
+ }
+ }
+
+ return \@cookies;
}
sub get_user_name
@@ -78,7 +78,7 @@ sub epoch_time_offset_from_win32_filetime
# 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
#
# 100 nanosecond intervals == 0.1 microsecond intervals
-
+
my $filetime_low32_1970 = 0xd53e8000;
my $filetime_high32_1970 = 0x019db1de;
@@ -135,7 +135,7 @@ sub load_cookie
my $secure = ($cookie->{FLAGS} & 1) != 0;
my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
- $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
+ $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
$cookie->{PATH}, $cookie->{DOMAIN}, undef,
0, $secure, $expires-$now, 0);
}
@@ -144,127 +144,109 @@ sub load_cookie
sub load
{
- my($self, $cookie_index) = @_;
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- my $cookie_dir = '';
- my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
- my $user_name = get_user_name();
- my $data;
-
- $cookie_index ||= $self->{'file'} || return;
- if ($cookie_index =~ /[\\\/][^\\\/]+$/)
- {
- $cookie_dir = $` . "\\";
- }
-
- local(*INDEX, $_);
-
- open(INDEX, $cookie_index) || return;
- binmode(INDEX);
- if (256 != read(INDEX, $data, 256))
- {
- warn "$cookie_index file is not large enough";
- close(INDEX);
- return;
- }
-
- # Cookies' index.dat file starts with 32 bytes of signature
- # followed by an offset to the first record, stored as a little-endian DWORD
- my ($sig, $size) = unpack('a32 V', $data);
-
- if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
- (0x4000 != $size))
- {
- warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
- close(INDEX);
- return;
- }
-
- if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
- {
- close(INDEX);
- return;
- }
-
- # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
- # so read in two 0x80 byte sectors and adjust if not a Cookie.
- while (256 == read(INDEX, $data, 256))
- {
- # each record starts with a 4-byte signature
- # and a count (little-endian DWORD) of 0x80 byte sectors for the record
- ($sig, $size) = unpack('a4 V', $data);
-
- # Cookies are found in 'URL ' records
- if ('URL ' ne $sig)
- {
- # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
- if (($sig eq 'HASH') || ($sig eq 'LEAK'))
- {
- # '-2' takes into account the two 0x80 byte sectors we've just read in
- if (($size > 0) && ($size != 2))
- {
- if (0 == seek(INDEX, ($size-2)*0x80, 1))
- {
- # Seek failed. Something's wrong. Gonna stop.
- last;
- }
- }
- }
- next;
- }
-
- #$REMOVE Need to check if URL records in Cookies' index.dat will
- # ever use more than two 0x80 byte sectors
- if ($size > 2)
- {
- my $more_data = ($size-2)*0x80;
-
- if ($more_data != read(INDEX, $data, $more_data, 256))
- {
- last;
- }
- }
-
- (my $user_name2 = $user_name) =~ s/ /_/g;
- if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
- {
- my $cookie_file = $cookie_dir . $2; # form full pathname
-
- if (!$delay_load)
- {
- $self->load_cookie($cookie_file);
- }
- else
- {
- my $domain = $1;
-
- # grab only the domain name, drop everything from the first dir sep on
- if ($domain =~ m{[\\/]})
- {
- $domain = $`;
- }
-
- # set the delayload cookie for this domain with
- # the cookie_file as cookie for later-loading info
- $self->set_cookie(undef, 'cookie', $cookie_file,
- '//+delayload', $domain, undef,
- 0, 0, $now+86400, 0);
- }
- }
- }
-
- close(INDEX);
-
- 1;
+ my($self, $cookie_index) = @_;
+ my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+ my $cookie_dir = '';
+ my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
+ my $user_name = get_user_name();
+ my $data;
+
+ $cookie_index ||= $self->{'file'} || return;
+ if ($cookie_index =~ /[\\\/][^\\\/]+$/) {
+ $cookie_dir = $` . "\\";
+ }
+
+ open (my $fh, '<:raw', $cookie_index) || return;
+ if (256 != read($fh, $data, 256)) {
+ warn "$cookie_index file is not large enough";
+ return;
+ }
+
+ # Cookies' index.dat file starts with 32 bytes of signature
+ # followed by an offset to the first record, stored as a little-endian DWORD
+ my ($sig, $size) = unpack('a32 V', $data);
+
+ # check that sig is valid (only tested in IE6.0)
+ if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || (0x4000 != $size)) {
+ warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
+ return;
+ }
+
+ # move the file ptr to start of the first record
+ if (0 == seek($fh, $size, 0)) {
+ return;
+ }
+
+ # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
+ # so read in two 0x80 byte sectors and adjust if not a Cookie.
+ while (256 == read($fh, $data, 256)) {
+ # each record starts with a 4-byte signature
+ # and a count (little-endian DWORD) of 0x80 byte sectors for the record
+ ($sig, $size) = unpack('a4 V', $data);
+
+ # Cookies are found in 'URL ' records
+ if ('URL ' ne $sig) {
+ # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
+ if (($sig eq 'HASH') || ($sig eq 'LEAK')) {
+ # '-2' takes into account the two 0x80 byte sectors we've just read in
+ if (($size > 0) && ($size != 2)) {
+ if (0 == seek($fh, ($size-2)*0x80, 1)) {
+ # Seek failed. Something's wrong. Gonna stop.
+ last;
+ }
+ }
+ }
+ next;
+ }
+
+ #$REMOVE Need to check if URL records in Cookies' index.dat will
+ # ever use more than two 0x80 byte sectors
+ if ($size > 2) {
+ my $more_data = ($size-2)*0x80;
+
+ if ($more_data != read($fh, $data, $more_data, 256)) {
+ last;
+ }
+ }
+
+ (my $user_name2 = $user_name) =~ s/ /_/g;
+ if ($data =~ /Cookie:\Q$user_name\E@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)@[\x21-\xFF]+\.txt)/) {
+ my $cookie_file = $cookie_dir . $2; # form full pathname
+
+ if (!$delay_load) {
+ $self->load_cookie($cookie_file);
+ }
+ else {
+ my $domain = $1;
+
+ # grab only the domain name, drop everything from the first dir sep on
+ if ($domain =~ m{[\\/]}) {
+ $domain = $`;
+ }
+
+ # set the delayload cookie for this domain with
+ # the cookie_file as cookie for later-loading info
+ $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86400, 0);
+ }
+ }
+ }
+
+ 1;
}
1;
-__END__
+=pod
+
+=encoding UTF-8
=head1 NAME
-HTTP::Cookies::Microsoft - access to Microsoft cookies files
+HTTP::Cookies::Microsoft - Access to Microsoft cookies files
+
+=head1 VERSION
+
+version 6.03
=head1 SYNOPSIS
@@ -325,5 +307,20 @@ Copyright 2002 Johnny Lee
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2002-2017 by Gisle Aas.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
=cut
+__END__
+
+#ABSTRACT: Access to Microsoft cookies files
+
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
index 5972029e558..180d5ff8116 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
@@ -1,38 +1,37 @@
package HTTP::Cookies::Netscape;
-
+$HTTP::Cookies::Netscape::VERSION = '6.03';
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = "6.00";
+$VERSION = "6.01";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
sub load
{
- my($self, $file) = @_;
+ my ($self, $file) = @_;
$file ||= $self->{'file'} || return;
- local(*FILE, $_);
+
local $/ = "\n"; # make sure we got standard record separator
- my @cookies;
- open(FILE, $file) || return;
- my $magic = <FILE>;
- unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
- warn "$file does not look like a netscape cookies file" if $^W;
- close(FILE);
- return;
+ open (my $fh, '<', $file) || return;
+ my $magic = <$fh>;
+ chomp $magic;
+ unless ($magic =~ /^#(?: Netscape)? HTTP Cookie File/) {
+ warn "$file does not look like a netscape cookies file";
+ return;
}
+
my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- while (<FILE>) {
- next if /^\s*\#/;
- next if /^\s*$/;
- tr/\n\r//d;
- my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
- $secure = ($secure eq "TRUE");
- $self->set_cookie(undef,$key,$val,$path,$domain,undef,
- 0,$secure,$expires-$now, 0);
+ while (my $line = <$fh>) {
+ chomp($line);
+ next if $line =~ /^\s*\#/;
+ next if $line =~ /^\s*$/;
+ $line =~ tr/\n\r//d;
+ my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $line);
+ $secure = ($secure eq "TRUE");
+ $self->set_cookie(undef, $key, $val, $path, $domain, undef, 0, $secure, $expires-$now, 0);
}
- close(FILE);
1;
}
@@ -40,12 +39,12 @@ sub save
{
my($self, $file) = @_;
$file ||= $self->{'file'} || return;
- local(*FILE, $_);
- open(FILE, ">$file") || return;
+
+ open(my $fh, '>', $file) || return;
# Use old, now broken link to the old cookie spec just in case something
# else (not us!) requires the comment block exactly this way.
- print FILE <<EOT;
+ print {$fh} <<EOT;
# Netscape HTTP Cookie File
# http://www.netscape.com/newsref/std/cookie_spec.html
# This is a generated file! Do not edit.
@@ -54,25 +53,30 @@ EOT
my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
$self->scan(sub {
- my($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest) = @_;
- return if $discard && !$self->{ignore_discard};
- $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
- return if $now > $expires;
- $secure = $secure ? "TRUE" : "FALSE";
- my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
- print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
+ my ($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, $rest) = @_;
+ return if $discard && !$self->{ignore_discard};
+ $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
+ return if $now > $expires;
+ $secure = $secure ? "TRUE" : "FALSE";
+ my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
+ print {$fh} join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
});
- close(FILE);
1;
}
1;
-__END__
+
+=pod
+
+=encoding UTF-8
=head1 NAME
-HTTP::Cookies::Netscape - access to Netscape cookies files
+HTTP::Cookies::Netscape - Access to Netscape cookies files
+
+=head1 VERSION
+
+version 6.03
=head1 SYNOPSIS
@@ -97,18 +101,27 @@ Please note that the Netscape/Mozilla cookie file format can't store
all the information available in the Set-Cookie2 headers, so you will
probably lose some information if you save in this format.
-At time of writing, this module seems to work fine with Mozilla
+At time of writing, this module seems to work fine with Mozilla
Phoenix/Firebird.
=head1 SEE ALSO
L<HTTP::Cookies::Microsoft>
-=head1 COPYRIGHT
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
-Copyright 2002-2003 Gisle Aas
+This software is copyright (c) 2002-2017 by Gisle Aas.
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
+__END__
+
+#ABSTRACT: Access to Netscape cookies files
+