/usr/share/perl5/XMLTV/Memoize.pm is in libxmltv-perl 0.5.63-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | # Just some routines related to the Memoize module that are used in
# more than one place in XMLTV. But not general enough to merge back
# into Memoize.
#
# $Id: Memoize.pm,v 1.15 2006/01/11 18:01:38 mattiasholmlund Exp $
#
package XMLTV::Memoize;
use strict;
use File::Basename;
use Getopt::Long;
# Use Log::TraceMessages if installed.
BEGIN {
eval { require Log::TraceMessages };
if ($@) {
*t = sub {};
*d = sub { '' };
}
else {
*t = \&Log::TraceMessages::t;
*d = \&Log::TraceMessages::d;
}
}
# Add an undocumented option to cache things in a DB_File database.
# You need to decide which subroutines should be cached: see
# XMLTV::Get_nice for how to memoize web page fetches. Call like
# this:
#
# if (check_argv('fred', 'jim')) {
# # The subs fred() and jim() are now memoized.
# }
#
# If the user passed a --cache option to your program, this will be
# removed from @ARGV and caching will be turned on. The optional
# argument to --cache gives the filename to use.
#
# Currently it is assumed that the function gives the same result in
# both scalar and list context.
#
# Note that the Memoize module is not loaded unless --cache options
# are found.
#
# Returns a ref to a list of code references for the memoized
# versions, if memoization happened (but does install the memoized
# versions under the original names too). Returns undef if no
# memoization was wanted.
#
sub check_argv( @ ) {
# local $Log::TraceMessages::On = 1;
my $yes = 0;
my $p = new Getopt::Long::Parser(config => ['passthrough']);
die if not $p;
my $opt_cache;
my $opt_quiet = 0;
my $result = $p->getoptions('cache:s' => \$opt_cache,
'quiet' => \$opt_quiet );
die "failure processing --cache option" if not $result;
unshift @ARGV, "--quiet" if $opt_quiet;
return undef if not defined $opt_cache;
my $filename;
if ($opt_cache eq '') {
# --cache given, but no filename. Guess one.
my $basename = File::Basename::basename($0);
$filename = "$basename.cache";
}
else {
$filename = $opt_cache;
}
print STDERR "using cache $filename\n" unless $opt_quiet;
require POSIX;
require Memoize;
require DB_File;
my @tie_args = ('DB_File', $filename,
POSIX::O_RDWR() | POSIX::O_CREAT(), 0666);
# $from_caller is a sub which converts a function name into one
# seen from the caller's namespace. Namespaces do not nest, so if
# it already has :: it should be left alone.
#
my $caller = caller();
t "caller: $caller";
my $from_caller = sub( $ ) {
for (shift) {
return $_ if /::/;
return "${caller}::$_";
}
};
# Annoyingly tie(%cache, @tie_args) doesn't work
my %cache;
tie %cache, 'DB_File', $filename,
POSIX::O_RDWR() | POSIX::O_CREAT(), 0666;
my @r;
foreach (@_) {
my $r = Memoize::memoize($from_caller->($_),
SCALAR_CACHE => [ HASH => \%cache ],
LIST_CACHE => 'MERGE');
die "could not memoize $_" if not $r;
push @r, $r;
}
return \@r;
}
1;
|