File Coverage

blib/lib/Keystone/Resolver.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

# $Id: Resolver.pm,v 1.37 2008-05-01 09:25:39 mike Exp $

package Keystone::Resolver;

use 5.008;
use strict;
use warnings;
use Keystone::Resolver::Utils;
use Keystone::Resolver::LogLevel;
use Keystone::Resolver::OpenURL;
use Keystone::Resolver::ContextObject;
use Keystone::Resolver::Descriptor;
use Keystone::Resolver::Database;
use Keystone::Resolver::ResultSet;

our $VERSION = '1.23';


=head1 NAME

Keystone::Resolver - an OpenURL resolver

=head1 SYNOPSIS

 use Keystone::Resolver;
 $resolver = new Keystone::Resolver();
 $openURL = $resolver->openURL($args, $base, $referer);
 ($type, $content) = $openURL->resolve();
 print "Content-type: $type\r\n\r\n$content";

=head1 DESCRIPTION

This is the top-level class of Index Data's Keystone Resolver.  It
delegates the process of resolving OpenURLs to a swarm of worker
classes.

=head1 METHODS

=cut

=head2 new()

 $resolver = new Keystone::Resolver();
 $resolver = new Keystone::Resolver(logprefix => "Keystone Resolver");
 $resolver = new Keystone::Resolver(logprefix => "Keystone Resolver",
                                    xsltdir => "/home/me/xslt");

Creates a new resolver that can be used to resolve OpenURLs.  If
arguments are provided, they are taken to be pairs that specify the
names and values of options.  See the documentation of the C
method below for information about specific options.

One option is special to this constructor: if C<_rw> is provided and
true, then the database is opened readwrite rather then readonly
(which is the default).

The resolver object accumulates some state as it goes along, so it
is generally more efficient to keep using a single resolver than to
make new one every time you need to resolve an OpenURL.

=cut

sub new {
    my $class = shift();
    my(%options) = @_;

    my $rw = delete $options{_rw};
    my $xsltdir = $ENV{KRxsltdir} || "../etc/xslt";
    my $this = bless {
	parser => undef,	# set when needed in parser()
	xslt => undef,		# set when needed in xslt()
	ua => undef,		# set when needed in ua()
	stylesheets => {},	# cache, populated by stylesheet()
	db => {},		# cache, populated by db()
	rw => $rw,
	options => {},
    }, $class;

    # Initial options can be overridden by creation-time arguments.
    # They should probably take default values from the Config table
    # of the RDB instead of hard-wired values.
    $this->option(logprefix => $0);
    $this->option(loglevel => $ENV{KRloglevel} || 0);
    $this->option(xsltdir => $xsltdir);
    foreach my $key (keys %options) {
	$this->option($key, $options{$key});
    }

    $this->log(Keystone::Resolver::LogLevel::LIFECYCLE, "new resolver $this");
    return $this;
}


sub DESTROY {
    my $this = shift();
    static_log(Keystone::Resolver::LogLevel::LIFECYCLE, "dead resolver $this");
    return; # The rest of this is unnecessary
    my @names = sort keys %{ $this->{db} };
    foreach my $name (@names) {
	static_log(Keystone::Resolver::LogLevel::LIFECYCLE,
		   "killing DB '$name'");
	undef $this->{db}->{$name};
    }
}


=head2 option()

 $level = $resolver->option("loglevel");
 $oldpath = $resolver->option(xsltdir => "/home/me/xslt");

Gets and sets options in a C object.  When called with a
single argument, returns the value the resolver has for that key.
When called with two arguments, a key and a value, sets the specified
new value for that key and returns the old value anyway.

Supported options include:

=over 4

=item logprefix

The initial string emitted at the beginning of each line of debugging
output generated by the C method.  The default value is the
name of the running program.

=item loglevel

A bit mask indicating the categories of message that should be logged
by calls to the C method.  Should be set to the bitwise AND of
zero or more of the symbolic constants defined in
C.  See the documentation of that module for a
description of the recognised categories.

=item xsltdir

The directory where the resolver looks for XSLT files.

=back

=cut

use vars qw($_last_loglevel $_last_logprefix);
# These must be set, probably by new(), before being used
$_last_loglevel = undef;
$_last_logprefix = undef;

# ### There is an issue with logging modality here: if a call is made
# with loglevel or dbi_trace > 0, then subsequent requests on the same
# resolver will inherit that logging level.  Maybe each request
# should explicitly zero the logging levels?
#
sub option {
    my $this = shift();
    my($key, $value) = @_;

    my $old = $this->{options}->{$key};
    if (defined $value) {
	# Special cases for "loglevel" to allow hex and octal bitmasks
	# and to parse non-numeric level-lists.
	if ($key eq "loglevel") {
	    $value = oct($value)
		if $value =~ /^0/;
	    $value = Keystone::Resolver::LogLevel::num($value)
		if $value !~ /^\d+$/;
	}
	#print STDERR "setting '$key' to '$value'\n";
	$this->{options}->{$key} = $value;

	# Save logging configuration for use of static_log()
	$_last_loglevel = $value if $key eq "loglevel";
	$_last_logprefix = $value if $key eq "logprefix";

	if ($key eq "dbi_trace") {
	    ### Two nastinesses here: the peek inside the database's
	    # internal structures, and the fact that we are operating
	    # on the default database.  We could "fix" the latter by
	    # changing the global state of the DBI library, but that
	    # would probably be even worse; or by getting db() from
	    # the OpenURL object (which might have a query parameter
	    # specifying which DB to work on) but we don't know what
	    # OpenURL object we're using.
	    $this->db()->{dbh}->trace($value);
	}

    }

    return $old;
}


=head2 log(), static_log()

 $resolver->log(Keystone::Resolver::LogLevel::CHITCHAT, "starting up");
 Keystone::Resolver::static_log(Keystone::Resolver::LogLevel::CHITCHAT, "end");

C Logs a message to the standard error stream if the log-level
of the resolver includes the level specified as the first argument in
its bitmask.  If so, the message consists of the logging prefix (by
default the name of the program), the label of the specified level in
parentheses, and all other arguments concatenated, finishing with a
newline.

C is provided for situtation in which no resolver object
is available, e.g. in C methods.  It behaves the same as
C but is a function, not a method.  Since it cannot consult the
options of a resolver object, it uses
I.
For most applications, in which only a single resolver is in use, this
will work just fine.  Complex applications that use multiple resolvers
should not rely on the integrity of static logging.

=cut

sub log {
    my $this = shift();
    _log($this->option("loglevel"), $this->option("logprefix"), @_);
}


sub static_log {
    _log($_last_loglevel, $_last_logprefix, @_);
}


sub _log {
    my($loglevel, $logprefix, $level, @args) = @_;

    if ($loglevel & $level) {
	### could check another option for whether to include PID
	my $label = Keystone::Resolver::LogLevel::label($level);
	print STDERR "$logprefix ($label): ", @args, "\n";
	#use Carp; carp "$logprefix ($label): ", @args;
    }
}


=head2 openURL()

 $openURL = $resolver->openURL($args, $base, $referer);

Creates a new C object using this
C and the specified arguments and referer.  This
is a shortcut for

 new Keystone::Resolver::OpenURL($resolver, $args, $base, $referer)

=cut

sub openURL {
    my $this = shift();

    #use Carp qw(cluck); cluck("$$: creating new OpenURL(" . join(", ", map { defined $_ ? "'$_'" : "undef" } @_) . ")");
    return new Keystone::Resolver::OpenURL($this, @_);
}


=head2 parser()

 $parser = $resolver->parser();

Returns the XML parser associated with this resolver.  If it does not
yet have a parser, then one is created for it, cached for next time,
and returned.  The parser is an C object: see the
documentation of that class for how to use it.

=cut

sub parser {
    my $this = shift();

    if (!defined $this->{parser}) {
	$this->{parser} = new XML::LibXML();
    }

    return $this->{parser};
}


=head2 xslt()

 $xslt = $resolver->xslt();

Returns the XSLT processor associated with this resolver.  If it does
not yet have a XSLT processor, then one is created for it, cached for
next time, and returned.  The XSLT processor is an C
object: see the documentation of that class for how to use it.

=cut

sub xslt {
    my $this = shift();

    if (!defined $this->{xslt}) {
	$this->{xslt} = new XML::LibXSLT();
    }

    return $this->{xslt};
}


=head2 ua()

 $ua = $resolver->ua();

Returns the LWP User Agent associated with this resolver.  If it does
not yet have a User Agent, then one is created for it, cached for next
time, and returned.

=cut

sub ua {
    my $this = shift();

    if (!defined $this->{ua}) {
	$this->{ua} = new LWP::UserAgent();
    }

    return $this->{ua};
}


=head2 stylesheet()

 $stylesheet1 = $resolver->stylesheet();
 $stylesheet2 = $resolver->stylesheet("foo");

Returns a stylesheet object for the XSLT stylesheet named in the
argument, or for the default stylesheet if no argument is supplied.
The returned object is an : see the
documentation of that class for how to use it.

=cut

# $this->{stylesheets} is used only in this function.  It's a cache
# mapping a full stylesheet pathname to a duple consisting of that
# file's last modification time and the compiled stylesheet described
# by it.  The file is compiled if we're asked for it for the first
# time or if it's changed since the last compilation.
#
sub stylesheet {
    my $this = shift();
    my($name) = @_;

    $name ||= "default";
    my $cache = $this->{stylesheets};
    my $filename = $this->option("xsltdir") . "/$name.xsl";
    my(@stat) = stat($filename)
	or die "can't stat XSLT file '$filename': $!";
    my $mtime = $stat[9];
    $this->log(Keystone::Resolver::LogLevel::CACHECHECK,
	       "checking cache for XSLT file '$name', age $mtime");

    if (!defined $cache->{$name} ||
	$mtime > $cache->{$name}->[0]) {
	my $style_doc = $this->parser()->parse_file($filename);
	my $stylesheet = $this->xslt()->parse_stylesheet($style_doc);
	$cache->{$name} = [ $mtime, $stylesheet ];
	$this->log(Keystone::Resolver::LogLevel::PARSEXSLT,
		   "parsed XSLT file '$name', age $mtime");
    }

    return $cache->{$name}->[1];
}


=head2 db()

 $db = $resolver->db();
 $db = $resolver->db("kr-backup");

Returns the database object associated with this specified name for
this resolver.  If no name is provided, the default name specified by
the C environment variable is used; if this is also missing,
"kr" is used.  If the resolver does not yet have a
database handle associated with this name, then one is created for it,
cached for next time, and returned.  The handle is a
C object: see the documentation for how
to use it.

=cut

sub db {
    my $this = shift();
    my($name) = @_;

    $name ||= $ENV{KRdb} || "kr";
    my $cache = $this->{db};
    return $cache->{$name}
        if defined $cache->{$name};

    $cache->{$name} =
	new Keystone::Resolver::Database($this, $name, $this->{rw});
    ### We want the cached Database references to be weak, so that
    #   the databases get destroyed before the resolver that they
    #   depend on.  Weakening the reference should do this but doesn't
    #	seem to have any effect (suggesting a bug in Perl?).  So we
    #	won't do it, in case it has unanticipated side-effects.
    #Scalar::Util::weaken($cache->{$name});
    return $cache->{$name};
}


=head1 AUTHOR

Mike Taylor [e-mail]

First version Tuesday 9th March 2004.

=head1 SEE ALSO

C,
C,
C,
C,
C,
C,
C.

=cut


1;