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

   1 package HTTP::Cookies::Microsoft;
   2
   3 use strict;
   4
   5 use vars qw(@ISA $VERSION);
   6
   7 $VERSION = "5.821";
   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                 (my $user_name2 = $user_name) =~ s/ /_/g;
 229                 if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
 230                 {
 231                         my $cookie_file = $cookie_dir . $2; # form full pathname
 232
 233                         if (!$delay_load)
 234                         {
 235                                 $self->load_cookie($cookie_file);
 236                         }
 237                         else
 238                         {
 239                                 my $domain = $1;
 240
 241                                 # grab only the domain name, drop everything from the first dir sep on
 242                                 if ($domain =~ m{[\\/]})
 243                                 {
 244                                         $domain = $`;
 245                                 }
 246
 247                                 # set the delayload cookie for this domain with
 248                                 # the cookie_file as cookie for later-loading info
 249                                 $self->set_cookie(undef, 'cookie', $cookie_file,
 250                                                       '//+delayload', $domain, undef,
 251                                                       0, 0, $now+86400, 0);
 252                         }
 253                 }
 254         }
 255
 256         close(INDEX);
 257
 258         1;
 259 }
 260
 261 1;
 262
 263 __END__
 264
 265 =head1 NAME
 266
 267 HTTP::Cookies::Microsoft - access to Microsoft cookies files
 268
 269 =head1 SYNOPSIS
 270
 271  use LWP;
 272  use HTTP::Cookies::Microsoft;
 273  use Win32::TieRegistry(Delimiter => "/");
 274  my $cookies_dir = $Registry->
 275       {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
 276
 277  $cookie_jar = HTTP::Cookies::Microsoft->new(
 278                    file     => "$cookies_dir\\index.dat",
 279                    'delayload' => 1,
 280                );
 281  my $browser = LWP::UserAgent->new;
 282  $browser->cookie_jar( $cookie_jar );
 283
 284 =head1 DESCRIPTION
 285
 286 This is a subclass of C<HTTP::Cookies> which
 287 loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
 288 cookie files.
 289
 290 See the documentation for L<HTTP::Cookies>.
 291
 292 =head1 METHODS
 293
 294 The following methods are provided:
 295
 296 =over 4
 297
 298 =item $cookie_jar = HTTP::Cookies::Microsoft->new;
 299
 300 The constructor takes hash style parameters. In addition
 301 to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
 302 recognizes the following:
 303
 304   delayload:       delay loading of cookie data until a request
 305                    is actually made. This results in faster
 306                    runtime unless you use most of the cookies
 307                    since only the domain's cookie data
 308                    is loaded on demand.
 309
 310 =back
 311
 312 =head1 CAVEATS
 313
 314 Please note that the code DOESN'T support saving to the MSIE
 315 cookie file format.
 316
 317 =head1 AUTHOR
 318
 319 Johnny Lee <typo_pl@hotmail.com>
 320
 321 =head1 COPYRIGHT
 322
 323 Copyright 2002 Johnny Lee
 324
 325 This library is free software; you can redistribute it and/or
 326 modify it under the same terms as Perl itself.
 327
 328 =cut
 329