Keystone::Resolver - an OpenURL resolver

 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";

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

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

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

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

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

 $parser = $resolver->parser();

 $xslt = $resolver->xslt();

 $ua = $resolver->ua();

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

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

# $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';

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};
    }
}

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;
}

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;
    }
}

sub openURL {
    my $this = shift();

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

sub parser {
    my $this = shift();

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

    return $this->{parser};
}

sub xslt {
    my $this = shift();

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

    return $this->{xslt};
}

sub ua {
    my $this = shift();

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

    return $this->{ua};
}

# $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];
}

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};
}

1;