File Coverage

blib/lib/HTTP/Cookies/Omniweb.pm

Criterion	Covered	Total	%
statement	69	72	95.8
branch	16	26	61.5
condition	3	10	30.0
subroutine	10	10	100.0
pod	2	2	100.0
total	100	120	83.3

package HTTP::Cookies::Omniweb;
use strict;

use warnings;
no warnings;

=encoding utf8

=head1 NAME

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

=head1 SYNOPSIS

	use HTTP::Cookies::Omniweb;

	$cookie_jar = HTTP::Cookies::Omniweb->new;

	# otherwise same as HTTP::Cookies

=head1 DESCRIPTION

This package overrides the C and C methods of HTTP::Cookies
so it can work with Omniweb cookie files.

See L.

=head1 BUGS

Although Omniweb declares that it uses a DTD, the URL to the DTD is
dead.

Omniweb seems to not store the path for cookies unless it is not
/, and sometimes it stores it as %2f.  I haven't completely figured
that out, so output files will not exactly match input files.

=head1 SOURCE AVAILABILITY

This code is in Github:

	https://github.com/CPAN-Adoptable-Modules/HTTP-Cookies-Omniweb

=head1 AUTHOR

brian d foy, C<<  >>

=head1 COPYRIGHT AND LICENSE

Copyright © 2002-2018, brian d foy . All rights reserved.

This program 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 );

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

$VERSION = '1.131';

my $EPOCH_OFFSET = 978_350_400;  # difference from Unix epoch

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

	$file ||= $self->{'file'} || return;

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

	open my $fh, $file or return;

	my $magic = ( <$fh>, <$fh>, <$fh> );

	unless( $magic =~ /^\s*\s*$/ )
		{
		warn "$file does not look like an Omniweb cookies file" if $^W;
		close $fh;
		return;
		}

	my $now = time() - $EPOCH_OFFSET;

	my $domain;
	while( <$fh> )
		{
		$domain = $1 if m//;
		next if m||;
		last if m||;
		next unless m|

		my $path    = m/path="(.*?)"/ ? $1 : "/";
		$path =~ s|%2f|/|ig;

		my $name    = $1 if m/name="(.*?)"/;
		my $value   = $1 if m/value="(.*?)"/;
		my $expires = $1 if m/expires="(.*?)"/;

		#print STDERR "D=$domain P=$path N=$name V=$value E=$expires\n";

		my $secure = FALSE;

		$self->set_cookie(undef, $name, $value, $path, $domain, undef,
			0, $secure, $expires - $now, 0);
		}

	close $fh;

	1;
	}

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

	$file ||= $self->{'file'} || return;

	local $_;
	open my $fh, '>:encoding(UTF-8)',  $file or return;

	print $fh <<'EOT';



EOT

	my $now = time - $EPOCH_OFFSET;

	foreach my $domain ( sort keys %{ $self->{COOKIES} } )
		{
		my $domain_hash = $self->{COOKIES}{$domain};

		print $fh qq|\n|;

		PATH: foreach my $path ( sort keys %$domain_hash )
			{
			my $cookie_hash = $domain_hash->{ $path };

			COOKIE: foreach my $name ( sort keys %$cookie_hash )
				{
				my( $value, $expires ) = @{ $cookie_hash->{$name} }[ 1, 5 ];
				$expires -= $EPOCH_OFFSET;
				my $path_str = $path eq '/' ? '' : qq| path="$path"|;

				print $fh qq|
					qq| expires="$expires" />\n|;
				}
			}

		print $fh "\n";
		}

	print $fh "\n";

	close $fh;

	1;
	}

1;