X-Git-Url: http://git.indexdata.com/?a=blobdiff_plain;f=lib%2FZOOM.pm;h=6b2f8c985b12b9c64addf7531872b3324412e1f3;hb=87c72eaf97a3dbf51a93dab782c2909539addc48;hp=0e3e5836f05346d3e9e32ff2e1f667b5e97112bb;hpb=a093850375464520c98525423b6222f89e7f7b1a;p=ZOOM-Perl-moved-to-github.git diff --git a/lib/ZOOM.pm b/lib/ZOOM.pm index 0e3e583..6b2f8c9 100644 --- a/lib/ZOOM.pm +++ b/lib/ZOOM.pm @@ -1,5 +1,3 @@ -# $Id: ZOOM.pm,v 1.36 2006-10-04 17:15:03 mike Exp $ - use strict; use warnings; use IO::File; @@ -34,7 +32,7 @@ sub MEMORY { Net::Z3950::ZOOM::ERROR_MEMORY } sub ENCODE { Net::Z3950::ZOOM::ERROR_ENCODE } sub DECODE { Net::Z3950::ZOOM::ERROR_DECODE } sub CONNECTION_LOST { Net::Z3950::ZOOM::ERROR_CONNECTION_LOST } -sub INIT { Net::Z3950::ZOOM::ERROR_INIT } +sub ZINIT { Net::Z3950::ZOOM::ERROR_INIT } sub INTERNAL { Net::Z3950::ZOOM::ERROR_INTERNAL } sub TIMEOUT { Net::Z3950::ZOOM::ERROR_TIMEOUT } sub UNSUPPORTED_PROTOCOL { Net::Z3950::ZOOM::ERROR_UNSUPPORTED_PROTOCOL } @@ -113,6 +111,12 @@ sub diag_str { return Net::Z3950::ZOOM::diag_str($code); } +sub diag_srw_str { + my($code) = @_; + + return Net::Z3950::ZOOM::diag_srw_str($code); +} + sub event_str { return Net::Z3950::ZOOM::event_str(@_); } @@ -139,10 +143,13 @@ sub new { my($code, $message, $addinfo, $diagset) = @_; $diagset ||= "ZOOM"; - if ($diagset eq "ZOOM") { + if (uc($diagset) eq "ZOOM" || uc($diagset) eq "BIB-1") { $message ||= ZOOM::diag_str($code); + } elsif (lc($diagset) eq "info:srw/diagnostic/1") { + $message ||= ZOOM::diag_srw_str($code); } else { - # Should fill in messages for other diagsets, too. + # Should fill in messages for any other known diagsets. + $message ||= "(unknown error)"; } return bless { @@ -175,7 +182,9 @@ sub diagset { sub render { my $this = shift(); - my $res = "ZOOM error " . $this->code() . ' "' . $this->message() . '"'; + + my $res = "ZOOM error " . $this->code(); + $res .= ' "' . $this->message() . '"' if $this->message(); $res .= ' (addinfo: "' . $this->addinfo() . '")' if $this->addinfo(); $res .= " from diag-set '" . $this->diagset() . "'" if $this->diagset(); return $res; @@ -314,25 +323,13 @@ sub new { my $class = shift(); my($host, $port, @options) = @_; - my $_opts = Net::Z3950::ZOOM::options_create(); - while (@options >= 2) { - my $key = shift(@options); - my $val = shift(@options); - Net::Z3950::ZOOM::options_set($_opts, $key, $val); - } - - die "Odd number of options specified" - if @options; - - my $_conn = Net::Z3950::ZOOM::connection_create($_opts); - Net::Z3950::ZOOM::connection_connect($_conn, $host, $port || 0); - my $conn = bless { - host => $host, - port => $port, - _conn => $_conn, - }; + my $conn = $class->create(@options); + $conn->{host} = $host; + $conn->{port} = $port; + Net::Z3950::ZOOM::connection_connect($conn->_conn(), $host, $port || 0); $conn->_check(); + return $conn; } @@ -349,24 +346,60 @@ sub _conn { sub _check { my $this = shift(); + my($always_die_on_error) = @_; my($errcode, $errmsg, $addinfo, $diagset) = (undef, "x", "x", "x"); $errcode = Net::Z3950::ZOOM::connection_error_x($this->_conn(), $errmsg, $addinfo, $diagset); - die new ZOOM::Exception($errcode, $errmsg, $addinfo, $diagset) - if $errcode; + if ($errcode) { + my $exception = new ZOOM::Exception($errcode, $errmsg, $addinfo, + $diagset); + if (!$this->option("async") || $always_die_on_error) { + ZOOM::Log::log("zoom_check", "throwing error $exception"); + die $exception; + } else { + ZOOM::Log::log("zoom_check", "not reporting error $exception"); + } + } +} + +# This wrapper for _check() is called only from outside the ZOOM +# module, and therefore only in situations where an asynchronous +# application is actively asking for an exception to be thrown if an +# error has been detected. So it passed always_die_on_error=1 to the +# underlying _check() method. +# +sub check { + my $this = shift(); + return $this->_check(1); } sub create { my $class = shift(); - my($options) = @_; + my(@options) = @_; - my $_conn = Net::Z3950::ZOOM::connection_create($options->_opts()); - return bless { + my $_opts; + if (@_ == 1) { + $_opts = $_[0]->_opts(); + } else { + $_opts = Net::Z3950::ZOOM::options_create(); + while (@options >= 2) { + my $key = shift(@options); + my $val = shift(@options); + Net::Z3950::ZOOM::options_set($_opts, $key, $val); + } + + die "Odd number of options specified" + if @options; + } + + my $_conn = Net::Z3950::ZOOM::connection_create($_opts); + my $conn = bless { host => undef, port => undef, _conn => $_conn, - }; + }, $class; + return $conn; } sub error_x { @@ -375,7 +408,15 @@ sub error_x { my($errcode, $errmsg, $addinfo, $diagset) = (undef, "dummy", "dummy", "d"); $errcode = Net::Z3950::ZOOM::connection_error_x($this->_conn(), $errmsg, $addinfo, $diagset); - return ($errcode, $errmsg, $addinfo, $diagset); + return wantarray() ? ($errcode, $errmsg, $addinfo, $diagset) : $errcode; +} + +sub exception { + my $this = shift(); + + my($errcode, $errmsg, $addinfo, $diagset) = $this->error_x(); + return undef if $errcode == 0; + return new ZOOM::Exception($errcode, $errmsg, $addinfo, $diagset); } sub errcode { @@ -495,6 +536,12 @@ sub is_idle { return Net::Z3950::ZOOM::connection_is_idle($this->_conn()); } +sub peek_event { + my $this = shift(); + + return Net::Z3950::ZOOM::connection_peek_event($this->_conn()); +} + sub destroy { my $this = shift(); @@ -531,6 +578,14 @@ sub sortby { or ZOOM::_oops(ZOOM::Error::SORTBY, $sortby); } +sub sortby2 { + my $this = shift(); + my($strategy, $sortby) = @_; + + Net::Z3950::ZOOM::query_sortby2($this->_query(), $strategy, $sortby) == 0 + or ZOOM::_oops(ZOOM::Error::SORTBY, $sortby); +} + sub destroy { my $this = shift(); @@ -727,6 +782,22 @@ sub records { my $this = shift(); my($start, $count, $return_records) = @_; + # If the request is out of range, ZOOM-C will currently (as of YAZ + # 2.1.38) no-op: it understandably refuses to build and send a + # known-bad APDU, but it doesn't set a diagnostic as it ought. So + # for now, we do it here. It would be more polite to stash the + # error-code in the ZOOM-C connection object for subsequent + # discovery (which is what ZOOM-C will presumably do itself when + # it's fixed) but since there is no API that allows us to do that, + # we just have to throw the exception right now. That's probably + # OK for synchronous applications, but not really for + # multiplexers. + my $size = $this->size(); + if ($start + $count-1 >= $size) { + # BIB-1 diagnostic 13 is "Present request out-of-range" + ZOOM::_oops(13, undef, "BIB-1"); + } + my $raw = Net::Z3950::ZOOM::resultset_records($this->_rs(), $start, $count, $return_records); # By design, $raw may be undefined (if $return_records is true) @@ -797,6 +868,25 @@ sub _rec { return $_rec; } +sub error { + my $this = shift(); + + my($errcode, $errmsg, $addinfo, $diagset) = (undef, "dummy", "dummy", "d"); + $errcode = Net::Z3950::ZOOM::record_error($this->_rec(), $errmsg, + $addinfo, $diagset); + + return wantarray() ? ($errcode, $errmsg, $addinfo, $diagset) : $errcode; +} + +sub exception { + my $this = shift(); + + my($errcode, $errmsg, $addinfo, $diagset) = $this->error(); + return undef if $errcode == 0; + return new ZOOM::Exception($errcode, $errmsg, $addinfo, $diagset); +} + + sub render { my $this = shift(); @@ -814,14 +904,7 @@ sub get { my($type, $args) = @_; $type = "$type;$args" if defined $args; - my $len = 0; - my $string = Net::Z3950::ZOOM::record_get($this->_rec(), $type, $len); - # I don't think we need '$len' at all. ### Probably the Perl-to-C - # glue code should use the value of `len' as well as the opaque - # data-pointer returned, to ensure that the SV contains all of the - # returned data and does not stop at the first NUL character in - # binary data. Carefully check the ZOOM_record_get() documentation. - return $string; + return Net::Z3950::ZOOM::record_get($this->_rec(), $type); } sub clone { @@ -1029,5 +1112,6 @@ sub log { Net::Z3950::ZOOM::yaz_log($level, join("", @message)); } +BEGIN { ZOOM::Log::mask_str("zoom_check"); } 1;