X-Git-Url: http://jsfdemo.indexdata.com/?a=blobdiff_plain;f=ir-tcl.c;h=ae10fcc88c3353f7fe27b156a2b701b44f17b7d9;hb=abebb38601de949966e36c4606232c88f755289b;hp=ad3fba6ff110dea62b4aab89b00c713300a53a25;hpb=2514337466dde9568aa6c267170510cc2bca4121;p=ir-tcl-moved-to-github.git diff --git a/ir-tcl.c b/ir-tcl.c index ad3fba6..ae10fcc 100644 --- a/ir-tcl.c +++ b/ir-tcl.c @@ -1,11 +1,41 @@ /* * IR toolkit for tcl/tk - * (c) Index Data 1995-1996 + * (c) Index Data 1995-1998 * See the file LICENSE for details. * Sebastian Hammer, Adam Dickmeiss * * $Log: ir-tcl.c,v $ - * Revision 1.96 1996-10-08 13:02:50 adam + * Revision 1.105 1998-04-02 14:31:08 adam + * This version works with compiled ASN.1 code. + * + * Revision 1.104 1998/02/27 14:26:07 adam + * Changed client so that it still works if target sets numberOfRecords + * in response to an illegal value. + * + * Revision 1.103 1997/11/19 11:22:10 adam + * Object identifiers can be accessed in GRS-1 records. + * + * Revision 1.102 1997/09/17 12:22:40 adam + * Changed to use YAZ version 1.4. The new comstack utility, cs_straddr, + * is used. + * + * Revision 1.101 1997/09/09 10:19:53 adam + * New MSV5.0 port with fewer warnings. + * + * Revision 1.100 1997/05/01 15:04:05 adam + * Added ir-log command. + * + * Revision 1.99 1997/04/30 07:24:47 adam + * Spell fix of an error message. + * + * 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. * @@ -357,6 +387,43 @@ #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; ierrorLine, - interp->result); + const char *errorInfo = Tcl_GetVar (interp, "errorInfo", 0); + logf (LOG_WARN, "Tcl error in line %d: %s\n%s", interp->errorLine, + interp->result, errorInfo ? errorInfo : ""); } Tcl_FreeResult (interp); xfree (tmp); @@ -525,6 +593,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 */ @@ -550,13 +636,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; } @@ -582,8 +661,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; @@ -637,8 +716,8 @@ static int do_init_request (void *obj, Tcl_Interp *interp, 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; @@ -1088,55 +1167,60 @@ 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")) { p->cs_link = cs_create (tcpip_type, CS_BLOCK, p->protocol_type); - addr = tcpip_strtoaddr (argv[2]); - if (!addr) - { - interp->result = "tcpip_strtoaddr fail"; - return TCL_ERROR; - } logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]); } else if (!strcmp (p->comstackType, "mosi")) { #if MOSI p->cs_link = cs_create (mosi_type, CS_BLOCK, p->protocol_type); - addr = mosi_strtoaddr (argv[2]); - if (!addr) - { - interp->result = "mosi_strtoaddr fail"; - return TCL_ERROR; - } 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; p->eventType = "connect"; + addr = cs_straddr (p->cs_link, argv[2]); + if (!addr) + { + ir_tcl_disconnect (p); + Tcl_AppendResult (interp, "cs_straddr fail", NULL); + return ir_tcl_error_exec (interp, argc, argv); + } if ((r=cs_connect (p->cs_link, addr)) < 0) { - interp->result = "connect fail"; ir_tcl_disconnect (p); - return TCL_ERROR; + Tcl_AppendResult (interp, "connect fail", NULL); + return ir_tcl_error_exec (interp, argc, argv); } ir_select_add (cs_fileno (p->cs_link), p); if (r == 1) @@ -1153,8 +1237,6 @@ static int do_connect (void *obj, Tcl_Interp *interp, ir_tcl_eval (p->interp, p->callback); } } - else - Tcl_AppendResult (interp, p->hostname, NULL); return TCL_OK; } @@ -1173,6 +1255,9 @@ void ir_tcl_disconnect (IrTcl_Obj *p) odr_reset (p->odr_in); +#if TCL_MAJOR_VERSION == 8 + cs_fileno(p->cs_link) = -1; +#endif cs_close (p->cs_link); p->cs_link = NULL; @@ -1375,8 +1460,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; } @@ -1407,8 +1492,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; @@ -1763,11 +1848,14 @@ static int ir_obj_method (ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { IrTcl_Methods tab[3]; - IrTcl_Obj *p = clientData; + IrTcl_Obj *p = (IrTcl_Obj *) clientData; 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; @@ -1775,7 +1863,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; } @@ -1784,7 +1873,7 @@ static int ir_obj_method (ClientData clientData, Tcl_Interp *interp, */ static void ir_obj_delete (ClientData clientData) { - IrTcl_Obj *obj = clientData; + IrTcl_Obj *obj = (IrTcl_Obj *) clientData; IrTcl_Methods tab[3]; --(obj->ref_count); @@ -1823,7 +1912,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)); @@ -1860,7 +1949,7 @@ int ir_obj_init (ClientData clientData, Tcl_Interp *interp, Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL); return TCL_ERROR; } - *subData = obj; + *subData = (ClientData) obj; return TCL_OK; } @@ -1907,22 +1996,23 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) return TCL_OK; p = obj->parent; + assert (argc > 1); if (argc != 3) { - logf (LOG_DEBUG, "search %s", *argv); - 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; @@ -1936,7 +2026,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; @@ -1990,8 +2080,8 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) 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); } query.which = Z_Query_type_1; query.u.type_1 = RPNquery; @@ -2012,9 +2102,9 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) 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); @@ -2035,8 +2125,9 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv) } 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); } @@ -2222,7 +2313,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) @@ -2230,7 +2322,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) @@ -2265,14 +2357,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); @@ -2300,7 +2396,8 @@ 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) @@ -2352,7 +2449,8 @@ static int do_diag (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) @@ -2385,7 +2483,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) @@ -2417,7 +2516,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) @@ -2433,7 +2533,7 @@ static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv) Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL); return TCL_ERROR; } - if (rl->u.dbrec.type != VAL_SUTRS) + if (!rl->u.dbrec.buf || rl->u.dbrec.type != VAL_SUTRS) return TCL_OK; Tcl_AppendElement (interp, rl->u.dbrec.buf); return TCL_OK; @@ -2453,7 +2553,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) @@ -2491,7 +2592,8 @@ static int do_getExplain (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 ?mask? ...\"", NULL); return TCL_ERROR; } if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR) @@ -2507,14 +2609,14 @@ static int do_getExplain (void *o, Tcl_Interp *interp, int argc, char **argv) Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL); return TCL_ERROR; } - if (rl->u.dbrec.type != VAL_EXPLAIN) + if (!rl->u.dbrec.buf || rl->u.dbrec.type != VAL_EXPLAIN) return TCL_OK; if (!(etype = z_ext_getentbyref (VAL_EXPLAIN))) return TCL_OK; - + assert (rl->u.dbrec.buf); odr_setbuf (p->odr_in, rl->u.dbrec.buf, rl->u.dbrec.size, 0); - if (!(*etype->fun)(p->odr_in, &rr, 0)) + if (!(*etype->fun)(p->odr_in, (char **) &rr, 0)) return TCL_OK; if (etype->what != Z_External_explainRecord) @@ -2595,10 +2697,9 @@ static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv) 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; @@ -2649,7 +2750,7 @@ static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv) typedef struct { int encoding; int syntax; - int size; + size_t size; } IrTcl_FileRecordHead; /* @@ -2670,7 +2771,8 @@ static int do_loadFile (void *o, Tcl_Interp *interp, return TCL_OK; if (argc < 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " filename ?start? ?number?\"", NULL); return TCL_ERROR; } if (argc > 3) @@ -2683,7 +2785,7 @@ static int do_loadFile (void *o, Tcl_Interp *interp, if (!inf) { Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL); - return TCL_ERROR; + return ir_tcl_error_exec (interp, argc, argv); } while (offset < (start+number)) { @@ -2704,10 +2806,9 @@ static int do_loadFile (void *o, Tcl_Interp *interp, rl->u.dbrec.size = size; if (size != head.size) { - Tcl_AppendResult (interp, "Bad ISO2709 encoding in file", - argv[2], NULL); fclose (inf); - return TCL_ERROR; + Tcl_AppendResult (interp, "bad ISO2709 encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); } } else if (head.encoding == IR_TCL_RECORD_ENCODING_RAW) @@ -2716,10 +2817,9 @@ static int do_loadFile (void *o, Tcl_Interp *interp, rl->u.dbrec.buf = ir_tcl_malloc (head.size + 1); if (fread (rl->u.dbrec.buf, rl->u.dbrec.size, 1, inf) < 1) { - Tcl_AppendResult (interp, "Bad RAW encoding in file", - argv[2], NULL); fclose (inf); - return TCL_ERROR; + Tcl_AppendResult (interp, "bad raw encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); } rl->u.dbrec.buf[rl->u.dbrec.size] = '\0'; } @@ -2727,9 +2827,9 @@ static int do_loadFile (void *o, Tcl_Interp *interp, { rl->u.dbrec.buf = NULL; rl->u.dbrec.size = 0; - Tcl_AppendResult (interp, "Bad encoding in file", argv[2], NULL); fclose (inf); - return TCL_ERROR; + Tcl_AppendResult (interp, "bad encoding", NULL); + return ir_tcl_error_exec (interp, argc, argv); } offset++; } @@ -2755,7 +2855,8 @@ static int do_saveFile (void *o, Tcl_Interp *interp, return TCL_OK; if (argc < 3) { - interp->result = "wrong # args"; + Tcl_AppendResult (interp, wrongArgs, *argv, " ", argv[1], + " filename ?start? ?number?\"", NULL); return TCL_ERROR; } if (argc > 3) @@ -2767,8 +2868,8 @@ static int do_saveFile (void *o, Tcl_Interp *interp, outf = fopen (argv[2], "w"); if (!outf) { - Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL); - return TCL_ERROR; + 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))) { @@ -2782,21 +2883,21 @@ static int do_saveFile (void *o, Tcl_Interp *interp, head.size = rl->u.dbrec.size; if (fwrite (&head, sizeof(head), 1, outf) < 1) { - Tcl_AppendResult (interp, "Cannot write ", argv[2], NULL); - return TCL_ERROR; + 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 ", argv[2], NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "cannot write", NULL); + return ir_tcl_error_exec (interp, argc, argv); } } offset++; } if (fclose (outf)) { - Tcl_AppendResult (interp, "Cannot write ", argv[2], NULL); - return TCL_ERROR; + Tcl_AppendResult (interp, "cannot write ", NULL); + return ir_tcl_error_exec (interp, argc, argv); } return TCL_OK; } @@ -2834,12 +2935,12 @@ static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { IrTcl_Methods tabs[3]; - IrTcl_SetObj *p = clientData; + IrTcl_SetObj *p = (IrTcl_SetObj *) clientData; int r; 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; @@ -2848,7 +2949,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; } @@ -2858,7 +2960,7 @@ static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp, static void ir_set_obj_delete (ClientData clientData) { IrTcl_Methods tabs[3]; - IrTcl_SetObj *p = clientData; + IrTcl_SetObj *p = (IrTcl_SetObj *) clientData; logf (LOG_DEBUG, "ir set delete"); @@ -2885,7 +2987,8 @@ 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)); @@ -2957,7 +3060,7 @@ static int ir_set_obj_init (ClientData clientData, Tcl_Interp *interp, if (ir_tcl_method (interp, 0, NULL, tabs, NULL) == TCL_ERROR) return TCL_ERROR; - *subData = obj; + *subData = (ClientData) obj; return TCL_OK; } @@ -2976,8 +3079,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; } @@ -3017,19 +3120,20 @@ 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); } apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest); @@ -3044,15 +3148,15 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv) 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); } bib1.proto = p->protocol_type; bib1.oclass = CLASS_ATTSET; @@ -3222,13 +3326,14 @@ 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; } + printf ("argv[2]=%s\n", argv[2]); if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR) return TCL_ERROR; - if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries - || i >= p->num_entries || i < 0) + if (!p->entries_flag || !p->entries || i >= p->num_entries || i < 0) return TCL_OK; switch (p->entries[i].which) { @@ -3274,14 +3379,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; } @@ -3291,7 +3397,7 @@ static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp, static void ir_scan_obj_delete (ClientData clientData) { IrTcl_Methods tabs[2]; - IrTcl_ScanObj *obj = clientData; + IrTcl_ScanObj *obj = (IrTcl_ScanObj *) clientData; tabs[0].tab = ir_scan_method_tab; tabs[0].obj = obj; @@ -3313,14 +3419,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; @@ -3338,6 +3445,47 @@ static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp, /* ------------------------------------------------------- */ +/* + * ir_log_init_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; +} + +/* + * ir_log_proc: log yaz message + */ +static int ir_log_proc (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + int mask; + if (argc != 3) + { + Tcl_AppendResult (interp, wrongArgs, *argv, + " level string\"", NULL); + return TCL_OK; + } + mask = log_mask_str_x (argv[1], 0); + logf (LOG_DEBUG, "%s", argv[2]); + return TCL_OK; +} + + +/* ------------------------------------------------------- */ static void ir_initResponse (void *obj, Z_InitResponse *initrs) { IrTcl_Obj *p = obj; @@ -3400,7 +3548,7 @@ static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, Z_DiagRec **list, int num) { int i; - char *addinfo; + char *addinfo = NULL; *dst_num = num; *dst_list = ir_tcl_malloc (sizeof(**dst_list) * num); @@ -3411,7 +3559,19 @@ static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num, { case Z_DiagRec_defaultFormat: (*dst_list)[i].condition = *list[i]->u.defaultFormat->condition; +#ifdef ASN_COMPILED + switch (list[i]->u.defaultFormat->which) + { + case Z_DefaultDiagFormat_v2Addinfo: + addinfo = list[i]->u.defaultFormat->u.v2Addinfo; + break; + case Z_DefaultDiagFormat_v3Addinfo: + addinfo = list[i]->u.defaultFormat->u.v3Addinfo; + break; + } +#else addinfo = list[i]->u.defaultFormat->addinfo; +#endif if (addinfo && ((*dst_list)[i].addinfo = ir_tcl_malloc (strlen(addinfo)+1))) strcpy ((*dst_list)[i].addinfo, addinfo); @@ -3448,12 +3608,12 @@ static void ir_handleDBRecord (IrTcl_Obj *p, IrTcl_RecordList *rl, 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)) + if (!(*etype->fun)(p->odr_in, (char **) &rr, 0)) return; switch (etype->what) { case Z_External_sutrs: - logf (LOG_LOG, "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))) { @@ -3464,12 +3624,12 @@ static void ir_handleDBRecord (IrTcl_Obj *p, IrTcl_RecordList *rl, rl->u.dbrec.size = oe->u.sutrs->len; break; case Z_External_grs1: - logf (LOG_LOG, "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_LOG, "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, @@ -3520,10 +3680,16 @@ static void ir_handleZRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj, &setobj->nonSurrogateDiagnosticNum); if (zrs->which == Z_Records_DBOSD) { - setobj->numberOfRecordsReturned = - zrs->u.databaseOrSurDiagnostics->num_records; - logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned); - for (offset = 0; offset < setobj->numberOfRecordsReturned; offset++) + int num_rec = zrs->u.databaseOrSurDiagnostics->num_records; + + if (num_rec != setobj->numberOfRecordsReturned) + { + logf (LOG_WARN, "numberOfRecordsReturned=%d but num records=%d", + setobj->numberOfRecordsReturned, num_rec); + setobj->numberOfRecordsReturned = num_rec; + } + + for (offset = 0; offset < num_rec; offset++) { Z_NamePlusRecord *znpr = zrs->u.databaseOrSurDiagnostics-> records[offset]; @@ -3552,12 +3718,19 @@ static void ir_handleZRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj, } else { +#ifdef ASN_COMPILED + Z_DiagRec dr, *dr_p = &dr; + dr.which = Z_DiagRec_defaultFormat; + dr.u.defaultFormat = zrs->u.nonSurrogateDiagnostic; +#else + Z_DiagRec *dr_p = zrs->u.nonSurrogateDiagnostic; +#endif logf (LOG_DEBUG, "NonSurrogateDiagnostic"); + setobj->numberOfRecordsReturned = 0; ir_handleDiags (&setobj->nonSurrogateDiagnosticList, &setobj->nonSurrogateDiagnosticNum, - &zrs->u.nonSurrogateDiagnostic, - 1); + &dr_p, 1); } } @@ -3589,10 +3762,14 @@ static void ir_searchResponse (void *o, Z_SearchResponse *searchrs, es = setobj->set_inher.smallSetElementSetNames; else es = setobj->set_inher.mediumSetElementSetNames; + setobj->numberOfRecordsReturned = *searchrs->numberOfRecordsReturned; ir_handleZRecords (o, zrs, setobj, es); } else + { + setobj->numberOfRecordsReturned = 0; setobj->recordFlag = 0; + } } @@ -3611,9 +3788,13 @@ static void ir_presentResponse (void *o, Z_PresentResponse *presrs, get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId); setobj->nextResultSetPosition = *presrs->nextResultSetPosition; if (zrs) + { + setobj->numberOfRecordsReturned = *presrs->numberOfRecordsReturned; ir_handleZRecords (o, zrs, setobj, setobj->set_inher.elementSetNames); + } else { + setobj->numberOfRecordsReturned = 0; setobj->recordFlag = 0; logf (LOG_DEBUG, "No records!"); } @@ -3646,67 +3827,81 @@ static void ir_scanResponse (void *o, Z_ScanResponse *scanrs, xfree (scanobj->entries); scanobj->entries = NULL; - + scanobj->num_entries = 0; + scanobj->entries_flag = 0; + ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList, &scanobj->nonSurrogateDiagnosticNum); if (scanrs->entries) { int i; - Z_Entry *ze; + Z_Entry **ze; scanobj->entries_flag = 1; - scanobj->which = scanrs->entries->which; - switch (scanobj->which) - { - case Z_ListEntries_entries: +#ifdef ASN_COMPILED + if (scanrs->entries) + { + scanobj->num_entries = scanrs->entries->num_entries; + scanobj->entries = ir_tcl_malloc (scanobj->num_entries * + sizeof(*scanobj->entries)); + ze = scanrs->entries->entries; + } +#else + if (scanrs->entries->which == Z_ListEntries_entries) + { scanobj->num_entries = scanrs->entries->u.entries->num_entries; scanobj->entries = ir_tcl_malloc (scanobj->num_entries * - sizeof(*scanobj->entries)); - for (i=0; inum_entries; i++) - { - ze = scanrs->entries->u.entries->entries[i]; - scanobj->entries[i].which = ze->which; - switch (ze->which) - { - case Z_Entry_termInfo: - if (ze->u.termInfo->term->which == Z_Term_general) - { - int l = ze->u.termInfo->term->u.general->len; - scanobj->entries[i].u.term.buf = ir_tcl_malloc (1+l); - memcpy (scanobj->entries[i].u.term.buf, - ze->u.termInfo->term->u.general->buf, - l); - scanobj->entries[i].u.term.buf[l] = '\0'; - } - else - scanobj->entries[i].u.term.buf = NULL; - if (ze->u.termInfo->globalOccurrences) - scanobj->entries[i].u.term.globalOccurrences = - *ze->u.termInfo->globalOccurrences; - else - scanobj->entries[i].u.term.globalOccurrences = 0; - break; - case Z_Entry_surrogateDiagnostic: - ir_handleDiags (&scanobj->entries[i].u.diag.list, - &scanobj->entries[i].u.diag.num, - &ze->u.surrogateDiagnostic, - 1); - break; - } - } - break; - case Z_ListEntries_nonSurrogateDiagnostics: + sizeof(*scanobj->entries)); + ze = scanrs->entries->u.entries->entries; + } +#endif + for (i=0; inum_entries; i++, ze++) + { + scanobj->entries[i].which = (*ze)->which; + switch ((*ze)->which) + { + case Z_Entry_termInfo: + if ((*ze)->u.termInfo->term->which == Z_Term_general) + { + int l = (*ze)->u.termInfo->term->u.general->len; + scanobj->entries[i].u.term.buf = ir_tcl_malloc (1+l); + memcpy (scanobj->entries[i].u.term.buf, + (*ze)->u.termInfo->term->u.general->buf, + l); + scanobj->entries[i].u.term.buf[l] = '\0'; + } + else + scanobj->entries[i].u.term.buf = NULL; + if ((*ze)->u.termInfo->globalOccurrences) + scanobj->entries[i].u.term.globalOccurrences = + *(*ze)->u.termInfo->globalOccurrences; + else + scanobj->entries[i].u.term.globalOccurrences = 0; + break; + case Z_Entry_surrogateDiagnostic: + ir_handleDiags (&scanobj->entries[i].u.diag.list, + &scanobj->entries[i].u.diag.num, + &(*ze)->u.surrogateDiagnostic, + 1); + break; + } + } +#ifdef ASN_COMPILED + if (scanrs->entries->nonsurrogateDiagnostics) + ir_handleDiags (&scanobj->nonSurrogateDiagnosticList, + &scanobj->nonSurrogateDiagnosticNum, + scanrs->entries->nonsurrogateDiagnostics, + scanrs->entries->num_nonsurrogateDiagnostics); +#else + if (scanrs->entries->which == Z_ListEntries_nonSurrogateDiagnostics) ir_handleDiags (&scanobj->nonSurrogateDiagnosticList, &scanobj->nonSurrogateDiagnosticNum, scanrs->entries->u.nonSurrogateDiagnostics-> diagRecs, scanrs->entries->u.nonSurrogateDiagnostics-> num_diagRecs); - break; - } +#endif } - else - scanobj->entries_flag = 0; } /* @@ -3714,7 +3909,7 @@ static void ir_scanResponse (void *o, Z_ScanResponse *scanrs, */ static void ir_select_read (ClientData clientData) { - IrTcl_Obj *p = clientData; + IrTcl_Obj *p = (IrTcl_Obj *) clientData; Z_APDU *apdu; int r; IrTcl_Request *rq; @@ -3744,7 +3939,7 @@ static void ir_select_read (ClientData clientData) p->failInfo = IR_TCL_FAIL_CONNECT; ir_tcl_eval (p->interp, p->failback); } - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return; } if (p->callback) @@ -3752,7 +3947,7 @@ static void ir_select_read (ClientData clientData) 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); + ir_obj_delete ((ClientData) p); return; } do @@ -3771,7 +3966,6 @@ static void ir_select_read (ClientData clientData) if (r <= 0) { logf (LOG_DEBUG, "cs_get failed, code %d", r); - ir_select_remove (cs_fileno (p->cs_link), p); ir_tcl_disconnect (p); if (p->failback) { @@ -3779,7 +3973,7 @@ static void ir_select_read (ClientData clientData) ir_tcl_eval (p->interp, p->failback); } /* release ir object now if callback deleted it */ - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return; } /* got complete APDU. Now decode */ @@ -3799,7 +3993,7 @@ static void ir_select_read (ClientData clientData) ir_tcl_eval (p->interp, p->failback); } /* release ir object now if failback deleted it */ - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return; } /* handle APDU and invoke callback */ @@ -3868,10 +4062,10 @@ static void ir_select_read (ClientData clientData) odr_reset (p->odr_in); if (p->ref_count == 1) { - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return; } - ir_obj_delete (p); + ir_obj_delete ((ClientData) 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"); @@ -3882,7 +4076,7 @@ static void ir_select_read (ClientData clientData) */ static int ir_select_write (ClientData clientData) { - IrTcl_Obj *p = clientData; + IrTcl_Obj *p = (IrTcl_Obj *) clientData; int r; IrTcl_Request *rq; @@ -3908,12 +4102,12 @@ static int ir_select_write (ClientData clientData) p->failInfo = IR_TCL_FAIL_CONNECT; ir_tcl_eval (p->interp, p->failback); } - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return 2; } if (p->callback) ir_tcl_eval (p->interp, p->callback); - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); return 2; } rq = p->request_queue; @@ -3932,7 +4126,7 @@ static int ir_select_write (ClientData clientData) p->failInfo = IR_TCL_FAIL_WRITE; ir_tcl_eval (p->interp, p->failback); } - ir_obj_delete (p); + ir_obj_delete ((ClientData) p); } else if (r == 0) /* remove select bit */ { @@ -3958,12 +4152,38 @@ static void ir_select_notify (ClientData clientData, int r, int w, int e) } } -/* ------------------------------------------------------- */ +/*----------------------------------------------------------- */ +/* + * 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); @@ -3971,6 +4191,11 @@ 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); + Tcl_CreateCommand (interp, "ir-log", ir_log_proc, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + nmem_init (); return TCL_OK; }