14015215895

Committed 26 Jan 2025 09:20PM UTC coverage: 58.879% (-3.2%) from 62.037%

Build # 14015215895

Build Type

push

github

Committed by

briandfoy

Commit Message

* for version 3.001

Run Details

63 of 107 relevant lines covered (58.88%)

23.08 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

58.88

/lib/HTTP/Cookies/Mozilla.pm

package HTTP::Cookies::Mozilla;
use strict;

use warnings;
no warnings;

=encoding utf8

=head1 NAME

HTTP::Cookies::Mozilla - Cookie storage and management for Mozilla

=head1 SYNOPSIS

        use HTTP::Cookies::Mozilla;

        my $file = ...; # Firefox profile dir / cookies.sqlite
        my $cookie_jar = HTTP::Cookies::Mozilla->new( file => $file );

        # otherwise same as HTTP::Cookies

=head1 DESCRIPTION

This package overrides the C<load()> and C<save()> methods of
HTTP::Cookies so it can work with Mozilla cookie files. These might
be stored in the user profile directory as F<cookies>. On macOS,for
instance, that's F<~/Application Support/Firefox/*/cookies.sqlite>.

This module should be able to work with all Mozilla derived browsers
(FireBird, Camino, et alia).

Note that as of FireFox, version 3, the cookie file format changed
from plain text files to SQLite databases, so you will need to have
either L<DBI>/L<DBD::SQLite>, or the B<sqlite3> executable somewhere
in the path. Neither one has been put as explicit dependency, anyway,
so you'll get an exception if you try to use this module with a new
style file but without having any of them:

   neither DBI nor pipe to sqlite3 worked (%s), install either one

If your command-line B<sqlite3> is not in the C<$ENV{PATH}>, you can
set C<$HTTP::Cookies::Mozilla::SQLITE> to point to the actual program
to be used, e.g.:

   use HTTP::Cookies::Mozilla;
   $HTTP::Cookies::Mozilla::SQLITE = '/path/to/sqlite3';

Usage of the external program is supported under perl 5.8 onwards only,
because previous perl versions do not support L<perlfunc/open> with
more than three arguments, which are safer. If you are still sticking
to perl 5.6, you'll have to install L<DBI>/L<DBD::SQLite> to make
FireFox 3 cookies work.

See L<HTTP::Cookies>.

=head1 SOURCE AVAILABILITY

The source is in GitHub:

        https://github.com/briandfoy/http-cookies-mozilla

=head1 AUTHOR

Derived from Gisle Aas's HTTP::Cookies::Netscape package with very
few material changes.

Flavio Poletti added the SQLite support.

Maintained by brian d foy, C<< <briandfoy@pobox.com> >>

=head1 COPYRIGHT AND LICENSE

Parts Copyright 1997-1999 Gisle Aas.

Other parts Copyright 2018-2024 by brian d foy, C<< <briandfoy@pobox.com> >>

This library is free software; you can redistribute it and/or modify
it under the terms of the Artistic License 2.0.

=cut

use base qw( HTTP::Cookies );
use vars qw( $VERSION $SQLITE );

use Carp qw(carp);

use constant TRUE  => 'TRUE';
use constant FALSE => 'FALSE';

$VERSION = '3.001';
$SQLITE = 'sqlite3';


sub _load_ff3 {
        my ($self, $file) = @_;
        my $cookies;
        my $query = 'SELECT host, path, name, value, isSecure, expiry FROM moz_cookies';
        eval {
                require DBI;
                my $dbh = DBI->connect('dbi:SQLite:dbname=' . $file, '', '',
                 {RaiseError => 1}
                 );
                $cookies = $dbh->selectall_arrayref($query);
                $dbh->disconnect();
                1;
                }
        or eval {
                require 5.008_000; # for >3 arguments open, which is safer
                open my $fh, '-|', $SQLITE, $file, $query or die $!;
                $cookies = [ map { [ split /\|/ ] } <$fh> ];
                1;
                }
        or do {
                carp "neither DBI nor pipe to sqlite3 worked ($@), install either one";
                return;
                };

        for my $cookie ( @$cookies )
                {
                my( $domain, $path, $key, $val, $secure, $expires ) = @$cookie;

                $self->set_cookie( undef, $key, $val, $path, $domain, undef,
                   0, $secure, $expires - _now(), 0 );
                }

        return 1;
}

sub load {
        my( $self, $file ) = @_;

        $file ||= $self->{'file'} || do {
                carp "load() did not get a filename!";
                return;
                };

        return $self->_load_ff3($file) if $file =~ m{\.sqlite}i;

        local $_;
        local $/ = "\n";  # make sure we got standard record separator

        my $fh;
        unless( open $fh, '<:utf8', $file ) {
                carp "Could not open file [$file]: $!";
                return;
                }

        my $magic = <$fh>;

        unless( $magic =~ /^\# HTTP Cookie File/ ) {
                carp "$file does not look like a Mozilla cookies file";
                close $fh;
                return;
                }

        while( <$fh> ) {
                next if /^\s*\#/;
                next if /^\s*$/;
                tr/\n\r//d;

                my( $domain, $bool1, $path, $secure, $expires, $key, $val )
                   = split /\t/;

                $secure = ( $secure eq TRUE );

                # The cookie format is an absolute time in epoch seconds, so
                # we subtract the current time (with appropriate offsets) to
                # get the max_age for the second-to-last argument.
                $self->set_cookie( undef, $key, $val, $path, $domain, undef,
                    0, $secure, $expires - _now(), 0 );
                }

        close $fh;

        1;
        }

BEGIN {
        my $EPOCH_OFFSET = $^O eq "MacOS" ? 21600 : 0;  # difference from Unix epoch
        sub _epoch_offset { $EPOCH_OFFSET }
        }

sub _now { time() - _epoch_offset() };

sub _scansub_maker {  # Encapsulate checks logic during cookie scan
        my ($self, $coresub) = @_;

        return sub {
                my( $version, $key, $val, $path, $domain, $port,
                    $path_spec, $secure, $expires, $discard, $rest ) = @_;

                return if $discard && not $self->{ignore_discard};

                $expires = $expires ? $expires - _epoch_offset() : 0;
                return if defined $expires && _now() > $expires;

                return $coresub->($domain, $path, $key, $val, $secure, $expires);
                };
        }

sub _save_ff3 {
        my ($self, $file) = @_;

        my @fnames = qw( host path name value isSecure expiry );
        my $fnames = join ', ', @fnames;

        eval {
                require DBI;
                my $dbh = DBI->connect('dbi:SQLite:dbname=' . $file, '', '',
                   {RaiseError => 1, AutoCommit => 0});

                $dbh->do('DROP TABLE IF EXISTS moz_cookies;');

                $dbh->do('CREATE TABLE moz_cookies '
                    . ' (id INTEGER PRIMARY KEY, name TEXT, value TEXT, host TEXT,'
                    . '  path TEXT,expiry INTEGER, lastAccessed INTEGER, '
                    . '  isSecure INTEGER, isHttpOnly INTEGER);');

                { # restrict scope for $sth
                my $pholds = join ', ', ('?') x @fnames;
                my $sth = $dbh->prepare(
                    "INSERT INTO moz_cookies($fnames) VALUES ($pholds)");
                $self->scan($self->_scansub_maker(
                        sub {
                                my( $domain, $path, $key, $val, $secure, $expires ) = @_;
                                $secure = $secure ? 1 : 0;
                                $sth->execute($domain, $path, $key, $val, $secure, $expires);
                                }
                                )
                        );
                $sth->finish();
                }

                $dbh->commit();
                $dbh->disconnect();
                1;
                }
        or eval {
                open my $fh, '|-', $SQLITE, $file or die $!;
                print {$fh} <<'INCIPIT';

BEGIN TRANSACTION;

DROP TABLE IF EXISTS moz_cookies;
CREATE TABLE moz_cookies
   (id INTEGER PRIMARY KEY, name TEXT, value TEXT, host TEXT,
    path TEXT,expiry INTEGER, lastAccessed INTEGER,
    isSecure INTEGER, isHttpOnly INTEGER);

INCIPIT

                $self->scan( $self->_scansub_maker(
                        sub {
                                my( $domain, $path, $key, $val, $secure, $expires ) = @_;
                                $secure = $secure ? 1 : 0;
                                my $values = join ', ',
                                        map {  # Encode all params as hex, a bit overkill
                                        my $hex = unpack 'H*', $_;
                                        "X'$hex'";
                                        } ( $domain, $path, $key, $val, $secure, $expires );
                                print {$fh}
                                        "INSERT INTO moz_cookies( $fnames ) VALUES ( $values );\n";
                                }
                        )
                );

                print {$fh} <<'EPILOGUE';

UPDATE moz_cookies SET lastAccessed = id;
END TRANSACTION;

EPILOGUE
        1;
        }
        or do {
                carp "neither DBI nor pipe to sqlite3 worked ($@), install either one";
                return;
        };

        return 1;
}

sub save {
        my( $self, $file ) = @_;

        $file ||= $self->{'file'} || do {
                carp "save() did not get a filename!";
                return;
                };

        return $self->_save_ff3($file) if $file =~ m{\. sqlite}imsx;

        local $_;

        my $fh;
        unless( open $fh, '>:utf8', $file ) {
                carp "Could not open file [$file]: $!";
                return;
                }

        print $fh <<'EOT';
# HTTP Cookie File
# http://www.netscape.com/newsref/std/cookie_spec.html
# This is a generated file!  Do not edit.
# To delete cookies, use the Cookie Manager.

EOT

        $self->scan($self->_scansub_maker(
                sub {
                        my( $domain, $path, $key, $val, $secure, $expires ) = @_;
                        $secure = $secure ? TRUE : FALSE;
                        my $bool = $domain =~ /^\./ ? TRUE : FALSE;
                        print $fh join( "\t", $domain, $bool, $path, $secure,
                                $expires, $key, $val ), "\n";
                        }
                        )
                );

        close $fh;

        1;
        }

1;

1	package HTTP::Cookies::Mozilla;
2	use strict;	30✔
3
4	use warnings;	30✔
5	no warnings;	30✔
6
7	=encoding utf8
8
9	=head1 NAME
10
11	HTTP::Cookies::Mozilla - Cookie storage and management for Mozilla
12
13	=head1 SYNOPSIS
14
15	use HTTP::Cookies::Mozilla;
16
17	my $file = ...; # Firefox profile dir / cookies.sqlite
18	my $cookie_jar = HTTP::Cookies::Mozilla->new( file => $file );
19
20	# otherwise same as HTTP::Cookies
21
22	=head1 DESCRIPTION
23
24	This package overrides the C<load()> and C<save()> methods of
25	HTTP::Cookies so it can work with Mozilla cookie files. These might
26	be stored in the user profile directory as F<cookies>. On macOS,for
27	instance, that's F<~/Application Support/Firefox/*/cookies.sqlite>.
28
29	This module should be able to work with all Mozilla derived browsers
30	(FireBird, Camino, et alia).
31
32	Note that as of FireFox, version 3, the cookie file format changed
33	from plain text files to SQLite databases, so you will need to have
34	either L<DBI>/L<DBD::SQLite>, or the B<sqlite3> executable somewhere
35	in the path. Neither one has been put as explicit dependency, anyway,
36	so you'll get an exception if you try to use this module with a new
37	style file but without having any of them:
38
39	neither DBI nor pipe to sqlite3 worked (%s), install either one
40
41	If your command-line B<sqlite3> is not in the C<$ENV{PATH}>, you can
42	set C<$HTTP::Cookies::Mozilla::SQLITE> to point to the actual program
43	to be used, e.g.:
44
45	use HTTP::Cookies::Mozilla;
46	$HTTP::Cookies::Mozilla::SQLITE = '/path/to/sqlite3';
47
48	Usage of the external program is supported under perl 5.8 onwards only,
49	because previous perl versions do not support L<perlfunc/open> with
50	more than three arguments, which are safer. If you are still sticking
51	to perl 5.6, you'll have to install L<DBI>/L<DBD::SQLite> to make
52	FireFox 3 cookies work.
53
54	See L<HTTP::Cookies>.
55
56	=head1 SOURCE AVAILABILITY
57
58	The source is in GitHub:
59
60	https://github.com/briandfoy/http-cookies-mozilla
61
62	=head1 AUTHOR
63
64	Derived from Gisle Aas's HTTP::Cookies::Netscape package with very
65	few material changes.
66
67	Flavio Poletti added the SQLite support.
68
69	Maintained by brian d foy, C<< <briandfoy@pobox.com> >>
70
71	=head1 COPYRIGHT AND LICENSE
72
73	Parts Copyright 1997-1999 Gisle Aas.
74
75	Other parts Copyright 2018-2024 by brian d foy, C<< <briandfoy@pobox.com> >>
76
77	This library is free software; you can redistribute it and/or modify
78	it under the terms of the Artistic License 2.0.
79
80	=cut
81
82	use base qw( HTTP::Cookies );	30✔
83	use vars qw( $VERSION $SQLITE );	30✔
84
85	use Carp qw(carp);	30✔
86
87	use constant TRUE => 'TRUE';	30✔
88	use constant FALSE => 'FALSE';	30✔
89
90	$VERSION = '3.001';
91	$SQLITE = 'sqlite3';
92
93
94	sub _load_ff3 {
95	my ($self, $file) = @_;	10✔
96	my $cookies;	10✔
97	my $query = 'SELECT host, path, name, value, isSecure, expiry FROM moz_cookies';	10✔
98	eval {
99	require DBI;	10✔
100	my $dbh = DBI->connect('dbi:SQLite:dbname=' . $file, '', '',	10✔
101	{RaiseError => 1}
102	);
103	$cookies = $dbh->selectall_arrayref($query);	10✔
104	$dbh->disconnect();	10✔
105	1;	10✔
106	}
107	or eval {
108	require 5.008_000; # for >3 arguments open, which is safer	×
109	open my $fh, '-\|', $SQLITE, $file, $query or die $!;	×
110	$cookies = [ map { [ split /\\|/ ] } <$fh> ];	×
111	1;	×
112	}
113	or do {	10✔
114	carp "neither DBI nor pipe to sqlite3 worked ($@), install either one";	×
115	return;	×
116	};
117
118	for my $cookie ( @$cookies )	10✔
119	{
120	my( $domain, $path, $key, $val, $secure, $expires ) = @$cookie;	50✔
121
122	$self->set_cookie( undef, $key, $val, $path, $domain, undef,	50✔
123	0, $secure, $expires - _now(), 0 );
124	}
125
126	return 1;	10✔
127	}
128
129	sub load {
130	my( $self, $file ) = @_;	30✔
131
132	$file \|\|= $self->{'file'} \|\| do {	30✔
133	carp "load() did not get a filename!";
134	return;
135	};
136
137	return $self->_load_ff3($file) if $file =~ m{\.sqlite}i;	30✔
138
139	local $_;	20✔
140	local $/ = "\n"; # make sure we got standard record separator	20✔
141
142	my $fh;	20✔
143	unless( open $fh, '<:utf8', $file ) {	20✔
144	carp "Could not open file [$file]: $!";	×
145	return;	×
146	}
147
148	my $magic = <$fh>;	20✔
149
150	unless( $magic =~ /^\# HTTP Cookie File/ ) {	20✔
151	carp "$file does not look like a Mozilla cookies file";	×
152	close $fh;	×
153	return;	×
154	}
155
156	while( <$fh> ) {	20✔
157	next if /^\s*\#/;	180✔
158	next if /^\s*$/;	120✔
159	tr/\n\r//d;	100✔
160
161	my( $domain, $bool1, $path, $secure, $expires, $key, $val )	100✔
162	= split /\t/;
163
164	$secure = ( $secure eq TRUE );	100✔
165
166	# The cookie format is an absolute time in epoch seconds, so
167	# we subtract the current time (with appropriate offsets) to
168	# get the max_age for the second-to-last argument.
169	$self->set_cookie( undef, $key, $val, $path, $domain, undef,	100✔
170	0, $secure, $expires - _now(), 0 );
171	}
172
173	close $fh;	20✔
174
175	1;	20✔
176	}
177
178	BEGIN {
179	my $EPOCH_OFFSET = $^O eq "MacOS" ? 21600 : 0; # difference from Unix epoch	30✔
180	sub _epoch_offset { $EPOCH_OFFSET }	250✔
181	}
182
183	sub _now { time() - _epoch_offset() };	200✔
184
185	sub _scansub_maker { # Encapsulate checks logic during cookie scan
186	my ($self, $coresub) = @_;	10✔
187
188	return sub {
189	my( $version, $key, $val, $path, $domain, $port,	50✔
190	$path_spec, $secure, $expires, $discard, $rest ) = @_;
191
192	return if $discard && not $self->{ignore_discard};	50✔
193
194	$expires = $expires ? $expires - _epoch_offset() : 0;	50✔
195	return if defined $expires && _now() > $expires;	50✔
196
197	return $coresub->($domain, $path, $key, $val, $secure, $expires);	50✔
198	};	10✔
199	}
200
201	sub _save_ff3 {
202	my ($self, $file) = @_;	×
203
204	my @fnames = qw( host path name value isSecure expiry );	×
205	my $fnames = join ', ', @fnames;	×
206
207	eval {
208	require DBI;	×
209	my $dbh = DBI->connect('dbi:SQLite:dbname=' . $file, '', '',	×
210	{RaiseError => 1, AutoCommit => 0});
211
212	$dbh->do('DROP TABLE IF EXISTS moz_cookies;');	×
213
214	$dbh->do('CREATE TABLE moz_cookies '	×
215	. ' (id INTEGER PRIMARY KEY, name TEXT, value TEXT, host TEXT,'
216	. ' path TEXT,expiry INTEGER, lastAccessed INTEGER, '
217	. ' isSecure INTEGER, isHttpOnly INTEGER);');
218
219	{ # restrict scope for $sth
220	my $pholds = join ', ', ('?') x @fnames;	×
221	my $sth = $dbh->prepare(	×
222	"INSERT INTO moz_cookies($fnames) VALUES ($pholds)");
223	$self->scan($self->_scansub_maker(
224	sub {
225	my( $domain, $path, $key, $val, $secure, $expires ) = @_;	×
226	$secure = $secure ? 1 : 0;	×
227	$sth->execute($domain, $path, $key, $val, $secure, $expires);	×
228	}
229	)
230	);	×
231	$sth->finish();	×
232	}
233
234	$dbh->commit();	×
235	$dbh->disconnect();	×
236	1;	×
237	}
238	or eval {
239	open my $fh, '\|-', $SQLITE, $file or die $!;	×
240	print {$fh} <<'INCIPIT';	×
241
242	BEGIN TRANSACTION;
243
244	DROP TABLE IF EXISTS moz_cookies;
245	CREATE TABLE moz_cookies
246	(id INTEGER PRIMARY KEY, name TEXT, value TEXT, host TEXT,
247	path TEXT,expiry INTEGER, lastAccessed INTEGER,
248	isSecure INTEGER, isHttpOnly INTEGER);
249
250	INCIPIT
251
252	$self->scan( $self->_scansub_maker(
253	sub {
254	my( $domain, $path, $key, $val, $secure, $expires ) = @_;	×
255	$secure = $secure ? 1 : 0;	×
256	my $values = join ', ',
257	map { # Encode all params as hex, a bit overkill
258	my $hex = unpack 'H*', $_;	×
259	"X'$hex'";	×
260	} ( $domain, $path, $key, $val, $secure, $expires );
261	print {$fh}	×
262	"INSERT INTO moz_cookies( $fnames ) VALUES ( $values );\n";
263	}
264	)
265	);	×
266
267	print {$fh} <<'EPILOGUE';	×
268
269	UPDATE moz_cookies SET lastAccessed = id;
270	END TRANSACTION;
271
272	EPILOGUE
273	1;	×
274	}
275	or do {	×
276	carp "neither DBI nor pipe to sqlite3 worked ($@), install either one";	×
277	return;	×
278	};
279
280	return 1;	×
281	}
282
283	sub save {
284	my( $self, $file ) = @_;	10✔
285
286	$file \|\|= $self->{'file'} \|\| do {	10✔
287	carp "save() did not get a filename!";
288	return;
289	};
290
291	return $self->_save_ff3($file) if $file =~ m{\. sqlite}imsx;	10✔
292
293	local $_;	10✔
294
295	my $fh;	10✔
296	unless( open $fh, '>:utf8', $file ) {	10✔
297	carp "Could not open file [$file]: $!";	×
298	return;	×
299	}
300
301	print $fh <<'EOT';	10✔
302	# HTTP Cookie File
303	# http://www.netscape.com/newsref/std/cookie_spec.html
304	# This is a generated file! Do not edit.
305	# To delete cookies, use the Cookie Manager.
306
307	EOT
308
309	$self->scan($self->_scansub_maker(
310	sub {
311	my( $domain, $path, $key, $val, $secure, $expires ) = @_;	50✔
312	$secure = $secure ? TRUE : FALSE;	50✔
313	my $bool = $domain =~ /^\./ ? TRUE : FALSE;	50✔
314	print $fh join( "\t", $domain, $bool, $path, $secure,	50✔
315	$expires, $key, $val ), "\n";
316	}
317	)
318	);	10✔
319
320	close $fh;	10✔
321
322	1;	10✔
323	}
324
325	1;

briandfoy / http-cookies-mozilla / 14015215895

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous