X-Git-Url: http://lists.indexdata.com/cgi-bin?a=blobdiff_plain;f=ir-tcl.c;h=93331e639c3363b34e61aa64d5b6b0076c2498d2;hb=ddc1fe181cb079af835166126fa052e2378e930b;hp=2db9f288fc082233b0a9d8b59fada93d1d04268f;hpb=e461bc647761fc0284d4556f526c93c8a00a22fa;p=ir-tcl-moved-to-github.git diff --git a/ir-tcl.c b/ir-tcl.c index 2db9f28..93331e6 100644 --- a/ir-tcl.c +++ b/ir-tcl.c @@ -1,11 +1,37 @@ /* * IR toolkit for tcl/tk - * (c) Index Data 1995-1996 + * (c) Index Data 1995-1997 * See the file LICENSE for details. * Sebastian Hammer, Adam Dickmeiss * * $Log: ir-tcl.c,v $ - * Revision 1.93 1996-08-16 15:07:45 adam + * 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. + * + * 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 @@ -347,6 +373,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; itab; 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 */ @@ -540,13 +621,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; } @@ -572,8 +646,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; @@ -627,8 +701,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; @@ -1078,13 +1152,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")) { @@ -1092,8 +1176,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]); } @@ -1104,29 +1188,29 @@ 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; p->eventType = "connect"; 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) @@ -1143,8 +1227,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; } @@ -1158,12 +1240,14 @@ void ir_tcl_disconnect (IrTcl_Obj *p) logf(LOG_DEBUG, "Closing connection to %s", p->hostname); xfree (p->hostname); p->hostname = NULL; - ir_select_remove_write (cs_fileno (p->cs_link), p); + assert (p->cs_link); ir_select_remove (cs_fileno (p->cs_link), p); odr_reset (p->odr_in); - assert (p->cs_link); +#if TCL_MAJOR_VERSION == 8 + cs_fileno(p->cs_link) = -1; +#endif cs_close (p->cs_link); p->cs_link = NULL; @@ -1366,8 +1450,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; } @@ -1398,8 +1482,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; @@ -1754,11 +1838,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; @@ -1766,7 +1853,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; } @@ -1775,7 +1863,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); @@ -1814,7 +1902,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)); @@ -1830,6 +1918,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; @@ -1850,7 +1939,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; } @@ -1897,22 +1986,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; @@ -1926,7 +2016,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; @@ -1980,8 +2070,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; @@ -2002,9 +2092,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); @@ -2025,8 +2115,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); } @@ -2212,7 +2303,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) @@ -2220,7 +2312,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) @@ -2255,14 +2347,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); @@ -2290,7 +2386,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) @@ -2342,7 +2439,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) @@ -2375,7 +2473,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) @@ -2407,7 +2506,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) @@ -2423,7 +2523,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; @@ -2443,7 +2543,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) @@ -2481,7 +2582,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) @@ -2497,12 +2599,12 @@ 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)) return TCL_OK; @@ -2585,10 +2687,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; @@ -2633,47 +2734,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; + size_t 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}, @@ -2695,6 +2914,7 @@ static IrTcl_Method ir_set_method_tab[] = { { "diag", do_diag, NULL}, { "responseStatus", do_responseStatus, NULL}, { "loadFile", do_loadFile, NULL}, + { "saveFile", do_saveFile, NULL}, { NULL, NULL} }; @@ -2705,12 +2925,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; @@ -2719,7 +2939,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; } @@ -2729,7 +2950,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"); @@ -2756,7 +2977,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)); @@ -2828,7 +3050,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; } @@ -2847,8 +3069,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; } @@ -2888,19 +3110,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); @@ -2915,15 +3138,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; @@ -3093,7 +3316,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) @@ -3145,14 +3369,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; } @@ -3162,7 +3387,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; @@ -3184,14 +3409,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; @@ -3209,6 +3435,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 (mask, "%s", argv[1], mask, argv[2]); + return TCL_OK; +} + + +/* ------------------------------------------------------- */ static void ir_initResponse (void *obj, Z_InitResponse *initrs) { IrTcl_Obj *p = obj; @@ -3324,7 +3591,7 @@ static void ir_handleDBRecord (IrTcl_Obj *p, IrTcl_RecordList *rl, 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))) { @@ -3335,12 +3602,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, @@ -3585,7 +3852,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; @@ -3615,7 +3882,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) @@ -3623,7 +3890,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 @@ -3642,7 +3909,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) { @@ -3650,7 +3916,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 */ @@ -3670,7 +3936,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 */ @@ -3739,10 +4005,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"); @@ -3753,7 +4019,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; @@ -3779,12 +4045,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; @@ -3803,7 +4069,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 */ { @@ -3829,12 +4095,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); @@ -3842,6 +4134,10 @@ 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); return TCL_OK; }