X-Git-Url: http://git.indexdata.com/?a=blobdiff_plain;f=lib%2FZOOM%2FIRSpy%2FUtils.pm;h=9c5f9517dfc294358ffe13e324f653d65d8da949;hb=6630d9e88e68aa87c0c27ea58c3b11140480891d;hp=75a7bf654c3952cfd5c1adc591dae3ef8377d484;hpb=ba5b05fd91d5be7e2954d8a56fa74f24ce83afa7;p=irspy-moved-to-github.git

diff --git a/lib/ZOOM/IRSpy/Utils.pm b/lib/ZOOM/IRSpy/Utils.pm
index 75a7bf6..9c5f951 100644
--- a/lib/ZOOM/IRSpy/Utils.pm
+++ b/lib/ZOOM/IRSpy/Utils.pm
@@ -1,4 +1,4 @@
-# $Id: Utils.pm,v 1.34 2007-06-27 11:08:08 mike Exp $
+# $Id: Utils.pm,v 1.38 2009-04-15 18:16:45 wosch Exp $
 
 package ZOOM::IRSpy::Utils;
 
@@ -18,7 +18,8 @@ our @EXPORT_OK = qw(utf8param
 		    irspy_identifier2target
 		    modify_xml_document
 		    bib1_access_point
-		    render_record);
+		    render_record
+		    calc_reliability);
 
 use XML::LibXML;
 use XML::LibXML::XPathContext;
@@ -28,9 +29,60 @@ use Encode qw(is_utf8);
 
 our $IRSPY_NS = 'http://indexdata.com/irspy/1.0';
 
+# Under Apache 2/mod_perl 2, the ubiquitous $r is no longer and
+# Apache::Request object, nor even an Apache2::Request, but an
+# Apache2::RequestReq ... which, astonishingly, doesn't have the
+# param() method.  So if we're given one of these things, we need to
+# make an Apache::Request out of, which at least isn't too hard.
+# However *sigh* this may not be a cheap operation, so we keep a cache
+# of already-made Request objects.
+#
+my %_apache2request;
+my %_paramsbyrequest;           # Used for Apache2 only
+sub utf8param {
+    my($r, $key, $value) = @_;
+
+    if ($r->isa('Apache2::RequestRec')) {
+        # Running under Apache2
+        if (defined $_apache2request{$r}) {
+            #warn "using existing Apache2::RequestReq for '$r'";
+            $r = $_apache2request{$r};
+        } else {
+            require Apache2::Request;
+            #warn "making new Apache2::RequestReq for '$r'";
+            $r = $_apache2request{$r} = new Apache2::Request($r);
+        }
+    }
+
+    if (!defined $key) {
+        return map { decode_utf8($_) } $r->param();
+    }
+
+    my $raw = undef;
+    $raw = $_paramsbyrequest{$r}->{$key} if $r->isa('Apache2::Request');
+    $raw = $r->param($key) if !defined $raw;
+
+    if (defined $value) {
+        # Argh!  Simply writing through to the underlying method
+        # param() won't work in Apache2, where param() is readonly.
+        # So we have to keep a hash of additional values, which we
+        # consult (above) before the actual parameters.  Ouch ouch.
+        if ($r->isa('Apache2::Request')) {
+            $_paramsbyrequest{$r}->{$key} = encode_utf8($value);
+        } else {
+            $r->param($key, encode_utf8($value));
+        }
+    }
+
+    return undef if !defined $raw;
+    my $cooked = decode_utf8($raw);
+    warn "converted '$raw' to '", $cooked, "'\n" if $cooked ne $raw;
+    return $cooked;
+}
+
 
 # Utility functions follow, exported for use of web UI
-sub utf8param {
+sub utf8param_apache1 {
     my($r, $key, $value) = @_;
     die "utf8param() called with value '$value'" if defined $value;
 
@@ -205,6 +257,9 @@ sub irspy_identifier2target {
 sub _irspy_identifier2target {
     my($id) = @_;
 
+    confess "_irspy_identifier2target(): id is undefined"
+	if !defined $id;
+
     my($protocol, $target) = ($id =~ /(.*?):(.*)/);
     if (uc($protocol) eq "Z39.50") {
 	return "tcp:$target";
@@ -214,7 +269,7 @@ sub _irspy_identifier2target {
 	return "sru=srw,http:$target";
     }
 
-    warn "unrecognised protocol '$protocol' in ID $id";
+    warn "_irspy_identifier2target($id): unrecognised protocol '$protocol'";
     return $target;
 }
 
@@ -399,7 +454,7 @@ sub inheritance_tree {
 # This function is made available in xslt using the register_function call
 sub xslt_strcmp {
     my ($arg1, $arg2) = @_;
-    return ($arg1->to_literal()) cmp ($arg2->to_literal());
+    return "$arg1" cmp "$arg2";
 }
 
 
@@ -716,4 +771,16 @@ sub render_record {
 }
 
 
+sub calc_reliability {
+    my($xc) = @_;
+
+    my @allpings = $xc->findnodes("i:status/i:probe");
+    my $nall = @allpings;
+    return "[untested]" if $nall == 0;
+    my @okpings = $xc->findnodes('i:status/i:probe[@ok = "1"]');
+    my $nok = @okpings;
+    return "$nok/$nall = " . int(100*$nok/$nall) . "%";
+}
+
+
 1;