X-Git-Url: http://jsfdemo.indexdata.com/?a=blobdiff_plain;ds=sidebyside;f=lib%2FZOOM.pm;h=4fd85023144b1239e050e3f63e9b151c99bbafb4;hb=07c4793d97e8ecd805df97ad36164384bc15bb2b;hp=5d378beab214ffa5f76b151e5518e35270d3f070;hpb=b0dd79557412ca039daebfdeaccd0e1a28240b88;p=ZOOM-Perl-moved-to-github.git diff --git a/lib/ZOOM.pm b/lib/ZOOM.pm index 5d378be..4fd8502 100644 --- a/lib/ZOOM.pm +++ b/lib/ZOOM.pm @@ -1,65 +1,741 @@ -package ZOOM; +# $Id: ZOOM.pm,v 1.14 2005-11-08 11:46:59 mike Exp $ -use 5.008; use strict; use warnings; -use AutoLoader qw(AUTOLOAD); +use Net::Z3950::ZOOM; -our @ISA = qw(); -our $VERSION = '0.01'; +package ZOOM; -require XSLoader; -XSLoader::load('ZOOM', $VERSION); -# Preloaded methods go here. +# Member naming convention: hash-element names which begin with an +# underscore represent underlying ZOOM-C object descriptors; those +# which lack them represent Perl's ZOOM objects. (The same convention +# is used in naming local variables where appropriate.) +# +# So, for example, the ZOOM::Connection class has an {_conn} element, +# which is a pointer to the ZOOM-C Connection object; but the +# ZOOM::ResultSet class has a {conn} element, which is a reference to +# the Perl-level Connection object by which it was created. (It may +# be that we find we have no need for these references, but for now +# they are retained.) +# +# To get at the underlying ZOOM-C connection object of a result-set +# (if you ever needed to do such a thing, which you probably don't) +# you'd use $rs->{conn}->_conn(). -# Autoload methods go after =cut, and are processed by the autosplit program. +# ---------------------------------------------------------------------------- -1; -__END__ -# Below is stub documentation for your module. You'd better edit it! +# The "Error" package contains constants returned as error-codes. +package ZOOM::Error; +sub NONE { Net::Z3950::ZOOM::ERROR_NONE } +sub CONNECT { Net::Z3950::ZOOM::ERROR_CONNECT } +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 INTERNAL { Net::Z3950::ZOOM::ERROR_INTERNAL } +sub TIMEOUT { Net::Z3950::ZOOM::ERROR_TIMEOUT } +sub UNSUPPORTED_PROTOCOL { Net::Z3950::ZOOM::ERROR_UNSUPPORTED_PROTOCOL } +sub UNSUPPORTED_QUERY { Net::Z3950::ZOOM::ERROR_UNSUPPORTED_QUERY } +sub INVALID_QUERY { Net::Z3950::ZOOM::ERROR_INVALID_QUERY } +# The following are added specifically for this OO interface +sub CREATE_QUERY { 20001 } +sub QUERY_CQL { 20002 } +sub QUERY_PQF { 20003 } +sub SORTBY { 20004 } +sub CLONE { 20005 } + +# The "Event" package contains constants returned by last_event() +package ZOOM::Event; +sub NONE { Net::Z3950::ZOOM::EVENT_NONE } +sub CONNECT { Net::Z3950::ZOOM::EVENT_CONNECT } +sub SEND_DATA { Net::Z3950::ZOOM::EVENT_SEND_DATA } +sub RECV_DATA { Net::Z3950::ZOOM::EVENT_RECV_DATA } +sub TIMEOUT { Net::Z3950::ZOOM::EVENT_TIMEOUT } +sub UNKNOWN { Net::Z3950::ZOOM::EVENT_UNKNOWN } +sub SEND_APDU { Net::Z3950::ZOOM::EVENT_SEND_APDU } +sub RECV_APDU { Net::Z3950::ZOOM::EVENT_RECV_APDU } +sub RECV_RECORD { Net::Z3950::ZOOM::EVENT_RECV_RECORD } +sub RECV_SEARCH { Net::Z3950::ZOOM::EVENT_RECV_SEARCH } + +# ---------------------------------------------------------------------------- + +package ZOOM; + +sub diag_str { + my($code) = @_; + + # Special cases for error specific to the OO layer + if ($code == ZOOM::Error::CREATE_QUERY) { + return "can't create query object"; + } elsif ($code == ZOOM::Error::QUERY_CQL) { + return "can't set CQL query"; + } elsif ($code == ZOOM::Error::QUERY_PQF) { + return "can't set prefix query"; + } elsif ($code == ZOOM::Error::SORTBY) { + return "can't set sort-specification"; + } elsif ($code == ZOOM::Error::CLONE) { + return "can't clone record"; + } + + return Net::Z3950::ZOOM::diag_str($code); +} + +### More of the ZOOM::Exception instantiations should use this +sub _oops { + my($code, $addinfo) = @_; + + die new ZOOM::Exception($code, diag_str($code), $addinfo); +} + +# ---------------------------------------------------------------------------- + +package ZOOM::Exception; + +sub new { + my $class = shift(); + my($code, $message, $addinfo) = @_; + ### support diag-set, too + + return bless { + code => $code, + message => $message, + addinfo => $addinfo, + }, $class; +} + +sub code { + my $this = shift(); + return $this->{code}; +} + +sub message { + my $this = shift(); + return $this->{message}; +} + +sub addinfo { + my $this = shift(); + return $this->{addinfo}; +} + + +# ---------------------------------------------------------------------------- + +package ZOOM::Options; + +sub new { + my $class = shift(); + my($p1, $p2) = @_; + + my $opts; + if (@_ == 0) { + $opts = Net::Z3950::ZOOM::options_create(); + } elsif (@_ == 1) { + $opts = Net::Z3950::ZOOM::options_create_with_parent($p1->_opts()); + } elsif (@_ == 2) { + $opts = Net::Z3950::ZOOM::options_create_with_parent2($p1->_opts(), + $p2->_opts()); + } else { + die "can't make $class object with more than 2 parents"; + } + + return bless { + _opts => $opts, + }, $class; +} + +sub _opts { + my $this = shift(); + + my $_opts = $this->{_opts}; + die "{_opts} undefined: has this Options block been destroy()ed?" + if !defined $_opts; + + return $_opts; +} + +sub option { + my $this = shift(); + my($key, $value) = @_; + + my $oldval = Net::Z3950::ZOOM::options_get($this->_opts(), $key); + Net::Z3950::ZOOM::options_set($this->_opts(), $key, $value) + if defined $value; + + return $oldval; +} + +sub option_binary { + my $this = shift(); + my($key, $value) = @_; + + my $dummylen = 0; + my $oldval = Net::Z3950::ZOOM::options_getl($this->_opts(), + $key, $dummylen); + Net::Z3950::ZOOM::options_setl($this->_opts(), $key, + $value, length($value)) + if defined $value; + + return $oldval; +} + +# This is a bit stupid, since the scalar values that Perl returns from +# option() can be used as a boolean; but it's just possible that some +# applications will rely on ZOOM_options_get_bool()'s idiosyncratic +# interpretation of what constitutes truth. +# +sub bool { + my $this = shift(); + my($key, $default) = @_; + + return Net::Z3950::ZOOM::options_get_bool($this->_opts(), $key, $default); +} + +# .. and the next two are even more stupid +sub int { + my $this = shift(); + my($key, $default) = @_; + + return Net::Z3950::ZOOM::options_get_int($this->_opts(), $key, $default); +} + +sub set_int { + my $this = shift(); + my($key, $value) = @_; + + Net::Z3950::ZOOM::options_set_int($this->_opts(), $key, $value); +} + +# ### Feel guilty. Feel very, very guilty. I've not been able to +# get the callback memory-management right in "ZOOM.xs", with +# the result that the values of $function and $udata passed into +# this function, which are on the stack, have sometimes been +# freed by the time they're used by __ZOOM_option_callback(), +# with hilarious results. To avoid this, I copy the values into +# module-scoped globals, and pass _those_ into the extension +# function. To avoid overwriting those globals by subsequent +# calls, I keep all the old ones, pushed onto the @_function and +# @_udata arrays, which means that THIS FUNCTION LEAKS MEMORY +# LIKE IT'S GOING OUT OF FASHION. Not nice. One day, I should +# fix this, but for now there's more important fish to fry. +# +my(@_function, @_udata); +sub set_callback { + my $o1 = shift(); + my($function, $udata) = @_; + + push @_function, $function; + push @_udata, $udata; + Net::Z3950::ZOOM::options_set_callback($o1->_opts(), + $_function[-1], $_udata[-1]); +} + +sub destroy { + my $this = shift(); + + Net::Z3950::ZOOM::options_destroy($this->_opts()); + $this->{_opts} = undef; +} + + +# ---------------------------------------------------------------------------- + +package ZOOM::Connection; + +sub new { + my $class = shift(); + my($host, $port) = @_; + + my $_conn = Net::Z3950::ZOOM::connection_new($host, $port); + my($errcode, $errmsg, $addinfo) = (undef, "dummy", "dummy"); + $errcode = Net::Z3950::ZOOM::connection_error($_conn, $errmsg, $addinfo); + die new ZOOM::Exception($errcode, $errmsg, $addinfo) if $errcode; + + return bless { + host => $host, + port => $port, + _conn => $_conn, + }; +} + +sub create { + my $class = shift(); + my($options) = @_; + + my $_conn = Net::Z3950::ZOOM::connection_create($options->_opts()); + return bless { + host => undef, + port => undef, + _conn => $_conn, + }; +} + +# PRIVATE to this class +sub _conn { + my $this = shift(); + + my $_conn = $this->{_conn}; + die "{_conn} undefined: has this Connection been destroy()ed?" + if !defined $_conn; + + return $_conn; +} + +sub error_x { + my $this = shift(); + + 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); +} + +sub errcode { + my $this = shift(); + return Net::Z3950::ZOOM::connection_errcode($this->_conn()); +} + +sub errmsg { + my $this = shift(); + return Net::Z3950::ZOOM::connection_errmsg($this->_conn()); +} + +sub addinfo { + my $this = shift(); + return Net::Z3950::ZOOM::connection_addinfo($this->_conn()); +} + +sub connect { + my $this = shift(); + my($host, $port) = @_; + + Net::Z3950::ZOOM::connection_connect($this->_conn(), $host, $port); + my($errcode, $errmsg, $addinfo) = (undef, "dummy", "dummy"); + $errcode = Net::Z3950::ZOOM::connection_error($this->_conn(), + $errmsg, $addinfo); + die new ZOOM::Exception($errcode, $errmsg, $addinfo) if $errcode; + # No return value +} + +sub option { + my $this = shift(); + my($key, $value) = @_; + + my $oldval = Net::Z3950::ZOOM::connection_option_get($this->_conn(), $key); + Net::Z3950::ZOOM::connection_option_set($this->_conn(), $key, $value) + if defined $value; + + return $oldval; +} + +sub option_binary { + my $this = shift(); + my($key, $value) = @_; + + my $dummylen = 0; + my $oldval = Net::Z3950::ZOOM::connection_option_getl($this->_conn(), + $key, $dummylen); + Net::Z3950::ZOOM::connection_option_setl($this->_conn(), $key, + $value, length($value)) + if defined $value; + + return $oldval; +} + +sub search { + my $this = shift(); + my($query) = @_; + + my $_rs = Net::Z3950::ZOOM::connection_search($this->_conn(), + $query->_query()); + my($errcode, $errmsg, $addinfo) = (undef, "dummy", "dummy"); + $errcode = Net::Z3950::ZOOM::connection_error($this->_conn(), + $errmsg, $addinfo); + die new ZOOM::Exception($errcode, $errmsg, $addinfo) if $errcode; + + return _new ZOOM::ResultSet($this, $query, $_rs); +} + +sub search_pqf { + my $this = shift(); + my($pqf) = @_; + + my $_rs = Net::Z3950::ZOOM::connection_search_pqf($this->_conn(), $pqf); + my($errcode, $errmsg, $addinfo) = (undef, "dummy", "dummy"); + $errcode = Net::Z3950::ZOOM::connection_error($this->_conn(), + $errmsg, $addinfo); + die new ZOOM::Exception($errcode, $errmsg, $addinfo) if $errcode; + + return _new ZOOM::ResultSet($this, $pqf, $_rs); +} + +sub scan { + my $this = shift(); + my($startterm) = @_; + + my $_ss = Net::Z3950::ZOOM::connection_scan($this->_conn(), $startterm); + my($errcode, $errmsg, $addinfo) = (undef, "dummy", "dummy"); + $errcode = Net::Z3950::ZOOM::connection_error($this->_conn(), + $errmsg, $addinfo); + die new ZOOM::Exception($errcode, $errmsg, $addinfo) if $errcode; -=head1 NAME + return _new ZOOM::ScanSet($this, $startterm, $_ss); +} -ZOOM - Perl extension for blah blah blah +sub destroy { + my $this = shift(); -=head1 SYNOPSIS + Net::Z3950::ZOOM::connection_destroy($this->_conn()); + $this->{_conn} = undef; +} - use ZOOM; - blah blah blah -=head1 DESCRIPTION +# ---------------------------------------------------------------------------- -Stub documentation for ZOOM, created by h2xs. It looks like the -author of the extension was negligent enough to leave the stub -unedited. +package ZOOM::Query; -Blah blah blah. +sub new { + my $class = shift(); + die "You can't create $class objects: it's a virtual base class"; +} +# PRIVATE to this class and ZOOM::Connection::search() +sub _query { + my $this = shift(); -=head1 SEE ALSO + my $_query = $this->{_query}; + die "{_query} undefined: has this Query been destroy()ed?" + if !defined $_query; -Mention other useful documentation such as the documentation of -related modules or operating system documentation (such as man pages -in UNIX), or any relevant external documentation such as RFCs or -standards. + return $_query; +} -If you have a mailing list set up for your module, mention it here. +sub sortby { + my $this = shift(); + my($sortby) = @_; -If you have a web site set up for your module, mention it here. + Net::Z3950::ZOOM::query_sortby($this->_query(), $sortby) == 0 + or ZOOM::_oops(ZOOM::Error::SORTBY, $sortby); +} -=head1 AUTHOR +sub destroy { + my $this = shift(); -Mike Taylor, Emike@E + Net::Z3950::ZOOM::query_destroy($this->_query()); + $this->{_query} = undef; +} -=head1 COPYRIGHT AND LICENSE -Copyright (C) 2005 by Mike Taylor +package ZOOM::Query::CQL; +our @ISA = qw(ZOOM::Query); -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself, either Perl version 5.8.4 or, -at your option, any later version of Perl 5 you may have available. +sub new { + my $class = shift(); + my($string) = @_; + my $q = Net::Z3950::ZOOM::query_create() + or ZOOM::_oops(ZOOM::Error::CREATE_QUERY); + Net::Z3950::ZOOM::query_cql($q, $string) == 0 + or ZOOM::_oops(ZOOM::Error::QUERY_CQL, $string); -=cut + return bless { + _query => $q, + }, $class; +} + + +package ZOOM::Query::PQF; +our @ISA = qw(ZOOM::Query); + +sub new { + my $class = shift(); + my($string) = @_; + + my $q = Net::Z3950::ZOOM::query_create() + or ZOOM::_oops(ZOOM::Error::CREATE_QUERY); + Net::Z3950::ZOOM::query_prefix($q, $string) == 0 + or ZOOM::_oops(ZOOM::Error::QUERY_PQF, $string); + + return bless { + _query => $q, + }, $class; +} + + +# ---------------------------------------------------------------------------- + +package ZOOM::ResultSet; + +sub new { + my $class = shift(); + die "You can't create $class objects directly"; +} + +# PRIVATE to ZOOM::Connection::search() and ZOOM::Connection::search_pqf() +sub _new { + my $class = shift(); + my($conn, $query, $_rs) = @_; + + return bless { + conn => $conn, + query => $query, # This is not currently used, which is + # just as well since it could be + # either a string (when the RS is + # created with search_pqf()) or a + # ZOOM::Query object (when it's + # created with search()) + _rs => $_rs, + }, $class; +} + +# PRIVATE to this class +sub _rs { + my $this = shift(); + + my $_rs = $this->{_rs}; + die "{_rs} undefined: has this ResultSet been destroy()ed?" + if !defined $_rs; + + return $_rs; +} + +sub option { + my $this = shift(); + my($key, $value) = @_; + + my $oldval = Net::Z3950::ZOOM::resultset_option_get($this->_rs(), $key); + Net::Z3950::ZOOM::resultset_option_set($this->_rs(), $key, $value) + if defined $value; + + return $oldval; +} + +sub size { + my $this = shift(); + + return Net::Z3950::ZOOM::resultset_size($this->_rs()); +} + +sub record { + my $this = shift(); + my($which) = @_; + + my $_rec = Net::Z3950::ZOOM::resultset_record($this->_rs(), $which); + ### Check for error -- but how? + return undef if !defined $_rec; + + # For some reason, I have to use the explicit "->" syntax in order + # to invoke the ZOOM::Record constructor here, even though I don't + # have to do the same for _new ZOOM::ResultSet above. Weird. + return ZOOM::Record->_new($this, $which, $_rec); +} + +sub record_immediate { + my $this = shift(); + my($which) = @_; + + my $_rec = Net::Z3950::ZOOM::resultset_record_immediate($this->_rs(), + $which); + ### Check for error -- but how? + return undef if !defined $_rec; + + return ZOOM::Record->_new($this, $which, $_rec); +} + +sub cache_reset { + my $this = shift(); + + Net::Z3950::ZOOM::resultset_cache_reset($this->_rs()); +} + +sub records { + my $this = shift(); + my($start, $count, $return_records) = @_; + + my $raw = Net::Z3950::ZOOM::resultset_records($this->_rs(), $start, $count, + $return_records); + return undef if !defined $raw; + + # We need to package up the returned records in ZOOM::Record objects + my @res = (); + for my $i (0 .. @$raw-1) { + my $_rec = $raw->[$i]; + if (!defined $_rec) { + push @res, undef; + } else { + push @res, ZOOM::Record->_new($this, $start+$i, $_rec); + } + } + + return \@res; +} + +sub sort { + my $this = shift(); + my($sort_type, $sort_spec) = @_; + + Net::Z3950::ZOOM::resultset_sort($this->_rs(), $sort_type, $sort_spec); + ### There's no way to check for success, as this is a void function +} + +sub destroy { + my $this = shift(); + + Net::Z3950::ZOOM::resultset_destroy($this->_rs()); + $this->{_rs} = undef; +} + + +# ---------------------------------------------------------------------------- + +package ZOOM::Record; + +sub new { + my $class = shift(); + die "You can't create $class objects directly"; +} + +# PRIVATE to ZOOM::ResultSet::record(), +# ZOOM::ResultSet::record_immediate(), ZOOM::ResultSet::records() and +# ZOOM::Record::clone() +# +sub _new { + my $class = shift(); + my($rs, $which, $_rec) = @_; + + return bless { + rs => $rs, + which => $which, + _rec => $_rec, + }, $class; +} + +# PRIVATE to this class +sub _rec { + my $this = shift(); + + my $_rec = $this->{_rec}; + die "{_rec} undefined: has this Record been destroy()ed?" + if !defined $_rec; + + return $_rec; +} + +sub render { + my $this = shift(); + + my $len = 0; + my $string = Net::Z3950::ZOOM::record_get($this->_rec(), "render", $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; +} + +sub raw { + my $this = shift(); + + my $len = 0; + my $string = Net::Z3950::ZOOM::record_get($this->_rec(), "raw", $len); + # See comment about $len in render() + return $string; +} + +sub clone { + my $this = shift(); + + my $raw = Net::Z3950::ZOOM::record_clone($this->_rec()) + or ZOOM::_oops(ZOOM::Error::CLONE); + + # Arg 1 (rs) is undefined as the new record doesn't belong to an RS + return _new ZOOM::Record(undef, undef, $raw); +} + +sub destroy { + my $this = shift(); + + Net::Z3950::ZOOM::record_destroy($this->_rec()); + $this->{_rec} = undef; +} + + +# ---------------------------------------------------------------------------- + +package ZOOM::ScanSet; + +sub new { + my $class = shift(); + die "You can't create $class objects directly"; +} + +# PRIVATE to ZOOM::Connection::scan(), +sub _new { + my $class = shift(); + my($conn, $startterm, $_ss) = @_; + + return bless { + conn => $conn, + startterm => $startterm, + _ss => $_ss, + }, $class; +} + +# PRIVATE to this class +sub _ss { + my $this = shift(); + + my $_ss = $this->{_ss}; + die "{_ss} undefined: has this ScanSet been destroy()ed?" + if !defined $_ss; + + return $_ss; +} + +sub size { + my $this = shift(); + + return Net::Z3950::ZOOM::scanset_size($this->_ss()); +} + +sub term { + my $this = shift(); + my($which) = @_; + + my($occ, $len) = (0, 0); + my $term = Net::Z3950::ZOOM::scanset_term($this->_ss(), $which, + $occ, $len); + return undef if !defined $term; + die "length of term '$term' differs from returned len=$len" + if length($term) != $len; + + return ($term, $occ); +} + +sub display_term { + my $this = shift(); + my($which) = @_; + + my($occ, $len) = (0, 0); + my $term = Net::Z3950::ZOOM::scanset_display_term($this->_ss(), $which, + $occ, $len); + return undef if !defined $term; + die "length of display term '$term' differs from returned len=$len" + if length($term) != $len; + + return ($term, $occ); +} + +sub destroy { + my $this = shift(); + + Net::Z3950::ZOOM::scanset_destroy($this->_ss()); + $this->{_ss} = undef; +} + + +1;