2 * IR toolkit for tcl/tk
4 * See the file LICENSE for details.
5 * Sebastian Hammer, Adam Dickmeiss
8 * Revision 1.42 1995-06-19 08:08:52 adam
9 * client.tcl: hotTargets now contain both database and target name.
10 * ir-tcl.c: setting protocol edited. Errors in callbacks are logged
11 * by logf(LOG_WARN, ...) calls.
13 * Revision 1.41 1995/06/16 12:28:16 adam
14 * Implemented preferredRecordSyntax.
15 * Minor changes in diagnostic handling.
16 * Record list deleted when connection closes.
18 * Revision 1.40 1995/06/14 13:37:18 adam
19 * Setting recordType implemented.
20 * Setting implementationVersion implemented.
21 * Settings implementationId / implementationName edited.
23 * Revision 1.39 1995/06/08 10:26:32 adam
24 * Bug fix in ir_strdup.
26 * Revision 1.38 1995/06/01 16:36:47 adam
27 * About buttons. Minor bug fixes.
29 * Revision 1.37 1995/06/01 07:31:20 adam
30 * Rename of many typedefs -> IrTcl_...
32 * Revision 1.36 1995/05/31 13:09:59 adam
33 * Client searches/presents may be interrupted.
34 * New moving book-logo.
36 * Revision 1.35 1995/05/31 08:36:33 adam
37 * Bug fix in client.tcl: didn't save options on clientrc.tcl.
38 * New method: referenceId. More work on scan.
40 * Revision 1.34 1995/05/29 10:33:42 adam
41 * README and rename of startup script.
43 * Revision 1.33 1995/05/29 09:15:11 quinn
44 * Changed CS_SR to PROTO_SR, etc.
46 * Revision 1.32 1995/05/29 08:44:16 adam
47 * Work on delete of objects.
49 * Revision 1.31 1995/05/26 11:44:10 adam
50 * Bugs fixed. More work on MARC utilities and queries. Test
51 * client is up-to-date again.
53 * Revision 1.30 1995/05/26 08:54:11 adam
54 * New MARC utilities. Uses prefix query.
56 * Revision 1.29 1995/05/24 14:10:22 adam
57 * Work on idAuthentication, protocolVersion and options.
59 * Revision 1.28 1995/05/23 15:34:48 adam
60 * Many new settings, userInformationField, smallSetUpperBound, etc.
61 * A number of settings are inherited when ir-set is executed.
62 * This version is incompatible with the graphical test client (client.tcl).
64 * Revision 1.27 1995/05/11 15:34:47 adam
65 * Scan request changed a bit. This version works with RLG.
67 * Revision 1.26 1995/04/18 16:11:51 adam
68 * First version of graphical Scan. Some work on query-by-form.
70 * Revision 1.25 1995/04/17 09:37:17 adam
71 * Further development of scan.
73 * Revision 1.24 1995/04/11 14:16:42 adam
74 * Further work on scan. Response works. Entries aren't saved yet.
76 * Revision 1.23 1995/04/10 10:50:27 adam
77 * Result-set name defaults to suffix of ir-set name.
78 * Started working on scan. Not finished at this point.
80 * Revision 1.22 1995/03/31 10:43:03 adam
81 * More robust when getting bad MARC records.
83 * Revision 1.21 1995/03/31 08:56:37 adam
84 * New button "Search".
86 * Revision 1.20 1995/03/29 16:07:09 adam
87 * Bug fix: Didn't use setName in present request.
89 * Revision 1.19 1995/03/28 12:45:23 adam
90 * New ir method failback: called on disconnect/protocol error.
91 * New ir set/get method: protocol: SR / Z3950.
92 * Simple popup and disconnect when failback is invoked.
94 * Revision 1.18 1995/03/21 15:50:12 adam
97 * Revision 1.17 1995/03/21 13:41:03 adam
98 * Comstack cs_create not used too often. Non-blocking connect.
100 * Revision 1.16 1995/03/21 08:26:06 adam
101 * New method, setName, to specify the result set name (other than Default).
102 * New method, responseStatus, which returns diagnostic info, if any, after
103 * present response / search response.
105 * Revision 1.15 1995/03/20 15:24:07 adam
106 * Diagnostic records saved on searchResponse.
108 * Revision 1.14 1995/03/20 08:53:22 adam
109 * Event loop in tclmain.c rewritten. New method searchStatus.
111 * Revision 1.13 1995/03/17 18:26:17 adam
112 * Non-blocking i/o used now. Database names popup as cascade items.
114 * Revision 1.12 1995/03/17 15:45:00 adam
115 * Improved target/database setup.
117 * Revision 1.11 1995/03/16 17:54:03 adam
118 * Minor changes really.
120 * Revision 1.10 1995/03/15 16:14:50 adam
121 * Blocking arg in cs_create changed.
123 * Revision 1.9 1995/03/15 13:59:24 adam
126 * Revision 1.8 1995/03/15 08:25:16 adam
127 * New method presentStatus to check for error on present. Misc. cleanup
128 * of IrTcl_RecordList manipulations. Full MARC record presentation in
131 * Revision 1.7 1995/03/14 17:32:29 adam
132 * Presentation of full Marc record in popup window.
134 * Revision 1.6 1995/03/12 19:31:55 adam
135 * Pattern matching implemented when retrieving MARC records. More
136 * diagnostic functions.
138 * Revision 1.5 1995/03/10 18:00:15 adam
139 * Actual presentation in line-by-line format. RPN query support.
141 * Revision 1.4 1995/03/09 16:15:08 adam
142 * First presentRequest attempts. Hot-target list.
148 #include <sys/time.h>
158 int (*method) (void *obj, Tcl_Interp *interp, int argc, char **argv);
166 static Tcl_Interp *irTcl_interp;
168 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num);
169 static int do_disconnect (void *obj, Tcl_Interp *interp,
170 int argc, char **argv);
172 static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj,
175 IrTcl_RecordList *rl;
177 for (rl = setobj->record_list; rl; rl = rl->next)
183 case Z_NamePlusRecord_databaseRecord:
184 free (rl->u.dbrec.buf);
185 rl->u.dbrec.buf = NULL;
187 case Z_NamePlusRecord_surrogateDiagnostic:
188 ir_deleteDiags (&rl->u.surrogateDiagnostics.list,
189 &rl->u.surrogateDiagnostics.num);
197 rl = malloc (sizeof(*rl));
199 rl->next = setobj->record_list;
201 setobj->record_list = rl;
208 enum oid_value value;
210 } IrTcl_recordSyntaxTab[] = {
211 { VAL_UNIMARC, "UNIMARC" },
212 { VAL_INTERMARC, "INTERMARC" },
214 { VAL_USMARC, "USMARC" },
215 { VAL_UKMARC, "UKMARC" },
216 { VAL_NORMARC, "NORMARC" },
217 { VAL_LIBRISMARC, "LIBRISMARC" },
218 { VAL_DANMARC, "DANMARC" },
219 { VAL_FINMARC, "FINMARC" },
221 { VAL_CANMARC, "CANMARC" },
223 { VAL_PICAMARC, "PICAMARC" },
224 { VAL_AUSMARC, "AUSMARC" },
225 { VAL_IBERMARC, "IBERMARC" },
226 { VAL_SUTRS, "SUTRS" },
233 int IrTcl_eval (Tcl_Interp *interp, const char *command)
235 char *tmp = malloc (strlen(command)+1);
240 logf (LOG_FATAL, "Out of memory in IrTcl_eval");
243 strcpy (tmp, command);
244 r = Tcl_Eval (interp, tmp);
246 logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine, interp->result);
252 * IrTcl_getRecordSyntaxStr: Return record syntax name of object id
254 static const char *IrTcl_getRecordSyntaxStr (enum oid_value value)
257 for (i = 0; IrTcl_recordSyntaxTab[i].name; i++)
258 if (IrTcl_recordSyntaxTab[i].value == value)
259 return IrTcl_recordSyntaxTab[i].name;
264 * IrTcl_getRecordSyntaxVal: Return record syntax value of string
266 static enum oid_value IrTcl_getRecordSyntaxVal (const char *name)
269 for (i = 0; IrTcl_recordSyntaxTab[i].name; i++)
270 if (!strcmp (IrTcl_recordSyntaxTab[i].name, name))
271 return IrTcl_recordSyntaxTab[i].value;
275 static IrTcl_RecordList *find_IR_record (IrTcl_SetObj *setobj, int no)
277 IrTcl_RecordList *rl;
279 for (rl = setobj->record_list; rl; rl = rl->next)
285 static void delete_IR_records (IrTcl_SetObj *setobj)
287 IrTcl_RecordList *rl, *rl1;
289 for (rl = setobj->record_list; rl; rl = rl1)
293 case Z_NamePlusRecord_databaseRecord:
294 free (rl->u.dbrec.buf);
296 case Z_NamePlusRecord_surrogateDiagnostic:
297 ir_deleteDiags (&rl->u.surrogateDiagnostics.list,
298 &rl->u.surrogateDiagnostics.num);
304 setobj->record_list = NULL;
308 * get_set_int: Set/get integer value
310 static int get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)
316 if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)
319 sprintf (buf, "%d", *val);
320 Tcl_AppendResult (interp, buf, NULL);
325 * ir_method: Search for method in table and invoke method handler
327 int ir_method (Tcl_Interp *interp, int argc, char **argv, IrTcl_Methods *tab)
329 IrTcl_Methods *tab_i = tab;
332 for (tab_i = tab; tab_i->tab; tab_i++)
333 for (t = tab_i->tab; t->name; t++)
336 if ((*t->method)(tab_i->obj, interp, argc, argv) == TCL_ERROR)
340 if (!strcmp (t->name, argv[1]))
341 return (*t->method)(tab_i->obj, interp, argc, argv);
345 Tcl_AppendResult (interp, "Bad method. Possible methods:", NULL);
346 for (tab_i = tab; tab_i->tab; tab_i++)
347 for (t = tab_i->tab; t->name; t++)
348 Tcl_AppendResult (interp, " ", t->name, NULL);
353 * ir_method_r: Get status for all readable elements
355 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,
363 for (; tab->name; tab++)
366 argv_n[1] = tab->name;
367 Tcl_AppendResult (interp, "{", NULL);
368 (*tab->method)(obj, interp, argc_n, argv_n);
369 Tcl_AppendResult (interp, "} ", NULL);
375 * ir_named_bits: get/set named bits
377 int ir_named_bits (struct ir_named_entry *tab, Odr_bitmask *ob,
378 Tcl_Interp *interp, int argc, char **argv)
380 struct ir_named_entry *ti;
385 for (no = 0; no < argc; no++)
387 for (ti = tab; ti->name; ti++)
388 if (!strcmp (argv[no], ti->name))
390 ODR_MASK_SET (ob, ti->pos);
395 Tcl_AppendResult (interp, "Bad bit mask: ", argv[no], NULL);
401 for (ti = tab; ti->name; ti++)
402 if (ODR_MASK_GET (ob, ti->pos))
403 Tcl_AppendElement (interp, ti->name);
408 * ir_strdup: Duplicate string
410 int ir_strdup (Tcl_Interp *interp, char** p, const char *s)
417 *p = malloc (strlen(s)+1);
420 interp->result = "strdup fail";
428 * ir_strdel: Delete string
430 int ir_strdel (Tcl_Interp *interp, char **p)
438 * ir_malloc: Malloc function
440 void *ir_malloc (Tcl_Interp *interp, size_t size)
442 static char buf[128];
443 void *p = malloc (size);
447 sprintf (buf, "Malloc fail. %ld bytes requested", (long) size);
448 interp->result = buf;
454 static void set_referenceId (ODR o, Z_ReferenceId **dst, const char *src)
460 *dst = odr_malloc (o, sizeof(**dst));
461 (*dst)->size = (*dst)->len = strlen(src);
462 (*dst)->buf = odr_malloc (o, (*dst)->len);
463 memcpy ((*dst)->buf, src, (*dst)->len);
467 static void get_referenceId (char **dst, Z_ReferenceId *src)
475 *dst = malloc (src->len+1);
476 memcpy (*dst, src->buf, src->len);
477 (*dst)[src->len] = '\0';
480 /* ------------------------------------------------------- */
483 * do_init_request: init method on IR object
485 static int do_init_request (void *obj, Tcl_Interp *interp,
486 int argc, char **argv)
497 interp->result = "not connected";
500 odr_reset (p->odr_out);
501 apdu = zget_APDU (p->odr_out, Z_APDU_initRequest);
502 req = apdu->u.initRequest;
504 set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
505 req->options = &p->options;
506 req->protocolVersion = &p->protocolVersion;
507 req->preferredMessageSize = &p->preferredMessageSize;
508 req->maximumRecordSize = &p->maximumRecordSize;
510 if (p->idAuthenticationGroupId)
512 Z_IdPass *pass = odr_malloc (p->odr_out, sizeof(*pass));
513 Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
515 auth->which = Z_IdAuthentication_idPass;
516 auth->u.idPass = pass;
517 if (p->idAuthenticationGroupId && *p->idAuthenticationGroupId)
518 pass->groupId = p->idAuthenticationGroupId;
520 pass->groupId = NULL;
521 if (p->idAuthenticationUserId && *p->idAuthenticationUserId)
522 pass->userId = p->idAuthenticationUserId;
525 if (p->idAuthenticationPassword && *p->idAuthenticationPassword)
526 pass->password = p->idAuthenticationPassword;
528 pass->password = NULL;
529 req->idAuthentication = auth;
531 else if (!p->idAuthenticationOpen || !*p->idAuthenticationOpen)
532 req->idAuthentication = NULL;
535 Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
537 auth->which = Z_IdAuthentication_open;
538 auth->u.open = p->idAuthenticationOpen;
539 req->idAuthentication = auth;
541 req->implementationId = p->implementationId;
542 req->implementationName = p->implementationName;
543 req->implementationVersion = p->implementationVersion;
544 req->userInformationField = 0;
546 if (!z_APDU (p->odr_out, &apdu, 0))
548 Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
550 odr_reset (p->odr_out);
553 p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
554 if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
556 interp->result = "cs_put failed in init";
557 do_disconnect (p, NULL, 2, NULL);
562 ir_select_add_write (cs_fileno(p->cs_link), p);
563 logf (LOG_DEBUG, "Sent part of initializeRequest (%d bytes)", p->slen);
566 logf (LOG_DEBUG, "Sent whole initializeRequest (%d bytes)", p->slen);
571 * do_protocolVersion: Set protocol Version
573 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
574 int argc, char **argv)
576 static struct ir_named_entry version_tab[] = {
587 ODR_MASK_ZERO (&p->protocolVersion);
588 ODR_MASK_SET (&p->protocolVersion, 0);
589 ODR_MASK_SET (&p->protocolVersion, 1);
592 return ir_named_bits (version_tab, &p->protocolVersion,
593 interp, argc-2, argv+2);
597 * do_options: Set options
599 static int do_options (void *obj, Tcl_Interp *interp,
600 int argc, char **argv)
602 static struct ir_named_entry options_tab[] = {
606 { "resourceReport", 3 },
607 { "triggerResourceCtrl", 4},
608 { "resourceCtrl", 5},
612 { "extendedServices", 10},
613 { "level-1Segmentation", 11},
614 { "level-2Segmentation", 12},
615 { "concurrentOperations", 13},
616 { "namedResultSets", 14},
623 ODR_MASK_ZERO (&p->options);
624 ODR_MASK_SET (&p->options, 0);
625 ODR_MASK_SET (&p->options, 1);
626 ODR_MASK_SET (&p->options, 7);
627 ODR_MASK_SET (&p->options, 14);
630 return ir_named_bits (options_tab, &p->options, interp, argc-2, argv+2);
634 * do_preferredMessageSize: Set/get preferred message size
636 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
637 int argc, char **argv)
643 p->preferredMessageSize = 30000;
646 return get_set_int (&p->preferredMessageSize, interp, argc, argv);
650 * do_maximumRecordSize: Set/get maximum record size
652 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
653 int argc, char **argv)
659 p->maximumRecordSize = 30000;
662 return get_set_int (&p->maximumRecordSize, interp, argc, argv);
666 * do_initResult: Get init result
668 static int do_initResult (void *obj, Tcl_Interp *interp,
669 int argc, char **argv)
675 return get_set_int (&p->initResult, interp, argc, argv);
680 * do_implementationName: Set/get Implementation Name.
682 static int do_implementationName (void *obj, Tcl_Interp *interp,
683 int argc, char **argv)
688 return ir_strdup (interp, &p->implementationName,
689 "Index Data/IrTcl on YAZ");
691 return ir_strdel (interp, &p->implementationName);
694 free (p->implementationName);
695 if (ir_strdup (interp, &p->implementationName, argv[2])
699 Tcl_AppendResult (interp, p->implementationName, (char*) NULL);
704 * do_implementationId: Get Implementation Id.
706 static int do_implementationId (void *obj, Tcl_Interp *interp,
707 int argc, char **argv)
712 return ir_strdup (interp, &p->implementationId, "YAZ (id=81)");
714 return ir_strdel (interp, &p->implementationId);
715 Tcl_AppendResult (interp, p->implementationId, (char*) NULL);
720 * do_implementationVersion: get Implementation Version.
722 static int do_implementationVersion (void *obj, Tcl_Interp *interp,
723 int argc, char **argv)
728 return ir_strdup (interp, &p->implementationVersion, YAZ_VERSION);
730 return ir_strdel (interp, &p->implementationVersion);
731 Tcl_AppendResult (interp, p->implementationVersion, (char*) NULL);
736 * do_targetImplementationName: Get Implementation Name of target.
738 static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
739 int argc, char **argv)
745 p->targetImplementationName = NULL;
749 return ir_strdel (interp, &p->targetImplementationName);
750 Tcl_AppendResult (interp, p->targetImplementationName, (char*) NULL);
755 * do_targetImplementationId: Get Implementation Id of target
757 static int do_targetImplementationId (void *obj, Tcl_Interp *interp,
758 int argc, char **argv)
764 p->targetImplementationId = NULL;
768 return ir_strdel (interp, &p->targetImplementationId);
769 Tcl_AppendResult (interp, p->targetImplementationId, (char*) NULL);
774 * do_targetImplementationVersion: Get Implementation Version of target
776 static int do_targetImplementationVersion (void *obj, Tcl_Interp *interp,
777 int argc, char **argv)
783 p->targetImplementationVersion = NULL;
787 return ir_strdel (interp, &p->targetImplementationVersion);
788 Tcl_AppendResult (interp, p->targetImplementationVersion, (char*) NULL);
793 * do_idAuthentication: Set/get id Authentication
795 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
796 int argc, char **argv)
800 if (argc >= 3 || argc == -1)
802 free (p->idAuthenticationOpen);
803 free (p->idAuthenticationGroupId);
804 free (p->idAuthenticationUserId);
805 free (p->idAuthenticationPassword);
807 if (argc >= 3 || argc <= 0)
809 p->idAuthenticationOpen = NULL;
810 p->idAuthenticationGroupId = NULL;
811 p->idAuthenticationUserId = NULL;
812 p->idAuthenticationPassword = NULL;
820 if (ir_strdup (interp, &p->idAuthenticationOpen, argv[2])
826 if (ir_strdup (interp, &p->idAuthenticationGroupId, argv[2])
829 if (ir_strdup (interp, &p->idAuthenticationUserId, argv[3])
832 if (ir_strdup (interp, &p->idAuthenticationPassword, argv[4])
837 if (p->idAuthenticationOpen)
838 Tcl_AppendElement (interp, p->idAuthenticationOpen);
839 else if (p->idAuthenticationGroupId)
841 Tcl_AppendElement (interp, p->idAuthenticationGroupId);
842 Tcl_AppendElement (interp, p->idAuthenticationUserId);
843 Tcl_AppendElement (interp, p->idAuthenticationPassword);
849 * do_connect: connect method on IR object
851 static int do_connect (void *obj, Tcl_Interp *interp,
852 int argc, char **argv)
864 interp->result = "already connected";
867 if (!strcmp (p->cs_type, "tcpip"))
869 p->cs_link = cs_create (tcpip_type, CS_BLOCK, p->protocol_type);
870 addr = tcpip_strtoaddr (argv[2]);
873 interp->result = "tcpip_strtoaddr fail";
876 logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]);
878 else if (!strcmp (p->cs_type, "mosi"))
881 p->cs_link = cs_create (mosi_type, CS_BLOCK, p->protocol_type);
882 addr = mosi_strtoaddr (argv[2]);
885 interp->result = "mosi_strtoaddr fail";
888 logf (LOG_DEBUG, "mosi connect %s", argv[2]);
890 interp->result = "MOSI support not there";
896 Tcl_AppendResult (interp, "Bad comstack type: ",
900 if (ir_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
902 if ((r=cs_connect (p->cs_link, addr)) < 0)
904 interp->result = "connect fail";
905 do_disconnect (p, NULL, 2, NULL);
908 ir_select_add (cs_fileno (p->cs_link), p);
911 ir_select_add_write (cs_fileno (p->cs_link), p);
918 IrTcl_eval (p->interp, p->callback);
922 Tcl_AppendElement (interp, p->hostname);
927 * do_disconnect: disconnect method on IR object
929 static int do_disconnect (void *obj, Tcl_Interp *interp,
930 int argc, char **argv)
945 ir_select_remove_write (cs_fileno (p->cs_link), p);
946 ir_select_remove (cs_fileno (p->cs_link), p);
949 cs_close (p->cs_link);
952 ODR_MASK_ZERO (&p->options);
953 ODR_MASK_SET (&p->options, 0);
954 ODR_MASK_SET (&p->options, 1);
955 ODR_MASK_SET (&p->options, 7);
956 ODR_MASK_SET (&p->options, 14);
958 assert (!p->cs_link);
963 * do_comstack: Set/get comstack method on IR object
965 static int do_comstack (void *o, Tcl_Interp *interp,
966 int argc, char **argv)
971 return ir_strdup (interp, &obj->cs_type, "tcpip");
973 return ir_strdel (interp, &obj->cs_type);
977 if (ir_strdup (interp, &obj->cs_type, argv[2]) == TCL_ERROR)
980 Tcl_AppendElement (interp, obj->cs_type);
986 * do_callback: add callback
988 static int do_callback (void *obj, Tcl_Interp *interp,
989 int argc, char **argv)
999 return ir_strdel (interp, &p->callback);
1005 if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
1010 p->interp = irTcl_interp;
1016 * do_failback: add error handle callback
1018 static int do_failback (void *obj, Tcl_Interp *interp,
1019 int argc, char **argv)
1028 else if (argc == -1)
1029 return ir_strdel (interp, &p->failback);
1035 if (ir_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
1040 p->interp = irTcl_interp;
1046 * do_protocol: Set/get protocol method on IR object
1048 static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv)
1054 p->protocol_type = PROTO_Z3950;
1059 if (!strcmp (argv[2], "Z39"))
1060 p->protocol_type = PROTO_Z3950;
1061 else if (!strcmp (argv[2], "SR"))
1062 p->protocol_type = PROTO_SR;
1065 Tcl_AppendResult (interp, "Bad protocol: ", argv[2], NULL);
1070 switch (p->protocol_type)
1073 Tcl_AppendElement (interp, "Z39");
1076 Tcl_AppendElement (interp, "SR");
1083 * do_databaseNames: specify database names
1085 static int do_databaseNames (void *obj, Tcl_Interp *interp,
1086 int argc, char **argv)
1089 IrTcl_SetCObj *p = obj;
1093 for (i=0; i<p->num_databaseNames; i++)
1094 free (p->databaseNames[i]);
1095 free (p->databaseNames);
1099 p->num_databaseNames = 0;
1100 p->databaseNames = NULL;
1105 for (i=0; i<p->num_databaseNames; i++)
1106 Tcl_AppendElement (interp, p->databaseNames[i]);
1109 if (p->databaseNames)
1111 for (i=0; i<p->num_databaseNames; i++)
1112 free (p->databaseNames[i]);
1113 free (p->databaseNames);
1115 p->num_databaseNames = argc - 2;
1116 if (!(p->databaseNames = ir_malloc (interp,
1117 sizeof(*p->databaseNames) * p->num_databaseNames)))
1119 for (i=0; i<p->num_databaseNames; i++)
1121 if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
1129 * do_replaceIndicator: Set/get replace Set indicator
1131 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
1132 int argc, char **argv)
1134 IrTcl_SetCObj *p = obj;
1138 p->replaceIndicator = 1;
1141 return get_set_int (&p->replaceIndicator, interp, argc, argv);
1145 * do_queryType: Set/Get query method
1147 static int do_queryType (void *obj, Tcl_Interp *interp,
1148 int argc, char **argv)
1150 IrTcl_SetCObj *p = obj;
1153 return ir_strdup (interp, &p->queryType, "rpn");
1154 else if (argc == -1)
1155 return ir_strdel (interp, &p->queryType);
1158 free (p->queryType);
1159 if (ir_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR)
1162 Tcl_AppendResult (interp, p->queryType, NULL);
1167 * do_userInformationField: Get User information field
1169 static int do_userInformationField (void *obj, Tcl_Interp *interp,
1170 int argc, char **argv)
1176 p->userInformationField = NULL;
1179 else if (argc == -1)
1180 return ir_strdel (interp, &p->userInformationField);
1181 Tcl_AppendResult (interp, p->userInformationField, NULL);
1186 * do_smallSetUpperBound: Set/get small set upper bound
1188 static int do_smallSetUpperBound (void *o, Tcl_Interp *interp,
1189 int argc, char **argv)
1191 IrTcl_SetCObj *p = o;
1195 p->smallSetUpperBound = 0;
1198 return get_set_int (&p->smallSetUpperBound, interp, argc, argv);
1202 * do_largeSetLowerBound: Set/get large set lower bound
1204 static int do_largeSetLowerBound (void *o, Tcl_Interp *interp,
1205 int argc, char **argv)
1207 IrTcl_SetCObj *p = o;
1211 p->largeSetLowerBound = 2;
1214 return get_set_int (&p->largeSetLowerBound, interp, argc, argv);
1218 * do_mediumSetPresentNumber: Set/get large set lower bound
1220 static int do_mediumSetPresentNumber (void *o, Tcl_Interp *interp,
1221 int argc, char **argv)
1223 IrTcl_SetCObj *p = o;
1227 p->mediumSetPresentNumber = 0;
1230 return get_set_int (&p->mediumSetPresentNumber, interp, argc, argv);
1234 * do_referenceId: Set/Get referenceId
1236 static int do_referenceId (void *obj, Tcl_Interp *interp,
1237 int argc, char **argv)
1239 IrTcl_SetCObj *p = obj;
1243 p->referenceId = NULL;
1246 else if (argc == -1)
1247 return ir_strdel (interp, &p->referenceId);
1250 free (p->referenceId);
1251 if (ir_strdup (interp, &p->referenceId, argv[2]) == TCL_ERROR)
1254 Tcl_AppendResult (interp, p->referenceId, NULL);
1259 * do_preferredRecordSyntax: Set/get preferred record syntax
1261 static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp,
1262 int argc, char **argv)
1264 IrTcl_SetCObj *p = obj;
1268 p->preferredRecordSyntax = NULL;
1271 else if (argc == -1)
1273 free (p->preferredRecordSyntax);
1274 p->preferredRecordSyntax = NULL;
1279 free (p->preferredRecordSyntax);
1280 p->preferredRecordSyntax = NULL;
1281 if (argv[2][0] && (p->preferredRecordSyntax =
1282 malloc (sizeof(*p->preferredRecordSyntax))))
1283 *p->preferredRecordSyntax = IrTcl_getRecordSyntaxVal (argv[2]);
1288 static IrTcl_Method ir_method_tab[] = {
1289 { 1, "comstack", do_comstack },
1290 { 1, "protocol", do_protocol },
1291 { 0, "failback", do_failback },
1293 { 1, "connect", do_connect },
1294 { 0, "protocolVersion", do_protocolVersion },
1295 { 1, "preferredMessageSize", do_preferredMessageSize },
1296 { 1, "maximumRecordSize", do_maximumRecordSize },
1297 { 1, "implementationName", do_implementationName },
1298 { 1, "implementationId", do_implementationId },
1299 { 1, "implementationVersion", do_implementationVersion },
1300 { 0, "targetImplementationName", do_targetImplementationName },
1301 { 0, "targetImplementationId", do_targetImplementationId },
1302 { 0, "targetImplementationVersion", do_targetImplementationVersion },
1303 { 0, "userInformationField", do_userInformationField },
1304 { 1, "idAuthentication", do_idAuthentication },
1305 { 0, "options", do_options },
1306 { 0, "init", do_init_request },
1307 { 0, "initResult", do_initResult },
1308 { 0, "disconnect", do_disconnect },
1309 { 0, "callback", do_callback },
1313 static IrTcl_Method ir_set_c_method_tab[] = {
1314 { 0, "databaseNames", do_databaseNames},
1315 { 0, "replaceIndicator", do_replaceIndicator},
1316 { 0, "queryType", do_queryType },
1317 { 0, "preferredRecordSyntax", do_preferredRecordSyntax },
1318 { 0, "smallSetUpperBound", do_smallSetUpperBound},
1319 { 0, "largeSetLowerBound", do_largeSetLowerBound},
1320 { 0, "mediumSetPresentNumber", do_mediumSetPresentNumber},
1321 { 0, "referenceId", do_referenceId },
1326 * ir_obj_method: IR Object methods
1328 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
1329 int argc, char **argv)
1331 IrTcl_Methods tab[3];
1332 IrTcl_Obj *p = clientData;
1335 return ir_method_r (clientData, interp, argc, argv, ir_method_tab);
1337 tab[0].tab = ir_method_tab;
1339 tab[1].tab = ir_set_c_method_tab;
1340 tab[1].obj = &p->set_inher;
1343 return ir_method (interp, argc, argv, tab);
1347 * ir_obj_delete: IR Object disposal
1349 static void ir_obj_delete (ClientData clientData)
1351 IrTcl_Obj *obj = clientData;
1352 IrTcl_Methods tab[3];
1355 if (obj->ref_count > 0)
1357 assert (obj->ref_count == 0);
1359 tab[0].tab = ir_method_tab;
1361 tab[1].tab = ir_set_c_method_tab;
1362 tab[1].obj = &obj->set_inher;
1365 ir_method (NULL, -1, NULL, tab);
1366 odr_destroy (obj->odr_in);
1367 odr_destroy (obj->odr_out);
1368 odr_destroy (obj->odr_pr);
1369 free (obj->buf_out);
1375 * ir_obj_mk: IR Object creation
1377 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
1378 int argc, char **argv)
1380 IrTcl_Methods tab[3];
1388 interp->result = "wrong # args";
1391 if (!(obj = ir_malloc (interp, sizeof(*obj))))
1396 obj->bibset = ccl_qual_mk ();
1397 if ((inf = fopen ("default.bib", "r")))
1399 ccl_qual_file (obj->bibset, inf);
1404 obj->odr_in = odr_createmem (ODR_DECODE);
1405 obj->odr_out = odr_createmem (ODR_ENCODE);
1406 obj->odr_pr = odr_createmem (ODR_PRINT);
1408 obj->len_out = 10000;
1409 if (!(obj->buf_out = ir_malloc (interp, obj->len_out)))
1411 odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out, 0);
1416 tab[0].tab = ir_method_tab;
1418 tab[1].tab = ir_set_c_method_tab;
1419 tab[1].obj = &obj->set_inher;
1422 if (ir_method (interp, 0, NULL, tab) == TCL_ERROR)
1424 Tcl_CreateCommand (interp, argv[1], ir_obj_method,
1425 (ClientData) obj, ir_obj_delete);
1429 /* ------------------------------------------------------- */
1431 * do_search: Do search request
1433 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
1435 Z_SearchRequest *req;
1439 IrTcl_SetObj *obj = o;
1440 IrTcl_Obj *p = obj->parent;
1450 interp->result = "wrong # args";
1453 if (!obj->set_inher.num_databaseNames)
1455 interp->result = "no databaseNames";
1460 interp->result = "not connected";
1463 odr_reset (p->odr_out);
1464 apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest);
1465 req = apdu->u.searchRequest;
1467 bib1.proto = p->protocol_type;
1468 bib1.class = CLASS_ATTSET;
1469 bib1.value = VAL_BIB1;
1471 set_referenceId (p->odr_out, &req->referenceId,
1472 obj->set_inher.referenceId);
1474 req->smallSetUpperBound = &obj->set_inher.smallSetUpperBound;
1475 req->largeSetLowerBound = &obj->set_inher.largeSetLowerBound;
1476 req->mediumSetPresentNumber = &obj->set_inher.mediumSetPresentNumber;
1477 req->replaceIndicator = &obj->set_inher.replaceIndicator;
1478 req->resultSetName = obj->setName ? obj->setName : "Default";
1479 logf (LOG_DEBUG, "Search, resultSetName %s", req->resultSetName);
1480 req->num_databaseNames = obj->set_inher.num_databaseNames;
1481 req->databaseNames = obj->set_inher.databaseNames;
1482 for (r=0; r < obj->set_inher.num_databaseNames; r++)
1483 logf (LOG_DEBUG, " Database %s", obj->set_inher.databaseNames[r]);
1484 req->smallSetElementSetNames = 0;
1485 req->mediumSetElementSetNames = 0;
1486 if (obj->set_inher.preferredRecordSyntax)
1488 struct oident ident;
1490 ident.proto = p->protocol_type;
1491 ident.class = CLASS_RECSYN;
1492 ident.value = *obj->set_inher.preferredRecordSyntax;
1493 req->preferredRecordSyntax = odr_oiddup (p->odr_out,
1494 oid_getoidbyent (&ident));
1497 req->preferredRecordSyntax = 0;
1498 req->query = &query;
1500 if (!strcmp (obj->set_inher.queryType, "rpn"))
1502 Z_RPNQuery *RPNquery;
1504 RPNquery = p_query_rpn (p->odr_out, argv[2]);
1507 Tcl_AppendResult (interp, "Syntax error in query", NULL);
1510 RPNquery->attributeSetId = oid_getoidbyent (&bib1);
1511 query.which = Z_Query_type_1;
1512 query.u.type_1 = RPNquery;
1513 logf (LOG_DEBUG, "RPN");
1516 else if (!strcmp (obj->set_inher.queryType, "cclrpn"))
1520 struct ccl_rpn_node *rpn;
1521 Z_RPNQuery *RPNquery;
1523 rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
1526 Tcl_AppendResult (interp, "CCL error: ",
1527 ccl_err_msg(error), NULL);
1530 ccl_pr_tree (rpn, stderr);
1531 fprintf (stderr, "\n");
1532 assert((RPNquery = ccl_rpn_query(rpn)));
1533 RPNquery->attributeSetId = oid_getoidbyent (&bib1);
1534 query.which = Z_Query_type_1;
1535 query.u.type_1 = RPNquery;
1536 logf (LOG_DEBUG, "CCLRPN");
1539 else if (!strcmp (obj->set_inher.queryType, "ccl"))
1541 query.which = Z_Query_type_2;
1542 query.u.type_2 = &ccl_query;
1543 ccl_query.buf = (unsigned char *) argv[2];
1544 ccl_query.len = strlen (argv[2]);
1545 logf (LOG_DEBUG, "CCL");
1549 interp->result = "unknown query method";
1552 if (!z_APDU (p->odr_out, &apdu, 0))
1554 interp->result = odr_errlist [odr_geterror (p->odr_out)];
1555 odr_reset (p->odr_out);
1558 p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
1559 if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1561 interp->result = "cs_put failed in search";
1566 ir_select_add_write (cs_fileno(p->cs_link), p);
1567 logf (LOG_DEBUG, "Sent part of searchRequest (%d bytes)", p->slen);
1571 logf (LOG_DEBUG, "Whole search request (%d bytes)", p->slen);
1577 * do_resultCount: Get number of hits
1579 static int do_resultCount (void *o, Tcl_Interp *interp,
1580 int argc, char **argv)
1582 IrTcl_SetObj *obj = o;
1586 return get_set_int (&obj->resultCount, interp, argc, argv);
1590 * do_searchStatus: Get search status (after search response)
1592 static int do_searchStatus (void *o, Tcl_Interp *interp,
1593 int argc, char **argv)
1595 IrTcl_SetObj *obj = o;
1599 return get_set_int (&obj->searchStatus, interp, argc, argv);
1603 * do_presentStatus: Get search status (after search/present response)
1605 static int do_presentStatus (void *o, Tcl_Interp *interp,
1606 int argc, char **argv)
1608 IrTcl_SetObj *obj = o;
1612 return get_set_int (&obj->presentStatus, interp, argc, argv);
1616 * do_nextResultSetPosition: Get next result set position
1617 * (after search/present response)
1619 static int do_nextResultSetPosition (void *o, Tcl_Interp *interp,
1620 int argc, char **argv)
1622 IrTcl_SetObj *obj = o;
1626 return get_set_int (&obj->nextResultSetPosition, interp, argc, argv);
1630 * do_setName: Set result Set name
1632 static int do_setName (void *o, Tcl_Interp *interp,
1633 int argc, char **argv)
1635 IrTcl_SetObj *obj = o;
1638 return ir_strdup (interp, &obj->setName, "Default");
1639 else if (argc == -1)
1640 return ir_strdel (interp, &obj->setName);
1643 free (obj->setName);
1644 if (ir_strdup (interp, &obj->setName, argv[2])
1648 Tcl_AppendElement (interp, obj->setName);
1653 * do_numberOfRecordsReturned: Get number of records returned
1655 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
1656 int argc, char **argv)
1658 IrTcl_SetObj *obj = o;
1662 obj->numberOfRecordsReturned = 0;
1665 return get_set_int (&obj->numberOfRecordsReturned, interp, argc, argv);
1669 * do_type: Return type (if any) at position.
1671 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)
1673 IrTcl_SetObj *obj = o;
1675 IrTcl_RecordList *rl;
1679 obj->record_list = NULL;
1682 else if (argc == -1)
1684 delete_IR_records (obj);
1689 sprintf (interp->result, "wrong # args");
1692 if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1694 rl = find_IR_record (obj, offset);
1699 case Z_NamePlusRecord_databaseRecord:
1700 interp->result = "DB";
1702 case Z_NamePlusRecord_surrogateDiagnostic:
1703 interp->result = "SD";
1711 * do_recordType: Return record type (if any) at position.
1713 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
1715 IrTcl_SetObj *obj = o;
1717 IrTcl_RecordList *rl;
1723 else if (argc == -1)
1729 sprintf (interp->result, "wrong # args");
1732 if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1734 rl = find_IR_record (obj, offset);
1737 if (rl->which != Z_NamePlusRecord_databaseRecord)
1739 Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
1742 Tcl_AppendElement (interp, (char*)
1743 IrTcl_getRecordSyntaxStr (rl->u.dbrec.type));
1750 static int ir_diagResult (Tcl_Interp *interp, IrTcl_Diagnostic *list, int num)
1756 for (i = 0; i<num; i++)
1758 logf (LOG_DEBUG, "Diagnostic, code %d", list[i].condition);
1759 sprintf (buf, "%d", list[i].condition);
1760 Tcl_AppendElement (interp, buf);
1761 cp = diagbib1_str (list[i].condition);
1763 Tcl_AppendElement (interp, (char*) cp);
1765 Tcl_AppendElement (interp, "");
1766 if (list[i].addinfo)
1767 Tcl_AppendElement (interp, (char*) list[i].addinfo);
1769 Tcl_AppendElement (interp, "");
1775 * do_diag: Return diagnostic record info
1777 static int do_diag (void *o, Tcl_Interp *interp, int argc, char **argv)
1779 IrTcl_SetObj *obj = o;
1781 IrTcl_RecordList *rl;
1787 sprintf (interp->result, "wrong # args");
1790 if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1792 rl = find_IR_record (obj, offset);
1795 Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1798 if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
1800 Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
1803 return ir_diagResult (interp, rl->u.surrogateDiagnostics.list,
1804 rl->u.surrogateDiagnostics.num);
1808 * do_getMarc: Get ISO2709 Record lines/fields
1810 static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
1812 IrTcl_SetObj *obj = o;
1814 IrTcl_RecordList *rl;
1820 sprintf (interp->result, "wrong # args");
1823 if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1825 rl = find_IR_record (obj, offset);
1828 Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1831 if (rl->which != Z_NamePlusRecord_databaseRecord)
1833 Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
1836 return ir_tcl_get_marc (interp, rl->u.dbrec.buf, argc, argv);
1841 * do_responseStatus: Return response status (present or search)
1843 static int do_responseStatus (void *o, Tcl_Interp *interp,
1844 int argc, char **argv)
1846 IrTcl_SetObj *obj = o;
1850 obj->recordFlag = 0;
1851 obj->nonSurrogateDiagnosticNum = 0;
1852 obj->nonSurrogateDiagnosticList = NULL;
1855 else if (argc == -1)
1857 ir_deleteDiags (&obj->nonSurrogateDiagnosticList,
1858 &obj->nonSurrogateDiagnosticNum);
1861 if (!obj->recordFlag)
1863 Tcl_AppendElement (interp, "OK");
1868 case Z_Records_DBOSD:
1869 Tcl_AppendElement (interp, "DBOSD");
1872 Tcl_AppendElement (interp, "NSD");
1873 return ir_diagResult (interp, obj->nonSurrogateDiagnosticList,
1874 obj->nonSurrogateDiagnosticNum);
1880 * do_present: Perform Present Request
1883 static int do_present (void *o, Tcl_Interp *interp,
1884 int argc, char **argv)
1886 IrTcl_SetObj *obj = o;
1887 IrTcl_Obj *p = obj->parent;
1889 Z_PresentRequest *req;
1898 if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
1905 if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
1912 interp->result = "not connected";
1915 odr_reset (p->odr_out);
1917 obj->number = number;
1919 apdu = zget_APDU (p->odr_out, Z_APDU_presentRequest);
1920 req = apdu->u.presentRequest;
1922 set_referenceId (p->odr_out, &req->referenceId,
1923 obj->set_inher.referenceId);
1925 req->resultSetId = obj->setName ? obj->setName : "Default";
1927 req->resultSetStartPoint = &start;
1928 req->numberOfRecordsRequested = &number;
1929 req->preferredRecordSyntax = 0;
1931 if (!z_APDU (p->odr_out, &apdu, 0))
1933 interp->result = odr_errlist [odr_geterror (p->odr_out)];
1934 odr_reset (p->odr_out);
1937 p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
1938 if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1940 interp->result = "cs_put failed in present";
1945 ir_select_add_write (cs_fileno(p->cs_link), p);
1946 logf (LOG_DEBUG, "Part of present request, start=%d, num=%d"
1947 " (%d bytes)", start, number, p->slen);
1951 logf (LOG_DEBUG, "Whole present request, start=%d, num=%d"
1952 " (%d bytes)", start, number, p->slen);
1958 * do_loadFile: Load result set from file
1961 static int do_loadFile (void *o, Tcl_Interp *interp,
1962 int argc, char **argv)
1964 IrTcl_SetObj *setobj = o;
1974 interp->result = "wrong # args";
1977 inf = fopen (argv[2], "r");
1980 Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
1983 while ((buf = ir_tcl_fread_marc (inf, &size)))
1985 IrTcl_RecordList *rl;
1987 rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
1988 rl->u.dbrec.buf = buf;
1989 rl->u.dbrec.size = size;
1992 setobj->numberOfRecordsReturned = no-1;
1997 static IrTcl_Method ir_set_method_tab[] = {
1998 { 0, "search", do_search },
1999 { 0, "searchStatus", do_searchStatus },
2000 { 0, "presentStatus", do_presentStatus },
2001 { 0, "nextResultSetPosition", do_nextResultSetPosition },
2002 { 0, "setName", do_setName },
2003 { 0, "resultCount", do_resultCount },
2004 { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },
2005 { 0, "present", do_present },
2006 { 0, "type", do_type },
2007 { 0, "getMarc", do_getMarc },
2008 { 0, "recordType", do_recordType },
2009 { 0, "diag", do_diag },
2010 { 0, "responseStatus", do_responseStatus },
2011 { 0, "loadFile", do_loadFile },
2016 * ir_set_obj_method: IR Set Object methods
2018 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
2019 int argc, char **argv)
2021 IrTcl_Methods tabs[3];
2022 IrTcl_SetObj *p = clientData;
2026 interp->result = "wrong # args";
2029 tabs[0].tab = ir_set_method_tab;
2031 tabs[1].tab = ir_set_c_method_tab;
2032 tabs[1].obj = &p->set_inher;
2035 return ir_method (interp, argc, argv, tabs);
2039 * ir_set_obj_delete: IR Set Object disposal
2041 static void ir_set_obj_delete (ClientData clientData)
2043 IrTcl_Methods tabs[3];
2044 IrTcl_SetObj *p = clientData;
2046 tabs[0].tab = ir_set_method_tab;
2048 tabs[1].tab = ir_set_c_method_tab;
2049 tabs[1].obj = &p->set_inher;
2052 ir_method (NULL, -1, NULL, tabs);
2058 * ir_set_obj_mk: IR Set Object creation
2060 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
2061 int argc, char **argv)
2063 IrTcl_Methods tabs[3];
2066 if (argc < 2 || argc > 3)
2068 interp->result = "wrong # args";
2071 if (!(obj = ir_malloc (interp, sizeof(*obj))))
2075 Tcl_CmdInfo parent_info;
2080 if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
2082 interp->result = "No parent";
2085 obj->parent = (IrTcl_Obj *) parent_info.clientData;
2087 dst = &obj->set_inher;
2088 src = &obj->parent->set_inher;
2090 dst->num_databaseNames = src->num_databaseNames;
2091 if (!(dst->databaseNames =
2092 ir_malloc (interp, sizeof (*dst->databaseNames)
2093 * dst->num_databaseNames)))
2095 for (i = 0; i < dst->num_databaseNames; i++)
2097 if (ir_strdup (interp, &dst->databaseNames[i],
2098 src->databaseNames[i]) == TCL_ERROR)
2101 if (ir_strdup (interp, &dst->queryType, src->queryType)
2105 if (ir_strdup (interp, &dst->referenceId, src->referenceId)
2109 if (src->preferredRecordSyntax &&
2110 (dst->preferredRecordSyntax
2111 = malloc (sizeof(*dst->preferredRecordSyntax))))
2112 *dst->preferredRecordSyntax = *src->preferredRecordSyntax;
2114 dst->preferredRecordSyntax = NULL;
2115 dst->replaceIndicator = src->replaceIndicator;
2116 dst->smallSetUpperBound = src->smallSetUpperBound;
2117 dst->largeSetLowerBound = src->largeSetLowerBound;
2118 dst->mediumSetPresentNumber = src->mediumSetPresentNumber;
2123 tabs[0].tab = ir_set_method_tab;
2127 if (ir_method (interp, 0, NULL, tabs) == TCL_ERROR)
2130 Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
2131 (ClientData) obj, ir_set_obj_delete);
2135 /* ------------------------------------------------------- */
2138 * do_scan: Perform scan
2140 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
2144 IrTcl_ScanObj *obj = o;
2145 IrTcl_Obj *p = obj->parent;
2149 struct ccl_rpn_node *rpn;
2158 interp->result = "wrong # args";
2161 if (!p->set_inher.num_databaseNames)
2163 interp->result = "no databaseNames";
2168 interp->result = "not connected";
2171 odr_reset (p->odr_out);
2173 bib1.proto = p->protocol_type;
2174 bib1.class = CLASS_ATTSET;
2175 bib1.value = VAL_BIB1;
2177 apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest);
2178 req = apdu->u.scanRequest;
2180 set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
2181 req->num_databaseNames = p->set_inher.num_databaseNames;
2182 req->databaseNames = p->set_inher.databaseNames;
2183 req->attributeSet = oid_getoidbyent (&bib1);
2186 if (!(req->termListAndStartPoint = p_query_scan (p->odr_out, argv[2])))
2188 Tcl_AppendResult (interp, "Syntax error in query", NULL);
2192 rpn = ccl_find_str(p->bibset, argv[2], &r, &pos);
2195 Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL);
2198 ccl_pr_tree (rpn, stderr);
2199 fprintf (stderr, "\n");
2200 if (!(req->termListAndStartPoint = ccl_scan_query (rpn)))
2203 req->stepSize = &obj->stepSize;
2204 req->numberOfTermsRequested = &obj->numberOfTermsRequested;
2205 req->preferredPositionInResponse = &obj->preferredPositionInResponse;
2206 logf (LOG_DEBUG, "stepSize=%d", *req->stepSize);
2207 logf (LOG_DEBUG, "numberOfTermsRequested=%d",
2208 *req->numberOfTermsRequested);
2209 logf (LOG_DEBUG, "preferredPositionInResponse=%d",
2210 *req->preferredPositionInResponse);
2212 if (!z_APDU (p->odr_out, &apdu, 0))
2214 interp->result = odr_errlist [odr_geterror (p->odr_out)];
2215 odr_reset (p->odr_out);
2218 p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
2219 if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
2221 interp->result = "cs_put failed in scan";
2226 ir_select_add_write (cs_fileno(p->cs_link), p);
2227 logf (LOG_DEBUG, "Sent part of scanRequest (%d bytes)", p->slen);
2231 logf (LOG_DEBUG, "Whole scan request (%d bytes)", p->slen);
2237 * do_stepSize: Set/get replace Step Size
2239 static int do_stepSize (void *obj, Tcl_Interp *interp,
2240 int argc, char **argv)
2242 IrTcl_ScanObj *p = obj;
2248 return get_set_int (&p->stepSize, interp, argc, argv);
2252 * do_numberOfTermsRequested: Set/get Number of Terms requested
2254 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,
2255 int argc, char **argv)
2257 IrTcl_ScanObj *p = obj;
2261 p->numberOfTermsRequested = 20;
2264 return get_set_int (&p->numberOfTermsRequested, interp, argc, argv);
2269 * do_preferredPositionInResponse: Set/get preferred Position
2271 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,
2272 int argc, char **argv)
2274 IrTcl_ScanObj *p = obj;
2278 p->preferredPositionInResponse = 1;
2281 return get_set_int (&p->preferredPositionInResponse, interp, argc, argv);
2285 * do_scanStatus: Get scan status
2287 static int do_scanStatus (void *obj, Tcl_Interp *interp,
2288 int argc, char **argv)
2290 IrTcl_ScanObj *p = obj;
2294 return get_set_int (&p->scanStatus, interp, argc, argv);
2298 * do_numberOfEntriesReturned: Get number of Entries returned
2300 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,
2301 int argc, char **argv)
2303 IrTcl_ScanObj *p = obj;
2307 return get_set_int (&p->numberOfEntriesReturned, interp, argc, argv);
2311 * do_positionOfTerm: Get position of Term
2313 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,
2314 int argc, char **argv)
2316 IrTcl_ScanObj *p = obj;
2320 return get_set_int (&p->positionOfTerm, interp, argc, argv);
2324 * do_scanLine: get Scan Line (surrogate or normal) after response
2326 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)
2328 IrTcl_ScanObj *p = obj;
2334 p->entries_flag = 0;
2336 p->nonSurrogateDiagnosticNum = 0;
2337 p->nonSurrogateDiagnosticList = 0;
2340 else if (argc == -1)
2342 p->entries_flag = 0;
2343 /* release entries */
2346 ir_deleteDiags (&p->nonSurrogateDiagnosticList,
2347 &p->nonSurrogateDiagnosticNum);
2352 interp->result = "wrong # args";
2355 if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)
2357 if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries
2358 || i >= p->num_entries || i < 0)
2360 switch (p->entries[i].which)
2362 case Z_Entry_termInfo:
2363 Tcl_AppendElement (interp, "T");
2364 if (p->entries[i].u.term.buf)
2365 Tcl_AppendElement (interp, p->entries[i].u.term.buf);
2367 Tcl_AppendElement (interp, "");
2368 sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);
2369 Tcl_AppendElement (interp, numstr);
2371 case Z_Entry_surrogateDiagnostic:
2372 Tcl_AppendElement (interp, "SD");
2373 return ir_diagResult (interp, p->entries[i].u.diag.list,
2374 p->entries[i].u.diag.num);
2380 static IrTcl_Method ir_scan_method_tab[] = {
2381 { 0, "scan", do_scan },
2382 { 0, "stepSize", do_stepSize },
2383 { 0, "numberOfTermsRequested", do_numberOfTermsRequested },
2384 { 0, "preferredPositionInResponse", do_preferredPositionInResponse },
2385 { 0, "scanStatus", do_scanStatus },
2386 { 0, "numberOfEntriesReturned", do_numberOfEntriesReturned },
2387 { 0, "positionOfTerm", do_positionOfTerm },
2388 { 0, "scanLine", do_scanLine },
2393 * ir_scan_obj_method: IR Scan Object methods
2395 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,
2396 int argc, char **argv)
2398 IrTcl_Methods tabs[2];
2402 interp->result = "wrong # args";
2405 tabs[0].tab = ir_scan_method_tab;
2406 tabs[0].obj = clientData;
2409 return ir_method (interp, argc, argv, tabs);
2413 * ir_scan_obj_delete: IR Scan Object disposal
2415 static void ir_scan_obj_delete (ClientData clientData)
2417 IrTcl_Methods tabs[2];
2418 IrTcl_ScanObj *obj = clientData;
2420 tabs[0].tab = ir_scan_method_tab;
2424 ir_method (NULL, -1, NULL, tabs);
2429 * ir_scan_obj_mk: IR Scan Object creation
2431 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,
2432 int argc, char **argv)
2434 Tcl_CmdInfo parent_info;
2436 IrTcl_Methods tabs[2];
2440 interp->result = "wrong # args";
2443 if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
2445 interp->result = "No parent";
2448 if (!(obj = ir_malloc (interp, sizeof(*obj))))
2451 obj->parent = (IrTcl_Obj *) parent_info.clientData;
2453 tabs[0].tab = ir_scan_method_tab;
2457 if (ir_method (interp, 0, NULL, tabs) == TCL_ERROR)
2459 Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,
2460 (ClientData) obj, ir_scan_obj_delete);
2464 /* ------------------------------------------------------- */
2466 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
2470 p->initResult = *initrs->result ? 1 : 0;
2471 if (!*initrs->result)
2472 logf (LOG_DEBUG, "Connection rejected by target");
2474 logf (LOG_DEBUG, "Connection accepted by target");
2476 get_referenceId (&p->set_inher.referenceId, initrs->referenceId);
2478 free (p->targetImplementationId);
2479 ir_strdup (p->interp, &p->targetImplementationId,
2480 initrs->implementationId);
2481 free (p->targetImplementationName);
2482 ir_strdup (p->interp, &p->targetImplementationName,
2483 initrs->implementationName);
2484 free (p->targetImplementationVersion);
2485 ir_strdup (p->interp, &p->targetImplementationVersion,
2486 initrs->implementationVersion);
2488 p->maximumRecordSize = *initrs->maximumRecordSize;
2489 p->preferredMessageSize = *initrs->preferredMessageSize;
2491 memcpy (&p->options, initrs->options, sizeof(initrs->options));
2492 memcpy (&p->protocolVersion, initrs->protocolVersion,
2493 sizeof(initrs->protocolVersion));
2494 free (p->userInformationField);
2495 p->userInformationField = NULL;
2496 if (initrs->userInformationField)
2500 if (initrs->userInformationField->which == ODR_EXTERNAL_octet &&
2501 (p->userInformationField =
2503 initrs->userInformationField->u.octet_aligned->len)
2506 memcpy (p->userInformationField,
2507 initrs->userInformationField->u.octet_aligned->buf,
2509 (p->userInformationField)[len] = '\0';
2514 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num)
2517 for (i = 0; i<*dst_num; i++)
2518 free (dst_list[i]->addinfo);
2524 static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num,
2525 Z_DiagRec **list, int num)
2531 *dst_list = malloc (sizeof(**dst_list) * num);
2537 for (i = 0; i<num; i++)
2539 switch (list[i]->which)
2541 case Z_DiagRec_defaultFormat:
2542 (*dst_list)[i].condition = *list[i]->u.defaultFormat->condition;
2543 addinfo = list[i]->u.defaultFormat->addinfo;
2545 ((*dst_list)[i].addinfo = malloc (strlen(addinfo)+1)))
2546 strcpy ((*dst_list)[i].addinfo, addinfo);
2549 (*dst_list)[i].addinfo = NULL;
2550 (*dst_list)[i].condition = 0;
2555 static void ir_handleRecords (void *o, Z_Records *zrs)
2558 IrTcl_SetObj *setobj = p->set_child;
2561 IrTcl_RecordList *rl;
2563 setobj->which = zrs->which;
2564 setobj->recordFlag = 1;
2566 ir_deleteDiags (&setobj->nonSurrogateDiagnosticList,
2567 &setobj->nonSurrogateDiagnosticNum);
2568 if (zrs->which == Z_Records_DBOSD)
2570 setobj->numberOfRecordsReturned =
2571 zrs->u.databaseOrSurDiagnostics->num_records;
2572 logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned);
2573 for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
2575 rl = new_IR_record (setobj, setobj->start + offset,
2576 zrs->u.databaseOrSurDiagnostics->
2577 records[offset]->which);
2578 if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
2580 ir_handleDiags (&rl->u.surrogateDiagnostics.list,
2581 &rl->u.surrogateDiagnostics.num,
2582 &zrs->u.databaseOrSurDiagnostics->
2583 records[offset]->u.surrogateDiagnostic,
2588 Z_DatabaseRecord *zr;
2591 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
2593 oe = (Odr_external*) zr;
2594 rl->u.dbrec.size = zr->u.octet_aligned->len;
2595 rl->u.dbrec.type = VAL_USMARC;
2596 if (oe->which == ODR_EXTERNAL_octet && rl->u.dbrec.size > 0)
2598 const char *buf = (char*) zr->u.octet_aligned->buf;
2599 if ((rl->u.dbrec.buf = malloc (rl->u.dbrec.size)))
2600 memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size);
2601 if (oe->direct_reference)
2603 struct oident *ident =
2604 oid_getentbyoid (oe->direct_reference);
2605 rl->u.dbrec.type = ident->value;
2609 rl->u.dbrec.buf = NULL;
2613 else if (zrs->which == Z_Records_multipleNSD)
2615 logf (LOG_DEBUG, "multipleNonSurrogateDiagnostic %d",
2616 zrs->u.multipleNonSurDiagnostics->num_diagRecs);
2617 setobj->numberOfRecordsReturned = 0;
2618 ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
2619 &setobj->nonSurrogateDiagnosticNum,
2620 zrs->u.multipleNonSurDiagnostics->diagRecs,
2621 zrs->u.multipleNonSurDiagnostics->num_diagRecs);
2625 logf (LOG_DEBUG, "NonSurrogateDiagnostic");
2626 setobj->numberOfRecordsReturned = 0;
2627 ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
2628 &setobj->nonSurrogateDiagnosticNum,
2629 &zrs->u.nonSurrogateDiagnostic,
2634 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
2637 IrTcl_SetObj *setobj = p->set_child;
2638 Z_Records *zrs = searchrs->records;
2640 logf (LOG_DEBUG, "Received search response");
2643 logf (LOG_DEBUG, "Search response, no object!");
2646 setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
2647 get_referenceId (&setobj->set_inher.referenceId, searchrs->referenceId);
2648 setobj->resultCount = *searchrs->resultCount;
2649 if (searchrs->presentStatus)
2650 setobj->presentStatus = *searchrs->presentStatus;
2651 if (searchrs->nextResultSetPosition)
2652 setobj->nextResultSetPosition = *searchrs->nextResultSetPosition;
2654 logf (LOG_DEBUG, "Search response %d, %d hits",
2655 setobj->searchStatus, setobj->resultCount);
2657 ir_handleRecords (o, zrs);
2659 setobj->recordFlag = 0;
2663 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
2666 IrTcl_SetObj *setobj = p->set_child;
2667 Z_Records *zrs = presrs->records;
2669 logf (LOG_DEBUG, "Received present response");
2672 logf (LOG_DEBUG, "Present response, no object!");
2675 setobj->presentStatus = *presrs->presentStatus;
2676 get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId);
2677 setobj->nextResultSetPosition = *presrs->nextResultSetPosition;
2679 ir_handleRecords (o, zrs);
2682 setobj->recordFlag = 0;
2683 logf (LOG_DEBUG, "No records!");
2687 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs)
2690 IrTcl_ScanObj *scanobj = p->scan_child;
2692 logf (LOG_DEBUG, "Received scanResponse");
2694 get_referenceId (&p->set_inher.referenceId, scanrs->referenceId);
2695 scanobj->scanStatus = *scanrs->scanStatus;
2696 logf (LOG_DEBUG, "scanStatus=%d", scanobj->scanStatus);
2698 if (scanrs->stepSize)
2699 scanobj->stepSize = *scanrs->stepSize;
2700 logf (LOG_DEBUG, "stepSize=%d", scanobj->stepSize);
2702 scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;
2703 logf (LOG_DEBUG, "numberOfEntriesReturned=%d",
2704 scanobj->numberOfEntriesReturned);
2706 if (scanrs->positionOfTerm)
2707 scanobj->positionOfTerm = *scanrs->positionOfTerm;
2709 scanobj->positionOfTerm = -1;
2710 logf (LOG_DEBUG, "positionOfTerm=%d", scanobj->positionOfTerm);
2712 free (scanobj->entries);
2713 scanobj->entries = NULL;
2715 ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList,
2716 &scanobj->nonSurrogateDiagnosticNum);
2717 if (scanrs->entries)
2722 scanobj->entries_flag = 1;
2723 scanobj->which = scanrs->entries->which;
2724 switch (scanobj->which)
2726 case Z_ListEntries_entries:
2727 scanobj->num_entries = scanrs->entries->u.entries->num_entries;
2728 scanobj->entries = malloc (scanobj->num_entries *
2729 sizeof(*scanobj->entries));
2730 for (i=0; i<scanobj->num_entries; i++)
2732 ze = scanrs->entries->u.entries->entries[i];
2733 scanobj->entries[i].which = ze->which;
2736 case Z_Entry_termInfo:
2737 if (ze->u.termInfo->term->which == Z_Term_general)
2739 int l = ze->u.termInfo->term->u.general->len;
2740 scanobj->entries[i].u.term.buf = malloc (1+l);
2741 memcpy (scanobj->entries[i].u.term.buf,
2742 ze->u.termInfo->term->u.general->buf,
2744 scanobj->entries[i].u.term.buf[l] = '\0';
2747 scanobj->entries[i].u.term.buf = NULL;
2748 if (ze->u.termInfo->globalOccurrences)
2749 scanobj->entries[i].u.term.globalOccurrences =
2750 *ze->u.termInfo->globalOccurrences;
2752 scanobj->entries[i].u.term.globalOccurrences = 0;
2754 case Z_Entry_surrogateDiagnostic:
2755 ir_handleDiags (&scanobj->entries[i].u.diag.list,
2756 &scanobj->entries[i].u.diag.num,
2757 &ze->u.surrogateDiagnostic,
2763 case Z_ListEntries_nonSurrogateDiagnostics:
2764 ir_handleDiags (&scanobj->nonSurrogateDiagnosticList,
2765 &scanobj->nonSurrogateDiagnosticNum,
2766 scanrs->entries->u.nonSurrogateDiagnostics->
2768 scanrs->entries->u.nonSurrogateDiagnostics->
2774 scanobj->entries_flag = 0;
2778 * ir_select_read: handle incoming packages
2780 void ir_select_read (ClientData clientData)
2782 IrTcl_Obj *p = clientData;
2788 r = cs_rcvconnect (p->cs_link);
2792 ir_select_remove_write (cs_fileno (p->cs_link), p);
2795 logf (LOG_DEBUG, "cs_rcvconnect error");
2797 IrTcl_eval (p->interp, p->failback);
2798 do_disconnect (p, NULL, 2, NULL);
2802 IrTcl_eval (p->interp, p->callback);
2807 /* signal one more use of ir object - callbacks must not
2808 release the ir memory (p pointer) */
2810 if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) <= 0)
2812 logf (LOG_DEBUG, "cs_get failed, code %d", r);
2813 ir_select_remove (cs_fileno (p->cs_link), p);
2815 IrTcl_eval (p->interp, p->failback);
2816 do_disconnect (p, NULL, 2, NULL);
2818 /* relase ir object now if callback deleted it */
2824 odr_setbuf (p->odr_in, p->buf_in, r, 0);
2825 logf (LOG_DEBUG, "cs_get ok, got %d", r);
2826 if (!z_APDU (p->odr_in, &apdu, 0))
2828 logf (LOG_DEBUG, "%s", odr_errlist [odr_geterror (p->odr_in)]);
2830 IrTcl_eval (p->interp, p->failback);
2831 do_disconnect (p, NULL, 2, NULL);
2833 /* release ir object now if failback deleted it */
2839 case Z_APDU_initResponse:
2840 ir_initResponse (p, apdu->u.initResponse);
2842 case Z_APDU_searchResponse:
2843 ir_searchResponse (p, apdu->u.searchResponse);
2845 case Z_APDU_presentResponse:
2846 ir_presentResponse (p, apdu->u.presentResponse);
2848 case Z_APDU_scanResponse:
2849 ir_scanResponse (p, apdu->u.scanResponse);
2852 logf (LOG_WARN, "Received unknown APDU type (%d)", apdu->which);
2854 IrTcl_eval (p->interp, p->failback);
2855 do_disconnect (p, NULL, 2, NULL);
2857 odr_reset (p->odr_in);
2859 IrTcl_eval (p->interp, p->callback);
2860 if (p->ref_count == 1)
2866 } while (p->cs_link && cs_more (p->cs_link));
2870 * ir_select_write: handle outgoing packages - not yet written.
2872 void ir_select_write (ClientData clientData)
2874 IrTcl_Obj *p = clientData;
2877 logf (LOG_DEBUG, "In write handler");
2880 r = cs_rcvconnect (p->cs_link);
2886 logf (LOG_DEBUG, "cs_rcvconnect error");
2887 ir_select_remove_write (cs_fileno (p->cs_link), p);
2889 IrTcl_eval (p->interp, p->failback);
2890 do_disconnect (p, NULL, 2, NULL);
2893 ir_select_remove_write (cs_fileno (p->cs_link), p);
2895 IrTcl_eval (p->interp, p->callback);
2898 if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
2900 logf (LOG_DEBUG, "select write fail");
2902 IrTcl_eval (p->interp, p->failback);
2903 do_disconnect (p, NULL, 2, NULL);
2905 else if (r == 0) /* remove select bit */
2907 ir_select_remove_write (cs_fileno (p->cs_link), p);
2911 /* ------------------------------------------------------- */
2914 * ir_tcl_init: Registration of TCL commands.
2916 int ir_tcl_init (Tcl_Interp *interp)
2918 Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
2919 (Tcl_CmdDeleteProc *) NULL);
2920 Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
2921 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2922 Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,
2923 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2924 irTcl_interp = interp;