* Sebastian Hammer, Adam Dickmeiss
*
* $Log: ir-tcl.c,v $
- * Revision 1.93 1996-08-16 15:07:45 adam
+ * Revision 1.98 1997-04-13 18:57:20 adam
+ * Better error reporting and aligned with Tcl/Tk style.
+ * Rework of notifier code with Tcl_File handles.
+ *
+ * Revision 1.97 1996/11/14 17:11:07 adam
+ * Added Explain documentaion.
+ *
+ * Revision 1.96 1996/10/08 13:02:50 adam
+ * When dealing with records, odr_choice_enable_bias function is used to
+ * prevent decoding of externals.
+ *
+ * Revision 1.95 1996/09/13 10:51:49 adam
+ * Bug fix: ir_tcl_select_set called Tcl_GetFile at disconnect.
+ *
+ * Revision 1.94 1996/08/21 13:32:53 adam
+ * Implemented saveFile method and extended loadFile method to work with it.
+ *
+ * Revision 1.93 1996/08/16 15:07:45 adam
* First work on Explain.
*
* Revision 1.92 1996/08/09 15:33:07 adam
#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);
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 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, "conncet 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)
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)
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)
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},
{ "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_proc: set yaz log level
+ */
+static int ir_log_init_proc (ClientData clientData, Tcl_Interp *interp,
+ int argc, char **argv)
+{
+ if (argc <= 1 || argc > 4)
+ {
+ Tcl_AppendResult (interp, wrongArgs, *argv,
+ " ?level ?prefix ?filename\"", NULL);
+ return TCL_OK;
+ }
+ if (argc == 2)
+ log_init (log_mask_str (argv[1]), "", NULL);
+ else if (argc == 3)
+ log_init (log_mask_str (argv[1]), argv[2], NULL);
+ else
+ log_init (log_mask_str (argv[1]), argv[2], argv[3]);
+ return TCL_OK;
+}
+
+/* ------------------------------------------------------- */
static void ir_initResponse (void *obj, Z_InitResponse *initrs)
{
IrTcl_Obj *p = obj;
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)))
{
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,
}
}
-/* ------------------------------------------------------- */
+/*----------------------------------------------------------- */
+/*
+ * 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);
return TCL_OK;
}
projects / ir-tcl-moved-to-github.git / blobdiff