Do not build tst_clones for non-threaded Perls
[simpleserver-moved-to-github.git] / SimpleServer.xs
1 /*
2  * $Id: SimpleServer.xs,v 1.32 2004-06-07 16:48:38 adam Exp $ 
3  * ----------------------------------------------------------------------
4  * 
5  * Copyright (c) 2000-2004, Index Data.
6  *
7  * Permission to use, copy, modify, distribute, and sell this software and
8  * its documentation, in whole or in part, for any purpose, is hereby granted,
9  * provided that:
10  *
11  * 1. This copyright and permission notice appear in all copies of the
12  * software and its documentation. Notices of copyright or attribution
13  * which appear at the beginning of any file must remain unchanged.
14  *
15  * 2. The name of Index Data or the individual authors may not be used to
16  * endorse or promote products derived from this software without specific
17  * prior written permission.
18  *
19  * THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT WARRANTY OF ANY KIND,
20  * EXPRESS, IMPLIED, OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
21  * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
22  * IN NO EVENT SHALL INDEX DATA BE LIABLE FOR ANY SPECIAL, INCIDENTAL,
23  * INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND, OR ANY DAMAGES
24  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER OR
25  * NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
26  * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
27  * OF THIS SOFTWARE.
28  */
29
30 #include "EXTERN.h"
31 #include "perl.h"
32 #include "proto.h"
33 #include "embed.h"
34 #include "XSUB.h"
35 #include <yaz/backend.h>
36 #include <yaz/log.h>
37 #include <yaz/wrbuf.h>
38 #include <stdio.h>
39 #ifdef WIN32
40 #else
41 #include <unistd.h>
42 #endif
43 #include <stdlib.h>
44 #include <ctype.h>
45 #define GRS_MAX_FIELDS 500 
46 #ifdef ASN_COMPILED
47 #include <yaz/ill.h>
48 #endif
49 #ifndef sv_undef                /* To fix the problem with Perl 5.6.0 */
50 #define sv_undef PL_sv_undef
51 #endif
52
53 NMEM_MUTEX simpleserver_mutex;
54
55 typedef struct {
56         SV *handle;
57
58         SV *init_ref;
59         SV *close_ref;
60         SV *sort_ref;
61         SV *search_ref;
62         SV *fetch_ref;
63         SV *present_ref;
64         SV *esrequest_ref;
65         SV *delete_ref;
66         SV *scan_ref;
67         NMEM nmem;
68         int stop_flag;  /* is used to stop server prematurely .. */
69 } Zfront_handle;
70
71 #define ENABLE_STOP_SERVER 0
72
73 SV *init_ref = NULL;
74 SV *close_ref = NULL;
75 SV *sort_ref = NULL;
76 SV *search_ref = NULL;
77 SV *fetch_ref = NULL;
78 SV *present_ref = NULL;
79 SV *esrequest_ref = NULL;
80 SV *delete_ref = NULL;
81 SV *scan_ref = NULL;
82 PerlInterpreter *root_perl_context;
83 int MAX_OID = 15;
84
85 #define GRS_BUF_SIZE 512
86
87 CV * simpleserver_sv2cv(SV *handler) {
88     STRLEN len;
89     char *buf;
90    
91     if (SvPOK(handler)) {
92         CV *ret;
93         buf = SvPV( handler, len);
94         if ( !( ret = perl_get_cv(buf, FALSE ) ) ) {
95             fprintf( stderr, "simpleserver_sv2cv: No such handler '%s'\n\n", buf );
96             exit(1);
97         }
98         
99         return ret;
100     } else {
101         return (CV *) handler;
102     }
103 }
104
105 /* debugging routine to check for destruction of Perl interpreters */
106 #ifdef USE_ITHREADS
107 void tst_clones(void)
108 {
109     int i; 
110     PerlInterpreter *parent = PERL_GET_CONTEXT;
111     for (i = 0; i<5000; i++)
112     {
113         PerlInterpreter *perl_interp;
114
115         PERL_SET_CONTEXT(parent);
116         PL_perl_destruct_level = 2;
117         perl_interp = perl_clone(parent, CLONEf_CLONE_HOST);
118         PL_perl_destruct_level = 2;
119         PERL_SET_CONTEXT(perl_interp);
120         perl_destruct(perl_interp);
121         perl_free(perl_interp);
122     }
123     exit (0);
124 }
125 #endif
126
127 int simpleserver_clone(void) {
128 #ifdef USE_ITHREADS
129      nmem_mutex_enter(simpleserver_mutex);
130      if (1)
131      {
132          PerlInterpreter *current = PERL_GET_CONTEXT;
133
134          /* if current is unset, then we're in a new thread with
135           * no Perl interpreter for it. So we must create one .
136           * This will only happen when threaded is used..
137           */
138          if (!current) {
139              PerlInterpreter *perl_interp;
140              PERL_SET_CONTEXT( root_perl_context );
141              perl_interp = perl_clone(root_perl_context, CLONEf_CLONE_HOST);
142              PERL_SET_CONTEXT( perl_interp );
143          }
144      }
145      nmem_mutex_leave(simpleserver_mutex);
146 #endif
147      return 0;
148 }
149
150
151 void simpleserver_free(void) {
152     nmem_mutex_enter(simpleserver_mutex);
153     if (1)
154     {
155         PerlInterpreter *current_interp = PERL_GET_CONTEXT;
156
157         /* If current Perl Interp is different from root interp, then
158          * we're in threaded mode and we must destroy.. 
159          */
160         if (current_interp != root_perl_context) {
161             PL_perl_destruct_level = 2;
162             PERL_SET_CONTEXT(current_interp);
163             perl_destruct(current_interp);
164             perl_free(current_interp);
165         }
166     }
167     nmem_mutex_leave(simpleserver_mutex);
168 }
169
170
171 Z_GenericRecord *read_grs1(char *str, ODR o)
172 {
173         int type, ivalue;
174         char line[GRS_BUF_SIZE+1], *buf, *ptr, *original;
175         char value[GRS_BUF_SIZE+1];
176         Z_GenericRecord *r = 0;
177
178         original = str;
179         r = (Z_GenericRecord *)odr_malloc(o, sizeof(*r));
180         r->elements = (Z_TaggedElement **) odr_malloc(o, sizeof(Z_TaggedElement*) * GRS_MAX_FIELDS);
181         r->num_elements = 0;
182         
183         for (;;)
184         {
185                 Z_TaggedElement *t;
186                 Z_ElementData *c;
187                 int len;
188         
189                 ptr = strchr(str, '\n');
190                 if (!ptr) {
191                         return r;
192                 }
193                 len = ptr - str;
194                 if (len > GRS_BUF_SIZE) {
195                     yaz_log(LOG_WARN, "GRS string too long - truncating (%d > %d)", len, GRS_BUF_SIZE);
196                     len = GRS_BUF_SIZE;
197                 }
198                 strncpy(line, str, len);
199                 line[len] = 0;
200                 buf = line;
201                 str = ptr + 1;
202                 while (*buf && isspace(*buf))
203                         buf++;
204                 if (*buf == '}') {
205                         memmove(original, str, strlen(str));
206                         return r;
207                 }
208                 if (sscanf(buf, "(%d,%[^)])", &type, value) != 2)
209                 {
210                         yaz_log(LOG_WARN, "Bad data in '%s'", buf);
211                         return r;
212                 }
213                 if (!type && *value == '0')
214                         return r;
215                 if (!(buf = strchr(buf, ')')))
216                         return r;
217                 buf++;
218                 while (*buf && isspace(*buf))
219                         buf++;
220                 if (r->num_elements >= GRS_MAX_FIELDS)
221                 {
222                         yaz_log(LOG_WARN, "Max number of GRS-1 elements exceeded [GRS_MAX_FIELDS=%d]", GRS_MAX_FIELDS);
223                         exit(0);
224                 }
225                 r->elements[r->num_elements] = t = (Z_TaggedElement *) odr_malloc(o, sizeof(Z_TaggedElement));
226                 t->tagType = (int *)odr_malloc(o, sizeof(int));
227                 *t->tagType = type;
228                 t->tagValue = (Z_StringOrNumeric *)
229                         odr_malloc(o, sizeof(Z_StringOrNumeric));
230                 if ((ivalue = atoi(value)))
231                 {
232                         t->tagValue->which = Z_StringOrNumeric_numeric;
233                         t->tagValue->u.numeric = (int *)odr_malloc(o, sizeof(int));
234                         *t->tagValue->u.numeric = ivalue;
235                 }
236                 else
237                 {
238                         t->tagValue->which = Z_StringOrNumeric_string;
239                         t->tagValue->u.string = (char *)odr_malloc(o, strlen(value)+1);
240                         strcpy(t->tagValue->u.string, value);
241                 }
242                 t->tagOccurrence = 0;
243                 t->metaData = 0;
244                 t->appliedVariant = 0;
245                 t->content = c = (Z_ElementData *)odr_malloc(o, sizeof(Z_ElementData));
246                 if (*buf == '{')
247                 {
248                         c->which = Z_ElementData_subtree;
249                         c->u.subtree = read_grs1(str, o);
250                 }
251                 else
252                 {
253                         c->which = Z_ElementData_string;
254                         c->u.string = odr_strdup(o, buf);
255                 }
256                 r->num_elements++;
257         }
258 }
259
260
261
262
263 static void oid2str(Odr_oid *o, WRBUF buf)
264 {
265     for (; *o >= 0; o++) {
266         char ibuf[16];
267         sprintf(ibuf, "%d", *o);
268         wrbuf_puts(buf, ibuf);
269         if (o[1] > 0)
270             wrbuf_putc(buf, '.');
271     }
272 }
273
274
275 static int rpn2pquery(Z_RPNStructure *s, WRBUF buf)
276 {
277     switch (s->which) {
278         case Z_RPNStructure_simple: {
279             Z_Operand *o = s->u.simple;
280
281             switch (o->which) {
282                 case Z_Operand_APT: {
283                     Z_AttributesPlusTerm *at = o->u.attributesPlusTerm;
284
285                     if (at->attributes) {
286                         int i;
287                         char ibuf[16];
288
289                         for (i = 0; i < at->attributes->num_attributes; i++) {
290                             wrbuf_puts(buf, "@attr ");
291                             if (at->attributes->attributes[i]->attributeSet) {
292                                 oid2str(at->attributes->attributes[i]->attributeSet, buf);
293                                 wrbuf_putc(buf, ' ');
294                             }
295                             sprintf(ibuf, "%d=", *at->attributes->attributes[i]->attributeType);
296                             assert(at->attributes->attributes[i]->which == Z_AttributeValue_numeric);
297                             wrbuf_puts(buf, ibuf);
298                             sprintf(ibuf, "%d ", *at->attributes->attributes[i]->value.numeric);
299                             wrbuf_puts(buf, ibuf);
300                         }
301                     }
302                     switch (at->term->which) {
303                         case Z_Term_general: {
304                             wrbuf_putc(buf, '"');
305                             wrbuf_write(buf, (char*) at->term->u.general->buf, at->term->u.general->len);
306                             wrbuf_puts(buf, "\" ");
307                             break;
308                         }
309                         default: abort();
310                     }
311                     break;
312                 }
313                 default: abort();
314             }
315             break;
316         }
317         case Z_RPNStructure_complex: {
318             Z_Complex *c = s->u.complex;
319
320             switch (c->roperator->which) {
321                 case Z_Operator_and: wrbuf_puts(buf, "@and "); break;
322                 case Z_Operator_or: wrbuf_puts(buf, "@or "); break;
323                 case Z_Operator_and_not: wrbuf_puts(buf, "@not "); break;
324                 case Z_Operator_prox: abort();
325                 default: abort();
326             }
327             if (!rpn2pquery(c->s1, buf))
328                 return 0;
329             if (!rpn2pquery(c->s2, buf))
330                 return 0;
331             break;
332         }
333         default: abort();
334     }
335     return 1;
336 }
337
338
339 WRBUF zquery2pquery(Z_Query *q)
340 {
341     WRBUF buf = wrbuf_alloc();
342
343     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101) 
344         return 0;
345     if (q->u.type_1->attributeSetId) {
346         /* Output attribute set ID */
347         wrbuf_puts(buf, "@attrset ");
348         oid2str(q->u.type_1->attributeSetId, buf);
349         wrbuf_putc(buf, ' ');
350     }
351     return rpn2pquery(q->u.type_1->RPNStructure, buf) ? buf : 0;
352 }
353
354
355 /* Lifted verbatim from Net::Z3950 yazwrap/util.c */
356 #include <stdarg.h>
357 void fatal(char *fmt, ...)
358 {
359     va_list ap;
360
361     fprintf(stderr, "FATAL (yazwrap): ");
362     va_start(ap, fmt);
363     vfprintf(stderr, fmt, ap);
364     va_end(ap);
365     fprintf(stderr, "\n");
366     abort();
367 }
368
369
370 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
371 /*
372  * Creates a new Perl object of type `class'; the newly-created scalar
373  * that is a reference to the blessed thingy `referent' is returned.
374  */
375 static SV *newObject(char *class, SV *referent)
376 {
377     HV *stash;
378     SV *sv;
379
380     sv = newRV_noinc((SV*) referent);
381     stash = gv_stashpv(class, 0);
382     if (stash == 0)
383         fatal("attempt to create object of undefined class '%s'", class);
384     /*assert(stash != 0);*/
385     sv_bless(sv, stash);
386     return sv;
387 }
388
389
390 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
391 static void setMember(HV *hv, char *name, SV *val)
392 {
393     /* We don't increment `val's reference count -- I think this is
394      * right because it's created with a refcount of 1, and in fact
395      * the reference via this hash is the only reference to it in
396      * general.
397      */
398     if (!hv_store(hv, name, (U32) strlen(name), val, (U32) 0))
399         fatal("couldn't store member in hash");
400 }
401
402
403 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
404 static SV *translateOID(Odr_oid *x)
405 {
406     /* Yaz represents an OID by an int array terminated by a negative
407      * value, typically -1; we represent it as a reference to a
408      * blessed scalar string of "."-separated elements.
409      */
410     char buf[1000];
411     int i;
412
413     *buf = '\0';
414     for (i = 0; x[i] >= 0; i++) {
415         sprintf(buf + strlen(buf), "%d", (int) x[i]);
416         if (x[i+1] >- 0)
417             strcat(buf, ".");
418     }
419
420     /*
421      * ### We'd like to return a blessed scalar (string) here, but of
422      *  course you can't do that in Perl: only references can be
423      *  blessed, so we'd have to return a _reference_ to a string, and
424      *  bless _that_.  Better to do without the blessing, I think.
425      */
426     if (1) {
427         return newSVpv(buf, 0);
428     } else {
429         return newObject("Net::Z3950::APDU::OID", newSVpv(buf, 0));
430     }
431 }
432
433
434 static SV *rpn2perl(Z_RPNStructure *s)
435 {
436     SV *sv;
437     HV *hv;
438     AV *av;
439
440     switch (s->which) {
441     case Z_RPNStructure_simple: {
442         Z_Operand *o = s->u.simple;
443         Z_AttributesPlusTerm *at;
444         if (o->which != Z_Operand_APT)
445             fatal("can't handle RPN simples other than APT");
446         at = o->u.attributesPlusTerm;
447         if (at->term->which != Z_Term_general)
448             fatal("can't handle RPN terms other than general");
449
450         sv = newObject("Net::Z3950::RPN::Term", (SV*) (hv = newHV()));
451         if (at->attributes) {
452             int i;
453             SV *attrs = newObject("Net::Z3950::RPN::Attributes",
454                                   (SV*) (av = newAV()));
455             for (i = 0; i < at->attributes->num_attributes; i++) {
456                 Z_AttributeElement *elem = at->attributes->attributes[i];
457                 HV *hv2;
458                 SV *tmp = newObject("Net::Z3950::RPN::Attribute",
459                                     (SV*) (hv2 = newHV()));
460                 if (elem->attributeSet)
461                     setMember(hv2, "attributeSet",
462                               translateOID(elem->attributeSet));
463                 setMember(hv2, "attributeType",
464                           newSViv(*elem->attributeType));
465                 assert(elem->which == Z_AttributeValue_numeric);
466                 setMember(hv2, "attributeValue",
467                           newSViv(*elem->value.numeric));
468                 av_push(av, tmp);
469             }
470             setMember(hv, "attributes", attrs);
471         }
472         setMember(hv, "term", newSVpv((char*) at->term->u.general->buf,
473                                       at->term->u.general->len));
474         return sv;
475     }
476     case Z_RPNStructure_complex: {
477         SV *tmp;
478         Z_Complex *c = s->u.complex;
479         char *type = 0;         /* vacuous assignment satisfies gcc -Wall */
480         switch (c->roperator->which) {
481         case Z_Operator_and:     type = "Net::Z3950::RPN::And"; break;
482         case Z_Operator_or:      type = "Net::Z3950::RPN::Or"; break;
483         case Z_Operator_and_not: type = "Net::Z3950::RPN::AndNot"; break;
484         case Z_Operator_prox:    fatal("proximity not yet supported");
485         default: fatal("unknown RPN operator %d", (int) c->roperator->which);
486         }
487         sv = newObject(type, (SV*) (av = newAV()));
488         if ((tmp = rpn2perl(c->s1)) == 0)
489             return 0;
490         av_push(av, tmp);
491         if ((tmp = rpn2perl(c->s2)) == 0)
492             return 0;
493         av_push(av, tmp);
494         return sv;
495     }
496     default: fatal("unknown RPN node type %d", (int) s->which);
497     }
498
499     return 0;
500 }
501
502
503 static SV *zquery2perl(Z_Query *q)
504 {
505     SV *sv;
506     HV *hv;
507
508     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101) 
509         return 0;
510     sv = newObject("Net::Z3950::APDU::Query", (SV*) (hv = newHV()));
511     if (q->u.type_1->attributeSetId)
512         setMember(hv, "attributeSet",
513                   translateOID(q->u.type_1->attributeSetId));
514     setMember(hv, "query", rpn2perl(q->u.type_1->RPNStructure));
515     return sv;
516 }
517
518
519 int bend_sort(void *handle, bend_sort_rr *rr)
520 {
521         HV *href;
522         AV *aref;
523         SV **temp;
524         SV *err_code;
525         SV *err_str;
526         SV *status;
527         STRLEN len;
528         char *ptr;
529         char *ODR_err_str;
530         char **input_setnames;
531         Zfront_handle *zhandle = (Zfront_handle *)handle;
532         int i;
533         
534         dSP;
535         ENTER;
536         SAVETMPS;
537         
538         aref = newAV();
539         input_setnames = rr->input_setnames;
540         for (i = 0; i < rr->num_input_setnames; i++)
541         {
542                 av_push(aref, newSVpv(*input_setnames++, 0));
543         }
544         href = newHV();
545         hv_store(href, "INPUT", 5, newRV( (SV*) aref), 0);
546         hv_store(href, "OUTPUT", 6, newSVpv(rr->output_setname, 0), 0);
547         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
548         hv_store(href, "STATUS", 6, newSViv(0), 0);
549
550         PUSHMARK(sp);
551
552         XPUSHs(sv_2mortal(newRV( (SV*) href)));
553
554         PUTBACK;
555
556         perl_call_sv(sort_ref, G_SCALAR | G_DISCARD);
557
558         SPAGAIN;
559
560         temp = hv_fetch(href, "ERR_CODE", 8, 1);
561         err_code = newSVsv(*temp);
562
563         temp = hv_fetch(href, "ERR_STR", 7, 1);
564         err_str = newSVsv(*temp);
565
566         temp = hv_fetch(href, "STATUS", 6, 1);
567         status = newSVsv(*temp);
568
569         PUTBACK;
570         FREETMPS;
571         LEAVE;
572
573         hv_undef(href),
574         av_undef(aref);
575         rr->errcode = SvIV(err_code);
576         rr->sort_status = SvIV(status);
577         ptr = SvPV(err_str, len);
578         ODR_err_str = (char *)odr_malloc(rr->stream, len + 1);
579         strcpy(ODR_err_str, ptr);
580         rr->errstring = ODR_err_str;
581
582         sv_free(err_code);
583         sv_free(err_str);
584         sv_free(status);
585         
586         return 0;
587 }
588
589
590 int bend_search(void *handle, bend_search_rr *rr)
591 {
592         HV *href;
593         AV *aref;
594         SV **temp;
595         char *ODR_errstr;
596         STRLEN len;
597         int i;
598         char **basenames;
599         WRBUF query;
600         char *ptr;
601         SV *point;
602         Zfront_handle *zhandle = (Zfront_handle *)handle;
603         CV* handler_cv = 0;
604
605         dSP;
606         ENTER;
607         SAVETMPS;
608
609         aref = newAV();
610         basenames = rr->basenames;
611         for (i = 0; i < rr->num_bases; i++)
612         {
613                 av_push(aref, newSVpv(*basenames++, 0));
614         }
615 #if ENABLE_STOP_SERVER
616         if (rr->num_bases == 1 && !strcmp(rr->basenames[0], "XXstop"))
617         {
618                 zhandle->stop_flag = 1;
619         }
620 #endif
621         href = newHV();         
622         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
623         hv_store(href, "REPL_SET", 8, newSViv(rr->replace_set), 0);
624         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
625         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
626         hv_store(href, "HITS", 4, newSViv(0), 0);
627         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
628         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
629         hv_store(href, "PID", 3, newSViv(getpid()), 0);
630         hv_store(href, "RPN", 3, zquery2perl(rr->query), 0);
631         query = zquery2pquery(rr->query);
632         if (query)
633         {
634                 hv_store(href, "QUERY", 5, newSVpv((char *)query->buf, query->pos), 0);
635         }
636         else
637         {       
638                 rr->errcode = 108;
639         }
640         PUSHMARK(sp);
641         
642         XPUSHs(sv_2mortal(newRV( (SV*) href)));
643         
644         PUTBACK;
645
646         handler_cv = simpleserver_sv2cv( search_ref );
647         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
648
649         SPAGAIN;
650
651         temp = hv_fetch(href, "HITS", 4, 1);
652         rr->hits = SvIV(*temp);
653
654         temp = hv_fetch(href, "ERR_CODE", 8, 1);
655         rr->errcode = SvIV(*temp);
656
657         temp = hv_fetch(href, "ERR_STR", 7, 1);
658         ptr = SvPV(*temp, len);
659         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
660         strcpy(ODR_errstr, ptr);
661         rr->errstring = ODR_errstr;
662
663         temp = hv_fetch(href, "HANDLE", 6, 1);
664         point = newSVsv(*temp);
665
666         hv_undef(href);
667         av_undef(aref);
668
669         zhandle->handle = point;
670         sv_free( (SV*) aref);
671         sv_free( (SV*) href);
672         wrbuf_free(query, 1);
673         PUTBACK;
674         FREETMPS;
675         LEAVE;
676         return 0;
677 }
678
679
680 /* ### this is worryingly similar to oid2str() */
681 WRBUF oid2dotted(int *oid)
682 {
683
684         WRBUF buf = wrbuf_alloc();
685         int dot = 0;
686
687         for (; *oid != -1 ; oid++)
688         {
689                 char ibuf[16];
690                 if (dot)
691                 {
692                         wrbuf_putc(buf, '.');
693                 }
694                 else
695                 {
696                         dot = 1;
697                 }
698                 sprintf(ibuf, "%d", *oid);
699                 wrbuf_puts(buf, ibuf);
700         }
701         return buf;
702 }
703                 
704
705 int dotted2oid(char *dotted, int *buffer)
706 {
707         int *oid;
708         char ibuf[16];
709         char *ptr;
710         int n = 0;
711
712         ptr = ibuf;
713         oid = buffer;
714         while (*dotted)
715         {
716                 if (*dotted == '.')
717                 {
718                         n++;
719                         if (n == MAX_OID)  /* Terminate if more than MAX_OID entries */
720                         {
721                                 *oid = -1;
722                                 return -1;
723                         }
724                         *ptr = 0;
725                         sscanf(ibuf, "%d", oid++);
726                         ptr = ibuf;
727                         dotted++;
728
729                 }
730                 else
731                 {
732                         *ptr++ = *dotted++;
733                 }
734         }
735         if (n < MAX_OID)
736         {
737                 *ptr = 0;
738                 sscanf(ibuf, "%d", oid++);
739         }
740         *oid = -1;
741         return 0;
742 }
743
744
745 int bend_fetch(void *handle, bend_fetch_rr *rr)
746 {
747         HV *href;
748         SV **temp;
749         SV *basename;
750         SV *record;
751         SV *last;
752         SV *err_code;
753         SV *err_string;
754         SV *sur_flag;
755         SV *point;
756         SV *rep_form;
757         char *ptr;
758         char *ODR_record;
759         char *ODR_basename;
760         char *ODR_errstr;
761         int *ODR_oid_buf;
762         oident *oid;
763         WRBUF oid_dotted;
764         Zfront_handle *zhandle = (Zfront_handle *)handle;
765         CV* handler_cv = 0;
766
767         Z_RecordComposition *composition;
768         Z_ElementSetNames *simple;
769         STRLEN length;
770
771         dSP;
772         ENTER;
773         SAVETMPS;
774
775         rr->errcode = 0;
776         href = newHV();
777         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
778         temp = hv_store(href, "OFFSET", 6, newSViv(rr->number), 0);
779         oid_dotted = oid2dotted(rr->request_format_raw);
780         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
781         hv_store(href, "REP_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
782         hv_store(href, "BASENAME", 8, newSVpv("", 0), 0);
783         hv_store(href, "RECORD", 6, newSVpv("", 0), 0);
784         hv_store(href, "LAST", 4, newSViv(0), 0);
785         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
786         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
787         hv_store(href, "SUR_FLAG", 8, newSViv(0), 0);
788         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
789         hv_store(href, "PID", 3, newSViv(getpid()), 0);
790         if (rr->comp)
791         {
792                 composition = rr->comp;
793                 if (composition->which == Z_RecordComp_simple)
794                 {
795                         simple = composition->u.simple;
796                         if (simple->which == Z_ElementSetNames_generic)
797                         {
798                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
799                         } 
800                         else
801                         {
802                                 rr->errcode = 26;
803                         }
804                 }
805                 else
806                 {
807                         rr->errcode = 26;
808                 }
809         }
810
811         PUSHMARK(sp);
812
813         XPUSHs(sv_2mortal(newRV( (SV*) href)));
814
815         PUTBACK;
816         
817         handler_cv = simpleserver_sv2cv( fetch_ref );
818         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
819
820         SPAGAIN;
821
822         temp = hv_fetch(href, "BASENAME", 8, 1);
823         basename = newSVsv(*temp);
824
825         temp = hv_fetch(href, "RECORD", 6, 1);
826         record = newSVsv(*temp);
827
828         temp = hv_fetch(href, "LAST", 4, 1);
829         last = newSVsv(*temp);
830
831         temp = hv_fetch(href, "ERR_CODE", 8, 1);
832         err_code = newSVsv(*temp);
833
834         temp = hv_fetch(href, "ERR_STR", 7, 1),
835         err_string = newSVsv(*temp);
836
837         temp = hv_fetch(href, "SUR_FLAG", 8, 1);
838         sur_flag = newSVsv(*temp);
839
840         temp = hv_fetch(href, "REP_FORM", 8, 1);
841         rep_form = newSVsv(*temp);
842
843         temp = hv_fetch(href, "HANDLE", 6, 1);
844         point = newSVsv(*temp);
845
846
847         hv_undef(href);
848         
849         ptr = SvPV(basename, length);
850         ODR_basename = (char *)odr_malloc(rr->stream, length + 1);
851         strcpy(ODR_basename, ptr);
852         rr->basename = ODR_basename;
853
854         ptr = SvPV(rep_form, length);
855         ODR_oid_buf = (int *)odr_malloc(rr->stream, (MAX_OID + 1) * sizeof(int));
856         if (dotted2oid(ptr, ODR_oid_buf) == -1)         /* Maximum number of OID elements exceeded */
857         {
858                 printf("Net::Z3950::SimpleServer: WARNING: OID structure too long, max length is %d\n", MAX_OID);
859         }
860         rr->output_format_raw = ODR_oid_buf;    
861         
862         ptr = SvPV(record, length);
863         oid = oid_getentbyoid(ODR_oid_buf);
864         if (oid->value == VAL_GRS1)             /* Treat GRS-1 records separately */
865         {
866                 rr->record = (char *) read_grs1(ptr, rr->stream);
867                 rr->len = -1;
868         }
869         else
870         {
871                 ODR_record = (char *)odr_malloc(rr->stream, length + 1);
872                 strcpy(ODR_record, ptr);
873                 rr->record = ODR_record;
874                 rr->len = length;
875         }
876         zhandle->handle = point;
877         handle = zhandle;
878         rr->last_in_set = SvIV(last);
879         
880         if (!(rr->errcode))
881         {
882                 rr->errcode = SvIV(err_code);
883                 ptr = SvPV(err_string, length);
884                 ODR_errstr = (char *)odr_malloc(rr->stream, length + 1);
885                 strcpy(ODR_errstr, ptr);
886                 rr->errstring = ODR_errstr;
887         }
888         rr->surrogate_flag = SvIV(sur_flag);
889
890         wrbuf_free(oid_dotted, 1);
891         sv_free((SV*) href);
892         sv_free(basename);
893         sv_free(record);
894         sv_free(last);
895         sv_free(err_string);
896         sv_free(err_code),
897         sv_free(sur_flag);
898         sv_free(rep_form);
899
900         PUTBACK;
901         FREETMPS;
902         LEAVE;
903         
904         return 0;
905 }
906
907
908 int bend_present(void *handle, bend_present_rr *rr)
909 {
910         HV *href;
911         SV **temp;
912         SV *err_code;
913         SV *err_string;
914         SV *hits;
915         SV *point;
916         STRLEN len;
917         Z_RecordComposition *composition;
918         Z_ElementSetNames *simple;
919         char *ODR_errstr;
920         char *ptr;
921         Zfront_handle *zhandle = (Zfront_handle *)handle;
922         CV* handler_cv = 0;
923
924 /*      WRBUF oid_dotted; */
925
926         dSP;
927         ENTER;
928         SAVETMPS;
929
930         href = newHV();
931         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
932         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
933         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
934         hv_store(href, "START", 5, newSViv(rr->start), 0);
935         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
936         hv_store(href, "NUMBER", 6, newSViv(rr->number), 0);
937         /*oid_dotted = oid2dotted(rr->request_format_raw);
938         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);*/
939         hv_store(href, "HITS", 4, newSViv(0), 0);
940         hv_store(href, "PID", 3, newSViv(getpid()), 0);
941         if (rr->comp)
942         {
943                 composition = rr->comp;
944                 if (composition->which == Z_RecordComp_simple)
945                 {
946                         simple = composition->u.simple;
947                         if (simple->which == Z_ElementSetNames_generic)
948                         {
949                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
950                         } 
951                         else
952                         {
953                                 rr->errcode = 26;
954                                 return 0;
955                         }
956                 }
957                 else
958                 {
959                         rr->errcode = 26;
960                         return 0;
961                 }
962         }
963
964         PUSHMARK(sp);
965         
966         XPUSHs(sv_2mortal(newRV( (SV*) href)));
967         
968         PUTBACK;
969         
970         handler_cv = simpleserver_sv2cv( present_ref );
971         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
972         
973         SPAGAIN;
974
975         temp = hv_fetch(href, "ERR_CODE", 8, 1);
976         err_code = newSVsv(*temp);
977
978         temp = hv_fetch(href, "ERR_STR", 7, 1);
979         err_string = newSVsv(*temp);
980
981         temp = hv_fetch(href, "HITS", 4, 1);
982         hits = newSVsv(*temp);
983
984         temp = hv_fetch(href, "HANDLE", 6, 1);
985         point = newSVsv(*temp);
986
987         PUTBACK;
988         FREETMPS;
989         LEAVE;
990         
991         hv_undef(href);
992         rr->errcode = SvIV(err_code);
993         rr->hits = SvIV(hits);
994
995         ptr = SvPV(err_string, len);
996         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
997         strcpy(ODR_errstr, ptr);
998         rr->errstring = ODR_errstr;
999 /*      wrbuf_free(oid_dotted, 1);*/
1000         zhandle->handle = point;
1001         handle = zhandle;
1002         sv_free(err_code);
1003         sv_free(err_string);
1004         sv_free(hits);
1005         sv_free( (SV*) href);
1006
1007         return 0;
1008 }
1009
1010
1011 int bend_esrequest(void *handle, bend_esrequest_rr *rr)
1012 {
1013         perl_call_sv(esrequest_ref, G_VOID | G_DISCARD | G_NOARGS);
1014         return 0;
1015 }
1016
1017
1018 int bend_delete(void *handle, bend_delete_rr *rr)
1019 {
1020         perl_call_sv(delete_ref, G_VOID | G_DISCARD | G_NOARGS);
1021         return 0;
1022 }
1023
1024
1025 int bend_scan(void *handle, bend_scan_rr *rr)
1026 {
1027         HV *href;
1028         AV *aref;
1029         AV *list;
1030         AV *entries;
1031         HV *scan_item;
1032         struct scan_entry *scan_list;
1033         struct scan_entry *buffer;
1034         int *step_size = rr->step_size;
1035         int i;
1036         char **basenames;
1037         SV **temp;
1038         SV *err_code = sv_newmortal();
1039         SV *err_str = sv_newmortal();
1040         SV *point = sv_newmortal();
1041         SV *status = sv_newmortal();
1042         SV *number = sv_newmortal();
1043         char *ptr;
1044         char *ODR_errstr;
1045         STRLEN len;
1046         int term_len;
1047         SV *entries_ref;
1048         Zfront_handle *zhandle = (Zfront_handle *)handle;
1049         CV* handler_cv = 0;
1050
1051         dSP;
1052         ENTER;
1053         SAVETMPS;
1054         href = newHV();
1055         list = newAV();
1056         if (rr->term->term->which == Z_Term_general)
1057         {
1058                 term_len = rr->term->term->u.general->len;
1059                 hv_store(href, "TERM", 4, newSVpv(rr->term->term->u.general->buf, term_len), 0);
1060         } else {
1061                 rr->errcode = 229;      /* Unsupported term type */
1062                 return 0;
1063         }
1064         hv_store(href, "STEP", 4, newSViv(*step_size), 0);
1065         hv_store(href, "NUMBER", 6, newSViv(rr->num_entries), 0);
1066         hv_store(href, "POS", 3, newSViv(rr->term_position), 0);
1067         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1068         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
1069         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1070         hv_store(href, "STATUS", 6, newSViv(BEND_SCAN_SUCCESS), 0);
1071         hv_store(href, "ENTRIES", 7, newRV((SV *) list), 0);
1072         aref = newAV();
1073         basenames = rr->basenames;
1074         for (i = 0; i < rr->num_bases; i++)
1075         {
1076                 av_push(aref, newSVpv(*basenames++, 0));
1077         }
1078         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
1079
1080         PUSHMARK(sp);
1081
1082         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1083
1084         PUTBACK;
1085
1086         handler_cv = simpleserver_sv2cv( scan_ref );
1087         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1088
1089         SPAGAIN;
1090
1091         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1092         err_code = newSVsv(*temp);
1093
1094         temp = hv_fetch(href, "ERR_STR", 7, 1);
1095         err_str = newSVsv(*temp);
1096
1097         temp = hv_fetch(href, "HANDLE", 6, 1);
1098         point = newSVsv(*temp);
1099
1100         temp = hv_fetch(href, "STATUS", 6, 1);
1101         status = newSVsv(*temp);
1102         
1103         temp = hv_fetch(href, "NUMBER", 6, 1);
1104         number = newSVsv(*temp);
1105
1106         temp = hv_fetch(href, "ENTRIES", 7, 1);
1107         entries_ref = newSVsv(*temp);
1108
1109         PUTBACK;
1110         FREETMPS;
1111         LEAVE;
1112
1113         ptr = SvPV(err_str, len);
1114         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
1115         strcpy(ODR_errstr, ptr);
1116         rr->errstring = ODR_errstr;
1117         rr->errcode = SvIV(err_code);
1118         rr->num_entries = SvIV(number);
1119         rr->status = SvIV(status);
1120         scan_list = (struct scan_entry *) odr_malloc (rr->stream, rr->num_entries * sizeof(*scan_list));
1121         buffer = scan_list;
1122         entries = (AV *)SvRV(entries_ref);
1123         for (i = 0; i < rr->num_entries; i++)
1124         {
1125                 scan_item = (HV *)SvRV(sv_2mortal(av_shift(entries)));
1126                 temp = hv_fetch(scan_item, "TERM", 4, 1);
1127                 ptr = SvPV(*temp, len);
1128                 buffer->term = (char *) odr_malloc (rr->stream, len + 1); 
1129                 strcpy(buffer->term, ptr);
1130                 temp = hv_fetch(scan_item, "OCCURRENCE", 10, 1); 
1131                 buffer->occurrences = SvIV(*temp);
1132                 buffer++;
1133                 hv_undef(scan_item);
1134         }
1135         rr->entries = scan_list;
1136         zhandle->handle = point;
1137         handle = zhandle;
1138         sv_free(err_code);
1139         sv_free(err_str);
1140         sv_free(status);
1141         sv_free(number);
1142         hv_undef(href);
1143         sv_free((SV *)href);
1144         av_undef(aref);
1145         sv_free((SV *)aref);
1146         av_undef(list);
1147         sv_free((SV *)list);
1148         av_undef(entries);
1149         /*sv_free((SV *)entries);*/
1150         sv_free(entries_ref);
1151
1152         return 0;
1153 }
1154
1155 bend_initresult *bend_init(bend_initrequest *q)
1156 {
1157         int dummy = simpleserver_clone();
1158         bend_initresult *r = (bend_initresult *)
1159                 odr_malloc (q->stream, sizeof(*r));
1160         char *ptr;
1161         char *user = NULL;
1162         char *passwd = NULL;
1163         CV* handler_cv = 0;
1164         dSP;
1165         STRLEN len;
1166         NMEM nmem = nmem_create();
1167         Zfront_handle *zhandle =  (Zfront_handle *) nmem_malloc (nmem,
1168                         sizeof(*zhandle));
1169         SV *handle;
1170         HV *href;
1171         SV **temp;
1172
1173         ENTER;
1174         SAVETMPS;
1175
1176         zhandle->nmem = nmem;
1177         zhandle->stop_flag = 0;
1178         /*q->bend_sort = bend_sort;*/
1179         if (search_ref)
1180         {
1181                 q->bend_search = bend_search;
1182         }
1183         if (present_ref)
1184         {
1185                 q->bend_present = bend_present;
1186         }
1187         /*q->bend_esrequest = bend_esrequest;*/
1188         /*q->bend_delete = bend_delete;*/
1189         if (fetch_ref)
1190         {
1191                 q->bend_fetch = bend_fetch;
1192         }
1193         if (scan_ref)
1194         {
1195                 q->bend_scan = bend_scan;
1196         }
1197
1198         href = newHV(); 
1199         hv_store(href, "IMP_ID", 6, newSVpv("", 0), 0);
1200         hv_store(href, "IMP_NAME", 8, newSVpv("", 0), 0);
1201         hv_store(href, "IMP_VER", 7, newSVpv("", 0), 0);
1202         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1203         hv_store(href, "ERR_STR", 7, newSViv(0), 0);
1204         hv_store(href, "PEER_NAME", 9, newSVpv(q->peer_name, 0), 0);
1205         hv_store(href, "HANDLE", 6, newSVsv(&sv_undef), 0);
1206         hv_store(href, "PID", 3, newSViv(getpid()), 0);
1207         if (q->auth) {
1208             if (q->auth->which == Z_IdAuthentication_open) {
1209                 char *openpass = xstrdup (q->auth->u.open);
1210                 char *cp = strchr (openpass, '/');
1211                 if (cp) {
1212                     *cp = '\0';
1213                     user = nmem_strdup (odr_getmem (q->stream), openpass);
1214                     passwd = nmem_strdup (odr_getmem (q->stream), cp + 1);
1215                 }
1216                 xfree(openpass);
1217             } else if (q->auth->which == Z_IdAuthentication_idPass) {
1218                 user = q->auth->u.idPass->userId;
1219                 passwd = q->auth->u.idPass->password;
1220             }
1221             /* ### some code paths have user/password unassigned here */
1222             hv_store(href, "USER", 4, newSVpv(user, 0), 0);
1223             hv_store(href, "PASS", 4, newSVpv(passwd, 0), 0);
1224         }
1225
1226         PUSHMARK(sp);   
1227
1228         XPUSHs(sv_2mortal(newRV((SV*) href)));
1229
1230         PUTBACK;
1231
1232         if (init_ref != NULL)
1233         {
1234              handler_cv = simpleserver_sv2cv( init_ref );
1235              perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1236         }
1237
1238         SPAGAIN;
1239
1240         temp = hv_fetch(href, "IMP_ID", 6, 1);
1241         ptr = SvPV(*temp, len);
1242         q->implementation_id = nmem_strdup(nmem, ptr);
1243
1244         temp = hv_fetch(href, "IMP_NAME", 8, 1);
1245         ptr = SvPV(*temp, len);
1246         q->implementation_name = nmem_strdup(nmem, ptr);
1247
1248         temp = hv_fetch(href, "IMP_VER", 7, 1);
1249         ptr = SvPV(*temp, len);
1250         q->implementation_version = nmem_strdup(nmem, ptr);
1251
1252         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1253         r->errcode = SvIV(*temp);
1254
1255         temp = hv_fetch(href, "ERR_STR", 7, 1);
1256         ptr = SvPV(*temp, len);
1257         r->errstring = (char *)odr_malloc(q->stream, len + 1);
1258         strcpy(r->errstring, ptr);
1259
1260         temp = hv_fetch(href, "HANDLE", 6, 1);
1261         handle= newSVsv(*temp);
1262         zhandle->handle = handle;
1263
1264         r->handle = zhandle;
1265
1266         hv_undef(href);
1267         sv_free((SV*) href);
1268
1269         PUTBACK;
1270         FREETMPS;
1271         LEAVE;
1272         
1273         return r;       
1274 }
1275
1276 void bend_close(void *handle)
1277 {
1278         HV *href;
1279         Zfront_handle *zhandle = (Zfront_handle *)handle;
1280         CV* handler_cv = 0;
1281         int stop_flag = 0;
1282         dSP;
1283         ENTER;
1284         SAVETMPS;
1285
1286         if (close_ref)
1287         {
1288                 href = newHV();
1289                 hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1290
1291                 PUSHMARK(sp);
1292
1293                 XPUSHs(sv_2mortal(newRV((SV *)href)));
1294
1295                 PUTBACK;
1296         
1297                 handler_cv = simpleserver_sv2cv( close_ref );
1298                 perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1299         
1300                 SPAGAIN;
1301
1302                 sv_free((SV*) href);
1303         }
1304         sv_free(zhandle->handle);
1305         PUTBACK;
1306         FREETMPS;
1307         LEAVE;
1308         stop_flag = zhandle->stop_flag;
1309         nmem_destroy(zhandle->nmem);
1310         simpleserver_free();
1311
1312         if (stop_flag)
1313                 exit(0);
1314         return;
1315 }
1316
1317
1318 MODULE = Net::Z3950::SimpleServer       PACKAGE = Net::Z3950::SimpleServer
1319
1320 void
1321 set_init_handler(arg)
1322                 SV *arg
1323         CODE:
1324                 init_ref = newSVsv(arg);
1325                 
1326
1327 void
1328 set_close_handler(arg)
1329                 SV *arg
1330         CODE:
1331                 close_ref = newSVsv(arg);
1332
1333
1334 void
1335 set_sort_handler(arg)
1336                 SV *arg
1337         CODE:
1338                 sort_ref = newSVsv(arg);
1339
1340 void
1341 set_search_handler(arg)
1342                 SV *arg
1343         CODE:
1344                 search_ref = newSVsv(arg);
1345
1346
1347 void
1348 set_fetch_handler(arg)
1349                 SV *arg
1350         CODE:
1351                 fetch_ref = newSVsv(arg);
1352
1353
1354 void
1355 set_present_handler(arg)
1356                 SV *arg
1357         CODE:
1358                 present_ref = newSVsv(arg);
1359
1360
1361 void
1362 set_esrequest_handler(arg)
1363                 SV *arg
1364         CODE:
1365                 esrequest_ref = newSVsv(arg);
1366
1367
1368 void
1369 set_delete_handler(arg)
1370                 SV *arg
1371         CODE:
1372                 delete_ref = newSVsv(arg);
1373
1374
1375 void
1376 set_scan_handler(arg)
1377                 SV *arg
1378         CODE:
1379                 scan_ref = newSVsv(arg);
1380
1381
1382 int
1383 start_server(...)
1384         PREINIT:
1385                 char **argv;
1386                 char **argv_buf;
1387                 char *ptr;
1388                 int i;
1389                 STRLEN len;
1390         CODE:
1391                 argv_buf = (char **)xmalloc((items + 1) * sizeof(char *));
1392                 argv = argv_buf;
1393                 for (i = 0; i < items; i++)
1394                 {
1395                         ptr = SvPV(ST(i), len);
1396                         *argv_buf = (char *)xmalloc(len + 1);
1397                         strcpy(*argv_buf++, ptr); 
1398                 }
1399                 *argv_buf = NULL;
1400                 root_perl_context = PERL_GET_CONTEXT;
1401                 nmem_mutex_create(&simpleserver_mutex);
1402 #if 0
1403                 /* only for debugging perl_clone .. */
1404                 tst_clones();
1405 #endif
1406                 
1407                 RETVAL = statserv_main(items, argv, bend_init, bend_close);
1408         OUTPUT:
1409                 RETVAL
1410
1411
1412 int
1413 ScanSuccess()
1414         CODE:
1415                 RETVAL = BEND_SCAN_SUCCESS;
1416         OUTPUT:
1417                 RETVAL
1418
1419 int
1420 ScanPartial()
1421         CODE:
1422                 RETVAL = BEND_SCAN_PARTIAL;
1423         OUTPUT:
1424                 RETVAL
1425
1426