vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/HTTP/Cookies/Microsoft.pm

   1 package HTTP::Cookies::Microsoft;
   2
   3 use strict;
   4
   5 use vars qw(@ISA $VERSION);
   6
   7 $VERSION = "5.810";
   8
   9 require HTTP::Cookies;
  10 @ISA=qw(HTTP::Cookies);
  11
  12 sub load_cookies_from_file
  13 {
  14         my ($file) = @_;
  15         my @cookies;
  16         my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
  17         my ($lo_create, $hi_create, $sep);
  18
  19         open(COOKIES, $file) || return;
  20
  21         while ($key = <COOKIES>)
  22         {
  23                 chomp($key);
  24                 chomp($value     = <COOKIES>);
  25                 chomp($domain_path= <COOKIES>);
  26                 chomp($flags     = <COOKIES>);          # 0x0001 bit is for secure
  27                 chomp($lo_expire = <COOKIES>);
  28                 chomp($hi_expire = <COOKIES>);
  29                 chomp($lo_create = <COOKIES>);
  30                 chomp($hi_create = <COOKIES>);
  31                 chomp($sep       = <COOKIES>);
  32
  33                 if (!defined($key) || !defined($value) || !defined($domain_path) ||
  34                         !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
  35                         !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
  36                         ($sep ne '*'))
  37                 {
  38                         last;
  39                 }
  40
  41                 if ($domain_path =~ /^([^\/]+)(\/.*)$/)
  42                 {
  43                         my $domain = $1;
  44                         my $path = $2;
  45
  46                         push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
  47                                         PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
  48                                         LOXP => $lo_expire, HICREATE => $hi_create,
  49                                         LOCREATE => $lo_create});
  50                 }
  51         }
  52
  53         return \@cookies;
  54 }
  55
  56 sub get_user_name
  57 {
  58         use Win32;
  59         use locale;
  60         my $user = lc(Win32::LoginName());
  61
  62         return $user;
  63 }
  64
  65 # MSIE stores create and expire times as Win32 FILETIME,
  66 # which is 64 bits of 100 nanosecond intervals since Jan 01 1601
  67 #
  68 # But Cookies code expects time in 32-bit value expressed
  69 # in seconds since Jan 01 1970
  70 #
  71 sub epoch_time_offset_from_win32_filetime
  72 {
  73         my ($high, $low) = @_;
  74
  75         #--------------------------------------------------------
  76         # USEFUL CONSTANT
  77         #--------------------------------------------------------
  78         # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
  79         #
  80         # 100 nanosecond intervals == 0.1 microsecond intervals
  81
  82         my $filetime_low32_1970 = 0xd53e8000;
  83         my $filetime_high32_1970 = 0x019db1de;
  84
  85         #------------------------------------
  86         # ALGORITHM
  87         #------------------------------------
  88         # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
  89         #
  90         # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
  91         # 2. Divide by 10 to get to microseconds (1/millionth second)
  92         # 3. Divide by 1000000 (10 ^ 6) to get to seconds
  93         #
  94         # We can combine Step 2 & 3 into one divide.
  95         #
  96         # After much trial and error, I came up with the following code which
  97         # avoids using Math::BigInt or floating pt, but still gives correct answers
  98
  99         # If the filetime is before the epoch, return 0
 100         if (($high < $filetime_high32_1970) ||
 101             (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
 102         {
 103                 return 0;
 104         }
 105
 106         # Can't multiply by 0x100000000, (1 << 32),
 107         # without Perl issuing an integer overflow warning
 108         #
 109         # So use two multiplies by 0x10000 instead of one multiply by 0x100000000
 110         #
 111         # The result is the same.
 112         #
 113         my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
 114         my $time = (($high * 0x10000) * 0x10000) + $low;
 115
 116         $time -= $date1970;
 117         $time /= 10000000;
 118
 119         return $time;
 120 }
 121
 122 sub load_cookie
 123 {
 124         my($self, $file) = @_;
 125         my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
 126         my $cookie_data;
 127
 128         if (-f $file)
 129         {
 130                 # open the cookie file and get the data
 131                 $cookie_data = load_cookies_from_file($file);
 132
 133                 foreach my $cookie (@{$cookie_data})
 134                 {
 135                         my $secure = ($cookie->{FLAGS} & 1) != 0;
 136                         my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
 137
 138                         $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
 139                                           $cookie->{PATH}, $cookie->{DOMAIN}, undef,
 140                                           0, $secure, $expires-$now, 0);
 141                 }
 142         }
 143 }
 144
 145 sub load
 146 {
 147         my($self, $cookie_index) = @_;
 148         my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
 149         my $cookie_dir = '';
 150         my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
 151         my $user_name = get_user_name();
 152         my $data;
 153
 154         $cookie_index ||= $self->{'file'} || return;
 155         if ($cookie_index =~ /[\\\/][^\\\/]+$/)
 156         {
 157                 $cookie_dir = $` . "\\";
 158         }
 159
 160         local(*INDEX, $_);
 161
 162         open(INDEX, $cookie_index) || return;
 163         binmode(INDEX);
 164         if (256 != read(INDEX, $data, 256))
 165         {
 166                 warn "$cookie_index file is not large enough";
 167                 close(INDEX);
 168                 return;
 169         }
 170
 171         # Cookies' index.dat file starts with 32 bytes of signature
 172         # followed by an offset to the first record, stored as a little-endian DWORD
 173         my ($sig, $size) = unpack('a32 V', $data);
 174
 175         if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
 176                 (0x4000 != $size))
 177         {
 178                 warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
 179                 close(INDEX);
 180                 return;
 181         }
 182
 183         if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
 184         {
 185                 close(INDEX);
 186                 return;
 187         }
 188
 189         # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
 190         # so read in two 0x80 byte sectors and adjust if not a Cookie.
 191         while (256 == read(INDEX, $data, 256))
 192         {
 193                 # each record starts with a 4-byte signature
 194                 # and a count (little-endian DWORD) of 0x80 byte sectors for the record
 195                 ($sig, $size) = unpack('a4 V', $data);
 196
 197                 # Cookies are found in 'URL ' records
 198                 if ('URL ' ne $sig)
 199                 {
 200                         # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
 201                         if (($sig eq 'HASH') || ($sig eq 'LEAK'))
 202                         {
 203                                 # '-2' takes into account the two 0x80 byte sectors we've just read in
 204                                 if (($size > 0) && ($size != 2))
 205                                 {
 206                                     if (0 == seek(INDEX, ($size-2)*0x80, 1))
 207                                     {
 208                                             # Seek failed. Something's wrong. Gonna stop.
 209                                             last;
 210                                     }
 211                                 }
 212                         }
 213                         next;
 214                 }
 215
 216                 #$REMOVE Need to check if URL records in Cookies' index.dat will
 217                 #        ever use more than two 0x80 byte sectors
 218                 if ($size > 2)
 219                 {
 220                         my $more_data = ($size-2)*0x80;
 221
 222                         if ($more_data != read(INDEX, $data, $more_data, 256))
 223                         {
 224                                 last;
 225                         }
 226                 }
 227
 228                 if ($data =~ /Cookie\:$user_name\@([\x21-\xFF]+).*?($user_name\@[\x21-\xFF]+\.txt)/)
 229                 {
 230                         my $cookie_file = $cookie_dir . $2; # form full pathname
 231
 232                         if (!$delay_load)
 233                         {
 234                                 $self->load_cookie($cookie_file);
 235                         }
 236                         else
 237                         {
 238                                 my $domain = $1;
 239
 240                                 # grab only the domain name, drop everything from the first dir sep on
 241                                 if ($domain =~ m{[\\/]})
 242                                 {
 243                                         $domain = $`;
 244                                 }
 245
 246                                 # set the delayload cookie for this domain with
 247                                 # the cookie_file as cookie for later-loading info
 248                                 $self->set_cookie(undef, 'cookie', $cookie_file,
 249                                                       '//+delayload', $domain, undef,
 250                                                       0, 0, $now+86400, 0);
 251                         }
 252                 }
 253         }
 254
 255         close(INDEX);
 256
 257         1;
 258 }
 259
 260 1;
 261
 262 __END__
 263
 264 =head1 NAME
 265
 266 HTTP::Cookies::Microsoft - access to Microsoft cookies files
 267
 268 =head1 SYNOPSIS
 269
 270  use LWP;
 271  use HTTP::Cookies::Microsoft;
 272  use Win32::TieRegistry(Delimiter => "/");
 273  my $cookies_dir = $Registry->
 274       {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
 275
 276  $cookie_jar = HTTP::Cookies::Microsoft->new(
 277                    file     => "$cookies_dir\\index.dat",
 278                    'delayload' => 1,
 279                );
 280  my $browser = LWP::UserAgent->new;
 281  $browser->cookie_jar( $cookie_jar );
 282
 283 =head1 DESCRIPTION
 284
 285 This is a subclass of C<HTTP::Cookies> which
 286 loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
 287 cookie files.
 288
 289 See the documentation for L<HTTP::Cookies>.
 290
 291 =head1 METHODS
 292
 293 The following methods are provided:
 294
 295 =over 4
 296
 297 =item $cookie_jar = HTTP::Cookies::Microsoft->new;
 298
 299 The constructor takes hash style parameters. In addition
 300 to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
 301 recognizes the following:
 302
 303   delayload:       delay loading of cookie data until a request
 304                    is actually made. This results in faster
 305                    runtime unless you use most of the cookies
 306                    since only the domain's cookie data
 307                    is loaded on demand.
 308
 309 =back
 310
 311 =head1 CAVEATS
 312
 313 Please note that the code DOESN'T support saving to the MSIE
 314 cookie file format.
 315
 316 =head1 AUTHOR
 317
 318 Johnny Lee <typo_pl@hotmail.com>
 319
 320 =head1 COPYRIGHT
 321
 322 Copyright 2002 Johnny Lee
 323
 324 This library is free software; you can redistribute it and/or
 325 modify it under the same terms as Perl itself.
 326
 327 =cut
 328