From 657bd74a4d71b1125a3bff1fe99631591ddf1873 Mon Sep 17 00:00:00 2001 From: Mike Taylor Date: Thu, 28 Feb 2002 11:21:57 +0000 Subject: [PATCH] Add RPN structure to search-handler argument hash. --- Changes | 34 +++++++++++ MANIFEST | 1 + SimpleServer.pm | 21 ++++++- SimpleServer.xs | 171 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- test.pl | 4 +- 5 files changed, 226 insertions(+), 5 deletions(-) diff --git a/Changes b/Changes index 77b6625..791e8b0 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,39 @@ Revision history for Perl extension Net::Z3950::Server. +0.04 (in progress) + - Add Changelog (### Why? We already have this file!) + - Add TODO file (although it's empty!) + - Change interface to constructor, and fix test.pl script to + use the new interface. + - Add support for Scan. + - Add support for building GRS-1 records. + - Add grs_test.pl test suite for new GRS-1 code. + - Add RPN structure to search-handler argument hash. + - Add PID element to init, search, fetch and present-handler + argument hashes (but not the sort, scan and close-handlers, + for some reason.) + - Fix typos in documentation. + +0.03 Thu Nov 09 16:22:00 + - Add the INSTALL file. + - Add support for a present-handler (distinct from fetch). + - Remove `$args->{LEN} = length($record)' from the example + fetch-handler in the documentation. + - Minor corrections to documentation, e.g. add commas after + elements in anonymous hash of arguments. + - Record syntaxes (formats) are now specified as ASCII OIDs + (e.g. "1.2.840.10003.5.10") rather than human-readable + strings (e.g. "usmarc") + - Add some XS code to support sorting, though it doesn't seem + to be finished yet, and is not wired out. + - Use symbolic constants (e.g. Z_ElementSetNames_generic + instead of hard-wired magic number 1). + - Add PEER_NAME element to init-handler argument hash. + - Minor changes to ztest.pl. + +0.02 Mon Sep 11 12:32:00 2000 + - First released versions + 0.01 Wed Aug 30 14:54:01 2000 - original version; created by h2xs 1.19 diff --git a/MANIFEST b/MANIFEST index bad6f72..f345998 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,6 +1,7 @@ Changes Makefile.PL MANIFEST +MANIFEST.SKIP SimpleServer.pm SimpleServer.xs test.pl diff --git a/SimpleServer.pm b/SimpleServer.pm index 3dc3d2c..2893c50 100644 --- a/SimpleServer.pm +++ b/SimpleServer.pm @@ -26,7 +26,10 @@ ## ## $Log: SimpleServer.pm,v $ -## Revision 1.9 2001-08-29 11:48:36 sondberg +## Revision 1.10 2002-02-28 11:21:57 mike +## Add RPN structure to search-handler argument hash. +## +## Revision 1.9 2001/08/29 11:48:36 sondberg ## Added routines ## ## Net::Z3950::SimpleServer::ScanSuccess @@ -61,7 +64,7 @@ require AutoLoader; @EXPORT = qw( ); -$VERSION = '0.02'; +$VERSION = '0.04'; bootstrap Net::Z3950::SimpleServer $VERSION; @@ -110,6 +113,20 @@ sub launch_server { } +# Register packages that we will use in translated RPNs +package Net::Z3950::APDU::Query; +package Net::Z3950::APDU::OID; +package Net::Z3950::RPN::And; +package Net::Z3950::RPN::Or; +package Net::Z3950::RPN::AndNot; +package Net::Z3950::RPN::Term; +package Net::Z3950::RPN::Attributes; +package Net::Z3950::RPN::Attribute; + +# Must revert to original package for Autoloader's benefit +package Net::Z3950::SimpleServer; + + # Autoload methods go after =cut, and are processed by the autosplit program. 1; diff --git a/SimpleServer.xs b/SimpleServer.xs index 77c3fc6..5fe2cfa 100644 --- a/SimpleServer.xs +++ b/SimpleServer.xs @@ -25,7 +25,10 @@ */ /*$Log: SimpleServer.xs,v $ -/*Revision 1.12 2001-08-30 14:02:10 sondberg +/*Revision 1.13 2002-02-28 11:21:57 mike +/*Add RPN structure to search-handler argument hash. +/* +/*Revision 1.12 2001/08/30 14:02:10 sondberg /*Small changes. /* /*Revision 1.11 2001/08/30 13:15:11 sondberg @@ -279,6 +282,170 @@ WRBUF zquery2pquery(Z_Query *q) } +/* Lifted verbatim from Net::Z3950 yazwrap/util.c */ +#include +void fatal(char *fmt, ...) +{ + va_list ap; + + fprintf(stderr, "FATAL (yazwrap): "); + va_start(ap, fmt); + vfprintf(stderr, fmt, ap); + va_end(ap); + fprintf(stderr, "\n"); + abort(); +} + + +/* Lifted verbatim from Net::Z3950 yazwrap/receive.c */ +/* + * Creates a new Perl object of type `class'; the newly-created scalar + * that is a reference to the blessed thingy `referent' is returned. + */ +static SV *newObject(char *class, SV *referent) +{ + HV *stash; + SV *sv; + + sv = newRV_noinc((SV*) referent); + stash = gv_stashpv(class, 0); + if (stash == 0) + fatal("attempt to create object of undefined class '%s'", class); + /*assert(stash != 0);*/ + sv_bless(sv, stash); + return sv; +} + + +/* Lifted verbatim from Net::Z3950 yazwrap/receive.c */ +static void setMember(HV *hv, char *name, SV *val) +{ + /* We don't increment `val's reference count -- I think this is + * right because it's created with a refcount of 1, and in fact + * the reference via this hash is the only reference to it in + * general. + */ + if (!hv_store(hv, name, (U32) strlen(name), val, (U32) 0)) + fatal("couldn't store member in hash"); +} + + +/* Lifted verbatim from Net::Z3950 yazwrap/receive.c */ +static SV *translateOID(Odr_oid *x) +{ + /* Yaz represents an OID by an int array terminated by a negative + * value, typically -1; we represent it as a reference to a + * blessed scalar string of "."-separated elements. + */ + char buf[1000]; + int i; + + *buf = '\0'; + for (i = 0; x[i] >= 0; i++) { + sprintf(buf + strlen(buf), "%d", (int) x[i]); + if (x[i+1] >- 0) + strcat(buf, "."); + } + + /* + * ### We'd like to return a blessed scalar (string) here, but of + * course you can't do that in Perl: only references can be + * blessed, so we'd have to return a _reference_ to a string, and + * bless _that_. Better to do without the blessing, I think. + */ + if (1) { + return newSVpv(buf, 0); + } else { + return newObject("Net::Z3950::APDU::OID", newSVpv(buf, 0)); + } +} + + +static SV *rpn2perl(Z_RPNStructure *s) +{ + SV *sv; + HV *hv; + AV *av; + + switch (s->which) { + case Z_RPNStructure_simple: { + Z_Operand *o = s->u.simple; + Z_AttributesPlusTerm *at; + if (o->which != Z_Operand_APT) + fatal("can't handle RPN simples other than APT"); + at = o->u.attributesPlusTerm; + if (at->term->which != Z_Term_general) + fatal("can't handle RPN terms other than general"); + + sv = newObject("Net::Z3950::RPN::Term", (SV*) (hv = newHV())); + if (at->attributes) { + int i; + SV *attrs = newObject("Net::Z3950::RPN::Attributes", + (SV*) (av = newAV())); + for (i = 0; i < at->attributes->num_attributes; i++) { + Z_AttributeElement *elem = at->attributes->attributes[i]; + HV *hv2; + SV *tmp = newObject("Net::Z3950::RPN::Attribute", + (SV*) (hv2 = newHV())); + if (elem->attributeSet) + setMember(hv2, "attributeSet", + translateOID(elem->attributeSet)); + setMember(hv2, "attributeType", + newSViv(*elem->attributeType)); + assert(elem->which == Z_AttributeValue_numeric); + setMember(hv2, "attributeValue", + newSViv(*elem->value.numeric)); + av_push(av, tmp); + } + setMember(hv, "attributes", attrs); + } + setMember(hv, "term", newSVpv((char*) at->term->u.general->buf, + at->term->u.general->len)); + return sv; + } + case Z_RPNStructure_complex: { + SV *tmp; + Z_Complex *c = s->u.complex; + char *type = 0; /* vacuous assignment satisfies gcc -Wall */ + switch (c->roperator->which) { + case Z_Operator_and: type = "Net::Z3950::RPN::And"; break; + case Z_Operator_or: type = "Net::Z3950::RPN::Or"; break; + case Z_Operator_and_not: type = "Net::Z3950::RPN::AndNot"; break; + case Z_Operator_prox: fatal("proximity not yet supported"); + default: fatal("unknown RPN operator %d", (int) c->roperator->which); + } + sv = newObject(type, (SV*) (av = newAV())); + if ((tmp = rpn2perl(c->s1)) == 0) + return 0; + av_push(av, tmp); + if ((tmp = rpn2perl(c->s2)) == 0) + return 0; + av_push(av, tmp); + return sv; + } + default: fatal("unknown RPN node type %d", (int) s->which); + } + + return 0; +} + + +static SV *zquery2perl(Z_Query *q) +{ + SV *sv; + HV *hv; + + if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101) + return 0; + sv = newObject("Net::Z3950::APDU::Query", (SV*) (hv = newHV())); + if (q->u.type_1->attributeSetId) + setMember(hv, "attributeSet", + translateOID(q->u.type_1->attributeSetId)); + setMember(hv, "query", rpn2perl(q->u.type_1->RPNStructure)); + return sv; +} + + int bend_sort(void *handle, bend_sort_rr *rr) { HV *href; @@ -391,6 +558,7 @@ int bend_search(void *handle, bend_search_rr *rr) hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0); hv_store(href, "HANDLE", 6, zhandle->handle, 0); hv_store(href, "PID", 3, newSViv(getpid()), 0); + hv_store(href, "RPN", 3, zquery2perl(rr->query), 0); query = zquery2pquery(rr->query); if (query) { @@ -450,6 +618,7 @@ int bend_search(void *handle, bend_search_rr *rr) } +/* ### this is worryingly similar to oid2str() */ WRBUF oid2dotted(int *oid) { diff --git a/test.pl b/test.pl index b0a03de..a7184be 100644 --- a/test.pl +++ b/test.pl @@ -82,11 +82,11 @@ sub my_close_handler { if (!defined($pid = fork() )) { die "Cannot fork: $!\n"; } elsif ($pid) { ## Parent launches server - my $handler = Net::Z3950::SimpleServer->new({ + my $handler = Net::Z3950::SimpleServer->new( INIT => \&my_init_handler, CLOSE => \&my_close_handler, SEARCH => \&my_search_handler, - FETCH => \&my_fetch_handler }); + FETCH => \&my_fetch_handler); $handler->launch_server("test.pl", "-1", @ARGV); } else { ## Child starts the client -- 1.7.10.4