lib/ZOOM.pm

   1 use strict;
   2 use warnings;
   3 use IO::File;
   4 use Net::Z3950::ZOOM;
   5
   6
   7 package ZOOM;
   8
   9 # Member naming convention: hash-element names which begin with an
  10 # underscore represent underlying ZOOM-C object descriptors; those
  11 # which lack them represent Perl's ZOOM objects.  (The same convention
  12 # is used in naming local variables where appropriate.)
  13 #
  14 # So, for example, the ZOOM::Connection class has an {_conn} element,
  15 # which is a pointer to the ZOOM-C Connection object; but the
  16 # ZOOM::ResultSet class has a {conn} element, which is a reference to
  17 # the Perl-level Connection object by which it was created.  (It may
  18 # be that we find we have no need for these references, but for now
  19 # they are retained.)
  20 #
  21 # To get at the underlying ZOOM-C connection object of a result-set
  22 # (if you ever needed to do such a thing, which you probably don't)
  23 # you'd use $rs->{conn}->_conn().
  24
  25 # ----------------------------------------------------------------------------
  26
  27 # The "Error" package contains constants returned as error-codes.
  28 package ZOOM::Error;
  29 sub NONE { Net::Z3950::ZOOM::ERROR_NONE }
  30 sub CONNECT { Net::Z3950::ZOOM::ERROR_CONNECT }
  31 sub MEMORY { Net::Z3950::ZOOM::ERROR_MEMORY }
  32 sub ENCODE { Net::Z3950::ZOOM::ERROR_ENCODE }
  33 sub DECODE { Net::Z3950::ZOOM::ERROR_DECODE }
  34 sub CONNECTION_LOST { Net::Z3950::ZOOM::ERROR_CONNECTION_LOST }
  35 sub ZINIT { Net::Z3950::ZOOM::ERROR_INIT }
  36 sub INTERNAL { Net::Z3950::ZOOM::ERROR_INTERNAL }
  37 sub TIMEOUT { Net::Z3950::ZOOM::ERROR_TIMEOUT }
  38 sub UNSUPPORTED_PROTOCOL { Net::Z3950::ZOOM::ERROR_UNSUPPORTED_PROTOCOL }
  39 sub UNSUPPORTED_QUERY { Net::Z3950::ZOOM::ERROR_UNSUPPORTED_QUERY }
  40 sub INVALID_QUERY { Net::Z3950::ZOOM::ERROR_INVALID_QUERY }
  41 sub CQL_PARSE { Net::Z3950::ZOOM::ERROR_CQL_PARSE }
  42 sub CQL_TRANSFORM { Net::Z3950::ZOOM::ERROR_CQL_TRANSFORM }
  43 sub CCL_CONFIG { Net::Z3950::ZOOM::ERROR_CCL_CONFIG }
  44 sub CCL_PARSE { Net::Z3950::ZOOM::ERROR_CCL_PARSE }
  45 # The following are added specifically for this OO interface
  46 sub CREATE_QUERY { 20001 }
  47 sub QUERY_CQL { 20002 }
  48 sub QUERY_PQF { 20003 }
  49 sub SORTBY { 20004 }
  50 sub CLONE { 20005 }
  51 sub PACKAGE { 20006 }
  52 sub SCANTERM { 20007 }
  53 sub LOGLEVEL { 20008 }
  54
  55 # Separate space for CCL errors.  Great.
  56 package ZOOM::CCL::Error;
  57 sub OK { Net::Z3950::ZOOM::CCL_ERR_OK }
  58 sub TERM_EXPECTED { Net::Z3950::ZOOM::CCL_ERR_TERM_EXPECTED }
  59 sub RP_EXPECTED { Net::Z3950::ZOOM::CCL_ERR_RP_EXPECTED }
  60 sub SETNAME_EXPECTED { Net::Z3950::ZOOM::CCL_ERR_SETNAME_EXPECTED }
  61 sub OP_EXPECTED { Net::Z3950::ZOOM::CCL_ERR_OP_EXPECTED }
  62 sub BAD_RP { Net::Z3950::ZOOM::CCL_ERR_BAD_RP }
  63 sub UNKNOWN_QUAL { Net::Z3950::ZOOM::CCL_ERR_UNKNOWN_QUAL }
  64 sub DOUBLE_QUAL { Net::Z3950::ZOOM::CCL_ERR_DOUBLE_QUAL }
  65 sub EQ_EXPECTED { Net::Z3950::ZOOM::CCL_ERR_EQ_EXPECTED }
  66 sub BAD_RELATION { Net::Z3950::ZOOM::CCL_ERR_BAD_RELATION }
  67 sub TRUNC_NOT_LEFT { Net::Z3950::ZOOM::CCL_ERR_TRUNC_NOT_LEFT }
  68 sub TRUNC_NOT_BOTH { Net::Z3950::ZOOM::CCL_ERR_TRUNC_NOT_BOTH }
  69 sub TRUNC_NOT_RIGHT { Net::Z3950::ZOOM::CCL_ERR_TRUNC_NOT_RIGHT }
  70
  71 # The "Event" package contains constants returned by last_event()
  72 package ZOOM::Event;
  73 sub NONE { Net::Z3950::ZOOM::EVENT_NONE }
  74 sub CONNECT { Net::Z3950::ZOOM::EVENT_CONNECT }
  75 sub SEND_DATA { Net::Z3950::ZOOM::EVENT_SEND_DATA }
  76 sub RECV_DATA { Net::Z3950::ZOOM::EVENT_RECV_DATA }
  77 sub TIMEOUT { Net::Z3950::ZOOM::EVENT_TIMEOUT }
  78 sub UNKNOWN { Net::Z3950::ZOOM::EVENT_UNKNOWN }
  79 sub SEND_APDU { Net::Z3950::ZOOM::EVENT_SEND_APDU }
  80 sub RECV_APDU { Net::Z3950::ZOOM::EVENT_RECV_APDU }
  81 sub RECV_RECORD { Net::Z3950::ZOOM::EVENT_RECV_RECORD }
  82 sub RECV_SEARCH { Net::Z3950::ZOOM::EVENT_RECV_SEARCH }
  83 sub ZEND { Net::Z3950::ZOOM::EVENT_END }
  84
  85 # ----------------------------------------------------------------------------
  86
  87 package ZOOM;
  88
  89 sub diag_str {
  90     my($code) = @_;
  91
  92     # Special cases for error specific to the OO layer
  93     if ($code == ZOOM::Error::CREATE_QUERY) {
  94         return "can't create query object";
  95     } elsif ($code == ZOOM::Error::QUERY_CQL) {
  96         return "can't set CQL query";
  97     } elsif ($code == ZOOM::Error::QUERY_PQF) {
  98         return "can't set prefix query";
  99     } elsif ($code == ZOOM::Error::SORTBY) {
 100         return "can't set sort-specification";
 101     } elsif ($code == ZOOM::Error::CLONE) {
 102         return "can't clone record";
 103     } elsif ($code == ZOOM::Error::PACKAGE) {
 104         return "can't create package";
 105     } elsif ($code == ZOOM::Error::SCANTERM) {
 106         return "can't retrieve term from scan-set";
 107     } elsif ($code == ZOOM::Error::LOGLEVEL) {
 108         return "unregistered log-level";
 109     }
 110
 111     return Net::Z3950::ZOOM::diag_str($code);
 112 }
 113
 114 sub diag_srw_str {
 115     my($code) = @_;
 116
 117     return Net::Z3950::ZOOM::diag_srw_str($code);
 118 }
 119
 120 sub event_str {
 121     return Net::Z3950::ZOOM::event_str(@_);
 122 }
 123
 124 sub event {
 125     my($connsref) = @_;
 126
 127     my @_connsref = map { $_->_conn() } @$connsref;
 128     return Net::Z3950::ZOOM::event(\@_connsref);
 129 }
 130
 131 sub _oops {
 132     my($code, $addinfo, $diagset) = @_;
 133
 134     die new ZOOM::Exception($code, undef, $addinfo, $diagset);
 135 }
 136
 137 # ----------------------------------------------------------------------------
 138
 139 package ZOOM::Exception;
 140
 141 sub new {
 142     my $class = shift();
 143     my($code, $message, $addinfo, $diagset) = @_;
 144
 145     $diagset ||= "ZOOM";
 146     if (uc($diagset) eq "ZOOM" || uc($diagset) eq "BIB-1") {
 147         $message ||= ZOOM::diag_str($code);
 148     } elsif (lc($diagset) eq "info:srw/diagnostic/1") {
 149         $message ||= ZOOM::diag_srw_str($code);
 150     } else {
 151         # Should fill in messages for any other known diagsets.
 152         $message ||= "(unknown error)";
 153     }
 154
 155     return bless {
 156         code => $code,
 157         message => $message,
 158         addinfo => $addinfo,
 159         diagset => $diagset,
 160     }, $class;
 161 }
 162
 163 sub code {
 164     my $this = shift();
 165     return $this->{code};
 166 }
 167
 168 sub message {
 169     my $this = shift();
 170     return $this->{message};
 171 }
 172
 173 sub addinfo {
 174     my $this = shift();
 175     return $this->{addinfo};
 176 }
 177
 178 sub diagset {
 179     my $this = shift();
 180     return $this->{diagset};
 181 }
 182
 183 sub render {
 184     my $this = shift();
 185
 186     my $res = "ZOOM error " . $this->code();
 187     $res .= ' "' . $this->message() . '"' if $this->message();
 188     $res .= ' (addinfo: "' . $this->addinfo() . '")' if $this->addinfo();
 189     $res .= " from diag-set '" . $this->diagset() . "'" if $this->diagset();
 190     return $res;
 191 }
 192
 193 # This means that untrapped exceptions render nicely.
 194 use overload '""' => \&render;
 195
 196 # ----------------------------------------------------------------------------
 197
 198 package ZOOM::Options;
 199
 200 sub new {
 201     my $class = shift();
 202     my($p1, $p2) = @_;
 203
 204     my $opts;
 205     if (@_ == 0) {
 206         $opts = Net::Z3950::ZOOM::options_create();
 207     } elsif (@_ == 1) {
 208         $opts = Net::Z3950::ZOOM::options_create_with_parent($p1->_opts());
 209     } elsif (@_ == 2) {
 210         $opts = Net::Z3950::ZOOM::options_create_with_parent2($p1->_opts(),
 211                                                               $p2->_opts());
 212     } else {
 213         die "can't make $class object with more than 2 parents";
 214     }
 215
 216     return bless {
 217         _opts => $opts,
 218     }, $class;
 219 }
 220
 221 # PRIVATE to this class and ZOOM::Connection::create() and
 222 # ZOOM::Connection::package()
 223 #
 224 sub _opts {
 225     my $this = shift();
 226
 227     my $_opts = $this->{_opts};
 228     die "{_opts} undefined: has this Options block been destroy()ed?"
 229         if !defined $_opts;
 230
 231     return $_opts;
 232 }
 233
 234 sub option {
 235     my $this = shift();
 236     my($key, $value) = @_;
 237
 238     my $oldval = Net::Z3950::ZOOM::options_get($this->_opts(), $key);
 239     Net::Z3950::ZOOM::options_set($this->_opts(), $key, $value)
 240         if defined $value;
 241
 242     return $oldval;
 243 }
 244
 245 sub option_binary {
 246     my $this = shift();
 247     my($key, $value) = @_;
 248
 249     my $dummylen = 0;
 250     my $oldval = Net::Z3950::ZOOM::options_getl($this->_opts(),
 251                                                 $key, $dummylen);
 252     Net::Z3950::ZOOM::options_setl($this->_opts(), $key,
 253                                    $value, length($value))
 254         if defined $value;
 255
 256     return $oldval;
 257 }
 258
 259 # This is a bit stupid, since the scalar values that Perl returns from
 260 # option() can be used as a boolean; but it's just possible that some
 261 # applications will rely on ZOOM_options_get_bool()'s idiosyncratic
 262 # interpretation of what constitutes truth.
 263 #
 264 sub bool {
 265     my $this = shift();
 266     my($key, $default) = @_;
 267
 268     return Net::Z3950::ZOOM::options_get_bool($this->_opts(), $key, $default);
 269 }
 270
 271 # .. and the next two are even more stupid
 272 sub int {
 273     my $this = shift();
 274     my($key, $default) = @_;
 275
 276     return Net::Z3950::ZOOM::options_get_int($this->_opts(), $key, $default);
 277 }
 278
 279 sub set_int {
 280     my $this = shift();
 281     my($key, $value) = @_;
 282
 283     Net::Z3950::ZOOM::options_set_int($this->_opts(), $key, $value);
 284 }
 285
 286 #   ### Feel guilty.  Feel very, very guilty.  I've not been able to
 287 #       get the callback memory-management right in "ZOOM.xs", with
 288 #       the result that the values of $function and $udata passed into
 289 #       this function, which are on the stack, have sometimes been
 290 #       freed by the time they're used by __ZOOM_option_callback(),
 291 #       with hilarious results.  To avoid this, I copy the values into
 292 #       module-scoped globals, and pass _those_ into the extension
 293 #       function.  To avoid overwriting those globals by subsequent
 294 #       calls, I keep all the old ones, pushed onto the @_function and
 295 #       @_udata arrays, which means that THIS FUNCTION LEAKS MEMORY
 296 #       LIKE IT'S GOING OUT OF FASHION.  Not nice.  One day, I should
 297 #       fix this, but for now there's more important fish to fry.
 298 #
 299 my(@_function, @_udata);
 300 sub set_callback {
 301     my $o1 = shift();
 302     my($function, $udata) = @_;
 303
 304     push @_function, $function;
 305     push @_udata, $udata;
 306     Net::Z3950::ZOOM::options_set_callback($o1->_opts(),
 307                                            $_function[-1], $_udata[-1]);
 308 }
 309
 310 sub destroy {
 311     my $this = shift();
 312
 313     Net::Z3950::ZOOM::options_destroy($this->_opts());
 314     $this->{_opts} = undef;
 315 }
 316
 317
 318 # ----------------------------------------------------------------------------
 319
 320 package ZOOM::Connection;
 321
 322 sub new {
 323     my $class = shift();
 324     my($host, $port, @options) = @_;
 325
 326     my $conn = $class->create(@options);
 327     $conn->{host} = $host;
 328     $conn->{port} = $port;
 329
 330     Net::Z3950::ZOOM::connection_connect($conn->_conn(), $host, $port || 0);
 331     $conn->_check();
 332
 333     return $conn;
 334 }
 335
 336 # PRIVATE to this class, to ZOOM::event() and to ZOOM::Query::CQL2RPN::new()
 337 sub _conn {
 338     my $this = shift();
 339
 340     my $_conn = $this->{_conn};
 341     die "{_conn} undefined: has this Connection been destroy()ed?"
 342         if !defined $_conn;
 343
 344     return $_conn;
 345 }
 346
 347 sub _check {
 348     my $this = shift();
 349     my($always_die_on_error) = @_;
 350
 351     my($errcode, $errmsg, $addinfo, $diagset) = (undef, "x", "x", "x");
 352     $errcode = Net::Z3950::ZOOM::connection_error_x($this->_conn(), $errmsg,
 353                                                     $addinfo, $diagset);
 354     if ($errcode) {
 355         my $exception = new ZOOM::Exception($errcode, $errmsg, $addinfo,
 356                                             $diagset);
 357         if (!$this->option("async") || $always_die_on_error) {
 358             ZOOM::Log::log("zoom_check", "throwing error $exception");
 359             die $exception;
 360         } else {
 361             ZOOM::Log::log("zoom_check", "not reporting error $exception");
 362         }
 363     }
 364 }
 365
 366 # This wrapper for _check() is called only from outside the ZOOM
 367 # module, and therefore only in situations where an asynchronous
 368 # application is actively asking for an exception to be thrown if an
 369 # error has been detected.  So it passed always_die_on_error=1 to the
 370 # underlying _check() method.
 371 #
 372 sub check {
 373     my $this = shift();
 374     return $this->_check(1);
 375 }
 376
 377 sub create {
 378     my $class = shift();
 379     my(@options) = @_;
 380
 381     my $_opts;
 382     if (@_ == 1) {
 383         $_opts = $_[0]->_opts();
 384     } else {
 385         $_opts = Net::Z3950::ZOOM::options_create();
 386         while (@options >= 2) {
 387             my $key = shift(@options);
 388             my $val = shift(@options);
 389             Net::Z3950::ZOOM::options_set($_opts, $key, $val);
 390         }
 391
 392         die "Odd number of options specified"
 393             if @options;
 394     }
 395
 396     my $_conn = Net::Z3950::ZOOM::connection_create($_opts);
 397     my $conn = bless {
 398         host => undef,
 399         port => undef,
 400         _conn => $_conn,
 401     }, $class;
 402     return $conn;
 403 }
 404
 405 sub error_x {
 406     my $this = shift();
 407
 408     my($errcode, $errmsg, $addinfo, $diagset) = (undef, "dummy", "dummy", "d");
 409     $errcode = Net::Z3950::ZOOM::connection_error_x($this->_conn(), $errmsg,
 410                                                     $addinfo, $diagset);
 411     return wantarray() ? ($errcode, $errmsg, $addinfo, $diagset) : $errcode;
 412 }
 413
 414 sub exception {
 415     my $this = shift();
 416
 417     my($errcode, $errmsg, $addinfo, $diagset) = $this->error_x();
 418     return undef if $errcode == 0;
 419     return new ZOOM::Exception($errcode, $errmsg, $addinfo, $diagset);
 420 }
 421
 422 sub errcode {
 423     my $this = shift();
 424     return Net::Z3950::ZOOM::connection_errcode($this->_conn());
 425 }
 426
 427 sub errmsg {
 428     my $this = shift();
 429     return Net::Z3950::ZOOM::connection_errmsg($this->_conn());
 430 }
 431
 432 sub addinfo {
 433     my $this = shift();
 434     return Net::Z3950::ZOOM::connection_addinfo($this->_conn());
 435 }
 436
 437 sub diagset {
 438     my $this = shift();
 439     return Net::Z3950::ZOOM::connection_diagset($this->_conn());
 440 }
 441
 442 sub connect {
 443     my $this = shift();
 444     my($host, $port) = @_;
 445
 446     $port = 0 if !defined $port;
 447     Net::Z3950::ZOOM::connection_connect($this->_conn(), $host, $port);
 448     $this->_check();
 449     # No return value
 450 }
 451
 452 sub option {
 453     my $this = shift();
 454     my($key, $value) = @_;
 455
 456     my $oldval = Net::Z3950::ZOOM::connection_option_get($this->_conn(), $key);
 457     Net::Z3950::ZOOM::connection_option_set($this->_conn(), $key, $value)
 458         if defined $value;
 459
 460     return $oldval;
 461 }
 462
 463 sub option_binary {
 464     my $this = shift();
 465     my($key, $value) = @_;
 466
 467     my $dummylen = 0;
 468     my $oldval = Net::Z3950::ZOOM::connection_option_getl($this->_conn(),
 469                                                           $key, $dummylen);
 470     Net::Z3950::ZOOM::connection_option_setl($this->_conn(), $key,
 471                                              $value, length($value))
 472         if defined $value;
 473
 474     return $oldval;
 475 }
 476
 477 sub search {
 478     my $this = shift();
 479     my($query) = @_;
 480
 481     my $_rs = Net::Z3950::ZOOM::connection_search($this->_conn(),
 482                                                   $query->_query());
 483     $this->_check();
 484     return _new ZOOM::ResultSet($this, $query, $_rs);
 485 }
 486
 487 sub search_pqf {
 488     my $this = shift();
 489     my($pqf) = @_;
 490
 491     my $_rs = Net::Z3950::ZOOM::connection_search_pqf($this->_conn(), $pqf);
 492     $this->_check();
 493     return _new ZOOM::ResultSet($this, $pqf, $_rs);
 494 }
 495
 496 sub scan_pqf {
 497     my $this = shift();
 498     my($startterm) = @_;
 499
 500     my $_ss = Net::Z3950::ZOOM::connection_scan($this->_conn(), $startterm);
 501     $this->_check();
 502     return _new ZOOM::ScanSet($this, $startterm, $_ss);
 503 }
 504
 505 sub scan {
 506     my $this = shift();
 507     my($query) = @_;
 508
 509     my $_ss = Net::Z3950::ZOOM::connection_scan1($this->_conn(),
 510                                                  $query->_query());
 511     $this->_check();
 512     return _new ZOOM::ScanSet($this, $query, $_ss);
 513 }
 514
 515 sub package {
 516     my $this = shift();
 517     my($options) = @_;
 518
 519     my $_o = defined $options ? $options->_opts() :
 520         Net::Z3950::ZOOM::options_create();
 521     my $_p = Net::Z3950::ZOOM::connection_package($this->_conn(), $_o)
 522         or ZOOM::_oops(ZOOM::Error::PACKAGE);
 523
 524     return _new ZOOM::Package($this, $options, $_p);
 525 }
 526
 527 sub last_event {
 528     my $this = shift();
 529
 530     return Net::Z3950::ZOOM::connection_last_event($this->_conn());
 531 }
 532
 533 sub is_idle {
 534     my $this = shift();
 535
 536     return Net::Z3950::ZOOM::connection_is_idle($this->_conn());
 537 }
 538
 539 sub peek_event {
 540     my $this = shift();
 541
 542     return Net::Z3950::ZOOM::connection_peek_event($this->_conn());
 543 }
 544
 545 sub destroy {
 546     my $this = shift();
 547
 548     Net::Z3950::ZOOM::connection_destroy($this->_conn());
 549     $this->{_conn} = undef;
 550 }
 551
 552
 553 # ----------------------------------------------------------------------------
 554
 555 package ZOOM::Query;
 556
 557 sub new {
 558     my $class = shift();
 559     die "You can't create $class objects: it's a virtual base class";
 560 }
 561
 562 # PRIVATE to this class and ZOOM::Connection::search()
 563 sub _query {
 564     my $this = shift();
 565
 566     my $_query = $this->{_query};
 567     die "{_query} undefined: has this Query been destroy()ed?"
 568         if !defined $_query;
 569
 570     return $_query;
 571 }
 572
 573 sub sortby {
 574     my $this = shift();
 575     my($sortby) = @_;
 576
 577     Net::Z3950::ZOOM::query_sortby($this->_query(), $sortby) == 0
 578         or ZOOM::_oops(ZOOM::Error::SORTBY, $sortby);
 579 }
 580
 581 sub sortby2 {
 582     my $this = shift();
 583     my($strategy, $sortby) = @_;
 584
 585     Net::Z3950::ZOOM::query_sortby2($this->_query(), $strategy, $sortby) == 0
 586         or ZOOM::_oops(ZOOM::Error::SORTBY, $sortby);
 587 }
 588
 589 sub destroy {
 590     my $this = shift();
 591
 592     Net::Z3950::ZOOM::query_destroy($this->_query());
 593     $this->{_query} = undef;
 594 }
 595
 596
 597 package ZOOM::Query::CQL;
 598 our @ISA = qw(ZOOM::Query);
 599
 600 sub new {
 601     my $class = shift();
 602     my($string) = @_;
 603
 604     my $q = Net::Z3950::ZOOM::query_create()
 605         or ZOOM::_oops(ZOOM::Error::CREATE_QUERY);
 606     Net::Z3950::ZOOM::query_cql($q, $string) == 0
 607         or ZOOM::_oops(ZOOM::Error::QUERY_CQL, $string);
 608
 609     return bless {
 610         _query => $q,
 611     }, $class;
 612 }
 613
 614
 615 package ZOOM::Query::CQL2RPN;
 616 our @ISA = qw(ZOOM::Query);
 617
 618 sub new {
 619     my $class = shift();
 620     my($string, $conn) = @_;
 621
 622     my $q = Net::Z3950::ZOOM::query_create()
 623         or ZOOM::_oops(ZOOM::Error::CREATE_QUERY);
 624     # check() throws the exception we want; but we only want it on failure!
 625     Net::Z3950::ZOOM::query_cql2rpn($q, $string, $conn->_conn()) == 0
 626         or $conn->_check();
 627
 628     return bless {
 629         _query => $q,
 630     }, $class;
 631 }
 632
 633
 634 # We have to work around the retarded ZOOM_query_ccl2rpn() API
 635 package ZOOM::Query::CCL2RPN;
 636 our @ISA = qw(ZOOM::Query);
 637
 638 sub new {
 639     my $class = shift();
 640     my($string, $conn) = @_;
 641
 642     my $q = Net::Z3950::ZOOM::query_create()
 643         or ZOOM::_oops(ZOOM::Error::CREATE_QUERY);
 644
 645     my $config = $conn->option("cclqual");
 646     if (!defined $config) {
 647         my $cclfile = $conn->option("cclfile")
 648             or ZOOM::_oops(ZOOM::Error::CCL_CONFIG,
 649                            "no 'cclqual' or 'cclfile' specified");
 650         my $fh = new IO::File("<$cclfile")
 651             or ZOOM::_oops(ZOOM::Error::CCL_CONFIG,
 652                            "can't open cclfile '$cclfile': $!");
 653         $config = join("", <$fh>);
 654         $fh->close();
 655     }
 656
 657     my($ccl_errcode, $ccl_errstr, $ccl_errpos) = (0, "", 0);
 658     if (Net::Z3950::ZOOM::query_ccl2rpn($q, $string, $config,
 659                                         $ccl_errcode, $ccl_errstr,
 660                                         $ccl_errpos) < 0) {
 661         # We have no use for $ccl_errcode or $ccl_errpos
 662         ZOOM::_oops(ZOOM::Error::CCL_PARSE, $ccl_errstr);
 663     }
 664
 665     return bless {
 666         _query => $q,
 667     }, $class;
 668 }
 669
 670
 671 package ZOOM::Query::PQF;
 672 our @ISA = qw(ZOOM::Query);
 673
 674 sub new {
 675     my $class = shift();
 676     my($string) = @_;
 677
 678     my $q = Net::Z3950::ZOOM::query_create()
 679         or ZOOM::_oops(ZOOM::Error::CREATE_QUERY);
 680     Net::Z3950::ZOOM::query_prefix($q, $string) == 0
 681         or ZOOM::_oops(ZOOM::Error::QUERY_PQF, $string);
 682
 683     return bless {
 684         _query => $q,
 685     }, $class;
 686 }
 687
 688
 689 # ----------------------------------------------------------------------------
 690
 691 package ZOOM::ResultSet;
 692
 693 sub new {
 694     my $class = shift();
 695     die "You can't create $class objects directly";
 696 }
 697
 698 # PRIVATE to ZOOM::Connection::search() and ZOOM::Connection::search_pqf()
 699 sub _new {
 700     my $class = shift();
 701     my($conn, $query, $_rs) = @_;
 702
 703     return bless {
 704         conn => $conn,
 705         query => $query,        # This is not currently used, which is
 706                                 # just as well since it could be
 707                                 # either a string (when the RS is
 708                                 # created with search_pqf()) or a
 709                                 # ZOOM::Query object (when it's
 710                                 # created with search())
 711         _rs => $_rs,
 712     }, $class;
 713 }
 714
 715 # PRIVATE to this class
 716 sub _rs {
 717     my $this = shift();
 718
 719     my $_rs = $this->{_rs};
 720     die "{_rs} undefined: has this ResultSet been destroy()ed?"
 721         if !defined $_rs;
 722
 723     return $_rs;
 724 }
 725
 726 sub option {
 727     my $this = shift();
 728     my($key, $value) = @_;
 729
 730     my $oldval = Net::Z3950::ZOOM::resultset_option_get($this->_rs(), $key);
 731     Net::Z3950::ZOOM::resultset_option_set($this->_rs(), $key, $value)
 732         if defined $value;
 733
 734     return $oldval;
 735 }
 736
 737 sub size {
 738     my $this = shift();
 739
 740     return Net::Z3950::ZOOM::resultset_size($this->_rs());
 741 }
 742
 743 sub record {
 744     my $this = shift();
 745     my($which) = @_;
 746
 747     my $_rec = Net::Z3950::ZOOM::resultset_record($this->_rs(), $which);
 748     $this->{conn}->_check();
 749
 750     # Even if no error has occurred, I think record() might
 751     # legitimately return undef if we're running in asynchronous mode
 752     # and the record just hasn't been retrieved yet.  This goes double
 753     # for record_immediate().
 754     return undef if !defined $_rec;
 755
 756     # For some reason, I have to use the explicit "->" syntax in order
 757     # to invoke the ZOOM::Record constructor here, even though I don't
 758     # have to do the same for _new ZOOM::ResultSet above.  Weird.
 759     return ZOOM::Record->_new($this, $which, $_rec);
 760 }
 761
 762 sub record_immediate {
 763     my $this = shift();
 764     my($which) = @_;
 765
 766     my $_rec = Net::Z3950::ZOOM::resultset_record_immediate($this->_rs(),
 767                                                             $which);
 768     $this->{conn}->_check();
 769     # The record might legitimately not be there yet
 770     return undef if !defined $_rec;
 771
 772     return ZOOM::Record->_new($this, $which, $_rec);
 773 }
 774
 775 sub cache_reset {
 776     my $this = shift();
 777
 778     Net::Z3950::ZOOM::resultset_cache_reset($this->_rs());
 779 }
 780
 781 sub records {
 782     my $this = shift();
 783     my($start, $count, $return_records) = @_;
 784
 785     # If the request is out of range, ZOOM-C will currently (as of YAZ
 786     # 2.1.38) no-op: it understandably refuses to build and send a
 787     # known-bad APDU, but it doesn't set a diagnostic as it ought.  So
 788     # for now, we do it here.  It would be more polite to stash the
 789     # error-code in the ZOOM-C connection object for subsequent
 790     # discovery (which is what ZOOM-C will presumably do itself when
 791     # it's fixed) but since there is no API that allows us to do that,
 792     # we just have to throw the exception right now.  That's probably
 793     # OK for synchronous applications, but not really for
 794     # multiplexers.
 795     my $size = $this->size();
 796     if ($start + $count-1 >= $size) {
 797         # BIB-1 diagnostic 13 is "Present request out-of-range"
 798         ZOOM::_oops(13, undef, "BIB-1");
 799     }
 800
 801     my $raw = Net::Z3950::ZOOM::resultset_records($this->_rs(), $start, $count,
 802                                                   $return_records);
 803     # By design, $raw may be undefined (if $return_records is true)
 804     return undef if !defined $raw;
 805
 806     # We need to package up the returned records in ZOOM::Record objects
 807     my @res = ();
 808     for my $i (0 .. @$raw-1) {
 809         my $_rec = $raw->[$i];
 810         if (!defined $_rec) {
 811             push @res, undef;
 812         } else {
 813             push @res, ZOOM::Record->_new($this, $start+$i, $_rec);
 814         }
 815     }
 816
 817     return \@res;
 818 }
 819
 820 sub sort {
 821     my $this = shift();
 822     my($sort_type, $sort_spec) = @_;
 823
 824     return Net::Z3950::ZOOM::resultset_sort1($this->_rs(),
 825                                              $sort_type, $sort_spec);
 826 }
 827
 828 sub destroy {
 829     my $this = shift();
 830
 831     Net::Z3950::ZOOM::resultset_destroy($this->_rs());
 832     $this->{_rs} = undef;
 833 }
 834
 835
 836 # ----------------------------------------------------------------------------
 837
 838 package ZOOM::Record;
 839
 840 sub new {
 841     my $class = shift();
 842     die "You can't create $class objects directly";
 843 }
 844
 845 # PRIVATE to ZOOM::ResultSet::record(),
 846 # ZOOM::ResultSet::record_immediate(), ZOOM::ResultSet::records() and
 847 # ZOOM::Record::clone()
 848 #
 849 sub _new {
 850     my $class = shift();
 851     my($rs, $which, $_rec) = @_;
 852
 853     return bless {
 854         rs => $rs,
 855         which => $which,
 856         _rec => $_rec,
 857     }, $class;
 858 }
 859
 860 # PRIVATE to this class
 861 sub _rec {
 862     my $this = shift();
 863
 864     my $_rec = $this->{_rec};
 865     die "{_rec} undefined: has this Record been destroy()ed?"
 866         if !defined $_rec;
 867
 868     return $_rec;
 869 }
 870
 871 sub error {
 872     my $this = shift();
 873
 874     my($errcode, $errmsg, $addinfo, $diagset) = (undef, "dummy", "dummy", "d");
 875     $errcode = Net::Z3950::ZOOM::record_error($this->_rec(), $errmsg,
 876                                               $addinfo, $diagset);
 877
 878     return wantarray() ? ($errcode, $errmsg, $addinfo, $diagset) : $errcode;
 879 }
 880
 881 sub exception {
 882     my $this = shift();
 883
 884     my($errcode, $errmsg, $addinfo, $diagset) = $this->error();
 885     return undef if $errcode == 0;
 886     return new ZOOM::Exception($errcode, $errmsg, $addinfo, $diagset);
 887 }
 888
 889
 890 sub render {
 891     my $this = shift();
 892
 893     return $this->get("render", @_);
 894 }
 895
 896 sub raw {
 897     my $this = shift();
 898
 899     return $this->get("raw", @_);
 900 }
 901
 902 sub get {
 903     my $this = shift();
 904     my($type, $args) = @_;
 905
 906     $type = "$type;$args" if defined $args;
 907     return Net::Z3950::ZOOM::record_get($this->_rec(), $type);
 908 }
 909
 910 sub clone {
 911     my $this = shift();
 912
 913     my $raw = Net::Z3950::ZOOM::record_clone($this->_rec())
 914         or ZOOM::_oops(ZOOM::Error::CLONE);
 915
 916     # Arg 1 (rs) is undefined as the new record doesn't belong to an RS
 917     return _new ZOOM::Record(undef, undef, $raw);
 918 }
 919
 920 sub destroy {
 921     my $this = shift();
 922
 923     Net::Z3950::ZOOM::record_destroy($this->_rec());
 924     $this->{_rec} = undef;
 925 }
 926
 927
 928 # ----------------------------------------------------------------------------
 929
 930 package ZOOM::ScanSet;
 931
 932 sub new {
 933     my $class = shift();
 934     die "You can't create $class objects directly";
 935 }
 936
 937 # PRIVATE to ZOOM::Connection::scan(),
 938 sub _new {
 939     my $class = shift();
 940     my($conn, $startterm, $_ss) = @_;
 941
 942     return bless {
 943         conn => $conn,
 944         startterm => $startterm,# This is not currently used, which is
 945                                 # just as well since it could be
 946                                 # either a string (when the SS is
 947                                 # created with scan()) or a
 948                                 # ZOOM::Query object (when it's
 949                                 # created with scan1())
 950         _ss => $_ss,
 951     }, $class;
 952 }
 953
 954 # PRIVATE to this class
 955 sub _ss {
 956     my $this = shift();
 957
 958     my $_ss = $this->{_ss};
 959     die "{_ss} undefined: has this ScanSet been destroy()ed?"
 960         if !defined $_ss;
 961
 962     return $_ss;
 963 }
 964
 965 sub option {
 966     my $this = shift();
 967     my($key, $value) = @_;
 968
 969     my $oldval = Net::Z3950::ZOOM::scanset_option_get($this->_ss(), $key);
 970     Net::Z3950::ZOOM::scanset_option_set($this->_ss(), $key, $value)
 971         if defined $value;
 972
 973     return $oldval;
 974 }
 975
 976 sub size {
 977     my $this = shift();
 978
 979     return Net::Z3950::ZOOM::scanset_size($this->_ss());
 980 }
 981
 982 sub term {
 983     my $this = shift();
 984     my($which) = @_;
 985
 986     my($occ, $len) = (0, 0);
 987     my $term = Net::Z3950::ZOOM::scanset_term($this->_ss(), $which,
 988                                               $occ, $len)
 989         or ZOOM::_oops(ZOOM::Error::SCANTERM);
 990
 991     die "length of term '$term' differs from returned len=$len"
 992         if length($term) != $len;
 993
 994     return ($term, $occ);
 995 }
 996
 997 sub display_term {
 998     my $this = shift();
 999     my($which) = @_;
1000
1001     my($occ, $len) = (0, 0);
1002     my $term = Net::Z3950::ZOOM::scanset_display_term($this->_ss(), $which,
1003                                                       $occ, $len)
1004         or ZOOM::_oops(ZOOM::Error::SCANTERM);
1005
1006     die "length of display term '$term' differs from returned len=$len"
1007         if length($term) != $len;
1008
1009     return ($term, $occ);
1010 }
1011
1012 sub destroy {
1013     my $this = shift();
1014
1015     Net::Z3950::ZOOM::scanset_destroy($this->_ss());
1016     $this->{_ss} = undef;
1017 }
1018
1019
1020 # ----------------------------------------------------------------------------
1021
1022 package ZOOM::Package;
1023
1024 sub new {
1025     my $class = shift();
1026     die "You can't create $class objects directly";
1027 }
1028
1029 # PRIVATE to ZOOM::Connection::package(),
1030 sub _new {
1031     my $class = shift();
1032     my($conn, $options, $_p) = @_;
1033
1034     return bless {
1035         conn => $conn,
1036         options => $options,
1037         _p => $_p,
1038     }, $class;
1039 }
1040
1041 # PRIVATE to this class
1042 sub _p {
1043     my $this = shift();
1044
1045     my $_p = $this->{_p};
1046     die "{_p} undefined: has this Package been destroy()ed?"
1047         if !defined $_p;
1048
1049     return $_p;
1050 }
1051
1052 sub option {
1053     my $this = shift();
1054     my($key, $value) = @_;
1055
1056     my $oldval = Net::Z3950::ZOOM::package_option_get($this->_p(), $key);
1057     Net::Z3950::ZOOM::package_option_set($this->_p(), $key, $value)
1058         if defined $value;
1059
1060     return $oldval;
1061 }
1062
1063 sub send {
1064     my $this = shift();
1065     my($type) = @_;
1066
1067     Net::Z3950::ZOOM::package_send($this->_p(), $type);
1068     $this->{conn}->_check();
1069 }
1070
1071 sub destroy {
1072     my $this = shift();
1073
1074     Net::Z3950::ZOOM::package_destroy($this->_p());
1075     $this->{_p} = undef;
1076 }
1077
1078
1079 # There follows trivial support for YAZ logging.  This is wired out
1080 # into the Net::Z3950::ZOOM package, and we here provide wrapper
1081 # functions -- nothing more than aliases, really -- in the ZOOM::Log
1082 # package.  There really is no point in inventing an OO interface.
1083 #
1084 # Passing @_ directly to the underlying Net::Z3950::ZOOM::* functions
1085 # doesn't work, for reasons that I can't begin to fathom, and that
1086 # don't particularly interest me.  Unpacking into scalars and passing
1087 # those _does_ work, so that's what we do.
1088
1089 package ZOOM::Log;
1090
1091 sub mask_str      { my($a) = @_; Net::Z3950::ZOOM::yaz_log_mask_str($a); }
1092 sub module_level  { my($a) = @_; Net::Z3950::ZOOM::yaz_log_module_level($a); }
1093 sub init          { my($a, $b, $c) = @_;
1094                     Net::Z3950::ZOOM::yaz_log_init($a, $b, $c) }
1095 sub init_file     { my($a) = @_; Net::Z3950::ZOOM::yaz_log_init_file($a) }
1096 sub init_level    { my($a) = @_; Net::Z3950::ZOOM::yaz_log_init_level($a) }
1097 sub init_prefix   { my($a) = @_; Net::Z3950::ZOOM::yaz_log_init_prefix($a) }
1098 sub time_format   { my($a) = @_; Net::Z3950::ZOOM::yaz_log_time_format($a) }
1099 sub init_max_size { my($a) = @_; Net::Z3950::ZOOM::yaz_log_init_max_size($a) }
1100
1101 sub log {
1102     my($level, @message) = @_;
1103
1104     if ($level !~ /^(0x)?\d+$/) {
1105         # Assuming its log-level name, we look it up.
1106         my $num = module_level($level);
1107         ZOOM::_oops(ZOOM::Error::LOGLEVEL, $level)
1108             if $num == 0;
1109         $level = $num;
1110     }
1111
1112     Net::Z3950::ZOOM::yaz_log($level, join("", @message));
1113 }
1114
1115 BEGIN { ZOOM::Log::mask_str("zoom_check"); }
1116
1117 1;