/*
* 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.91 1996-07-03 13:31:11 adam
+ * 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
+ * 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
#include <stdlib.h>
#include <stdio.h>
+#ifdef WINDOWS
+
+#else
#include <unistd.h>
+#endif
#include <time.h>
#include <assert.h>
#include "ir-tclp.h"
+#if defined(__WIN32__)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# 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; i<argc; i++)
+ Tcl_AppendResult (interp, (i ? " " : "\""), argv[i], NULL);
+ Tcl_AppendResult (interp, "\"", NULL);
+ return TCL_ERROR;
+}
+
+
static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num);
static void ir_select_notify (ClientData clientData, int r, int w, int e);
break;
}
xfree (rl->u.dbrec.buf);
+ rl->u.dbrec.buf = NULL;
break;
case Z_NamePlusRecord_surrogateDiagnostic:
ir_deleteDiags (&rl->u.surrogateDiagnostics.list,
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
*/
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;
}
}
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;
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;
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);
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"))
{
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]);
}
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)
ir_tcl_eval (p->interp, p->callback);
}
}
- else
- Tcl_AppendResult (interp, p->hostname, NULL);
return TCL_OK;
}
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);
cs_close (p->cs_link);
p->cs_link = NULL;
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;
}
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;
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;
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;
}
if (argc != 2)
{
- interp->result = "wrong # args";
+ Tcl_AppendResult (interp, wrongArgs, *argv, " objName\"", NULL);
return TCL_ERROR;
}
obj = ir_tcl_malloc (sizeof(*obj));
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;
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;
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;
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;
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);
}
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);
}
}
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)
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)
}
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);
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)
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)
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)
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)
/*
- * 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)
{
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)
/*
+ * 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,
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;
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},
{ "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}
};
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;
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;
}
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));
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;
}
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);
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;
}
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)
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;
}
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;
/* ------------------------------------------------------- */
+/*
+ * 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;
}
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;
}
}
-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;
setobj->numberOfRecordsReturned =
zrs->u.databaseOrSurDiagnostics->num_records;
logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned);
- for (offset = 0; offset<setobj->numberOfRecordsReturned; 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_grs_mk (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)
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;
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;
}
}
-/* ------------------------------------------------------- */
+/*----------------------------------------------------------- */
+/*
+ * 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);
(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;
}