File Coverage

blib/lib/HTTP/Cookies/Find.pm

Criterion	Covered	Total	%
statement	75	190	39.4
branch	11	82	13.4
condition	2	15	13.3
subroutine	19	21	90.4
pod	2	2	100.0
total	109	310	35.1

# $Id: Find.pm,v 1.415 2010-05-08 12:42:51 Martin Exp $

package HTTP::Cookies::Find;

use strict;

use base 'HTTP::Cookies';

use Carp;
use Config::IniFiles;
use Data::Dumper;  # for debugging only
use File::HomeDir;
use File::Spec::Functions;
use File::Slurp;
use HTTP::Cookies::Mozilla;
use HTTP::Cookies::Netscape;
use User;

our
$VERSION = do { my @r = (q$Revision: 1.415 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r };

=head1 NAME

HTTP::Cookies::Find - Locate cookies for the current user on the local machine.

=head1 SYNOPSIS

  use HTTP::Cookies::Find;
  my $oCookies = HTTP::Cookies::Find->new('domain.com');
  my @asMsg = HTTP::Cookies::Find::errors;
  # Now $oCookies is a subclass of HTTP::Cookies
  # and @asMsg is an array of error messages

  # Call in array context to find cookies from multiple
  # browsers/versions:
  my @aoCookies = HTTP::Cookies::Find->new('domain.com');
  # Now @aoCookies is an array of HTTP::Cookies objects

=head1 DESCRIPTION

Looks in various normal places for HTTP cookie files.

=head1 METHODS

=over

=item new

Returns a list of cookie jars of type HTTP::Cookies::[vendor],
for all vendor browsers found on the system.
If called in scalar context, returns one cookie jar for the "first" vendor browser found on the system.
The returned cookie objects are not tied to the cookie files on disk;
the returned cookie objects are read-only copies of the found cookies.
If no argument is given, the returned cookie objects contain read-only copies of ALL cookies.
If an argument is given, the returned cookie objects contain read-only copies of only those cookies whose hostname "matches" the argument.
Here "matches" means case-insensitive pattern match;
you can pass a qr{} regexp as well as a plain string for matching.

=cut

############################################# main pod documentation end ##

use constant DEBUG_NEW => 0;
use constant DEBUG_GET => 0;

# We use global variables so that the callback function can see them:
use vars qw( $sUser $sHostGlobal $oReal );

my @asError;

sub _add_error
  {
  push @asError, shift;
  } # _add_error

sub new
  {
  my $class = shift;
  $sHostGlobal = shift || '';
  my @aoRet;
  if ($^O =~ m!win32!i)
    {
 WIN32_MSIE:
      {
      # Massage the hostname in an attempt to make it match MS' highlevel
      # naming scheme:
      my $sHost = $sHostGlobal;
      $sHost =~ s!\.(com|edu|gov|net|org)\Z!!;  # delete USA domain
      $sHost =~ s!\.[a-z][a-z]\.[a-z][a-z]\Z!!;  # delete intl domain
      # We only look at cookies for the logged-in user:
      $sUser = lc User->Login;
      print STDERR " + Finding cookies for user $sUser with host matching ($sHost)...\n" if DEBUG_NEW;
      my ($sDir, %hsRegistry);
      eval q{require HTTP::Cookies::Microsoft};
      if ($@)
        {
        _add_error qq{ EEE can not load module HTTP::Cookies::Microsoft: $@\n};
        last WIN32_MSIE;
        } # if
      eval q{use Win32::TieRegistry(
                                    Delimiter => '/',
                                    TiedHash => \%hsRegistry,
                                   )};
      if ($@)
        {
        _add_error qq{ EEE can not load module Win32::TieRegistry: $@\n};
        last WIN32_MSIE;
        } # if
      $sDir = $hsRegistry{"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"} || '';
      if ($sDir eq '')
        {
        _add_error qq{ EEE can not find registry entry for MSIE cookies\n};
        last WIN32_MSIE;
        } # if
      unless (-d $sDir)
        {
        ; _add_error qq{ EEE registry entry for MSIE cookies is $sDir but that directory does not exist.\n}
        ; last WIN32_MSIE
        } # unless
      # index.dat is for XP; Low/index.dat is for Vista:
      foreach my $sFnameBase (qw( index.dat Low/index.dat ))
        {
        my $sFnameCookies = "$sDir\\$sFnameBase";
        if (-f $sFnameCookies)
          {
          _get_cookies($sFnameCookies, 'HTTP::Cookies::Microsoft');
          last WIN32_MSIE;
          } # if
        } # foreach
      } # end of WIN32_MSIE block
    # At this point, $oReal contains MSIE cookies (or undef).
    if (ref($oReal))
      {
      return $oReal if ! wantarray;
      push @aoRet, $oReal;
      } # if found MSIE cookies
    # If wantarray, or the MSIE cookie search failed, go on and look
    # for Netscape cookies:
 WIN32_NETSCAPE:
      {
      $oReal = undef;
      my $sDirWin = $ENV{WINDIR};
      my $sFnameWinIni = catfile($sDirWin, 'win.ini');
      if (! -f $sFnameWinIni)
        {
        _add_error qq{ EEE Windows ini file $sFnameWinIni does not exist\n};
        last WIN32_NETSCAPE;
        } # if
      my $oIniWin = new Config::IniFiles(
                                         -file => $sFnameWinIni,
                                        );
      if (! ref($oIniWin))
        {
        _add_error qq{ EEE can not parse $sFnameWinIni\n};
        last WIN32_NETSCAPE;
        } # if
      my $sFnameNSIni = $oIniWin->val('Netscape', 'ini');
      if (! defined $sFnameNSIni)
        {
        _add_error qq{ EEE Netscape / Mozilla is not installed\n};
        last WIN32_NETSCAPE;
        } # if
      if (! -f $sFnameNSIni)
        {
        _add_error qq{ EEE Netscape ini file $sFnameNSIni does not exist\n};
        last WIN32_NETSCAPE;
        } # if
      my $oIniNS = Config::IniFiles->new(
                                         -file => $sFnameNSIni,
                                        );
      if (! ref($oIniNS))
        {
        _add_error qq{ EEE can not parse $sFnameNSIni\n};
        last WIN32_NETSCAPE;
        } # if
      my $sFnameCookies = $oIniNS->val('Cookies', 'Cookie File');
      _get_cookies($sFnameCookies, 'HTTP::Cookies::Netscape');
      } # end of WIN32_NETSCAPE block
    # At this point, $oReal contains Netscape cookies (or undef).
    if (ref($oReal))
      {
      return $oReal if ! wantarray;
      push @aoRet, $oReal;
      } # if found Netscape cookies
      # If wantarray, or the previous cookie searches failed, go on and
    # look for FireFox cookies:
 WIN32_FIREFOX:
      {
      $oReal = undef;
      my $sProfileDir = "$ENV{APPDATA}/Mozilla/Firefox/Profiles";
      if (! opendir (DIR, $sProfileDir))
        {
        _add_error qq{ EEE Can't open Mozilla profile directory ( $sProfileDir ): $! };
        last WIN32_FIREFOX;
        } # if
      my $bMozFound;
      while ( my $test = readdir( DIR ) )
        {
        if ( -d "$sProfileDir/$test" && -f "$sProfileDir/$test/cookies.txt" )
          {
          $bMozFound = 1;
          my $sFnameCookies = "$sProfileDir/$test/cookies.txt";
          _get_cookies($sFnameCookies, 'HTTP::Cookies::Mozilla');
          } # if
        } # while
      closedir DIR or warn;
      if ( ! $bMozFound )
        {
        _add_error qq{ EEE No Mozilla cookie files found under $sProfileDir\\* }
        } # if
      } # end of WIN32_FIREFOX block
    # At this point, $oReal contains Netscape cookies (or undef):
    if (ref($oReal))
      {
      return $oReal if ! wantarray;
      push @aoRet, $oReal;
      } # if found Mozilla cookies
    # No more places to look, fall through and return what we've
    # found.
    } # if MSWin32
  elsif (
         ($^O =~ m!solaris!i)
         ||
         ($^O =~ m!linux!i)
        )
    {
    # Unix-like operating systems.
    $oReal = undef;
 UNIX_NETSCAPE4:
      {
      ; my $sFname = catfile(home(), '.netscape', 'cookies')
      ; print STDERR " + try $sFname...\n" if DEBUG_NEW
      ; _get_cookies($sFname, 'HTTP::Cookies::Netscape')
      ; last UNIX_NETSCAPE4 unless ref($oReal)
      ; push @aoRet, $oReal
      } # end of UNIX_NETSCAPE4 block
    # At this point, $oReal contains Netscape 7 cookies (or undef).
    ; if (ref($oReal))
      {
      ; return $oReal if ! wantarray
      ; push @aoRet, $oReal
      } # if found any cookies
 UNIX_NETSCAPE7:
      {
      ;
      } # end of UNIX_NETSCAPE7 block
    # At this point, $oReal contains Netscape 7 cookies (or undef).
    ; if (ref($oReal))
      {
      ; return $oReal if ! wantarray
      ; push @aoRet, $oReal
      } # if found any cookies
 UNIX_MOZILLA:
      {
      ; eval q{use HTTP::Cookies::Mozilla}
      ; my $sAppregFname = catfile(home(), '.mozilla', 'appreg')
      # ; print STDERR " + try to read appreg ==$sAppregFname==\n"
      ; if (! -f $sAppregFname)
        {
        ; _add_error qq{ EEE Mozilla file $sAppregFname does not exist\n};
        ; last UNIX_MOZILLA
        } # if
      ; my $sAppreg
      ; eval { $sAppreg = read_file($sAppregFname, binmode => ':raw') }
      ; $sAppreg ||= '';
      ; my ($sDir) = ($sAppreg =~ m!(.mozilla/.+?\.slt)\b!)
      # ; print STDERR " + found slt ==$sDir==\n"
      ; my $sFname = catfile(home(), $sDir, 'cookies.txt')
      # ; print STDERR " + try to read cookies ==$sFname==\n"
      ; _get_cookies($sFname, 'HTTP::Cookies::Mozilla')
      } # end of UNIX_MOZILLA block
    # At this point, $oReal contains Mozilla cookies (or undef).
    # ; print STDERR " +   After mozilla cookie check, oReal is ==$oReal==\n"
    ; if (ref($oReal))
      {
      ; return $oReal if ! wantarray
      # ; print STDERR " +   wantarray, keep looking\n"
      ; push @aoRet, $oReal
      } # if found Mozilla cookies
    } # if Unix
  else
    {
    # Future expansion: implement Netscape / other OS combinations
    }
  return wantarray ? @aoRet : $oReal;
  } # new

=item errors

If anything went wrong while finding cookies,
errors() will return a list of string(s) describing the error(s).

=cut

sub errors
  {
  return @asError;
  } # errors

sub _get_cookies
  {
  # Required arg1 = cookies filename:
  my $sFnameCookies = shift;
  # Required arg2 = cookies object type:
  my $sClass = shift;
  my $rcCallback = ($sClass =~ m!Microsoft!) ? \&_callback_msie
                 : ($sClass =~ m!Netscape!)  ? \&_callback_mozilla
                 : ($sClass =~ m!Mozilla!)   ? \&_callback_mozilla
                 :                             \&_callback_mozilla;
  # Our return value is an object of type HTTP::Cookies.
  print STDERR " + _get_cookies($sFnameCookies,$sClass)\n" if DEBUG_GET;
  if (! -f $sFnameCookies)
    {
    _add_error qq{ EEE cookies file $sFnameCookies does not exist\n};
    return undef;
    } # if
  # Because $oReal is a global variable, force creation of a new
  # object into a new variable:
  my $oRealNS = $sClass->new;
  unless (ref $oRealNS)
    {
    _add_error qq{ EEE can not create an empty $sClass object.\n};
    return undef;
    } # unless
  print STDERR " +   created oRealNS ==$oRealNS==...\n" if DEBUG_GET;
  $oReal = $oRealNS;
  # This is a dummy object that we use to find the appropriate
  # cookies:
  my $oDummy = $sClass->new(
                            File => $sFnameCookies,
                            'delayload' => 1,
                           );
  unless (ref $oDummy)
    {
    _add_error qq{ EEE can not create an empty $sClass object.\n};
    return undef;
    } # unless
  print STDERR " +   created oDummy ==$oDummy==...\n" if DEBUG_GET;
  $oDummy->scan($rcCallback) if ref($oDummy);
  print STDERR " +   return oReal ==$oReal==...\n" if DEBUG_GET;
  return $oReal;
  } # _get_cookies


sub _callback_msie
  {
  my ($version,
      $key, $val,
      $path, $domain, $port, $path_spec,
      $secure, $expires, $discard, $hash) = @_;
  # All we care about at this level is the filename, which is in the
  # $val slot:
  print STDERR " + consider cookie, val==$val==\n" if (DEBUG_NEW);
  return unless ($val =~ m!\@.*$sHostGlobal!i);
  print STDERR " +   matches host ($sHostGlobal)\n" if (1 < DEBUG_NEW);
  return unless ($val =~ m!\\$sUser\@!);
  print STDERR " +   matches user ($sUser)\n" if (1 < DEBUG_NEW);
  # This cookie file matches the user and host.  Add it to the cookies
  # we'll keep:
  $oReal->load_cookie($val);
  } # _callback_msie

sub _callback_mozilla
  {
  # print STDERR " + _callback got a cookie: ", Dumper(\@_);
  # return;
  # my ($version,
  #     $key, $val,
  #     $path, $domain, $port, $path_spec,
  #     $secure, $expires, $discard, $hash) = @_;
  my $sDomain = $_[4];
  print STDERR " +   consider cookie from domain ($sDomain), want host ($sHostGlobal)...\n" if DEBUG_NEW;
  return if (($sHostGlobal ne '') && ($sDomain !~ m!$sHostGlobal!i));
  print STDERR " +     domain ($sDomain) matches host ($sHostGlobal)\n" if DEBUG_NEW;
  $oReal->set_cookie(@_);
  } # _callback_mozilla

1;

__END__