The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
# -*- perl -*-

#
# $Id: test.pl,v 1.9 2003/10/22 21:34:45 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1997, 2000, 2002 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://user.cs.tu-berlin.de/~eserte/
#

BEGIN {
    if (!eval q{
	use Test;
	1;
    }) {
	print "1..0 # skip: no Test module\n";
	exit;
    }
}

BEGIN { plan tests => 3 }

use Netscape::Cache;
use Config;
use strict;
use Getopt::Long;

my $interactive;
if (!GetOptions("interactive" => \$interactive)) {
    die "usage: $^X -Mblib test.pl [-interactive] [/path/to/my/cachedir]";
}
ok(1);

$^W = 1;

my %args;
if (@ARGV) {
    $args{-cachedir} = $ARGV[0];
}
my $cache = new Netscape::Cache %args;
if (!$cache) {
    warn <<'EOF';
If your cache directory is in a non-standard location,
start test.pl manually with
    perl -Mblib test.pl /path/to/my/cachedir
This will not help if your berkeley db version is 2.x.x. If so,
read the documentation for workarounds.
EOF
    skip(1,1) for (2..3);
    exit;
}

my $batch_mode = ($Netscape::Cache::OS_Type eq 'win' ||
		  defined $ENV{BATCH});

my($o, @url);
while ($o = $cache->next_object) {
    push(@url, $o);
}
# sort by name
@url = sort {$a->{'URL'} cmp $b->{'URL'}} @url;

if ($interactive) {
    if ($batch_mode) {
	open(OUT, ">&STDOUT");
    } else {
	my $pager = $Config{'pager'} || 'more';
	open(OUT, "|$pager");
    }
    print OUT "*** Cache found in " . $cache->{'CACHEDIR'} . "\n";
    print OUT "Object oriented interface:\n";
    foreach (@url) {
	print OUT $_->{'URL'}, " ", scalar localtime $_->{'LAST_VISITED'}, "\n";
    }
}

ok(1);

my %tie;
tie %tie, 'Netscape::Cache';
print OUT "Tiehash interface:\n" if $interactive;
my $url;
while(($url, $o) = each %tie) {
    print OUT "$url => $o->{CACHEFILE}\n" if $interactive;
}

close OUT if $interactive;

ok(1);

exit 0;