X-Git-Url: http://git.indexdata.com/?a=blobdiff_plain;f=ir-tcl.c;h=e08c5952c96c1eb7424b86d45854016afd24ee05;hb=7d95b9c0eeb4360a9abbf92244bd459f85297304;hp=b9c9012f8787a862d1dd75e8a9264ea32cdd5ba5;hpb=641274e7f15702b5c3cbd36694c79183c8508725;p=ir-tcl-moved-to-github.git diff --git a/ir-tcl.c b/ir-tcl.c index b9c9012..e08c595 100644 --- a/ir-tcl.c +++ b/ir-tcl.c @@ -1,11 +1,72 @@ /* * IR toolkit for tcl/tk - * (c) Index Data 1995 + * (c) Index Data 1995-1996 * See the file LICENSE for details. * Sebastian Hammer, Adam Dickmeiss * * $Log: ir-tcl.c,v $ - * Revision 1.82 1996-02-29 15:30:21 adam + * Revision 1.98 1997-04-13 18:57:20 adam + * Better error reporting and aligned with Tcl/Tk style. + * Rework of notifier code with Tcl_File handles. + * + * Revision 1.97 1996/11/14 17:11:07 adam + * Added Explain documentaion. + * + * Revision 1.96 1996/10/08 13:02:50 adam + * When dealing with records, odr_choice_enable_bias function is used to + * prevent decoding of externals. + * + * Revision 1.95 1996/09/13 10:51:49 adam + * Bug fix: ir_tcl_select_set called Tcl_GetFile at disconnect. + * + * Revision 1.94 1996/08/21 13:32:53 adam + * Implemented saveFile method and extended loadFile method to work with it. + * + * Revision 1.93 1996/08/16 15:07:45 adam + * First work on Explain. + * + * Revision 1.92 1996/08/09 15:33:07 adam + * Modified the code to use tk4.1/tcl7.5 patch level 1. The time-driven + * polling is no longer activated on Windows since asynchrounous I/O works + * better. + * + * Revision 1.91 1996/07/03 13:31:11 adam + * The xmalloc/xfree functions from YAZ are used to manage memory. + * + * Revision 1.90 1996/06/27 14:21:00 adam + * Yet another Windows port. + * + * Revision 1.89 1996/06/11 15:27:15 adam + * Event type set to connect a little earlier in the do_connect function. + * + * Revision 1.88 1996/06/03 09:04:22 adam + * Changed a few logf calls. + * + * Revision 1.87 1996/05/29 06:37:51 adam + * Function ir_tcl_get_grs_r enhanced so that specific elements can be + * extracted. + * + * Revision 1.86 1996/03/20 13:54:04 adam + * The Tcl_File structure is only manipulated in the Tk-event interface + * in tkinit.c. + * + * Revision 1.85 1996/03/15 11:15:48 adam + * Modified to use new prototypes for p_query_rpn and p_query_scan. + * + * Revision 1.84 1996/03/07 12:42:49 adam + * Better logging when callback is invoked. + * + * Revision 1.83 1996/03/05 09:21:09 adam + * Bug fix: memory used by GRS records wasn't freed. + * Rewrote some of the error handling code - the connection is always + * closed before failback is called. + * If failback is defined the send APDU methods (init, search, ...) will + * return OK but invoke failback (as is the case if the write operation + * fails). + * Bug fix: ref_count in assoc object could grow if fraction of PDU was + * read. + * + * Revision 1.82 1996/02/29 15:30:21 adam * Export of IrTcl functionality to extensions. * * Revision 1.81 1996/02/26 18:38:32 adam @@ -291,19 +352,56 @@ #include #include +#ifdef WINDOWS + +#else #include +#endif #include #include #define CS_BLOCK 0 -#define IRTCL_GENERIC_FILES 0 - #include "ir-tclp.h" +#if defined(__WIN32__) +# define WIN32_LEAN_AND_MEAN +# include +# undef WIN32_LEAN_AND_MEAN + +/* + * VC++ has an alternate entry point called DllMain, so we need to rename + * our entry point. + */ + +# if defined(_MSC_VER) +# define EXPORT(a,b) __declspec(dllexport) a b +# define DllEntryPoint DllMain +# else +# if defined(__BORLANDC__) +# define EXPORT(a,b) a _export b +# else +# define EXPORT(a,b) a b +# endif +# endif +#else +# define EXPORT(a,b) a b +#endif + +static char *wrongArgs = "wrong # args: should be \""; + +static int ir_tcl_error_exec (Tcl_Interp *interp, int argc, char **argv) +{ + int i; + Tcl_AppendResult (interp, " while executing ", NULL); + for (i = 0; iwhich) + { + case Z_NamePlusRecord_databaseRecord: + switch (rl->u.dbrec.type) + { + case VAL_GRS1: + ir_tcl_grs_del (&rl->u.dbrec.u.grs1); + break; + default: + break; + } + xfree (rl->u.dbrec.buf); + rl->u.dbrec.buf = NULL; + break; + case Z_NamePlusRecord_surrogateDiagnostic: + ir_deleteDiags (&rl->u.surrogateDiagnostics.list, + &rl->u.surrogateDiagnostics.num); + break; + } + xfree (rl->elements); +} + static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj, int no, int which, const char *elements) @@ -340,18 +462,7 @@ static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj, if (no == rl->no && (!rl->elements || !elements || !strcmp(elements, rl->elements))) { - free (rl->elements); - switch (rl->which) - { - case Z_NamePlusRecord_databaseRecord: - free (rl->u.dbrec.buf); - rl->u.dbrec.buf = NULL; - break; - case Z_NamePlusRecord_surrogateDiagnostic: - ir_deleteDiags (&rl->u.surrogateDiagnostics.list, - &rl->u.surrogateDiagnostics.num); - break; - } + delete_IR_record (rl); break; } } @@ -375,13 +486,16 @@ int ir_tcl_eval (Tcl_Interp *interp, const char *command) char *tmp = ir_tcl_malloc (strlen(command)+1); int r; + logf (LOG_DEBUG, "Invoking %.23s ...", command); strcpy (tmp, command); r = Tcl_Eval (interp, tmp); if (r == TCL_ERROR) + { logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine, interp->result); + } Tcl_FreeResult (interp); - free (tmp); + xfree (tmp); return r; } @@ -431,18 +545,9 @@ static void delete_IR_records (IrTcl_SetObj *setobj) for (rl = setobj->record_list; rl; rl = rl1) { - switch (rl->which) - { - case Z_NamePlusRecord_databaseRecord: - free (rl->u.dbrec.buf); - break; - case Z_NamePlusRecord_surrogateDiagnostic: - ir_deleteDiags (&rl->u.surrogateDiagnostics.list, - &rl->u.surrogateDiagnostics.num); - break; - } + delete_IR_record (rl); rl1 = rl->next; - free (rl); + xfree (rl); } setobj->record_list = NULL; } @@ -464,6 +569,24 @@ int ir_tcl_get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; } + +/* + * ir_tcl_method_error + */ +int ir_tcl_method_error (Tcl_Interp *interp, int argc, char **argv, + IrTcl_Methods *tab) +{ + IrTcl_Methods *tab_i = tab; + IrTcl_Method *t; + + Tcl_AppendResult (interp, "bad method: \"", *argv, " ", argv[1], + "\"\nmethod should be of:", NULL); + for (tab_i = tab; tab_i->tab; tab_i++) + for (t = tab_i->tab; t->name; t++) + Tcl_AppendResult (interp, " ", t->name, NULL); + return TCL_ERROR; +} + /* * ir_tcl_method: Search for method in table and invoke method handler */ @@ -489,13 +612,6 @@ int ir_tcl_method (Tcl_Interp *interp, int argc, char **argv, if (argc <= 0) return TCL_OK; -#if 0 - Tcl_AppendResult (interp, "Bad method: ", argv[1], - ". Possible methods:", NULL); - for (tab_i = tab; tab_i->tab; tab_i++) - for (t = tab_i->tab; t->name; t++) - Tcl_AppendResult (interp, " ", t->name, NULL); -#endif *ret = TCL_ERROR; return TCL_ERROR; } @@ -521,8 +637,8 @@ int ir_tcl_named_bits (struct ir_named_entry *tab, Odr_bitmask *ob, } if (!ti->name) { - Tcl_AppendResult (interp, "Bad bit mask: ", argv[no], NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "bad bit mask ", argv[no], NULL); + return ir_tcl_error_exec (interp, argc, argv); } } return TCL_OK; @@ -548,7 +664,7 @@ static void set_referenceId (ODR o, Z_ReferenceId **dst, const char *src) static void get_referenceId (char **dst, Z_ReferenceId *src) { - free (*dst); + xfree (*dst); if (!src) { *dst = NULL; @@ -573,10 +689,11 @@ static int do_init_request (void *obj, Tcl_Interp *interp, if (argc <= 0) return TCL_OK; + logf (LOG_DEBUG, "init %s", *argv); if (!p->cs_link) { - interp->result = "init: not connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "not connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } apdu = zget_APDU (p->odr_out, Z_APDU_initRequest); req = apdu->u.initRequest; @@ -851,7 +968,7 @@ static int do_implementationName (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->implementationName); if (argc == 3) { - free (p->implementationName); + xfree (p->implementationName); if (ir_tcl_strdup (interp, &p->implementationName, argv[2]) == TCL_ERROR) return TCL_ERROR; @@ -886,7 +1003,11 @@ static int do_implementationVersion (void *obj, Tcl_Interp *interp, if (argc == 0) return ir_tcl_strdup (interp, &p->implementationVersion, - "YAZ: " YAZ_VERSION " / IrTcl: " IR_TCL_VERSION); + "YAZ: " YAZ_VERSION +#ifdef IR_TCL_VERSION + " / Irtcl: " IR_TCL_VERSION +#endif + ); else if (argc == -1) return ir_tcl_strdel (interp, &p->implementationVersion); Tcl_AppendResult (interp, p->implementationVersion, (char*) NULL); @@ -960,10 +1081,10 @@ static int do_idAuthentication (void *obj, Tcl_Interp *interp, if (argc >= 3 || argc == -1) { - free (p->idAuthenticationOpen); - free (p->idAuthenticationGroupId); - free (p->idAuthenticationUserId); - free (p->idAuthenticationPassword); + xfree (p->idAuthenticationOpen); + xfree (p->idAuthenticationGroupId); + xfree (p->idAuthenticationUserId); + xfree (p->idAuthenticationPassword); } if (argc >= 3 || argc <= 0) { @@ -1022,12 +1143,23 @@ static int do_connect (void *obj, Tcl_Interp *interp, if (argc <= 0) return TCL_OK; - if (argc == 3) + if (argc > 3) + { + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " ?hostname?\"", NULL); + return TCL_ERROR; + } + else if (argc < 3) + { + Tcl_AppendResult (interp, p->hostname, NULL); + } + else { + logf (LOG_DEBUG, "connect %s %s", *argv, argv[2]); if (p->hostname) { - interp->result = "already connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "already connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } if (!strcmp (p->comstackType, "tcpip")) { @@ -1035,8 +1167,8 @@ static int do_connect (void *obj, Tcl_Interp *interp, addr = tcpip_strtoaddr (argv[2]); if (!addr) { - interp->result = "tcpip_strtoaddr fail"; - return TCL_ERROR; + Tcl_AppendResult (interp, "tcpip_strtoaddr fail", NULL); + return ir_tcl_error_exec (interp, argc, argv); } logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]); } @@ -1047,106 +1179,65 @@ static int do_connect (void *obj, Tcl_Interp *interp, addr = mosi_strtoaddr (argv[2]); if (!addr) { - interp->result = "mosi_strtoaddr fail"; - return TCL_ERROR; + Tcl_AppendResult (interp, "mosi_strtoaddr fail", NULL); + return ir_tcl_error_exec (interp, argc, argv); } logf (LOG_DEBUG, "mosi connect %s", argv[2]); #else - interp->result = "MOSI support not there"; - return TCL_ERROR; + Tcl_AppendResult (interp, "mosi not supported", NULL); + return ir_tcl_error_exec (interp, argc, argv); #endif } else { - Tcl_AppendResult (interp, "Bad comstack type: ", + Tcl_AppendResult (interp, "bad comstack type ", p->comstackType, NULL); - return TCL_ERROR; + return ir_tcl_error_exec (interp, argc, argv); } if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR) return TCL_ERROR; -#if IRTCL_GENERIC_FILES -#ifdef WINDOWS - p->csFile = Tcl_GetFile (cs_fileno(p->cs_link), TCL_WIN_SOCKET); -#else - p->csFile = Tcl_GetFile (cs_fileno(p->cs_link), TCL_UNIX_FD); -#endif -#endif + p->eventType = "connect"; if ((r=cs_connect (p->cs_link, addr)) < 0) { - interp->result = "connect fail"; - do_disconnect (p, NULL, 2, NULL); - return TCL_ERROR; + ir_tcl_disconnect (p); + Tcl_AppendResult (interp, "conncet fail", NULL); + return ir_tcl_error_exec (interp, argc, argv); } - logf(LOG_DEBUG, "cs_connect() returned %d fd=%d", r, - cs_fileno(p->cs_link)); - p->eventType = "connect"; -#if IRTCL_GENERIC_FILES - ir_select_add (p->csFile, p); -#else ir_select_add (cs_fileno (p->cs_link), p); -#endif if (r == 1) { -#if IRTCL_GENERIC_FILES - ir_select_add_write (p->csFile, p); -#else + logf (LOG_DEBUG, "connect pending fd=%d", cs_fileno(p->cs_link)); ir_select_add_write (cs_fileno (p->cs_link), p); -#endif p->state = IR_TCL_R_Connecting; } else { + logf (LOG_DEBUG, "connect ok fd=%d", cs_fileno(p->cs_link)); p->state = IR_TCL_R_Idle; if (p->callback) ir_tcl_eval (p->interp, p->callback); } } - else - Tcl_AppendResult (interp, p->hostname, NULL); return TCL_OK; } -/* - * do_disconnect: disconnect method on IR object +/* + * ir_tcl_disconnect: close connection */ -static int do_disconnect (void *obj, Tcl_Interp *interp, - int argc, char **argv) +void ir_tcl_disconnect (IrTcl_Obj *p) { - IrTcl_Obj *p = obj; - - if (argc == 0) - { - p->state = IR_TCL_R_Idle; - p->eventType = NULL; - p->hostname = NULL; - p->cs_link = NULL; -#if IRTCL_GENERIC_FILES - p->csFile = 0; -#endif - return TCL_OK; - } if (p->hostname) { - logf(LOG_DEBUG, "Closing connection to %s", p->hostname); - free (p->hostname); + logf(LOG_DEBUG, "Closing connection to %s", p->hostname); + xfree (p->hostname); p->hostname = NULL; -#if IRTCL_GENERIC_FILES - ir_select_remove_write (p->csFile, p); - ir_select_remove (p->csFile, p); -#else - ir_select_remove_write (cs_fileno (p->cs_link), p); + assert (p->cs_link); ir_select_remove (cs_fileno (p->cs_link), p); -#endif odr_reset (p->odr_in); - assert (p->cs_link); cs_close (p->cs_link); p->cs_link = NULL; -#if IRTCL_GENERIC_FILES - Tcl_FreeFile (p->csFile); - p->csFile = NULL; -#endif ODR_MASK_ZERO (&p->options); ODR_MASK_SET (&p->options, 0); @@ -1161,6 +1252,25 @@ static int do_disconnect (void *obj, Tcl_Interp *interp, ir_tcl_del_q (p); } assert (!p->cs_link); +} + +/* + * do_disconnect: disconnect method on IR object + */ +static int do_disconnect (void *obj, Tcl_Interp *interp, + int argc, char **argv) +{ + IrTcl_Obj *p = obj; + + if (argc == 0) + { + p->state = IR_TCL_R_Idle; + p->eventType = NULL; + p->hostname = NULL; + p->cs_link = NULL; + return TCL_OK; + } + ir_tcl_disconnect (p); return TCL_OK; } @@ -1178,7 +1288,7 @@ static int do_comstack (void *o, Tcl_Interp *interp, return ir_tcl_strdel (interp, &obj->comstackType); else if (argc == 3) { - free (obj->comstackType); + xfree (obj->comstackType); if (ir_tcl_strdup (interp, &obj->comstackType, argv[2]) == TCL_ERROR) return TCL_ERROR; } @@ -1239,7 +1349,7 @@ static int do_callback (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->callback); if (argc == 3) { - free (p->callback); + xfree (p->callback); if (argv[2][0]) { if (ir_tcl_strdup (interp, &p->callback, argv[2]) == TCL_ERROR) @@ -1268,7 +1378,7 @@ static int do_failback (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->failback); else if (argc == 3) { - free (p->failback); + xfree (p->failback); if (argv[2][0]) { if (ir_tcl_strdup (interp, &p->failback, argv[2]) == TCL_ERROR) @@ -1297,7 +1407,7 @@ static int do_initResponse (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->initResponse); if (argc == 3) { - free (p->initResponse); + xfree (p->initResponse); if (argv[2][0]) { if (ir_tcl_strdup (interp, &p->initResponse, argv[2]) == TCL_ERROR) @@ -1328,8 +1438,8 @@ static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv) p->protocol_type = PROTO_SR; else { - Tcl_AppendResult (interp, "Bad protocol: ", argv[2], NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "bad protocol ", argv[2], NULL); + return ir_tcl_error_exec (interp, argc, argv); } return TCL_OK; } @@ -1360,8 +1470,8 @@ static int do_triggerResourceControl (void *obj, Tcl_Interp *interp, return TCL_OK; if (!p->cs_link) { - interp->result = "triggerResourceControl: not connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "not connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } apdu = zget_APDU (p->odr_out, Z_APDU_triggerResourceControlRequest); req = apdu->u.triggerResourceControlRequest; @@ -1384,8 +1494,8 @@ static int do_databaseNames (void *obj, Tcl_Interp *interp, if (argc == -1) { for (i=0; inum_databaseNames; i++) - free (p->databaseNames[i]); - free (p->databaseNames); + xfree (p->databaseNames[i]); + xfree (p->databaseNames); } if (argc <= 0) { @@ -1402,8 +1512,8 @@ static int do_databaseNames (void *obj, Tcl_Interp *interp, if (p->databaseNames) { for (i=0; inum_databaseNames; i++) - free (p->databaseNames[i]); - free (p->databaseNames); + xfree (p->databaseNames[i]); + xfree (p->databaseNames); } p->num_databaseNames = argc - 2; p->databaseNames = @@ -1448,7 +1558,7 @@ static int do_queryType (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->queryType); if (argc == 3) { - free (p->queryType); + xfree (p->queryType); if (ir_tcl_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR) return TCL_ERROR; } @@ -1540,7 +1650,7 @@ static int do_referenceId (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->referenceId); if (argc == 3) { - free (p->referenceId); + xfree (p->referenceId); if (ir_tcl_strdup (interp, &p->referenceId, argv[2]) == TCL_ERROR) return TCL_ERROR; } @@ -1563,13 +1673,13 @@ static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp, } else if (argc == -1) { - free (p->preferredRecordSyntax); + xfree (p->preferredRecordSyntax); p->preferredRecordSyntax = NULL; return TCL_OK; } if (argc == 3) { - free (p->preferredRecordSyntax); + xfree (p->preferredRecordSyntax); p->preferredRecordSyntax = NULL; if (argv[2][0] && (p->preferredRecordSyntax = ir_tcl_malloc (sizeof(*p->preferredRecordSyntax)))) @@ -1577,8 +1687,9 @@ static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp, } else if (argc == 2) { - Tcl_AppendElement (interp, IrTcl_getRecordSyntaxStr - (*p->preferredRecordSyntax)); + Tcl_AppendElement + (interp,!p->preferredRecordSyntax ? "" : + IrTcl_getRecordSyntaxStr(*p->preferredRecordSyntax)); } return TCL_OK; @@ -1601,7 +1712,7 @@ static int do_elementSetNames (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->elementSetNames); if (argc == 3) { - free (p->elementSetNames); + xfree (p->elementSetNames); if (ir_tcl_strdup (interp, &p->elementSetNames, argv[2]) == TCL_ERROR) return TCL_ERROR; } @@ -1626,7 +1737,7 @@ static int do_smallSetElementSetNames (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->smallSetElementSetNames); if (argc == 3) { - free (p->smallSetElementSetNames); + xfree (p->smallSetElementSetNames); if (ir_tcl_strdup (interp, &p->smallSetElementSetNames, argv[2]) == TCL_ERROR) return TCL_ERROR; @@ -1652,7 +1763,7 @@ static int do_mediumSetElementSetNames (void *obj, Tcl_Interp *interp, return ir_tcl_strdel (interp, &p->mediumSetElementSetNames); if (argc == 3) { - free (p->mediumSetElementSetNames); + xfree (p->mediumSetElementSetNames); if (ir_tcl_strdup (interp, &p->mediumSetElementSetNames, argv[2]) == TCL_ERROR) return TCL_ERROR; @@ -1719,7 +1830,10 @@ static int ir_obj_method (ClientData clientData, Tcl_Interp *interp, int r; if (argc < 2) + { + Tcl_AppendResult (interp, wrongArgs, *argv, "method args...\"", NULL); return TCL_ERROR; + } tab[0].tab = ir_method_tab; tab[0].obj = p; @@ -1727,7 +1841,8 @@ static int ir_obj_method (ClientData clientData, Tcl_Interp *interp, tab[1].obj = &p->set_inher; tab[2].tab = NULL; - ir_tcl_method (interp, argc, argv, tab, &r); + if (ir_tcl_method (interp, argc, argv, tab, &r) == TCL_ERROR) + return ir_tcl_method_error (interp, argc, argv, tab); return r; } @@ -1757,7 +1872,7 @@ static void ir_obj_delete (ClientData clientData) odr_destroy (obj->odr_in); odr_destroy (obj->odr_out); odr_destroy (obj->odr_pr); - free (obj); + xfree (obj); } /* @@ -1775,7 +1890,7 @@ int ir_obj_init (ClientData clientData, Tcl_Interp *interp, if (argc != 2) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " objName\"", NULL); return TCL_ERROR; } obj = ir_tcl_malloc (sizeof(*obj)); @@ -1791,6 +1906,7 @@ int ir_obj_init (ClientData clientData, Tcl_Interp *interp, logf (LOG_DEBUG, "ir object create %s", argv[1]); obj->odr_in = odr_createmem (ODR_DECODE); + odr_choice_enable_bias (obj->odr_in, 0); obj->odr_out = odr_createmem (ODR_ENCODE); obj->odr_pr = odr_createmem (ODR_PRINT); obj->state = IR_TCL_R_Idle; @@ -1853,36 +1969,34 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) IrTcl_SetObj *obj = o; IrTcl_Obj *p; int r; - oident bib1; if (argc <= 0) return TCL_OK; p = obj->parent; + assert (argc > 1); if (argc != 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], "query\"", + NULL); return TCL_ERROR; } + logf (LOG_DEBUG, "search %s %s", *argv, argv[2]); if (!obj->set_inher.num_databaseNames) { - interp->result = "no databaseNames"; - return TCL_ERROR; + Tcl_AppendResult (interp, "no databaseNames", NULL); + return ir_tcl_error_exec (interp, argc, argv); } if (!p->cs_link) { - interp->result = "search: not connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "not connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest); req = apdu->u.searchRequest; obj->start = 1; - bib1.proto = p->protocol_type; - bib1.oclass = CLASS_ATTSET; - bib1.value = VAL_BIB1; - set_referenceId (p->odr_out, &req->referenceId, obj->set_inher.referenceId); @@ -1890,7 +2004,7 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) req->largeSetLowerBound = &obj->set_inher.largeSetLowerBound; req->mediumSetPresentNumber = &obj->set_inher.mediumSetPresentNumber; req->replaceIndicator = &obj->set_inher.replaceIndicator; - req->resultSetName = obj->setName ? obj->setName : "Default"; + req->resultSetName = obj->setName ? obj->setName : "default"; logf (LOG_DEBUG, "Search, resultSetName %s", req->resultSetName); req->num_databaseNames = obj->set_inher.num_databaseNames; req->databaseNames = obj->set_inher.databaseNames; @@ -1935,21 +2049,20 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) req->mediumSetElementSetNames = NULL; req->query = &query; - + + logf (LOG_DEBUG, "queryType %s", obj->set_inher.queryType); if (!strcmp (obj->set_inher.queryType, "rpn")) { Z_RPNQuery *RPNquery; - RPNquery = p_query_rpn (p->odr_out, argv[2]); + RPNquery = p_query_rpn (p->odr_out, p->protocol_type, argv[2]); if (!RPNquery) { - Tcl_AppendResult (interp, "Syntax error in query", NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "query syntax error", NULL); + return ir_tcl_error_exec (interp, argc, argv); } - RPNquery->attributeSetId = oid_getoidbyent (&bib1); query.which = Z_Query_type_1; query.u.type_1 = RPNquery; - logf (LOG_DEBUG, "RPN"); } #if CCL2RPN else if (!strcmp (obj->set_inher.queryType, "cclrpn")) @@ -1958,21 +2071,27 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) int pos; struct ccl_rpn_node *rpn; Z_RPNQuery *RPNquery; + oident bib1; + + bib1.proto = p->protocol_type; + bib1.oclass = CLASS_ATTSET; + bib1.value = VAL_BIB1; rpn = ccl_find_str(p->bibset, argv[2], &error, &pos); if (error) { - Tcl_AppendResult (interp, "CCL error: ", - ccl_err_msg(error), NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "ccl syntax error ", ccl_err_msg(error), + NULL); + return ir_tcl_error_exec (interp, argc, argv); } +#if 0 ccl_pr_tree (rpn, stderr); fprintf (stderr, "\n"); +#endif assert((RPNquery = ccl_rpn_query(rpn))); RPNquery->attributeSetId = oid_getoidbyent (&bib1); query.which = Z_Query_type_1; query.u.type_1 = RPNquery; - logf (LOG_DEBUG, "CCLRPN"); } #endif else if (!strcmp (obj->set_inher.queryType, "ccl")) @@ -1981,12 +2100,12 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) query.u.type_2 = &ccl_query; ccl_query.buf = (unsigned char *) argv[2]; ccl_query.len = strlen (argv[2]); - logf (LOG_DEBUG, "CCL"); } else { - interp->result = "unknown query method"; - return TCL_ERROR; + Tcl_AppendResult (interp, "invalid query method ", + obj->set_inher.queryType, NULL); + return ir_tcl_error_exec (interp, argc, argv); } return ir_tcl_send_APDU (interp, p, apdu, "search", *argv); } @@ -2008,7 +2127,7 @@ static int do_searchResponse (void *o, Tcl_Interp *interp, return ir_tcl_strdel (interp, &obj->searchResponse); if (argc == 3) { - free (obj->searchResponse); + xfree (obj->searchResponse); if (argv[2][0]) { if (ir_tcl_strdup (interp, &obj->searchResponse, argv[2]) @@ -2038,7 +2157,7 @@ static int do_presentResponse (void *o, Tcl_Interp *interp, return ir_tcl_strdel (interp, &obj->presentResponse); if (argc == 3) { - free (obj->presentResponse); + xfree (obj->presentResponse); if (argv[2][0]) { if (ir_tcl_strdup (interp, &obj->presentResponse, argv[2]) @@ -2125,7 +2244,7 @@ static int do_setName (void *o, Tcl_Interp *interp, return ir_tcl_strdel (interp, &obj->setName); if (argc == 3) { - free (obj->setName); + xfree (obj->setName); if (ir_tcl_strdup (interp, &obj->setName, argv[2]) == TCL_ERROR) return TCL_ERROR; @@ -2172,7 +2291,8 @@ static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv) } if (argc != 3) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2180,7 +2300,7 @@ static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv) rl = find_IR_record (obj, offset); if (!rl) { - logf (LOG_DEBUG, "No record at position %d", offset); + logf (LOG_DEBUG, "%s %s %s: no record", argv[0], argv[1], argv[2]); return TCL_OK; } switch (rl->which) @@ -2215,14 +2335,18 @@ static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv) } if (argc != 3) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) return TCL_ERROR; rl = find_IR_record (obj, offset); if (!rl) + { + logf (LOG_DEBUG, "%s %s %s: no record", argv[0], argv[1], argv[2]); return TCL_OK; + } if (rl->which != Z_NamePlusRecord_databaseRecord) { Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL); @@ -2250,12 +2374,13 @@ static int do_recordElements (void *o, Tcl_Interp *interp, return ir_tcl_strdel (NULL, &obj->recordElements); if (argc > 3) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " ?position?\"", NULL); return TCL_ERROR; } if (argc == 3) { - free (obj->recordElements); + xfree (obj->recordElements); return ir_tcl_strdup (NULL, &obj->recordElements, (*argv[2] ? argv[2] : NULL)); } @@ -2274,7 +2399,6 @@ static int ir_diagResult (Tcl_Interp *interp, IrTcl_Diagnostic *list, int num) for (i = 0; iresult, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2336,7 +2461,8 @@ static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; if (argc < 7) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position line|field tag ind field\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2368,7 +2494,8 @@ static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; if (argc != 3) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2392,7 +2519,7 @@ static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv) /* - * do_getGrs: Get a GRS1 Record + * do_getGrs: Get a GRS-1 Record */ static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv) { @@ -2404,7 +2531,8 @@ static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; if (argc < 3) { - sprintf (interp->result, "wrong # args"); + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position ?(set,tag) (set,tag) ...?\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2427,6 +2555,55 @@ static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv) /* + * do_getExplain: Get an Explain Record + */ +static int do_getExplain (void *o, Tcl_Interp *interp, int argc, char **argv) +{ + IrTcl_SetObj *obj = o; + IrTcl_Obj *p = obj->parent; + void *rr; + Z_ext_typeent *etype; + int offset; + IrTcl_RecordList *rl; + + if (argc <= 0) + return TCL_OK; + if (argc < 3) + { + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position ?mask? ...\"", NULL); + return TCL_ERROR; + } + if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) + return TCL_ERROR; + rl = find_IR_record (obj, offset); + if (!rl) + { + Tcl_AppendResult (interp, "No record at #", argv[2], NULL); + return TCL_ERROR; + } + if (rl->which != Z_NamePlusRecord_databaseRecord) + { + Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL); + return TCL_ERROR; + } + if (rl->u.dbrec.type != VAL_EXPLAIN) + return TCL_OK; + + if (!(etype = z_ext_getentbyref (VAL_EXPLAIN))) + return TCL_OK; + + odr_setbuf (p->odr_in, rl->u.dbrec.buf, rl->u.dbrec.size, 0); + if (!(*etype->fun)(p->odr_in, &rr, 0)) + return TCL_OK; + + if (etype->what != Z_External_explainRecord) + return TCL_OK; + + return ir_tcl_get_explain (interp, rr, argc, argv); +} + +/* * do_responseStatus: Return response status (present or search) */ static int do_responseStatus (void *o, Tcl_Interp *interp, @@ -2494,13 +2671,13 @@ static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv) } else number = 10; + logf (LOG_DEBUG, "present %s %d %d", *argv, start, number); p = obj->parent; if (!p->cs_link) { - interp->result = "present: not connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "not connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } - obj->start = start; obj->number = number; @@ -2545,47 +2722,165 @@ static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv) return ir_tcl_send_APDU (interp, p, apdu, "present", *argv); } +#define IR_TCL_RECORD_ENCODING_ISO2709 1 +#define IR_TCL_RECORD_ENCODING_RAW 2 + +typedef struct { + int encoding; + int syntax; + int size; +} IrTcl_FileRecordHead; + /* * do_loadFile: Load result set from file */ - static int do_loadFile (void *o, Tcl_Interp *interp, int argc, char **argv) { IrTcl_SetObj *setobj = o; FILE *inf; size_t size; - int no = 1; + int offset; + int start = 1; + int number = 30000; char *buf; - + if (argc <= 0) return TCL_OK; - if (argc != 3) + if (argc < 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " filename ?start? ?number?\"", NULL); return TCL_ERROR; } + if (argc > 3) + start = atoi (argv[3]); + if (argc > 4) + number = atoi (argv[4]); + offset = start; + inf = fopen (argv[2], "r"); if (!inf) { Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL); - return TCL_ERROR; + return ir_tcl_error_exec (interp, argc, argv); } - while ((buf = ir_tcl_fread_marc (inf, &size))) + while (offset < (start+number)) { + IrTcl_FileRecordHead head; IrTcl_RecordList *rl; - rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord, "F"); - rl->u.dbrec.type = VAL_USMARC; - rl->u.dbrec.buf = buf; - rl->u.dbrec.size = size; - no++; + if (fread (&head, sizeof(head), 1, inf) < 1) + break; + rl = new_IR_record (setobj, offset, + Z_NamePlusRecord_databaseRecord, + (argc > 5) ? argv[5] : NULL); + rl->u.dbrec.type = head.syntax; + if (head.encoding == IR_TCL_RECORD_ENCODING_ISO2709) + { + if (!(buf = ir_tcl_fread_marc (inf, &size))) + break; + rl->u.dbrec.buf = buf; + rl->u.dbrec.size = size; + if (size != head.size) + { + fclose (inf); + Tcl_AppendResult (interp, "bad ISO2709 encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + } + else if (head.encoding == IR_TCL_RECORD_ENCODING_RAW) + { + rl->u.dbrec.size = head.size; + rl->u.dbrec.buf = ir_tcl_malloc (head.size + 1); + if (fread (rl->u.dbrec.buf, rl->u.dbrec.size, 1, inf) < 1) + { + fclose (inf); + Tcl_AppendResult (interp, "bad raw encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + rl->u.dbrec.buf[rl->u.dbrec.size] = '\0'; + } + else + { + rl->u.dbrec.buf = NULL; + rl->u.dbrec.size = 0; + fclose (inf); + Tcl_AppendResult (interp, "bad encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + offset++; } - setobj->numberOfRecordsReturned = no-1; + setobj->numberOfRecordsReturned = offset - start; fclose (inf); return TCL_OK; } +/* + * do_saveFile: Save result set on file + */ +static int do_saveFile (void *o, Tcl_Interp *interp, + int argc, char **argv) +{ + IrTcl_SetObj *setobj = o; + FILE *outf; + int offset; + int start = 1; + int number = 30000; + IrTcl_RecordList *rl; + + if (argc <= 0) + return TCL_OK; + if (argc < 3) + { + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " filename ?start? ?number?\"", NULL); + return TCL_ERROR; + } + if (argc > 3) + start = atoi (argv[3]); + if (argc > 4) + number = atoi (argv[4]); + offset = start; + + outf = fopen (argv[2], "w"); + if (!outf) + { + Tcl_AppendResult (interp, "cannot open file", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + while (offset < (start+number) && (rl = find_IR_record (setobj, offset))) + { + if (rl->which == Z_NamePlusRecord_databaseRecord && + rl->u.dbrec.buf && rl->u.dbrec.size) + { + IrTcl_FileRecordHead head; + + head.encoding = IR_TCL_RECORD_ENCODING_RAW; + head.syntax = rl->u.dbrec.type; + head.size = rl->u.dbrec.size; + if (fwrite (&head, sizeof(head), 1, outf) < 1) + { + Tcl_AppendResult (interp, "cannot write", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + if (fwrite (rl->u.dbrec.buf, rl->u.dbrec.size, 1, outf) < 1) + { + Tcl_AppendResult (interp, "cannot write", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + } + offset++; + } + if (fclose (outf)) + { + Tcl_AppendResult (interp, "cannot write ", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } + return TCL_OK; +} + + static IrTcl_Method ir_set_method_tab[] = { { "search", do_search, NULL}, { "searchResponse", do_searchResponse, NULL}, @@ -2601,11 +2896,13 @@ static IrTcl_Method ir_set_method_tab[] = { { "getMarc", do_getMarc, NULL}, { "getSutrs", do_getSutrs, NULL}, { "getGrs", do_getGrs, NULL}, + { "getExplain", do_getExplain, NULL}, { "recordType", do_recordType, NULL}, { "recordElements", do_recordElements, NULL}, { "diag", do_diag, NULL}, { "responseStatus", do_responseStatus, NULL}, { "loadFile", do_loadFile, NULL}, + { "saveFile", do_saveFile, NULL}, { NULL, NULL} }; @@ -2621,7 +2918,7 @@ static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp, if (argc < 2) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " method args...\"", NULL); return TCL_ERROR; } tabs[0].tab = ir_set_method_tab; @@ -2630,7 +2927,8 @@ static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp, tabs[1].obj = &p->set_inher; tabs[2].tab = NULL; - ir_tcl_method (interp, argc, argv, tabs, &r); + if (ir_tcl_method (interp, argc, argv, tabs, &r) == TCL_ERROR) + return ir_tcl_method_error (interp, argc, argv, tabs); return r; } @@ -2652,7 +2950,7 @@ static void ir_set_obj_delete (ClientData clientData) ir_tcl_method (NULL, -1, NULL, tabs, NULL); - free (p); + xfree (p); } /* @@ -2667,11 +2965,12 @@ static int ir_set_obj_init (ClientData clientData, Tcl_Interp *interp, if (argc < 2 || argc > 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, + " objSetName ?objParent?\"", NULL); return TCL_ERROR; } obj = ir_tcl_malloc (sizeof(*obj)); - logf (LOG_DEBUG, "ir set create"); + logf (LOG_DEBUG, "ir set create %s", argv[1]); if (parentData) { int i; @@ -2758,8 +3057,8 @@ static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp, Tcl_CmdInfo parent_info; if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info)) { - interp->result = "No parent"; - return TCL_ERROR; + Tcl_AppendResult (interp, "no object parent", NULL); + return ir_tcl_error_exec (interp, argc, argv); } parentData = parent_info.clientData; } @@ -2789,8 +3088,8 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv) Z_APDU *apdu; IrTcl_ScanObj *obj = o; IrTcl_Obj *p = obj->parent; - oident bib1; #if CCL2RPN + oident bib1; struct ccl_rpn_node *rpn; int pos; #endif @@ -2799,47 +3098,49 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; if (argc != 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " scanQuery\"", NULL); return TCL_ERROR; } + logf (LOG_DEBUG, "scan %s %s", *argv, argv[2]); if (!p->set_inher.num_databaseNames) { - interp->result = "no databaseNames"; - return TCL_ERROR; + Tcl_AppendResult (interp, "no databaseNames", NULL); + return ir_tcl_error_exec (interp, argc, argv); } if (!p->cs_link) { - interp->result = "scan: not connected"; - return TCL_ERROR; + Tcl_AppendResult (interp, "not connected", NULL); + return ir_tcl_error_exec (interp, argc, argv); } - bib1.proto = p->protocol_type; - bib1.oclass = CLASS_ATTSET; - bib1.value = VAL_BIB1; - apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest); req = apdu->u.scanRequest; set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId); req->num_databaseNames = p->set_inher.num_databaseNames; req->databaseNames = p->set_inher.databaseNames; - req->attributeSet = oid_getoidbyent (&bib1); #if !CCL2RPN - if (!(req->termListAndStartPoint = p_query_scan (p->odr_out, argv[2]))) + if (!(req->termListAndStartPoint = + p_query_scan (p->odr_out, p->protocol_type, + &req->attributeSet, argv[2]))) { - Tcl_AppendResult (interp, "Syntax error in query", NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "query syntax error", NULL); + return ir_tcl_error_exec (interp, argc, argv); } #else rpn = ccl_find_str(p->bibset, argv[2], &r, &pos); if (r) { - Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "ccl syntax error ", ccl_err_msg(r), NULL); + return ir_tcl_error_exec (interp, argc, argv); } - ccl_pr_tree (rpn, stderr); - fprintf (stderr, "\n"); + bib1.proto = p->protocol_type; + bib1.oclass = CLASS_ATTSET; + bib1.value = VAL_BIB1; + + req->attributeSet = oid_getoidbyent (&bib1); if (!(req->termListAndStartPoint = ccl_scan_query (rpn))) return TCL_ERROR; #endif @@ -2872,7 +3173,7 @@ static int do_scanResponse (void *o, Tcl_Interp *interp, return ir_tcl_strdel (interp, &obj->scanResponse); if (argc == 3) { - free (obj->scanResponse); + xfree (obj->scanResponse); if (argv[2][0]) { if (ir_tcl_strdup (interp, &obj->scanResponse, argv[2]) @@ -3003,7 +3304,8 @@ static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv) } if (argc != 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " position\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR) @@ -3055,14 +3357,15 @@ static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp, if (argc < 2) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " method args...\"", NULL); return TCL_ERROR; } tabs[0].tab = ir_scan_method_tab; tabs[0].obj = clientData; tabs[1].tab = NULL; - ir_tcl_method (interp, argc, argv, tabs, &r); + if (ir_tcl_method (interp, argc, argv, tabs, &r) == TCL_ERROR) + return ir_tcl_method_error (interp, argc, argv, tabs); return r; } @@ -3079,7 +3382,7 @@ static void ir_scan_obj_delete (ClientData clientData) tabs[1].tab = NULL; ir_tcl_method (NULL, -1, NULL, tabs, NULL); - free (obj); + xfree (obj); } /* @@ -3094,13 +3397,15 @@ static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp, if (argc != 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, + "objScanName objParentName\"", NULL); return TCL_ERROR; } + logf (LOG_DEBUG, "ir scan create %s", argv[1]); if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info)) { - interp->result = "No parent"; - return TCL_ERROR; + Tcl_AppendResult (interp, "no object parent", NULL); + return ir_tcl_error_exec (interp, argc, argv); } obj = ir_tcl_malloc (sizeof(*obj)); obj->parent = (IrTcl_Obj *) parent_info.clientData; @@ -3118,6 +3423,28 @@ static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp, /* ------------------------------------------------------- */ +/* + * ir_log_proc: set yaz log level + */ +static int ir_log_init_proc (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + if (argc <= 1 || argc > 4) + { + Tcl_AppendResult (interp, wrongArgs, *argv, + " ?level ?prefix ?filename\"", NULL); + return TCL_OK; + } + if (argc == 2) + log_init (log_mask_str (argv[1]), "", NULL); + else if (argc == 3) + log_init (log_mask_str (argv[1]), argv[2], NULL); + else + log_init (log_mask_str (argv[1]), argv[2], argv[3]); + return TCL_OK; +} + +/* ------------------------------------------------------- */ static void ir_initResponse (void *obj, Z_InitResponse *initrs) { IrTcl_Obj *p = obj; @@ -3130,13 +3457,13 @@ static void ir_initResponse (void *obj, Z_InitResponse *initrs) get_referenceId (&p->set_inher.referenceId, initrs->referenceId); - free (p->targetImplementationId); + xfree (p->targetImplementationId); ir_tcl_strdup (p->interp, &p->targetImplementationId, initrs->implementationId); - free (p->targetImplementationName); + xfree (p->targetImplementationName); ir_tcl_strdup (p->interp, &p->targetImplementationName, initrs->implementationName); - free (p->targetImplementationVersion); + xfree (p->targetImplementationVersion); ir_tcl_strdup (p->interp, &p->targetImplementationVersion, initrs->implementationVersion); @@ -3146,7 +3473,7 @@ static void ir_initResponse (void *obj, Z_InitResponse *initrs) memcpy (&p->options, initrs->options, sizeof(initrs->options)); memcpy (&p->protocolVersion, initrs->protocolVersion, sizeof(initrs->protocolVersion)); - free (p->userInformationField); + xfree (p->userInformationField); p->userInformationField = NULL; if (initrs->userInformationField) { @@ -3170,14 +3497,14 @@ static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num) { int i; for (i = 0; i<*dst_num; i++) - free (dst_list[i]->addinfo); - free (*dst_list); + xfree (dst_list[i]->addinfo); + xfree (*dst_list); *dst_list = NULL; *dst_num = 0; } static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, - Z_DiagRec **list, int num) + Z_DiagRec **list, int num) { int i; char *addinfo; @@ -3186,6 +3513,7 @@ static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, *dst_list = ir_tcl_malloc (sizeof(**dst_list) * num); for (i = 0; iwhich) { case Z_DiagRec_defaultFormat: @@ -3194,6 +3522,9 @@ static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, if (addinfo && ((*dst_list)[i].addinfo = ir_tcl_malloc (strlen(addinfo)+1))) strcpy ((*dst_list)[i].addinfo, addinfo); + cp = diagbib1_str ((*dst_list)[i].condition); + logf (LOG_DEBUG, "Diag %d %s %s", (*dst_list)[i].condition, + cp ? cp : "", addinfo ? addinfo : ""); break; default: (*dst_list)[i].addinfo = NULL; @@ -3202,7 +3533,86 @@ static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, } } -static void ir_handleRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj, +static void ir_handleDBRecord (IrTcl_Obj *p, IrTcl_RecordList *rl, + Z_External *oe) +{ + struct oident *ident; + Z_ext_typeent *etype; + + rl->u.dbrec.size = oe->u.octet_aligned->len; + rl->u.dbrec.buf = NULL; + + if ((ident = oid_getentbyoid (oe->direct_reference))) + rl->u.dbrec.type = ident->value; + else + rl->u.dbrec.type = VAL_USMARC; + + if (ident && (oe->which == Z_External_single || + oe->which == Z_External_octet) + && (etype = z_ext_getentbyref (ident->value))) + { + void *rr; + + odr_setbuf (p->odr_in, (char*) oe->u.octet_aligned->buf, + oe->u.octet_aligned->len, 0); + if (!(*etype->fun)(p->odr_in, &rr, 0)) + return; + switch (etype->what) + { + case Z_External_sutrs: + logf (LOG_DEBUG, "Z_External_sutrs"); + oe->u.sutrs = rr; + if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1))) + { + memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf, + oe->u.sutrs->len); + rl->u.dbrec.buf[oe->u.sutrs->len] = '\0'; + } + rl->u.dbrec.size = oe->u.sutrs->len; + break; + case Z_External_grs1: + logf (LOG_DEBUG, "Z_External_grs1"); + oe->u.grs1 = rr; + ir_tcl_grs_mk (oe->u.grs1, &rl->u.dbrec.u.grs1); + break; + case Z_External_explainRecord: + logf (LOG_DEBUG, "Z_External_explainRecord"); + if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size))) + { + memcpy (rl->u.dbrec.buf, oe->u.octet_aligned->buf, + rl->u.dbrec.size); + } + break; + } + } + else + { + if (oe->which == Z_External_octet && rl->u.dbrec.size > 0) + { + char *buf = (char*) oe->u.octet_aligned->buf; + if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size))) + memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size); + } + else if (rl->u.dbrec.type == VAL_SUTRS && + oe->which == Z_External_sutrs) + { + if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1))) + { + memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf, + oe->u.sutrs->len); + rl->u.dbrec.buf[oe->u.sutrs->len] = '\0'; + } + rl->u.dbrec.size = oe->u.sutrs->len; + } + else if (rl->u.dbrec.type == VAL_GRS1 && + oe->which == Z_External_grs1) + { + ir_tcl_grs_mk (oe->u.grs1, &rl->u.dbrec.u.grs1); + } + } +} + +static void ir_handleZRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj, const char *elements) { IrTcl_Obj *p = o; @@ -3220,64 +3630,21 @@ static void ir_handleRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj, setobj->numberOfRecordsReturned = zrs->u.databaseOrSurDiagnostics->num_records; logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned); - for (offset = 0; offsetnumberOfRecordsReturned; offset++) + for (offset = 0; offset < setobj->numberOfRecordsReturned; offset++) { - rl = new_IR_record (setobj, setobj->start + offset, - zrs->u.databaseOrSurDiagnostics-> - records[offset]->which, + Z_NamePlusRecord *znpr = zrs->u.databaseOrSurDiagnostics-> + records[offset]; + + rl = new_IR_record (setobj, setobj->start + offset, znpr->which, elements); if (rl->which == Z_NamePlusRecord_surrogateDiagnostic) - { ir_handleDiags (&rl->u.surrogateDiagnostics.list, &rl->u.surrogateDiagnostics.num, - &zrs->u.databaseOrSurDiagnostics-> - records[offset]->u.surrogateDiagnostic, + &znpr->u.surrogateDiagnostic, 1); - } else - { - Z_DatabaseRecord *zr; - Z_External *oe; - struct oident *ident; - - zr = zrs->u.databaseOrSurDiagnostics->records[offset] - ->u.databaseRecord; - oe = (Z_External*) zr; - rl->u.dbrec.size = zr->u.octet_aligned->len; - - if ((ident = oid_getentbyoid (oe->direct_reference))) - rl->u.dbrec.type = ident->value; - else - rl->u.dbrec.type = VAL_USMARC; - - if (oe->which == ODR_EXTERNAL_octet && rl->u.dbrec.size > 0) - { - char *buf = (char*) zr->u.octet_aligned->buf; - if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size))) - memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size); - } - else if (rl->u.dbrec.type == VAL_SUTRS && - oe->which == Z_External_sutrs) - { - odr_setbuf (p->odr_in, (char*) oe->u.single_ASN1_type->buf, - oe->u.single_ASN1_type->len, 0); - if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1))) - { - memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf, - oe->u.sutrs->len); - rl->u.dbrec.buf[oe->u.sutrs->len] = '\0'; - } - rl->u.dbrec.size = oe->u.sutrs->len; - } - else if (rl->u.dbrec.type == VAL_GRS1 && - oe->which == Z_External_grs1) - { - ir_tcl_read_grs (oe->u.grs1, &rl->u.dbrec.u.grs1); - rl->u.dbrec.buf = NULL; - } - else - rl->u.dbrec.buf = NULL; - } + ir_handleDBRecord (p, rl, + (Z_External*) (znpr->u.databaseRecord)); } } else if (zrs->which == Z_Records_multipleNSD) @@ -3320,7 +3687,7 @@ static void ir_searchResponse (void *o, Z_SearchResponse *searchrs, if (searchrs->nextResultSetPosition) setobj->nextResultSetPosition = *searchrs->nextResultSetPosition; - logf (LOG_DEBUG, "Search response %d, %d hits", + logf (LOG_DEBUG, "status %d hits %d", setobj->searchStatus, setobj->resultCount); if (zrs) { @@ -3329,7 +3696,7 @@ static void ir_searchResponse (void *o, Z_SearchResponse *searchrs, es = setobj->set_inher.smallSetElementSetNames; else es = setobj->set_inher.mediumSetElementSetNames; - ir_handleRecords (o, zrs, setobj, es); + ir_handleZRecords (o, zrs, setobj, es); } else setobj->recordFlag = 0; @@ -3351,7 +3718,7 @@ static void ir_presentResponse (void *o, Z_PresentResponse *presrs, get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId); setobj->nextResultSetPosition = *presrs->nextResultSetPosition; if (zrs) - ir_handleRecords (o, zrs, setobj, setobj->set_inher.elementSetNames); + ir_handleZRecords (o, zrs, setobj, setobj->set_inher.elementSetNames); else { setobj->recordFlag = 0; @@ -3384,7 +3751,7 @@ static void ir_scanResponse (void *o, Z_ScanResponse *scanrs, scanobj->positionOfTerm = -1; logf (LOG_DEBUG, "positionOfTerm=%d", scanobj->positionOfTerm); - free (scanobj->entries); + xfree (scanobj->entries); scanobj->entries = NULL; ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList, @@ -3465,7 +3832,7 @@ static void ir_select_read (ClientData clientData) logf(LOG_DEBUG, "Read handler fd=%d", cs_fileno(p->cs_link)); if (p->state == IR_TCL_R_Connecting) { - logf(LOG_DEBUG, "Connect handler"); + logf(LOG_DEBUG, "read: connect"); r = cs_rcvconnect (p->cs_link); if (r == 1) { @@ -3473,46 +3840,46 @@ static void ir_select_read (ClientData clientData) return; } p->state = IR_TCL_R_Idle; -#if IRTCL_GENERIC_FILES - ir_select_remove_write (p->csFile, p); -#else + p->ref_count = 2; ir_select_remove_write (cs_fileno (p->cs_link), p); -#endif if (r < 0) { logf (LOG_DEBUG, "cs_rcvconnect error"); + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_CONNECT; ir_tcl_eval (p->interp, p->failback); } - do_disconnect (p, NULL, 2, NULL); + ir_obj_delete (p); return; } - p->state = IR_TCL_R_Idle; if (p->callback) ir_tcl_eval (p->interp, p->callback); - if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle) + if (p->ref_count == 2 && p->cs_link && p->request_queue + && p->state == IR_TCL_R_Idle) ir_tcl_send_q (p, p->request_queue, "x"); + ir_obj_delete (p); return; } do { - /* signal one more use of ir object - callbacks must not - release the ir memory (p pointer) */ p->state = IR_TCL_R_Reading; - ++(p->ref_count); /* read incoming APDU */ - if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) <= 0) + if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) == 1) + { + logf(LOG_DEBUG, "PDU Fraction read"); + return ; + } + /* signal one more use of ir object - callbacks must not + release the ir memory (p pointer) */ + p->ref_count = 2; + if (r <= 0) { logf (LOG_DEBUG, "cs_get failed, code %d", r); -#if IRTCL_GENERIC_FILES - ir_select_remove (p->csFile, p); -#else ir_select_remove (cs_fileno (p->cs_link), p); -#endif - do_disconnect (p, NULL, 2, NULL); + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_READ; @@ -3522,11 +3889,6 @@ static void ir_select_read (ClientData clientData) ir_obj_delete (p); return; } - if (r == 1) - { - logf(LOG_DEBUG, "PDU Fraction read"); - return ; - } /* got complete APDU. Now decode */ p->apduLen = r; p->apduOffset = -1; @@ -3535,8 +3897,8 @@ static void ir_select_read (ClientData clientData) if (!z_APDU (p->odr_in, &apdu, 0)) { logf (LOG_DEBUG, "cs_get failed: %s", - odr_errmsg (odr_geterror (p->odr_in))); - do_disconnect (p, NULL, 2, NULL); + odr_errmsg (odr_geterror (p->odr_in))); + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_IN_APDU; @@ -3547,7 +3909,6 @@ static void ir_select_read (ClientData clientData) ir_obj_delete (p); return; } - logf(LOG_DEBUG, "Decoded ok"); /* handle APDU and invoke callback */ rq = p->request_queue; if (!rq) @@ -3556,7 +3917,7 @@ static void ir_select_read (ClientData clientData) exit (1); } object_name = rq->object_name; - logf (LOG_DEBUG, "getCommandInfo (%s)", object_name); + logf (LOG_DEBUG, "Object %s", object_name); apdu_call = NULL; if (Tcl_GetCommandInfo (p->interp, object_name, &cmd_info)) { @@ -3565,7 +3926,7 @@ static void ir_select_read (ClientData clientData) case Z_APDU_initResponse: p->eventType = "init"; ir_initResponse (p, apdu->u.initResponse); - apdu_call = p->initResponse; + apdu_call = p->initResponse; break; case Z_APDU_searchResponse: p->eventType = "search"; @@ -3591,7 +3952,7 @@ static void ir_select_read (ClientData clientData) default: logf (LOG_WARN, "Received unknown APDU type (%d)", apdu->which); - do_disconnect (p, NULL, 2, NULL); + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_UNKNOWN_APDU; @@ -3607,17 +3968,17 @@ static void ir_select_read (ClientData clientData) ir_tcl_eval (p->interp, apdu_call); else if (rq->callback) ir_tcl_eval (p->interp, rq->callback); - free (rq->buf_out); - free (rq->callback); - free (rq->object_name); - free (rq); + xfree (rq->buf_out); + xfree (rq->callback); + xfree (rq->object_name); + xfree (rq); odr_reset (p->odr_in); if (p->ref_count == 1) { ir_obj_delete (p); return; } - --(p->ref_count); + ir_obj_delete (p); } while (p->cs_link && cs_more (p->cs_link)); if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle) ir_tcl_send_q (p, p->request_queue, "x"); @@ -3626,7 +3987,7 @@ static void ir_select_read (ClientData clientData) /* * ir_select_write: handle outgoing packages - not yet written. */ -static void ir_select_write (ClientData clientData) +static int ir_select_write (ClientData clientData) { IrTcl_Obj *p = clientData; int r; @@ -3635,80 +3996,107 @@ static void ir_select_write (ClientData clientData) logf (LOG_DEBUG, "Write handler fd=%d", cs_fileno(p->cs_link)); if (p->state == IR_TCL_R_Connecting) { - logf(LOG_DEBUG, "Connect handler"); + logf(LOG_DEBUG, "write: connect"); r = cs_rcvconnect (p->cs_link); if (r == 1) - return; + { + logf (LOG_DEBUG, "cs_rcvconnect returned 1"); + return 2; + } p->state = IR_TCL_R_Idle; + p->ref_count = 2; + ir_select_remove_write (cs_fileno (p->cs_link), p); if (r < 0) { logf (LOG_DEBUG, "cs_rcvconnect error"); -#if IRTCL_GENERIC_FILES - ir_select_remove_write (p->csFile, p); -#else - ir_select_remove_write (cs_fileno (p->cs_link), p); -#endif + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_CONNECT; ir_tcl_eval (p->interp, p->failback); } - do_disconnect (p, NULL, 2, NULL); - return; + ir_obj_delete (p); + return 2; } -#if IRTCL_GENERIC_FILES - ir_select_remove_write (p->csFile, p); -#else - ir_select_remove_write (cs_fileno (p->cs_link), p); -#endif if (p->callback) ir_tcl_eval (p->interp, p->callback); - return; + ir_obj_delete (p); + return 2; } rq = p->request_queue; if (!rq || !rq->buf_out) - return; + return 0; assert (rq); if ((r=cs_put (p->cs_link, rq->buf_out, rq->len_out)) < 0) { logf (LOG_DEBUG, "cs_put write fail"); + p->ref_count = 2; + xfree (rq->buf_out); + rq->buf_out = NULL; + ir_tcl_disconnect (p); if (p->failback) { p->failInfo = IR_TCL_FAIL_WRITE; ir_tcl_eval (p->interp, p->failback); } - free (rq->buf_out); - rq->buf_out = NULL; - do_disconnect (p, NULL, 2, NULL); + ir_obj_delete (p); } else if (r == 0) /* remove select bit */ { - logf(LOG_DEBUG, "Write completed"); + logf (LOG_DEBUG, "Write completed"); p->state = IR_TCL_R_Waiting; -#if IRTCL_GENERIC_FILES - ir_select_remove_write (p->csFile, p); -#else ir_select_remove_write (cs_fileno (p->cs_link), p); -#endif - free (rq->buf_out); + xfree (rq->buf_out); rq->buf_out = NULL; } + return 1; } static void ir_select_notify (ClientData clientData, int r, int w, int e) { - if (r) - ir_select_read (clientData); if (w) - ir_select_write (clientData); + { + if (!ir_select_write (clientData) && r) + ir_select_read (clientData); + } + else if (r) + { + ir_select_read (clientData); + } } -/* ------------------------------------------------------- */ +/*----------------------------------------------------------- */ +/* + * DllEntryPoint -- + * + * This wrapper function is used by Windows to invoke the + * initialization code for the DLL. If we are compiling + * with Visual C++, this routine will be renamed to DllMain. + * routine. + * + * Results: + * Returns TRUE; + * + * Side effects: + * None. + */ + +#ifdef __WIN32__ +BOOL APIENTRY +DllEntryPoint(hInst, reason, reserved) + HINSTANCE hInst; /* Library instance handle. */ + DWORD reason; /* Reason this function is being called. */ + LPVOID reserved; /* Not used. */ +{ + return TRUE; +} +#endif +/* ------------------------------------------------------- */ /* * Irtcl_init: Registration of TCL commands. */ -int Irtcl_Init (Tcl_Interp *interp) +EXPORT (int,Irtcl_Init) (Tcl_Interp *interp) { Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); @@ -3716,6 +4104,8 @@ int Irtcl_Init (Tcl_Interp *interp) (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand (interp, "ir-log-init", ir_log_init_proc, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); return TCL_OK; }