ir-tcl.c

   1 /*\r
   2  * IR toolkit for tcl/tk\r
   3  * (c) Index Data 1995\r
   4  * See the file LICENSE for details.\r
   5  * Sebastian Hammer, Adam Dickmeiss\r
   6  *\r
   7  * $Log: ir-tcl.c,v $
   8  * Revision 1.65  1995-11-28 13:53:00  quinn
   9  * Windows port.
  10  *\r
  11  * Revision 1.64  1995/11/13  15:39:18  adam\r
  12  * Bug fix: {small,medium}SetElementSetNames weren't set correctly.\r
  13  * Bug fix: idAuthentication weren't set correctly.\r
  14  *\r
  15  * Revision 1.63  1995/11/13  09:55:39  adam\r
  16  * Multiple records at a position in a result-set with differnt\r
  17  * element specs.\r
  18  *\r
  19  * Revision 1.62  1995/10/18  17:20:33  adam\r
  20  * Work on target setup in client.tcl.\r
  21  *\r
  22  * Revision 1.61  1995/10/18  16:42:42  adam\r
  23  * New settings: smallSetElementSetNames and mediumSetElementSetNames.\r
  24  *\r
  25  * Revision 1.60  1995/10/18  15:43:31  adam\r
  26  * In search: mediumSetElementSetNames and smallSetElementSetNames are\r
  27  * set to elementSetNames.\r
  28  *\r
  29  * Revision 1.59  1995/10/17  12:18:58  adam\r
  30  * Bug fix: when target connection closed, the connection was not\r
  31  * properly reestablished.\r
  32  *\r
  33  * Revision 1.58  1995/10/16  17:00:55  adam\r
  34  * New setting: elementSetNames.\r
  35  * Various client improvements. Medium presentation format looks better.\r
  36  *\r
  37  * Revision 1.57  1995/09/21  13:11:51  adam\r
  38  * Support of dynamic loading.\r
  39  * Test script uses load command if necessary.\r
  40  *\r
  41  * Revision 1.56  1995/08/29  15:30:14  adam\r
  42  * Work on GRS records.\r
  43  *\r
  44  * Revision 1.55  1995/08/28  09:43:25  adam\r
  45  * Minor changes. configure only searches for yaz beta 3 and versions after\r
  46  * that.\r
  47  *\r
  48  * Revision 1.54  1995/08/24  12:25:16  adam\r
  49  * Modified to work with yaz 1.0b3.\r
  50  *\r
  51  * Revision 1.53  1995/08/04  12:49:26  adam\r
  52  * Bug fix: reading uninitialized variable p.\r
  53  *\r
  54  * Revision 1.52  1995/08/04  11:32:38  adam\r
  55  * More work on output queue. Memory related routines moved\r
  56  * to mem.c\r
  57  *\r
  58  * Revision 1.51  1995/08/03  13:22:54  adam\r
  59  * Request queue.\r
  60  *\r
  61  * Revision 1.50  1995/07/20  08:09:49  adam\r
  62  * client.tcl: Targets removed from hotTargets list when targets\r
  63  *  are removed/modified.\r
  64  * ir-tcl.c: More work on triggerResourceControl.\r
  65  *\r
  66  * Revision 1.49  1995/06/30  12:39:21  adam\r
  67  * Bug fix: loadFile didn't set record type.\r
  68  * The MARC routines are a little less strict in the interpretation.\r
  69  * Script display.tcl replaces the old marc.tcl.\r
  70  * New interactive script: shell.tcl.\r
  71  *\r
  72  * Revision 1.48  1995/06/27  19:03:50  adam\r
  73  * Bug fix in do_present in ir-tcl.c: p->set_child member weren't set.\r
  74  * nextResultSetPosition used instead of setOffset.\r
  75  *\r
  76  * Revision 1.47  1995/06/25  10:25:04  adam\r
  77  * Working on triggerResourceControl. Description of compile/install\r
  78  * procedure moved to ir-tcl.sgml.\r
  79  *\r
  80  * Revision 1.46  1995/06/22  13:15:06  adam\r
  81  * Feature: SUTRS. Setting getSutrs implemented.\r
  82  * Work on display formats.\r
  83  * Preferred record syntax can be set by the user.\r
  84  *\r
  85  * Revision 1.45  1995/06/20  08:07:30  adam\r
  86  * New setting: failInfo.\r
  87  * Working on better cancel mechanism.\r
  88  *\r
  89  * Revision 1.44  1995/06/19  17:01:20  adam\r
  90  * Minor changes.\r
  91  *\r
  92  * Revision 1.43  1995/06/19  13:06:08  adam\r
  93  * New define: IR_TCL_VERSION.\r
  94  *\r
  95  * Revision 1.42  1995/06/19  08:08:52  adam\r
  96  * client.tcl: hotTargets now contain both database and target name.\r
  97  * ir-tcl.c: setting protocol edited. Errors in callbacks are logged\r
  98  * by logf(LOG_WARN, ...) calls.\r
  99  *\r
 100  * Revision 1.41  1995/06/16  12:28:16  adam\r
 101  * Implemented preferredRecordSyntax.\r
 102  * Minor changes in diagnostic handling.\r
 103  * Record list deleted when connection closes.\r
 104  *\r
 105  * Revision 1.40  1995/06/14  13:37:18  adam\r
 106  * Setting recordType implemented.\r
 107  * Setting implementationVersion implemented.\r
 108  * Settings implementationId / implementationName edited.\r
 109  *\r
 110  * Revision 1.39  1995/06/08  10:26:32  adam\r
 111  * Bug fix in ir_strdup.\r
 112  *\r
 113  * Revision 1.38  1995/06/01  16:36:47  adam\r
 114  * About buttons. Minor bug fixes.\r
 115  *\r
 116  * Revision 1.37  1995/06/01  07:31:20  adam\r
 117  * Rename of many typedefs -> IrTcl_...\r
 118  *\r
 119  * Revision 1.36  1995/05/31  13:09:59  adam\r
 120  * Client searches/presents may be interrupted.\r
 121  * New moving book-logo.\r
 122  *\r
 123  * Revision 1.35  1995/05/31  08:36:33  adam\r
 124  * Bug fix in client.tcl: didn't save options on clientrc.tcl.\r
 125  * New method: referenceId. More work on scan.\r
 126  *\r
 127  * Revision 1.34  1995/05/29  10:33:42  adam\r
 128  * README and rename of startup script.\r
 129  *\r
 130  * Revision 1.33  1995/05/29  09:15:11  quinn\r
 131  * Changed CS_SR to PROTO_SR, etc.\r
 132  *\r
 133  * Revision 1.32  1995/05/29  08:44:16  adam\r
 134  * Work on delete of objects.\r
 135  *\r
 136  * Revision 1.31  1995/05/26  11:44:10  adam\r
 137  * Bugs fixed. More work on MARC utilities and queries. Test\r
 138  * client is up-to-date again.\r
 139  *\r
 140  * Revision 1.30  1995/05/26  08:54:11  adam\r
 141  * New MARC utilities. Uses prefix query.\r
 142  *\r
 143  * Revision 1.29  1995/05/24  14:10:22  adam\r
 144  * Work on idAuthentication, protocolVersion and options.\r
 145  *\r
 146  * Revision 1.28  1995/05/23  15:34:48  adam\r
 147  * Many new settings, userInformationField, smallSetUpperBound, etc.\r
 148  * A number of settings are inherited when ir-set is executed.\r
 149  * This version is incompatible with the graphical test client (client.tcl).\r
 150  *\r
 151  * Revision 1.27  1995/05/11  15:34:47  adam\r
 152  * Scan request changed a bit. This version works with RLG.\r
 153  *\r
 154  * Revision 1.26  1995/04/18  16:11:51  adam\r
 155  * First version of graphical Scan. Some work on query-by-form.\r
 156  *\r
 157  * Revision 1.25  1995/04/17  09:37:17  adam\r
 158  * Further development of scan.\r
 159  *\r
 160  * Revision 1.24  1995/04/11  14:16:42  adam\r
 161  * Further work on scan. Response works. Entries aren't saved yet.\r
 162  *\r
 163  * Revision 1.23  1995/04/10  10:50:27  adam\r
 164  * Result-set name defaults to suffix of ir-set name.\r
 165  * Started working on scan. Not finished at this point.\r
 166  *\r
 167  * Revision 1.22  1995/03/31  10:43:03  adam\r
 168  * More robust when getting bad MARC records.\r
 169  *\r
 170  * Revision 1.21  1995/03/31  08:56:37  adam\r
 171  * New button "Search".\r
 172  *\r
 173  * Revision 1.20  1995/03/29  16:07:09  adam\r
 174  * Bug fix: Didn't use setName in present request.\r
 175  *\r
 176  * Revision 1.19  1995/03/28  12:45:23  adam\r
 177  * New ir method failback: called on disconnect/protocol error.\r
 178  * New ir set/get method: protocol: SR / Z3950.\r
 179  * Simple popup and disconnect when failback is invoked.\r
 180  *\r
 181  * Revision 1.18  1995/03/21  15:50:12  adam\r
 182  * Minor changes.\r
 183  *\r
 184  * Revision 1.17  1995/03/21  13:41:03  adam\r
 185  * Comstack cs_create not used too often. Non-blocking connect.\r
 186  *\r
 187  * Revision 1.16  1995/03/21  08:26:06  adam\r
 188  * New method, setName, to specify the result set name (other than Default).\r
 189  * New method, responseStatus, which returns diagnostic info, if any, after\r
 190  * present response / search response.\r
 191  *\r
 192  * Revision 1.15  1995/03/20  15:24:07  adam\r
 193  * Diagnostic records saved on searchResponse.\r
 194  *\r
 195  * Revision 1.14  1995/03/20  08:53:22  adam\r
 196  * Event loop in tclmain.c rewritten. New method searchStatus.\r
 197  *\r
 198  * Revision 1.13  1995/03/17  18:26:17  adam\r
 199  * Non-blocking i/o used now. Database names popup as cascade items.\r
 200  *\r
 201  * Revision 1.12  1995/03/17  15:45:00  adam\r
 202  * Improved target/database setup.\r
 203  *\r
 204  * Revision 1.11  1995/03/16  17:54:03  adam\r
 205  * Minor changes really.\r
 206  *\r
 207  * Revision 1.10  1995/03/15  16:14:50  adam\r
 208  * Blocking arg in cs_create changed.\r
 209  *\r
 210  * Revision 1.9  1995/03/15  13:59:24  adam\r
 211  * Minor changes.\r
 212  *\r
 213  * Revision 1.8  1995/03/15  08:25:16  adam\r
 214  * New method presentStatus to check for error on present. Misc. cleanup\r
 215  * of IrTcl_RecordList manipulations. Full MARC record presentation in\r
 216  * search.tcl.\r
 217  *\r
 218  * Revision 1.7  1995/03/14  17:32:29  adam\r
 219  * Presentation of full Marc record in popup window.\r
 220  *\r
 221  * Revision 1.6  1995/03/12  19:31:55  adam\r
 222  * Pattern matching implemented when retrieving MARC records. More\r
 223  * diagnostic functions.\r
 224  *\r
 225  * Revision 1.5  1995/03/10  18:00:15  adam\r
 226  * Actual presentation in line-by-line format. RPN query support.\r
 227  *\r
 228  * Revision 1.4  1995/03/09  16:15:08  adam\r
 229  * First presentRequest attempts. Hot-target list.\r
 230  *\r
 231  */\r
 232 \r
 233 #include <stdlib.h>\r
 234 #include <stdio.h>\r
 235 #ifdef WINDOWS\r
 236 #include <time.h>\r
 237 #else\r
 238 #include <sys/time.h>\r
 239 #endif\r
 240 #include <assert.h>\r
 241 \r
 242 #define CS_BLOCK 0\r
 243 \r
 244 #include "ir-tclp.h"\r
 245 \r
 246 typedef struct {\r
 247     int type;\r
 248     char *name;\r
 249     int (*method) (void *obj, Tcl_Interp *interp, int argc, char **argv);\r
 250 } IrTcl_Method;\r
 251 \r
 252 typedef struct {\r
 253     void *obj;\r
 254     IrTcl_Method *tab;\r
 255 } IrTcl_Methods;\r
 256 \r
 257 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num);\r
 258 static int do_disconnect (void *obj, Tcl_Interp *interp, \r
 259                           int argc, char **argv);\r
 260 \r
 261 static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj, \r
 262                                         int no, int which, \r
 263                                         const char *elements)\r
 264 {\r
 265     IrTcl_RecordList *rl;\r
 266 \r
 267     for (rl = setobj->record_list; rl; rl = rl->next)\r
 268     {\r
 269         if (no == rl->no && (!rl->elements || !elements ||\r
 270                              !strcmp(elements, rl->elements)))\r
 271         {\r
 272             free (rl->elements);\r
 273             switch (rl->which)\r
 274             {\r
 275             case Z_NamePlusRecord_databaseRecord:\r
 276                 free (rl->u.dbrec.buf);\r
 277                 rl->u.dbrec.buf = NULL;\r
 278                 break;\r
 279             case Z_NamePlusRecord_surrogateDiagnostic:\r
 280                 ir_deleteDiags (&rl->u.surrogateDiagnostics.list,\r
 281                                 &rl->u.surrogateDiagnostics.num);\r
 282                 break;\r
 283             }\r
 284             break;\r
 285         }\r
 286     }\r
 287     if (!rl)\r
 288     {\r
 289         rl = ir_tcl_malloc (sizeof(*rl));\r
 290         rl->next = setobj->record_list;\r
 291         rl->no = no;\r
 292         setobj->record_list = rl;\r
 293     }\r
 294     rl->which = which;\r
 295     ir_tcl_strdup (NULL, &rl->elements, elements);\r
 296     return rl;\r
 297 }\r
 298 \r
 299 static struct {\r
 300     enum oid_value value;\r
 301     const char *name;\r
 302 } IrTcl_recordSyntaxTab[] = { \r
 303 { VAL_UNIMARC,    "UNIMARC" },\r
 304 { VAL_INTERMARC,  "INTERMARC" },\r
 305 { VAL_CCF,        "CCF" },\r
 306 { VAL_USMARC,     "USMARC" },\r
 307 { VAL_UKMARC,     "UKMARC" },\r
 308 { VAL_NORMARC,    "NORMARC" },\r
 309 { VAL_LIBRISMARC, "LIBRISMARC" },\r
 310 { VAL_DANMARC,    "DANMARC" },\r
 311 { VAL_FINMARC,    "FINMARC" },\r
 312 { VAL_MAB,        "MAB" },\r
 313 { VAL_CANMARC,    "CANMARC" },\r
 314 { VAL_SBN,        "SBN" },\r
 315 { VAL_PICAMARC,   "PICAMARC" },\r
 316 { VAL_AUSMARC,    "AUSMARC" },\r
 317 { VAL_IBERMARC,   "IBERMARC" },\r
 318 { VAL_SUTRS,      "SUTRS" },\r
 319 { VAL_GRS1,       "GRS1" },\r
 320 { 0, NULL }\r
 321 };\r
 322 \r
 323 /* \r
 324  * IrTcl_eval\r
 325  */\r
 326 int IrTcl_eval (Tcl_Interp *interp, const char *command)\r
 327 {\r
 328     char *tmp = ir_tcl_malloc (strlen(command)+1);\r
 329     int r;\r
 330 \r
 331     strcpy (tmp, command);\r
 332     r = Tcl_Eval (interp, tmp);\r
 333     if (r == TCL_ERROR)\r
 334         logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine, \r
 335               interp->result);\r
 336     Tcl_FreeResult (interp);\r
 337     free (tmp);\r
 338     return r;\r
 339 }\r
 340 \r
 341 /*\r
 342  * IrTcl_getRecordSyntaxStr: Return record syntax name of object id\r
 343  */\r
 344 static const char *IrTcl_getRecordSyntaxStr (enum oid_value value)\r
 345 {\r
 346     int i;\r
 347     for (i = 0; IrTcl_recordSyntaxTab[i].name; i++) \r
 348         if (IrTcl_recordSyntaxTab[i].value == value)\r
 349             return IrTcl_recordSyntaxTab[i].name;\r
 350     return "USMARC";\r
 351 }\r
 352 \r
 353 /*\r
 354  * IrTcl_getRecordSyntaxVal: Return record syntax value of string\r
 355  */\r
 356 static enum oid_value IrTcl_getRecordSyntaxVal (const char *name)\r
 357 {\r
 358     int i;\r
 359     for (i = 0; IrTcl_recordSyntaxTab[i].name; i++) \r
 360         if (!strcmp (IrTcl_recordSyntaxTab[i].name, name))\r
 361             return IrTcl_recordSyntaxTab[i].value;\r
 362     return 0;\r
 363 }\r
 364 \r
 365 static IrTcl_RecordList *find_IR_record (IrTcl_SetObj *setobj, int no)\r
 366 {\r
 367     IrTcl_RecordList *rl;\r
 368 \r
 369     for (rl = setobj->record_list; rl; rl = rl->next)\r
 370         if (no == rl->no && \r
 371             (!setobj->recordElements || !rl->elements || \r
 372              !strcmp (setobj->recordElements, rl->elements)))\r
 373             return rl;\r
 374     return NULL;\r
 375 }\r
 376 \r
 377 static void delete_IR_records (IrTcl_SetObj *setobj)\r
 378 {\r
 379     IrTcl_RecordList *rl, *rl1;\r
 380 \r
 381     for (rl = setobj->record_list; rl; rl = rl1)\r
 382     {\r
 383         switch (rl->which)\r
 384         {\r
 385         case Z_NamePlusRecord_databaseRecord:\r
 386             free (rl->u.dbrec.buf);\r
 387             break;\r
 388         case Z_NamePlusRecord_surrogateDiagnostic:\r
 389             ir_deleteDiags (&rl->u.surrogateDiagnostics.list,\r
 390                             &rl->u.surrogateDiagnostics.num);\r
 391             break;\r
 392         }\r
 393         rl1 = rl->next;\r
 394         free (rl);\r
 395     }\r
 396     setobj->record_list = NULL;\r
 397 }\r
 398 \r
 399 /*\r
 400  * get_set_int: Set/get integer value\r
 401  */\r
 402 static int get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)\r
 403 {\r
 404     char buf[20];\r
 405     \r
 406     if (argc == 3)\r
 407     {\r
 408         if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)\r
 409             return TCL_ERROR;\r
 410     }\r
 411     sprintf (buf, "%d", *val);\r
 412     Tcl_AppendResult (interp, buf, NULL);\r
 413     return TCL_OK;\r
 414 }\r
 415 \r
 416 /*\r
 417  * ir_method: Search for method in table and invoke method handler\r
 418  */\r
 419 int ir_method (Tcl_Interp *interp, int argc, char **argv, IrTcl_Methods *tab)\r
 420 {\r
 421     IrTcl_Methods *tab_i = tab;\r
 422     IrTcl_Method *t;\r
 423 \r
 424     for (tab_i = tab; tab_i->tab; tab_i++)\r
 425         for (t = tab_i->tab; t->name; t++)\r
 426             if (argc <= 0)\r
 427             {\r
 428                 if ((*t->method)(tab_i->obj, interp, argc, argv) == TCL_ERROR)\r
 429                     return TCL_ERROR;\r
 430             }\r
 431             else\r
 432                 if (!strcmp (t->name, argv[1]))\r
 433                     return (*t->method)(tab_i->obj, interp, argc, argv);\r
 434 \r
 435     if (argc <= 0)\r
 436         return TCL_OK;\r
 437     Tcl_AppendResult (interp, "Bad method: ", argv[1], \r
 438                       ". Possible methods:", NULL);\r
 439     for (tab_i = tab; tab_i->tab; tab_i++)\r
 440         for (t = tab_i->tab; t->name; t++)\r
 441             Tcl_AppendResult (interp, " ", t->name, NULL);\r
 442     return TCL_ERROR;\r
 443 }\r
 444 \r
 445 /*\r
 446  * ir_method_r: Get status for all readable elements\r
 447  */\r
 448 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,\r
 449                  IrTcl_Method *tab)\r
 450 {\r
 451     char *argv_n[3];\r
 452     int argc_n;\r
 453 \r
 454     argv_n[0] = argv[0];\r
 455     argc_n = 2;\r
 456     for (; tab->name; tab++)\r
 457         if (tab->type)\r
 458         {\r
 459             argv_n[1] = tab->name;\r
 460             Tcl_AppendResult (interp, "{", NULL);\r
 461             (*tab->method)(obj, interp, argc_n, argv_n);\r
 462             Tcl_AppendResult (interp, "} ", NULL);\r
 463         }\r
 464     return TCL_OK;\r
 465 }\r
 466 \r
 467 /*\r
 468  *  ir_named_bits: get/set named bits\r
 469  */\r
 470 int ir_named_bits (struct ir_named_entry *tab, Odr_bitmask *ob,\r
 471                    Tcl_Interp *interp, int argc, char **argv)\r
 472 {\r
 473     struct ir_named_entry *ti;\r
 474     if (argc > 0)\r
 475     {\r
 476         int no;\r
 477         ODR_MASK_ZERO (ob);\r
 478         for (no = 0; no < argc; no++)\r
 479         {\r
 480             for (ti = tab; ti->name; ti++)\r
 481                 if (!strcmp (argv[no], ti->name))\r
 482                 {\r
 483                     ODR_MASK_SET (ob, ti->pos);\r
 484                     break;\r
 485                 }\r
 486             if (!ti->name)\r
 487             {\r
 488                 Tcl_AppendResult (interp, "Bad bit mask: ", argv[no], NULL);\r
 489                 return TCL_ERROR;\r
 490             }\r
 491         }\r
 492         return TCL_OK;\r
 493     }\r
 494     for (ti = tab; ti->name; ti++)\r
 495         if (ODR_MASK_GET (ob, ti->pos))\r
 496             Tcl_AppendElement (interp, ti->name);\r
 497     return TCL_OK;\r
 498 }\r
 499 \r
 500 static void set_referenceId (ODR o, Z_ReferenceId **dst, const char *src)\r
 501 {\r
 502     if (!src || !*src)\r
 503         *dst = NULL;\r
 504     else\r
 505     {\r
 506         *dst = odr_malloc (o, sizeof(**dst));\r
 507         (*dst)->size = (*dst)->len = strlen(src);\r
 508         (*dst)->buf = odr_malloc (o, (*dst)->len);\r
 509         memcpy ((*dst)->buf, src, (*dst)->len);\r
 510     }\r
 511 }\r
 512 \r
 513 static void get_referenceId (char **dst, Z_ReferenceId *src)\r
 514 {\r
 515     free (*dst);\r
 516     if (!src)\r
 517     {\r
 518         *dst = NULL;\r
 519         return;\r
 520     }\r
 521     *dst = ir_tcl_malloc (src->len+1);\r
 522     memcpy (*dst, src->buf, src->len);\r
 523     (*dst)[src->len] = '\0';\r
 524 }\r
 525 \r
 526 /* ------------------------------------------------------- */\r
 527 \r
 528 /*\r
 529  * do_init_request: init method on IR object\r
 530  */\r
 531 static int do_init_request (void *obj, Tcl_Interp *interp,\r
 532                             int argc, char **argv)\r
 533 {\r
 534     Z_APDU *apdu;\r
 535     IrTcl_Obj *p = obj;\r
 536     Z_InitRequest *req;\r
 537 \r
 538     if (argc <= 0)\r
 539         return TCL_OK;\r
 540     if (!p->cs_link)\r
 541     {\r
 542         interp->result = "init: not connected";\r
 543         return TCL_ERROR;\r
 544     }\r
 545     apdu = zget_APDU (p->odr_out, Z_APDU_initRequest);\r
 546     req = apdu->u.initRequest;\r
 547 \r
 548     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);\r
 549     req->options = &p->options;\r
 550     req->protocolVersion = &p->protocolVersion;\r
 551     req->preferredMessageSize = &p->preferredMessageSize;\r
 552     req->maximumRecordSize = &p->maximumRecordSize;\r
 553 \r
 554     if (p->idAuthenticationGroupId)\r
 555     {\r
 556         Z_IdPass *pass = odr_malloc (p->odr_out, sizeof(*pass));\r
 557         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));\r
 558 \r
 559         logf (LOG_DEBUG, "using pass authentication");\r
 560 \r
 561         auth->which = Z_IdAuthentication_idPass;\r
 562         auth->u.idPass = pass;\r
 563         if (p->idAuthenticationGroupId && *p->idAuthenticationGroupId)\r
 564             pass->groupId = p->idAuthenticationGroupId;\r
 565         else\r
 566             pass->groupId = NULL;\r
 567         if (p->idAuthenticationUserId && *p->idAuthenticationUserId)\r
 568             pass->userId = p->idAuthenticationUserId;\r
 569         else\r
 570             pass->userId = NULL;\r
 571         if (p->idAuthenticationPassword && *p->idAuthenticationPassword)\r
 572             pass->password = p->idAuthenticationPassword;\r
 573         else\r
 574             pass->password = NULL;\r
 575         req->idAuthentication = auth;\r
 576     }\r
 577     else if (!p->idAuthenticationOpen || !*p->idAuthenticationOpen)\r
 578         req->idAuthentication = NULL;\r
 579     else\r
 580     {\r
 581         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));\r
 582 \r
 583         logf (LOG_DEBUG, "using open authentication");\r
 584         auth->which = Z_IdAuthentication_open;\r
 585         auth->u.open = p->idAuthenticationOpen;\r
 586         req->idAuthentication = auth;\r
 587     }\r
 588     req->implementationId = p->implementationId;\r
 589     req->implementationName = p->implementationName;\r
 590     req->implementationVersion = p->implementationVersion;\r
 591     req->userInformationField = 0;\r
 592 \r
 593     return ir_tcl_send_APDU (interp, p, apdu, "init", argv[0]);\r
 594 }\r
 595 \r
 596 /*\r
 597  * do_protocolVersion: Set protocol Version\r
 598  */\r
 599 static int do_protocolVersion (void *obj, Tcl_Interp *interp,\r
 600                                int argc, char **argv)\r
 601 {\r
 602     int version, i;\r
 603     char buf[10];\r
 604     IrTcl_Obj *p = obj;\r
 605 \r
 606     if (argc <= 0)\r
 607     {\r
 608         ODR_MASK_ZERO (&p->protocolVersion);\r
 609         ODR_MASK_SET (&p->protocolVersion, 0);\r
 610         ODR_MASK_SET (&p->protocolVersion, 1);\r
 611         return TCL_OK;\r
 612     }\r
 613     if (argc == 3)\r
 614     {\r
 615         if (Tcl_GetInt (interp, argv[2], &version)==TCL_ERROR)\r
 616             return TCL_ERROR;\r
 617         ODR_MASK_ZERO (&p->protocolVersion);\r
 618         for (i = 0; i<version; i++)\r
 619             ODR_MASK_SET (&p->protocolVersion, i);\r
 620     }\r
 621     for (i = 4; --i >= 0; )\r
 622         if (ODR_MASK_GET (&p->protocolVersion, i))\r
 623             break;\r
 624     sprintf (buf, "%d", i+1);\r
 625     interp->result = buf;\r
 626     return TCL_OK;\r
 627 }\r
 628 \r
 629 /*\r
 630  * do_options: Set options\r
 631  */\r
 632 static int do_options (void *obj, Tcl_Interp *interp,\r
 633                        int argc, char **argv)\r
 634 {\r
 635     static struct ir_named_entry options_tab[] = {\r
 636     { "search", 0 },\r
 637     { "present", 1 },\r
 638     { "delSet", 2 },\r
 639     { "resourceReport", 3 },\r
 640     { "triggerResourceCtrl", 4},\r
 641     { "resourceCtrl", 5},\r
 642     { "accessCtrl", 6},\r
 643     { "scan", 7},\r
 644     { "sort", 8},\r
 645     { "extendedServices", 10},\r
 646     { "level-1Segmentation", 11},\r
 647     { "level-2Segmentation", 12},\r
 648     { "concurrentOperations", 13},\r
 649     { "namedResultSets", 14},\r
 650     { NULL, 0}\r
 651     };\r
 652     IrTcl_Obj *p = obj;\r
 653 \r
 654     if (argc <= 0)\r
 655     {\r
 656         ODR_MASK_ZERO (&p->options);\r
 657         ODR_MASK_SET (&p->options, 0);\r
 658         ODR_MASK_SET (&p->options, 1);\r
 659         ODR_MASK_SET (&p->options, 4);\r
 660         ODR_MASK_SET (&p->options, 7);\r
 661         ODR_MASK_SET (&p->options, 14);\r
 662         return TCL_OK;\r
 663     }\r
 664     return ir_named_bits (options_tab, &p->options, interp, argc-2, argv+2);\r
 665 }\r
 666 \r
 667 /*\r
 668  * do_failInfo: Get fail information\r
 669  */\r
 670 static int do_failInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)\r
 671 {\r
 672     char buf[16], *cp;\r
 673     IrTcl_Obj *p = obj;\r
 674 \r
 675     if (argc <= 0)\r
 676     {\r
 677         p->failInfo = 0;\r
 678         return TCL_OK;\r
 679     }\r
 680     sprintf (buf, "%d", p->failInfo);\r
 681     switch (p->failInfo)\r
 682     {\r
 683     case 0:\r
 684         cp = "ok";\r
 685         break;\r
 686     case IR_TCL_FAIL_CONNECT:\r
 687         cp = "connect failed";\r
 688         break;\r
 689     case IR_TCL_FAIL_READ:\r
 690         cp = "connection closed";\r
 691         break;\r
 692     case IR_TCL_FAIL_WRITE:\r
 693         cp = "connection closed";\r
 694         break;\r
 695     case IR_TCL_FAIL_IN_APDU:\r
 696         cp = "failed to decode incoming APDU";\r
 697         break;\r
 698     case IR_TCL_FAIL_UNKNOWN_APDU:\r
 699         cp = "unknown APDU";\r
 700         break;\r
 701     default:\r
 702         cp = "";\r
 703     } \r
 704     Tcl_AppendElement (interp, buf);\r
 705     Tcl_AppendElement (interp, cp);\r
 706     return TCL_OK;\r
 707 }\r
 708 \r
 709 /*\r
 710  * do_preferredMessageSize: Set/get preferred message size\r
 711  */\r
 712 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,\r
 713                                     int argc, char **argv)\r
 714 {\r
 715     IrTcl_Obj *p = obj;\r
 716 \r
 717     if (argc <= 0)\r
 718     {\r
 719         p->preferredMessageSize = 30000;\r
 720         return TCL_OK;\r
 721     }\r
 722     return get_set_int (&p->preferredMessageSize, interp, argc, argv);\r
 723 }\r
 724 \r
 725 /*\r
 726  * do_maximumRecordSize: Set/get maximum record size\r
 727  */\r
 728 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,\r
 729                                  int argc, char **argv)\r
 730 {\r
 731     IrTcl_Obj *p = obj;\r
 732 \r
 733     if (argc <= 0)\r
 734     {\r
 735         p->maximumRecordSize = 30000;\r
 736         return TCL_OK;\r
 737     }\r
 738     return get_set_int (&p->maximumRecordSize, interp, argc, argv);\r
 739 }\r
 740 \r
 741 /*\r
 742  * do_initResult: Get init result\r
 743  */\r
 744 static int do_initResult (void *obj, Tcl_Interp *interp,\r
 745                           int argc, char **argv)\r
 746 {\r
 747     IrTcl_Obj *p = obj;\r
 748    \r
 749     if (argc <= 0)\r
 750         return TCL_OK;\r
 751     return get_set_int (&p->initResult, interp, argc, argv);\r
 752 }\r
 753 \r
 754 \r
 755 /*\r
 756  * do_implementationName: Set/get Implementation Name.\r
 757  */\r
 758 static int do_implementationName (void *obj, Tcl_Interp *interp,\r
 759                                     int argc, char **argv)\r
 760 {\r
 761     IrTcl_Obj *p = obj;\r
 762 \r
 763     if (argc == 0)\r
 764         return ir_tcl_strdup (interp, &p->implementationName,\r
 765                           "Index Data/IrTcl on YAZ");\r
 766     else if (argc == -1)\r
 767         return ir_tcl_strdel (interp, &p->implementationName);\r
 768     if (argc == 3)\r
 769     {\r
 770         free (p->implementationName);\r
 771         if (ir_tcl_strdup (interp, &p->implementationName, argv[2])\r
 772             == TCL_ERROR)\r
 773             return TCL_ERROR;\r
 774     }\r
 775     Tcl_AppendResult (interp, p->implementationName, (char*) NULL);\r
 776     return TCL_OK;\r
 777 }\r
 778 \r
 779 /*\r
 780  * do_implementationId: Get Implementation Id.\r
 781  */\r
 782 static int do_implementationId (void *obj, Tcl_Interp *interp,\r
 783                                 int argc, char **argv)\r
 784 {\r
 785     IrTcl_Obj *p = obj;\r
 786 \r
 787     if (argc == 0)\r
 788         return ir_tcl_strdup (interp, &p->implementationId, "YAZ (id=81)");\r
 789     else if (argc == -1)\r
 790         return ir_tcl_strdel (interp, &p->implementationId);\r
 791     Tcl_AppendResult (interp, p->implementationId, (char*) NULL);\r
 792     return TCL_OK;\r
 793 }\r
 794 \r
 795 /*\r
 796  * do_implementationVersion: get Implementation Version.\r
 797  */\r
 798 static int do_implementationVersion (void *obj, Tcl_Interp *interp,\r
 799                                      int argc, char **argv)\r
 800 {\r
 801     IrTcl_Obj *p = obj;\r
 802 \r
 803     if (argc == 0)\r
 804         return ir_tcl_strdup (interp, &p->implementationVersion, \r
 805                           "YAZ: " YAZ_VERSION " / IrTcl: " IR_TCL_VERSION);\r
 806     else if (argc == -1)\r
 807         return ir_tcl_strdel (interp, &p->implementationVersion);\r
 808     Tcl_AppendResult (interp, p->implementationVersion, (char*) NULL);\r
 809     return TCL_OK;\r
 810 }\r
 811 \r
 812 /*\r
 813  * do_targetImplementationName: Get Implementation Name of target.\r
 814  */\r
 815 static int do_targetImplementationName (void *obj, Tcl_Interp *interp,\r
 816                                         int argc, char **argv)\r
 817 {\r
 818     IrTcl_Obj *p = obj;\r
 819     \r
 820     if (argc == 0)\r
 821     {\r
 822         p->targetImplementationName = NULL;\r
 823         return TCL_OK;\r
 824     }\r
 825     else if (argc == -1)\r
 826         return ir_tcl_strdel (interp, &p->targetImplementationName);\r
 827     Tcl_AppendResult (interp, p->targetImplementationName, (char*) NULL);\r
 828     return TCL_OK;\r
 829 }\r
 830 \r
 831 /*\r
 832  * do_targetImplementationId: Get Implementation Id of target\r
 833  */\r
 834 static int do_targetImplementationId (void *obj, Tcl_Interp *interp,\r
 835                                       int argc, char **argv)\r
 836 {\r
 837     IrTcl_Obj *p = obj;\r
 838 \r
 839     if (argc == 0)\r
 840     {\r
 841         p->targetImplementationId = NULL;\r
 842         return TCL_OK;\r
 843     }\r
 844     else if (argc == -1)\r
 845         return ir_tcl_strdel (interp, &p->targetImplementationId);\r
 846     Tcl_AppendResult (interp, p->targetImplementationId, (char*) NULL);\r
 847     return TCL_OK;\r
 848 }\r
 849 \r
 850 /*\r
 851  * do_targetImplementationVersion: Get Implementation Version of target\r
 852  */\r
 853 static int do_targetImplementationVersion (void *obj, Tcl_Interp *interp,\r
 854                                            int argc, char **argv)\r
 855 {\r
 856     IrTcl_Obj *p = obj;\r
 857 \r
 858     if (argc == 0)\r
 859     {\r
 860         p->targetImplementationVersion = NULL;\r
 861         return TCL_OK;\r
 862     }\r
 863     else if (argc == -1)\r
 864         return ir_tcl_strdel (interp, &p->targetImplementationVersion);\r
 865     Tcl_AppendResult (interp, p->targetImplementationVersion, (char*) NULL);\r
 866     return TCL_OK;\r
 867 }\r
 868 \r
 869 /*\r
 870  * do_idAuthentication: Set/get id Authentication\r
 871  */\r
 872 static int do_idAuthentication (void *obj, Tcl_Interp *interp,\r
 873                                 int argc, char **argv)\r
 874 {\r
 875     IrTcl_Obj *p = obj;\r
 876 \r
 877     if (argc >= 3 || argc == -1)\r
 878     {\r
 879         free (p->idAuthenticationOpen);\r
 880         free (p->idAuthenticationGroupId);\r
 881         free (p->idAuthenticationUserId);\r
 882         free (p->idAuthenticationPassword);\r
 883     }\r
 884     if (argc >= 3 || argc <= 0)\r
 885     {\r
 886         p->idAuthenticationOpen = NULL;\r
 887         p->idAuthenticationGroupId = NULL;\r
 888         p->idAuthenticationUserId = NULL;\r
 889         p->idAuthenticationPassword = NULL;\r
 890     }\r
 891     if (argc <= 0)\r
 892         return TCL_OK;\r
 893     if (argc >= 3)\r
 894     {\r
 895         if (argc == 3)\r
 896         {\r
 897             if (argv[2][0] && \r
 898                 ir_tcl_strdup (interp, &p->idAuthenticationOpen, argv[2])\r
 899                 == TCL_ERROR)\r
 900                 return TCL_ERROR;\r
 901         }\r
 902         else if (argc == 5)\r
 903         {\r
 904             if (argv[2][0] && \r
 905                 ir_tcl_strdup (interp, &p->idAuthenticationGroupId, argv[2])\r
 906                 == TCL_ERROR)\r
 907                 return TCL_ERROR;\r
 908             if (argv[3][0] && \r
 909                 ir_tcl_strdup (interp, &p->idAuthenticationUserId, argv[3])\r
 910                 == TCL_ERROR)\r
 911                 return TCL_ERROR;\r
 912             if (argv[4][0] &&\r
 913                 ir_tcl_strdup (interp, &p->idAuthenticationPassword, argv[4])\r
 914                 == TCL_ERROR)\r
 915                 return TCL_ERROR;\r
 916         }\r
 917     }\r
 918     if (p->idAuthenticationOpen)\r
 919         Tcl_AppendElement (interp, p->idAuthenticationOpen);\r
 920     else if (p->idAuthenticationGroupId)\r
 921     {\r
 922         Tcl_AppendElement (interp, p->idAuthenticationGroupId);\r
 923         Tcl_AppendElement (interp, p->idAuthenticationUserId);\r
 924         Tcl_AppendElement (interp, p->idAuthenticationPassword);\r
 925     }\r
 926     return TCL_OK;\r
 927 }\r
 928 \r
 929 /*\r
 930  * do_connect: connect method on IR object\r
 931  */\r
 932 static int do_connect (void *obj, Tcl_Interp *interp,\r
 933                        int argc, char **argv)\r
 934 {\r
 935     void *addr;\r
 936     IrTcl_Obj *p = obj;\r
 937     int r;\r
 938 \r
 939     if (argc <= 0)\r
 940         return TCL_OK;\r
 941     if (argc == 3)\r
 942     {\r
 943         if (p->hostname)\r
 944         {\r
 945             interp->result = "already connected";\r
 946             return TCL_ERROR;\r
 947         }\r
 948         if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)\r
 949             return TCL_ERROR;\r
 950         if (!strcmp (p->cs_type, "tcpip"))\r
 951         {\r
 952             p->cs_link = cs_create (tcpip_type, CS_BLOCK, p->protocol_type);\r
 953             addr = tcpip_strtoaddr (argv[2]);\r
 954             if (!addr)\r
 955             {\r
 956                 interp->result = "tcpip_strtoaddr fail";\r
 957                 return TCL_ERROR;\r
 958             }\r
 959             logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]);\r
 960         }\r
 961         else if (!strcmp (p->cs_type, "mosi"))\r
 962         {\r
 963 #if MOSI\r
 964             p->cs_link = cs_create (mosi_type, CS_BLOCK, p->protocol_type);\r
 965             addr = mosi_strtoaddr (argv[2]);\r
 966             if (!addr)\r
 967             {\r
 968                 interp->result = "mosi_strtoaddr fail";\r
 969                 return TCL_ERROR;\r
 970             }\r
 971             logf (LOG_DEBUG, "mosi connect %s", argv[2]);\r
 972 #else\r
 973             interp->result = "MOSI support not there";\r
 974             return TCL_ERROR;\r
 975 #endif\r
 976         }\r
 977         else \r
 978         {\r
 979             Tcl_AppendResult (interp, "Bad comstack type: ", \r
 980                               p->cs_type, NULL);\r
 981             return TCL_ERROR;\r
 982         }\r
 983         if ((r=cs_connect (p->cs_link, addr)) < 0)\r
 984         {\r
 985             interp->result = "connect fail";\r
 986             do_disconnect (p, NULL, 2, NULL);\r
 987             return TCL_ERROR;\r
 988         }\r
 989         ir_select_add (cs_fileno (p->cs_link), p);\r
 990         if (r == 1)\r
 991         {\r
 992             ir_select_add_write (cs_fileno (p->cs_link), p);\r
 993             p->state = IR_TCL_R_Connecting;\r
 994         }\r
 995         else\r
 996         {\r
 997             p->state = IR_TCL_R_Idle;\r
 998             if (p->callback)\r
 999                 IrTcl_eval (p->interp, p->callback);\r
1000         }\r
1001     }\r
1002     else\r
1003         Tcl_AppendResult (interp, p->hostname, NULL);\r
1004     return TCL_OK;\r
1005 }\r
1006 \r
1007 /*\r
1008  * do_disconnect: disconnect method on IR object\r
1009  */\r
1010 static int do_disconnect (void *obj, Tcl_Interp *interp,\r
1011                           int argc, char **argv)\r
1012 {\r
1013     IrTcl_Obj *p = obj;\r
1014 \r
1015     if (argc == 0)\r
1016     {\r
1017         p->state = IR_TCL_R_Idle;\r
1018         p->hostname = NULL;\r
1019         p->cs_link = NULL;\r
1020         return TCL_OK;\r
1021     }\r
1022     if (p->hostname)\r
1023     {\r
1024         free (p->hostname);\r
1025         p->hostname = NULL;\r
1026         ir_select_remove_write (cs_fileno (p->cs_link), p);\r
1027         ir_select_remove (cs_fileno (p->cs_link), p);\r
1028 \r
1029         odr_reset (p->odr_in);\r
1030 \r
1031         assert (p->cs_link);\r
1032         cs_close (p->cs_link);\r
1033         p->cs_link = NULL;\r
1034 \r
1035         ODR_MASK_ZERO (&p->options);\r
1036         ODR_MASK_SET (&p->options, 0);\r
1037         ODR_MASK_SET (&p->options, 1);\r
1038         ODR_MASK_SET (&p->options, 4);\r
1039         ODR_MASK_SET (&p->options, 7);\r
1040         ODR_MASK_SET (&p->options, 14);\r
1041 \r
1042         ODR_MASK_ZERO (&p->protocolVersion);\r
1043         ODR_MASK_SET (&p->protocolVersion, 0);\r
1044         ODR_MASK_SET (&p->protocolVersion, 1);\r
1045         ir_tcl_del_q (p);\r
1046     }\r
1047     assert (!p->cs_link);\r
1048     return TCL_OK;\r
1049 }\r
1050 \r
1051 /*\r
1052  * do_comstack: Set/get comstack method on IR object\r
1053  */\r
1054 static int do_comstack (void *o, Tcl_Interp *interp,\r
1055                         int argc, char **argv)\r
1056 {\r
1057     IrTcl_Obj *obj = o;\r
1058 \r
1059     if (argc == 0)\r
1060         return ir_tcl_strdup (interp, &obj->cs_type, "tcpip");\r
1061     else if (argc == -1)\r
1062         return ir_tcl_strdel (interp, &obj->cs_type);\r
1063     else if (argc == 3)\r
1064     {\r
1065         free (obj->cs_type);\r
1066         if (ir_tcl_strdup (interp, &obj->cs_type, argv[2]) == TCL_ERROR)\r
1067             return TCL_ERROR;\r
1068     }\r
1069     Tcl_AppendElement (interp, obj->cs_type);\r
1070     return TCL_OK;\r
1071 }\r
1072 \r
1073 /*\r
1074  * do_logLevel: Set log level\r
1075  */\r
1076 static int do_logLevel (void *o, Tcl_Interp *interp,\r
1077                         int argc, char **argv)\r
1078 {\r
1079     if (argc <= 2)\r
1080         return TCL_OK;\r
1081     if (argc == 3)\r
1082         log_init (log_mask_str (argv[2]), "", NULL);\r
1083     else if (argc == 4)\r
1084         log_init (log_mask_str (argv[2]), argv[3], NULL);\r
1085     else if (argc == 5)\r
1086         log_init (log_mask_str (argv[2]), argv[3], argv[4]);\r
1087     return TCL_OK;\r
1088 }\r
1089 \r
1090 \r
1091 /*\r
1092  * do_callback: add callback\r
1093  */\r
1094 static int do_callback (void *obj, Tcl_Interp *interp,\r
1095                           int argc, char **argv)\r
1096 {\r
1097     IrTcl_Obj *p = obj;\r
1098 \r
1099     if (argc == 0)\r
1100     {\r
1101         p->callback = NULL;\r
1102         return TCL_OK;\r
1103     }\r
1104     else if (argc == -1)\r
1105         return ir_tcl_strdel (interp, &p->callback);\r
1106     if (argc == 3)\r
1107     {\r
1108         free (p->callback);\r
1109         if (argv[2][0])\r
1110         {\r
1111             if (ir_tcl_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)\r
1112                 return TCL_ERROR;\r
1113         }\r
1114         else\r
1115             p->callback = NULL;\r
1116     }\r
1117     return TCL_OK;\r
1118 }\r
1119 \r
1120 /*\r
1121  * do_failback: add error handle callback\r
1122  */\r
1123 static int do_failback (void *obj, Tcl_Interp *interp,\r
1124                           int argc, char **argv)\r
1125 {\r
1126     IrTcl_Obj *p = obj;\r
1127 \r
1128     if (argc == 0)\r
1129     {\r
1130         p->failback = NULL;\r
1131         return TCL_OK;\r
1132     }\r
1133     else if (argc == -1)\r
1134         return ir_tcl_strdel (interp, &p->failback);\r
1135     else if (argc == 3)\r
1136     {\r
1137         free (p->failback);\r
1138         if (argv[2][0])\r
1139         {\r
1140             if (ir_tcl_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)\r
1141                 return TCL_ERROR;\r
1142         }\r
1143         else\r
1144             p->failback = NULL;\r
1145     }\r
1146     return TCL_OK;\r
1147 }\r
1148 \r
1149 /*\r
1150  * do_protocol: Set/get protocol method on IR object\r
1151  */\r
1152 static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv)\r
1153 {\r
1154     IrTcl_Obj *p = o;\r
1155 \r
1156     if (argc <= 0)\r
1157     {\r
1158         p->protocol_type = PROTO_Z3950;\r
1159         return TCL_OK;\r
1160     }\r
1161     else if (argc == 3)\r
1162     {\r
1163         if (!strcmp (argv[2], "Z39"))\r
1164             p->protocol_type = PROTO_Z3950;\r
1165         else if (!strcmp (argv[2], "SR"))\r
1166             p->protocol_type = PROTO_SR;\r
1167         else\r
1168         {\r
1169             Tcl_AppendResult (interp, "Bad protocol: ", argv[2], NULL);\r
1170             return TCL_ERROR;\r
1171         }\r
1172         return TCL_OK;\r
1173     }\r
1174     switch (p->protocol_type)\r
1175     {\r
1176     case PROTO_Z3950:\r
1177         Tcl_AppendElement (interp, "Z39");\r
1178         break;\r
1179     case PROTO_SR:\r
1180         Tcl_AppendElement (interp, "SR");\r
1181         break;\r
1182     }\r
1183     return TCL_OK;\r
1184 }\r
1185 \r
1186 /*\r
1187  * do_triggerResourceControl:\r
1188  */\r
1189 static int do_triggerResourceControl (void *obj, Tcl_Interp *interp,\r
1190                                       int argc, char **argv)\r
1191 {\r
1192     IrTcl_Obj *p = obj;\r
1193     Z_APDU *apdu;\r
1194     Z_TriggerResourceControlRequest *req;\r
1195     bool_t is_false = 0;\r
1196 \r
1197     if (argc <= 0)\r
1198         return TCL_OK;\r
1199     if (!p->cs_link)\r
1200     {\r
1201         interp->result = "triggerResourceControl: not connected";\r
1202         return TCL_ERROR;\r
1203     }\r
1204     apdu = zget_APDU (p->odr_out, Z_APDU_triggerResourceControlRequest);\r
1205     req = apdu->u.triggerResourceControlRequest;\r
1206     *req->requestedAction = Z_TriggerResourceCtrl_cancel;\r
1207     req->resultSetWanted = &is_false; \r
1208     \r
1209     return ir_tcl_send_APDU (interp, p, apdu, "triggerResourceControl",\r
1210                              argv[0]);\r
1211 }\r
1212 \r
1213 /*\r
1214  * do_databaseNames: specify database names\r
1215  */\r
1216 static int do_databaseNames (void *obj, Tcl_Interp *interp,\r
1217                              int argc, char **argv)\r
1218 {\r
1219     int i;\r
1220     IrTcl_SetCObj *p = obj;\r
1221 \r
1222     if (argc == -1)\r
1223     {\r
1224         for (i=0; i<p->num_databaseNames; i++)\r
1225             free (p->databaseNames[i]);\r
1226         free (p->databaseNames);\r
1227     }\r
1228     if (argc <= 0)\r
1229     {\r
1230         p->num_databaseNames = 0;\r
1231         p->databaseNames = NULL;\r
1232         return TCL_OK;\r
1233     }\r
1234     if (argc < 3)\r
1235     {\r
1236         for (i=0; i<p->num_databaseNames; i++)\r
1237             Tcl_AppendElement (interp, p->databaseNames[i]);\r
1238         return TCL_OK;\r
1239     }\r
1240     if (p->databaseNames)\r
1241     {\r
1242         for (i=0; i<p->num_databaseNames; i++)\r
1243             free (p->databaseNames[i]);\r
1244         free (p->databaseNames);\r
1245     }\r
1246     p->num_databaseNames = argc - 2;\r
1247     p->databaseNames =\r
1248         ir_tcl_malloc (sizeof(*p->databaseNames) * p->num_databaseNames);\r
1249     for (i=0; i<p->num_databaseNames; i++)\r
1250     {\r
1251         if (ir_tcl_strdup (interp, &p->databaseNames[i], argv[2+i]) \r
1252             == TCL_ERROR)\r
1253             return TCL_ERROR;\r
1254     }\r
1255     return TCL_OK;\r
1256 }\r
1257 \r
1258 /*\r
1259  * do_replaceIndicator: Set/get replace Set indicator\r
1260  */\r
1261 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,\r
1262                                 int argc, char **argv)\r
1263 {\r
1264     IrTcl_SetCObj *p = obj;\r
1265 \r
1266     if (argc <= 0)\r
1267     {\r
1268         p->replaceIndicator = 1;\r
1269         return TCL_OK;\r
1270     }\r
1271     return get_set_int (&p->replaceIndicator, interp, argc, argv);\r
1272 }\r
1273 \r
1274 /*\r
1275  * do_queryType: Set/Get query method\r
1276  */\r
1277 static int do_queryType (void *obj, Tcl_Interp *interp,\r
1278                        int argc, char **argv)\r
1279 {\r
1280     IrTcl_SetCObj *p = obj;\r
1281 \r
1282     if (argc == 0)\r
1283         return ir_tcl_strdup (interp, &p->queryType, "rpn");\r
1284     else if (argc == -1)\r
1285         return ir_tcl_strdel (interp, &p->queryType);\r
1286     if (argc == 3)\r
1287     {\r
1288         free (p->queryType);\r
1289         if (ir_tcl_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR)\r
1290             return TCL_ERROR;\r
1291     }\r
1292     Tcl_AppendResult (interp, p->queryType, NULL);\r
1293     return TCL_OK;\r
1294 }\r
1295 \r
1296 /*\r
1297  * do_userInformationField: Get User information field\r
1298  */\r
1299 static int do_userInformationField (void *obj, Tcl_Interp *interp,\r
1300                                     int argc, char **argv)\r
1301 {\r
1302     IrTcl_Obj *p = obj;\r
1303     \r
1304     if (argc == 0)\r
1305     {\r
1306         p->userInformationField = NULL;\r
1307         return TCL_OK;\r
1308     }\r
1309     else if (argc == -1)\r
1310         return ir_tcl_strdel (interp, &p->userInformationField);\r
1311     Tcl_AppendResult (interp, p->userInformationField, NULL);\r
1312     return TCL_OK;\r
1313 }\r
1314 \r
1315 /*\r
1316  * do_smallSetUpperBound: Set/get small set upper bound\r
1317  */\r
1318 static int do_smallSetUpperBound (void *o, Tcl_Interp *interp,\r
1319                        int argc, char **argv)\r
1320 {\r
1321     IrTcl_SetCObj *p = o;\r
1322 \r
1323     if (argc <= 0)\r
1324     {\r
1325         p->smallSetUpperBound = 0;\r
1326         return TCL_OK;\r
1327     }\r
1328     return get_set_int (&p->smallSetUpperBound, interp, argc, argv);\r
1329 }\r
1330 \r
1331 /*\r
1332  * do_largeSetLowerBound: Set/get large set lower bound\r
1333  */\r
1334 static int do_largeSetLowerBound (void *o, Tcl_Interp *interp,\r
1335                                   int argc, char **argv)\r
1336 {\r
1337     IrTcl_SetCObj *p = o;\r
1338 \r
1339     if (argc <= 0)\r
1340     {\r
1341         p->largeSetLowerBound = 2;\r
1342         return TCL_OK;\r
1343     }\r
1344     return get_set_int (&p->largeSetLowerBound, interp, argc, argv);\r
1345 }\r
1346 \r
1347 /*\r
1348  * do_mediumSetPresentNumber: Set/get large set lower bound\r
1349  */\r
1350 static int do_mediumSetPresentNumber (void *o, Tcl_Interp *interp,\r
1351                                       int argc, char **argv)\r
1352 {\r
1353     IrTcl_SetCObj *p = o;\r
1354    \r
1355     if (argc <= 0)\r
1356     {\r
1357         p->mediumSetPresentNumber = 0;\r
1358         return TCL_OK;\r
1359     }\r
1360     return get_set_int (&p->mediumSetPresentNumber, interp, argc, argv);\r
1361 }\r
1362 \r
1363 /*\r
1364  * do_referenceId: Set/Get referenceId\r
1365  */\r
1366 static int do_referenceId (void *obj, Tcl_Interp *interp,\r
1367                            int argc, char **argv)\r
1368 {\r
1369     IrTcl_SetCObj *p = obj;\r
1370 \r
1371     if (argc == 0)\r
1372     {\r
1373         p->referenceId = NULL;\r
1374         return TCL_OK;\r
1375     }\r
1376     else if (argc == -1)\r
1377         return ir_tcl_strdel (interp, &p->referenceId);\r
1378     if (argc == 3)\r
1379     {\r
1380         free (p->referenceId);\r
1381         if (ir_tcl_strdup (interp, &p->referenceId, argv[2]) == TCL_ERROR)\r
1382             return TCL_ERROR;\r
1383     }\r
1384     Tcl_AppendResult (interp, p->referenceId, NULL);\r
1385     return TCL_OK;\r
1386 }\r
1387 \r
1388 /*\r
1389  * do_preferredRecordSyntax: Set/get preferred record syntax\r
1390  */\r
1391 static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp,\r
1392                                      int argc, char **argv)\r
1393 {\r
1394     IrTcl_SetCObj *p = obj;\r
1395 \r
1396     if (argc == 0)\r
1397     {\r
1398         p->preferredRecordSyntax = NULL;\r
1399         return TCL_OK;\r
1400     }\r
1401     else if (argc == -1)\r
1402     {\r
1403         free (p->preferredRecordSyntax);\r
1404         p->preferredRecordSyntax = NULL;\r
1405         return TCL_OK;\r
1406     }\r
1407     if (argc == 3)\r
1408     {\r
1409         free (p->preferredRecordSyntax);\r
1410         p->preferredRecordSyntax = NULL;\r
1411         if (argv[2][0] && (p->preferredRecordSyntax = \r
1412                            ir_tcl_malloc (sizeof(*p->preferredRecordSyntax))))\r
1413             *p->preferredRecordSyntax = IrTcl_getRecordSyntaxVal (argv[2]);\r
1414     }\r
1415     return TCL_OK;\r
1416             \r
1417 }\r
1418 \r
1419 /*\r
1420  * do_elementSetNames: Set/Get element Set Names\r
1421  */\r
1422 static int do_elementSetNames (void *obj, Tcl_Interp *interp,\r
1423                                int argc, char **argv)\r
1424 {\r
1425     IrTcl_SetCObj *p = obj;\r
1426 \r
1427     if (argc == 0)\r
1428     {\r
1429         p->elementSetNames = NULL;\r
1430         return TCL_OK;\r
1431     }\r
1432     else if (argc == -1)\r
1433         return ir_tcl_strdel (interp, &p->elementSetNames);\r
1434     if (argc == 3)\r
1435     {\r
1436         free (p->elementSetNames);\r
1437         if (ir_tcl_strdup (interp, &p->elementSetNames, argv[2]) == TCL_ERROR)\r
1438             return TCL_ERROR;\r
1439     }\r
1440     Tcl_AppendResult (interp, p->elementSetNames, NULL);\r
1441     return TCL_OK;\r
1442 }\r
1443 \r
1444 /*\r
1445  * do_smallSetElementSetNames: Set/Get small Set Element Set Names\r
1446  */\r
1447 static int do_smallSetElementSetNames (void *obj, Tcl_Interp *interp,\r
1448                                int argc, char **argv)\r
1449 {\r
1450     IrTcl_SetCObj *p = obj;\r
1451 \r
1452     if (argc == 0)\r
1453     {\r
1454         p->smallSetElementSetNames = NULL;\r
1455         return TCL_OK;\r
1456     }\r
1457     else if (argc == -1)\r
1458         return ir_tcl_strdel (interp, &p->smallSetElementSetNames);\r
1459     if (argc == 3)\r
1460     {\r
1461         free (p->smallSetElementSetNames);\r
1462         if (ir_tcl_strdup (interp, &p->smallSetElementSetNames,\r
1463                            argv[2]) == TCL_ERROR)\r
1464             return TCL_ERROR;\r
1465     }\r
1466     Tcl_AppendResult (interp, p->smallSetElementSetNames, NULL);\r
1467     return TCL_OK;\r
1468 }\r
1469 \r
1470 /*\r
1471  * do_mediumSetElementSetNames: Set/Get medium Set Element Set Names\r
1472  */\r
1473 static int do_mediumSetElementSetNames (void *obj, Tcl_Interp *interp,\r
1474                                int argc, char **argv)\r
1475 {\r
1476     IrTcl_SetCObj *p = obj;\r
1477 \r
1478     if (argc == 0)\r
1479     {\r
1480         p->mediumSetElementSetNames = NULL;\r
1481         return TCL_OK;\r
1482     }\r
1483     else if (argc == -1)\r
1484         return ir_tcl_strdel (interp, &p->mediumSetElementSetNames);\r
1485     if (argc == 3)\r
1486     {\r
1487         free (p->mediumSetElementSetNames);\r
1488         if (ir_tcl_strdup (interp, &p->mediumSetElementSetNames,\r
1489                            argv[2]) == TCL_ERROR)\r
1490             return TCL_ERROR;\r
1491     }\r
1492     Tcl_AppendResult (interp, p->mediumSetElementSetNames, NULL);\r
1493     return TCL_OK;\r
1494 }\r
1495 \r
1496 \r
1497 static IrTcl_Method ir_method_tab[] = {\r
1498 { 1, "comstack",                    do_comstack },\r
1499 { 1, "protocol",                    do_protocol },\r
1500 { 0, "failback",                    do_failback },\r
1501 { 0, "failInfo",                    do_failInfo },\r
1502 { 0, "logLevel",                    do_logLevel },\r
1503 \r
1504 { 1, "connect",                     do_connect },\r
1505 { 0, "protocolVersion",             do_protocolVersion },\r
1506 { 1, "preferredMessageSize",        do_preferredMessageSize },\r
1507 { 1, "maximumRecordSize",           do_maximumRecordSize },\r
1508 { 1, "implementationName",          do_implementationName },\r
1509 { 1, "implementationId",            do_implementationId },\r
1510 { 1, "implementationVersion",       do_implementationVersion },\r
1511 { 0, "targetImplementationName",    do_targetImplementationName },\r
1512 { 0, "targetImplementationId",      do_targetImplementationId },\r
1513 { 0, "targetImplementationVersion", do_targetImplementationVersion },\r
1514 { 0, "userInformationField",        do_userInformationField },\r
1515 { 1, "idAuthentication",            do_idAuthentication },\r
1516 { 0, "options",                     do_options },\r
1517 { 0, "init",                        do_init_request },\r
1518 { 0, "initResult",                  do_initResult },\r
1519 { 0, "disconnect",                  do_disconnect },\r
1520 { 0, "callback",                    do_callback },\r
1521 { 0, "triggerResourceControl",      do_triggerResourceControl },\r
1522 { 0, NULL, NULL}\r
1523 };\r
1524 \r
1525 static IrTcl_Method ir_set_c_method_tab[] = {\r
1526 { 0, "databaseNames",               do_databaseNames},\r
1527 { 0, "replaceIndicator",            do_replaceIndicator},\r
1528 { 0, "queryType",                   do_queryType },\r
1529 { 0, "preferredRecordSyntax",       do_preferredRecordSyntax },\r
1530 { 0, "smallSetUpperBound",          do_smallSetUpperBound},\r
1531 { 0, "largeSetLowerBound",          do_largeSetLowerBound},\r
1532 { 0, "mediumSetPresentNumber",      do_mediumSetPresentNumber},\r
1533 { 0, "referenceId",                 do_referenceId },\r
1534 { 0, "elementSetNames",             do_elementSetNames },\r
1535 { 0, "smallSetElementSetNames",     do_smallSetElementSetNames },\r
1536 { 0, "mediumSetElementSetNames",    do_mediumSetElementSetNames },\r
1537 { 0, NULL, NULL}\r
1538 };\r
1539 \r
1540 /* \r
1541  * ir_obj_method: IR Object methods\r
1542  */\r
1543 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,\r
1544                           int argc, char **argv)\r
1545 {\r
1546     IrTcl_Methods tab[3];\r
1547     IrTcl_Obj *p = clientData;\r
1548 \r
1549     if (argc < 2)\r
1550         return ir_method_r (clientData, interp, argc, argv, ir_method_tab);\r
1551 \r
1552     tab[0].tab = ir_method_tab;\r
1553     tab[0].obj = p;\r
1554     tab[1].tab = ir_set_c_method_tab;\r
1555     tab[1].obj = &p->set_inher;\r
1556     tab[2].tab = NULL;\r
1557 \r
1558     return ir_method (interp, argc, argv, tab);\r
1559 }\r
1560 \r
1561 /* \r
1562  * ir_obj_delete: IR Object disposal\r
1563  */\r
1564 static void ir_obj_delete (ClientData clientData)\r
1565 {\r
1566     IrTcl_Obj *obj = clientData;\r
1567     IrTcl_Methods tab[3];\r
1568 \r
1569     --(obj->ref_count);\r
1570     if (obj->ref_count > 0)\r
1571         return;\r
1572     assert (obj->ref_count == 0);\r
1573 \r
1574     logf (LOG_DEBUG, "ir object delete");\r
1575     tab[0].tab = ir_method_tab;\r
1576     tab[0].obj = obj;\r
1577     tab[1].tab = ir_set_c_method_tab;\r
1578     tab[1].obj = &obj->set_inher;\r
1579     tab[2].tab = NULL;\r
1580 \r
1581     ir_method (NULL, -1, NULL, tab);\r
1582 \r
1583     ir_tcl_del_q (obj);\r
1584     odr_destroy (obj->odr_in);\r
1585     odr_destroy (obj->odr_out);\r
1586     odr_destroy (obj->odr_pr);\r
1587     free (obj);\r
1588 }\r
1589 \r
1590 /* \r
1591  * ir_obj_mk: IR Object creation\r
1592  */\r
1593 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,\r
1594                       int argc, char **argv)\r
1595 {\r
1596     IrTcl_Methods tab[3];\r
1597     IrTcl_Obj *obj;\r
1598 #if CCL2RPN\r
1599     FILE *inf;\r
1600 #endif\r
1601 \r
1602     if (argc != 2)\r
1603     {\r
1604         interp->result = "wrong # args";\r
1605         return TCL_ERROR;\r
1606     }\r
1607     obj = ir_tcl_malloc (sizeof(*obj));\r
1608     obj->ref_count = 1;\r
1609 #if CCL2RPN\r
1610     obj->bibset = ccl_qual_mk (); \r
1611     if ((inf = fopen ("default.bib", "r")))\r
1612     {\r
1613         ccl_qual_file (obj->bibset, inf);\r
1614         fclose (inf);\r
1615     }\r
1616 #endif\r
1617 \r
1618     logf (LOG_DEBUG, "ir object create");\r
1619     obj->odr_in = odr_createmem (ODR_DECODE);\r
1620     obj->odr_out = odr_createmem (ODR_ENCODE);\r
1621     obj->odr_pr = odr_createmem (ODR_PRINT);\r
1622     obj->state = IR_TCL_R_Idle;\r
1623     obj->interp = interp;\r
1624 \r
1625     obj->len_in = 0;\r
1626     obj->buf_in = NULL;\r
1627     obj->request_queue = NULL;\r
1628 \r
1629     tab[0].tab = ir_method_tab;\r
1630     tab[0].obj = obj;\r
1631     tab[1].tab = ir_set_c_method_tab;\r
1632     tab[1].obj = &obj->set_inher;\r
1633     tab[2].tab = NULL;\r
1634 \r
1635     if (ir_method (interp, 0, NULL, tab) == TCL_ERROR)\r
1636         return TCL_ERROR;\r
1637     Tcl_CreateCommand (interp, argv[1], ir_obj_method,\r
1638                        (ClientData) obj, ir_obj_delete);\r
1639     return TCL_OK;\r
1640 }\r
1641 \r
1642 /* ------------------------------------------------------- */\r
1643 /*\r
1644  * do_search: Do search request\r
1645  */\r
1646 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)\r
1647 {\r
1648     Z_SearchRequest *req;\r
1649     Z_Query query;\r
1650     Z_APDU *apdu;\r
1651     Odr_oct ccl_query;\r
1652     IrTcl_SetObj *obj = o;\r
1653     IrTcl_Obj *p;\r
1654     int r;\r
1655     oident bib1;\r
1656 \r
1657     if (argc <= 0)\r
1658         return TCL_OK;\r
1659 \r
1660     p = obj->parent;\r
1661     if (argc != 3)\r
1662     {\r
1663         interp->result = "wrong # args";\r
1664         return TCL_ERROR;\r
1665     }\r
1666     if (!obj->set_inher.num_databaseNames)\r
1667     {\r
1668         interp->result = "no databaseNames";\r
1669         return TCL_ERROR;\r
1670     }\r
1671     if (!p->cs_link)\r
1672     {\r
1673         interp->result = "search: not connected";\r
1674         return TCL_ERROR;\r
1675     }\r
1676     apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest);\r
1677     req = apdu->u.searchRequest;\r
1678 \r
1679     obj->start = 1;\r
1680 \r
1681     bib1.proto = p->protocol_type;\r
1682     bib1.class = CLASS_ATTSET;\r
1683     bib1.value = VAL_BIB1;\r
1684 \r
1685     set_referenceId (p->odr_out, &req->referenceId,\r
1686                      obj->set_inher.referenceId);\r
1687 \r
1688     req->smallSetUpperBound = &obj->set_inher.smallSetUpperBound;\r
1689     req->largeSetLowerBound = &obj->set_inher.largeSetLowerBound;\r
1690     req->mediumSetPresentNumber = &obj->set_inher.mediumSetPresentNumber;\r
1691     req->replaceIndicator = &obj->set_inher.replaceIndicator;\r
1692     req->resultSetName = obj->setName ? obj->setName : "Default";\r
1693     logf (LOG_DEBUG, "Search, resultSetName %s", req->resultSetName);\r
1694     req->num_databaseNames = obj->set_inher.num_databaseNames;\r
1695     req->databaseNames = obj->set_inher.databaseNames;\r
1696     for (r=0; r < obj->set_inher.num_databaseNames; r++)\r
1697         logf (LOG_DEBUG, " Database %s", obj->set_inher.databaseNames[r]);\r
1698     if (obj->set_inher.preferredRecordSyntax)\r
1699     {\r
1700         struct oident ident;\r
1701 \r
1702         ident.proto = p->protocol_type;\r
1703         ident.class = CLASS_RECSYN;\r
1704         ident.value = *obj->set_inher.preferredRecordSyntax;\r
1705         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);\r
1706         req->preferredRecordSyntax = odr_oiddup (p->odr_out, \r
1707                                                  oid_getoidbyent (&ident));\r
1708     }\r
1709     else\r
1710         req->preferredRecordSyntax = 0;\r
1711 \r
1712     if (obj->set_inher.smallSetElementSetNames &&\r
1713         *obj->set_inher.smallSetElementSetNames)\r
1714     {\r
1715         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));\r
1716         \r
1717         esn->which = Z_ElementSetNames_generic;\r
1718         esn->u.generic = obj->set_inher.smallSetElementSetNames;\r
1719         req->smallSetElementSetNames = esn;\r
1720     }\r
1721     else\r
1722         req->smallSetElementSetNames = NULL; \r
1723     \r
1724     if (obj->set_inher.mediumSetElementSetNames &&\r
1725         *obj->set_inher.mediumSetElementSetNames)\r
1726     {\r
1727         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));\r
1728         \r
1729         esn->which = Z_ElementSetNames_generic;\r
1730         esn->u.generic = obj->set_inher.mediumSetElementSetNames;\r
1731         req->mediumSetElementSetNames = esn;\r
1732     }\r
1733     else\r
1734         req->mediumSetElementSetNames = NULL; \r
1735     \r
1736     req->query = &query;\r
1737     \r
1738     if (!strcmp (obj->set_inher.queryType, "rpn"))\r
1739     {\r
1740         Z_RPNQuery *RPNquery;\r
1741 \r
1742         RPNquery = p_query_rpn (p->odr_out, argv[2]);\r
1743         if (!RPNquery)\r
1744         {\r
1745             Tcl_AppendResult (interp, "Syntax error in query", NULL);\r
1746             return TCL_ERROR;\r
1747         }\r
1748         RPNquery->attributeSetId = oid_getoidbyent (&bib1);\r
1749         query.which = Z_Query_type_1;\r
1750         query.u.type_1 = RPNquery;\r
1751         logf (LOG_DEBUG, "RPN");\r
1752     }\r
1753 #if CCL2RPN\r
1754     else if (!strcmp (obj->set_inher.queryType, "cclrpn"))\r
1755     {\r
1756         int error;\r
1757         int pos;\r
1758         struct ccl_rpn_node *rpn;\r
1759         Z_RPNQuery *RPNquery;\r
1760 \r
1761         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);\r
1762         if (error)\r
1763         {\r
1764             Tcl_AppendResult (interp, "CCL error: ", \r
1765                               ccl_err_msg(error), NULL);\r
1766             return TCL_ERROR;\r
1767         }\r
1768         ccl_pr_tree (rpn, stderr);\r
1769         fprintf (stderr, "\n");\r
1770         assert((RPNquery = ccl_rpn_query(rpn)));\r
1771         RPNquery->attributeSetId = oid_getoidbyent (&bib1);\r
1772         query.which = Z_Query_type_1;\r
1773         query.u.type_1 = RPNquery;\r
1774         logf (LOG_DEBUG, "CCLRPN");\r
1775     }\r
1776 #endif\r
1777     else if (!strcmp (obj->set_inher.queryType, "ccl"))\r
1778     {\r
1779         query.which = Z_Query_type_2;\r
1780         query.u.type_2 = &ccl_query;\r
1781         ccl_query.buf = (unsigned char *) argv[2];\r
1782         ccl_query.len = strlen (argv[2]);\r
1783         logf (LOG_DEBUG, "CCL");\r
1784     }\r
1785     else\r
1786     {\r
1787         interp->result = "unknown query method";\r
1788         return TCL_ERROR;\r
1789     }\r
1790     return ir_tcl_send_APDU (interp, p, apdu, "search", argv[0]);\r
1791 }\r
1792 \r
1793 /*\r
1794  * do_resultCount: Get number of hits\r
1795  */\r
1796 static int do_resultCount (void *o, Tcl_Interp *interp,\r
1797                        int argc, char **argv)\r
1798 {\r
1799     IrTcl_SetObj *obj = o;\r
1800 \r
1801     if (argc <= 0)\r
1802         return TCL_OK;\r
1803     return get_set_int (&obj->resultCount, interp, argc, argv);\r
1804 }\r
1805 \r
1806 /*\r
1807  * do_searchStatus: Get search status (after search response)\r
1808  */\r
1809 static int do_searchStatus (void *o, Tcl_Interp *interp,\r
1810                             int argc, char **argv)\r
1811 {\r
1812     IrTcl_SetObj *obj = o;\r
1813 \r
1814     if (argc <= 0)\r
1815         return TCL_OK;\r
1816     return get_set_int (&obj->searchStatus, interp, argc, argv);\r
1817 }\r
1818 \r
1819 /*\r
1820  * do_presentStatus: Get search status (after search/present response)\r
1821  */\r
1822 static int do_presentStatus (void *o, Tcl_Interp *interp,\r
1823                             int argc, char **argv)\r
1824 {\r
1825     IrTcl_SetObj *obj = o;\r
1826 \r
1827     if (argc <= 0)\r
1828         return TCL_OK;\r
1829     return get_set_int (&obj->presentStatus, interp, argc, argv);\r
1830 }\r
1831 \r
1832 /*\r
1833  * do_nextResultSetPosition: Get next result set position\r
1834  *       (after search/present response)\r
1835  */\r
1836 static int do_nextResultSetPosition (void *o, Tcl_Interp *interp,\r
1837                                      int argc, char **argv)\r
1838 {\r
1839     IrTcl_SetObj *obj = o;\r
1840 \r
1841     if (argc <= 0)\r
1842     {\r
1843         obj->nextResultSetPosition = 0;\r
1844         return TCL_OK;\r
1845     }\r
1846     return get_set_int (&obj->nextResultSetPosition, interp, argc, argv);\r
1847 }\r
1848 \r
1849 /*\r
1850  * do_setName: Set result Set name\r
1851  */\r
1852 static int do_setName (void *o, Tcl_Interp *interp,\r
1853                        int argc, char **argv)\r
1854 {\r
1855     IrTcl_SetObj *obj = o;\r
1856 \r
1857     if (argc == 0)\r
1858         return ir_tcl_strdup (interp, &obj->setName, "Default");\r
1859     else if (argc == -1)\r
1860         return ir_tcl_strdel (interp, &obj->setName);\r
1861     if (argc == 3)\r
1862     {\r
1863         free (obj->setName);\r
1864         if (ir_tcl_strdup (interp, &obj->setName, argv[2])\r
1865             == TCL_ERROR)\r
1866             return TCL_ERROR;\r
1867     }\r
1868     Tcl_AppendElement (interp, obj->setName);\r
1869     return TCL_OK;\r
1870 }\r
1871 \r
1872 /*\r
1873  * do_numberOfRecordsReturned: Get number of records returned\r
1874  */\r
1875 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,\r
1876                                        int argc, char **argv)\r
1877 {\r
1878     IrTcl_SetObj *obj = o;\r
1879 \r
1880     if (argc <= 0)\r
1881     {\r
1882         obj->numberOfRecordsReturned = 0;\r
1883         return TCL_OK;\r
1884     }\r
1885     return get_set_int (&obj->numberOfRecordsReturned, interp, argc, argv);\r
1886 }\r
1887 \r
1888 /*\r
1889  * do_type: Return type (if any) at position.\r
1890  */\r
1891 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)\r
1892 {\r
1893     IrTcl_SetObj *obj = o;\r
1894     int offset;\r
1895     IrTcl_RecordList *rl;\r
1896 \r
1897     if (argc == 0)\r
1898     {\r
1899         obj->record_list = NULL;\r
1900         return TCL_OK;\r
1901     }\r
1902     else if (argc == -1)\r
1903     {\r
1904         delete_IR_records (obj);\r
1905         return TCL_OK;\r
1906     }\r
1907     if (argc != 3)\r
1908     {\r
1909         sprintf (interp->result, "wrong # args");\r
1910         return TCL_ERROR;\r
1911     }\r
1912     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
1913         return TCL_ERROR;\r
1914     rl = find_IR_record (obj, offset);\r
1915     if (!rl)\r
1916     {\r
1917         logf (LOG_DEBUG, "No record at position %d", offset);\r
1918         return TCL_OK;\r
1919     }\r
1920     switch (rl->which)\r
1921     {\r
1922     case Z_NamePlusRecord_databaseRecord:\r
1923         interp->result = "DB";\r
1924         break;\r
1925     case Z_NamePlusRecord_surrogateDiagnostic:\r
1926         interp->result = "SD";\r
1927         break;\r
1928     }\r
1929     return TCL_OK;\r
1930 }\r
1931 \r
1932 \r
1933 /*\r
1934  * do_recordType: Return record type (if any) at position.\r
1935  */\r
1936 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)\r
1937 {\r
1938     IrTcl_SetObj *obj = o;\r
1939     int offset;\r
1940     IrTcl_RecordList *rl;\r
1941 \r
1942     if (argc == 0)\r
1943     {\r
1944         return TCL_OK;\r
1945     }\r
1946     else if (argc == -1)\r
1947     {\r
1948         return TCL_OK;\r
1949     }\r
1950     if (argc != 3)\r
1951     {\r
1952         sprintf (interp->result, "wrong # args");\r
1953         return TCL_ERROR;\r
1954     }\r
1955     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
1956         return TCL_ERROR;\r
1957     rl = find_IR_record (obj, offset);\r
1958     if (!rl)\r
1959         return TCL_OK;\r
1960     if (rl->which != Z_NamePlusRecord_databaseRecord)\r
1961     {\r
1962         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);\r
1963         return TCL_ERROR;\r
1964     }\r
1965     Tcl_AppendElement (interp, (char*)\r
1966                        IrTcl_getRecordSyntaxStr (rl->u.dbrec.type));\r
1967     return TCL_OK;\r
1968 }\r
1969 \r
1970 /*\r
1971  * set record elements (for record extraction)\r
1972  */\r
1973 static int do_recordElements (void *o, Tcl_Interp *interp,\r
1974                               int argc, char **argv)\r
1975 {\r
1976     IrTcl_SetObj *obj = o;\r
1977 \r
1978     if (argc == 0)\r
1979     {\r
1980         obj->recordElements = NULL;\r
1981         return TCL_OK;\r
1982     }\r
1983     else if (argc == -1)\r
1984         return ir_tcl_strdel (NULL, &obj->recordElements);\r
1985     if (argc > 3)\r
1986     {\r
1987         sprintf (interp->result, "wrong # args");\r
1988         return TCL_ERROR;\r
1989     }\r
1990     if (argc == 3)\r
1991     {\r
1992         free (obj->recordElements);\r
1993         return ir_tcl_strdup (NULL, &obj->recordElements, \r
1994                               (*argv[2] ? argv[2] : NULL));\r
1995     }\r
1996     Tcl_AppendResult (interp, obj->recordElements, NULL);\r
1997     return TCL_OK;\r
1998 }\r
1999 \r
2000 /*\r
2001  * ir_diagResult \r
2002  */\r
2003 static int ir_diagResult (Tcl_Interp *interp, IrTcl_Diagnostic *list, int num)\r
2004 {\r
2005     char buf[20];\r
2006     int i;\r
2007     const char *cp;\r
2008 \r
2009     for (i = 0; i<num; i++)\r
2010     {\r
2011         logf (LOG_DEBUG, "Diagnostic, code %d", list[i].condition);\r
2012         sprintf (buf, "%d", list[i].condition);\r
2013         Tcl_AppendElement (interp, buf);\r
2014         cp = diagbib1_str (list[i].condition);\r
2015         if (cp)\r
2016             Tcl_AppendElement (interp, (char*) cp);\r
2017         else\r
2018             Tcl_AppendElement (interp, "");\r
2019         if (list[i].addinfo)\r
2020             Tcl_AppendElement (interp, (char*) list[i].addinfo);\r
2021         else\r
2022             Tcl_AppendElement (interp, "");\r
2023     }\r
2024     return TCL_OK;\r
2025 }\r
2026 \r
2027 /*\r
2028  * do_diag: Return diagnostic record info\r
2029  */\r
2030 static int do_diag (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2031 {\r
2032     IrTcl_SetObj *obj = o;\r
2033     int offset;\r
2034     IrTcl_RecordList *rl;\r
2035 \r
2036     if (argc <= 0)\r
2037         return TCL_OK;\r
2038     if (argc != 3)\r
2039     {\r
2040         sprintf (interp->result, "wrong # args");\r
2041         return TCL_ERROR;\r
2042     }\r
2043     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
2044         return TCL_ERROR;\r
2045     rl = find_IR_record (obj, offset);\r
2046     if (!rl)\r
2047     {\r
2048         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);\r
2049         return TCL_ERROR;\r
2050     }\r
2051     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)\r
2052     {\r
2053         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);\r
2054         return TCL_ERROR;\r
2055     }\r
2056     return ir_diagResult (interp, rl->u.surrogateDiagnostics.list,\r
2057                           rl->u.surrogateDiagnostics.num);\r
2058 }\r
2059 \r
2060 /*\r
2061  * do_getMarc: Get ISO2709 Record lines/fields\r
2062  */\r
2063 static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2064 {\r
2065     IrTcl_SetObj *obj = o;\r
2066     int offset;\r
2067     IrTcl_RecordList *rl;\r
2068 \r
2069     if (argc <= 0)\r
2070         return TCL_OK;\r
2071     if (argc < 7)\r
2072     {\r
2073         sprintf (interp->result, "wrong # args");\r
2074         return TCL_ERROR;\r
2075     }\r
2076     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
2077         return TCL_ERROR;\r
2078     rl = find_IR_record (obj, offset);\r
2079     if (!rl)\r
2080     {\r
2081         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);\r
2082         return TCL_ERROR;\r
2083     }\r
2084     if (rl->which != Z_NamePlusRecord_databaseRecord)\r
2085     {\r
2086         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);\r
2087         return TCL_ERROR;\r
2088     }\r
2089     return ir_tcl_get_marc (interp, rl->u.dbrec.buf, argc, argv);\r
2090 }\r
2091 \r
2092 /*\r
2093  * do_getSutrs: Get SUTRS Record\r
2094  */\r
2095 static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2096 {\r
2097     IrTcl_SetObj *obj = o;\r
2098     int offset;\r
2099     IrTcl_RecordList *rl;\r
2100 \r
2101     if (argc <= 0)\r
2102         return TCL_OK;\r
2103     if (argc != 3)\r
2104     {\r
2105         sprintf (interp->result, "wrong # args");\r
2106         return TCL_ERROR;\r
2107     }\r
2108     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
2109         return TCL_ERROR;\r
2110     rl = find_IR_record (obj, offset);\r
2111     if (!rl)\r
2112     {\r
2113         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);\r
2114         return TCL_ERROR;\r
2115     }\r
2116     if (rl->which != Z_NamePlusRecord_databaseRecord)\r
2117     {\r
2118         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);\r
2119         return TCL_ERROR;\r
2120     }\r
2121     if (rl->u.dbrec.type != VAL_SUTRS)\r
2122         return TCL_OK;\r
2123     Tcl_AppendElement (interp, rl->u.dbrec.buf);\r
2124     return TCL_OK;\r
2125 }\r
2126 \r
2127 \r
2128 /*\r
2129  * do_getGrs: Get a GRS1 Record\r
2130  */\r
2131 static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2132 {\r
2133     IrTcl_SetObj *obj = o;\r
2134     int offset;\r
2135     IrTcl_RecordList *rl;\r
2136 \r
2137     if (argc <= 0)\r
2138         return TCL_OK;\r
2139     if (argc < 3)\r
2140     {\r
2141         sprintf (interp->result, "wrong # args");\r
2142         return TCL_ERROR;\r
2143     }\r
2144     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)\r
2145         return TCL_ERROR;\r
2146     rl = find_IR_record (obj, offset);\r
2147     if (!rl)\r
2148     {\r
2149         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);\r
2150         return TCL_ERROR;\r
2151     }\r
2152     if (rl->which != Z_NamePlusRecord_databaseRecord)\r
2153     {\r
2154         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);\r
2155         return TCL_ERROR;\r
2156     }\r
2157     if (rl->u.dbrec.type != VAL_GRS1)\r
2158         return TCL_OK;\r
2159     return ir_tcl_get_grs (interp, rl->u.dbrec.u.grs1, argc, argv);\r
2160 }\r
2161 \r
2162 \r
2163 /*\r
2164  * do_responseStatus: Return response status (present or search)\r
2165  */\r
2166 static int do_responseStatus (void *o, Tcl_Interp *interp, \r
2167                              int argc, char **argv)\r
2168 {\r
2169     IrTcl_SetObj *obj = o;\r
2170 \r
2171     if (argc == 0)\r
2172     {\r
2173         obj->recordFlag = 0;\r
2174         obj->nonSurrogateDiagnosticNum = 0;\r
2175         obj->nonSurrogateDiagnosticList = NULL;\r
2176         return TCL_OK;\r
2177     }\r
2178     else if (argc == -1)\r
2179     {\r
2180         ir_deleteDiags (&obj->nonSurrogateDiagnosticList,\r
2181                         &obj->nonSurrogateDiagnosticNum);\r
2182         return TCL_OK;\r
2183     }\r
2184     if (!obj->recordFlag)\r
2185     {\r
2186         Tcl_AppendElement (interp, "OK");\r
2187         return TCL_OK;\r
2188     }\r
2189     switch (obj->which)\r
2190     {\r
2191     case Z_Records_DBOSD:\r
2192         Tcl_AppendElement (interp, "DBOSD");\r
2193         break;\r
2194     case Z_Records_NSD:\r
2195         Tcl_AppendElement (interp, "NSD");\r
2196         return ir_diagResult (interp, obj->nonSurrogateDiagnosticList,\r
2197                               obj->nonSurrogateDiagnosticNum);\r
2198     }\r
2199     return TCL_OK;\r
2200 }\r
2201 \r
2202 /*\r
2203  * do_present: Perform Present Request\r
2204  */\r
2205 \r
2206 static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2207 {\r
2208     IrTcl_SetObj *obj = o;\r
2209     IrTcl_Obj *p;\r
2210     Z_APDU *apdu;\r
2211     Z_PresentRequest *req;\r
2212     int start;\r
2213     int number;\r
2214 \r
2215     if (argc <= 0)\r
2216         return TCL_OK;\r
2217     if (argc >= 3)\r
2218     {\r
2219         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)\r
2220             return TCL_ERROR;\r
2221     }\r
2222     else\r
2223         start = 1;\r
2224     if (argc >= 4)\r
2225     {\r
2226         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)\r
2227             return TCL_ERROR;\r
2228     }\r
2229     else \r
2230         number = 10;\r
2231     p = obj->parent;\r
2232     if (!p->cs_link)\r
2233     {\r
2234         interp->result = "present: not connected";\r
2235         return TCL_ERROR;\r
2236     }\r
2237 \r
2238     obj->start = start;\r
2239     obj->number = number;\r
2240 \r
2241     apdu = zget_APDU (p->odr_out, Z_APDU_presentRequest);\r
2242     req = apdu->u.presentRequest;\r
2243 \r
2244     set_referenceId (p->odr_out, &req->referenceId,\r
2245                      obj->set_inher.referenceId);\r
2246 \r
2247     req->resultSetId = obj->setName ? obj->setName : "Default";\r
2248     \r
2249     req->resultSetStartPoint = &start;\r
2250     req->numberOfRecordsRequested = &number;\r
2251     if (obj->set_inher.preferredRecordSyntax)\r
2252     {\r
2253         struct oident ident;\r
2254 \r
2255         ident.proto = p->protocol_type;\r
2256         ident.class = CLASS_RECSYN;\r
2257         ident.value = *obj->set_inher.preferredRecordSyntax;\r
2258         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);\r
2259         req->preferredRecordSyntax = odr_oiddup (p->odr_out, \r
2260                                                  oid_getoidbyent (&ident));\r
2261     }\r
2262     else\r
2263         req->preferredRecordSyntax = 0;\r
2264 \r
2265     if (obj->set_inher.elementSetNames && *obj->set_inher.elementSetNames)\r
2266     {\r
2267         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));\r
2268         Z_RecordComposition *compo = odr_malloc (p->odr_out, sizeof(*compo));\r
2269 \r
2270         esn->which = Z_ElementSetNames_generic;\r
2271         esn->u.generic = obj->set_inher.elementSetNames;\r
2272 \r
2273         req->recordComposition = compo;\r
2274         compo->which = Z_RecordComp_simple;\r
2275         compo->u.simple = esn;\r
2276     }\r
2277     else\r
2278         req->recordComposition = NULL;\r
2279     return ir_tcl_send_APDU (interp, p, apdu, "present", argv[0]);\r
2280 }\r
2281 \r
2282 /*\r
2283  * do_loadFile: Load result set from file\r
2284  */\r
2285 \r
2286 static int do_loadFile (void *o, Tcl_Interp *interp,\r
2287                         int argc, char **argv)\r
2288 {\r
2289     IrTcl_SetObj *setobj = o;\r
2290     FILE *inf;\r
2291     size_t size;\r
2292     int  no = 1;\r
2293     char *buf;\r
2294 \r
2295     if (argc <= 0)\r
2296         return TCL_OK;\r
2297     if (argc != 3)\r
2298     {\r
2299         interp->result = "wrong # args";\r
2300         return TCL_ERROR;\r
2301     }\r
2302     inf = fopen (argv[2], "r");\r
2303     if (!inf)\r
2304     {\r
2305         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);\r
2306         return TCL_ERROR;\r
2307     }\r
2308     while ((buf = ir_tcl_fread_marc (inf, &size)))\r
2309     {\r
2310         IrTcl_RecordList *rl;\r
2311 \r
2312         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord, "F");\r
2313         rl->u.dbrec.type = VAL_USMARC;\r
2314         rl->u.dbrec.buf = buf;\r
2315         rl->u.dbrec.size = size;\r
2316         no++;\r
2317     }\r
2318     setobj->numberOfRecordsReturned = no-1;\r
2319     fclose (inf);\r
2320     return TCL_OK;\r
2321 }\r
2322 \r
2323 static IrTcl_Method ir_set_method_tab[] = {\r
2324     { 0, "search",                  do_search },\r
2325     { 0, "searchStatus",            do_searchStatus },\r
2326     { 0, "presentStatus",           do_presentStatus },\r
2327     { 0, "nextResultSetPosition",   do_nextResultSetPosition },\r
2328     { 0, "setName",                 do_setName },\r
2329     { 0, "resultCount",             do_resultCount },\r
2330     { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },\r
2331     { 0, "present",                 do_present },\r
2332     { 0, "type",                    do_type },\r
2333     { 0, "getMarc",                 do_getMarc },\r
2334     { 0, "getSutrs",                do_getSutrs },\r
2335     { 0, "getGrs",                  do_getGrs },\r
2336     { 0, "recordType",              do_recordType },\r
2337     { 0, "recordElements",          do_recordElements },\r
2338     { 0, "diag",                    do_diag },\r
2339     { 0, "responseStatus",          do_responseStatus },\r
2340     { 0, "loadFile",                do_loadFile },\r
2341     { 0, NULL, NULL}\r
2342 };\r
2343 \r
2344 /* \r
2345  * ir_set_obj_method: IR Set Object methods\r
2346  */\r
2347 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,\r
2348                           int argc, char **argv)\r
2349 {\r
2350     IrTcl_Methods tabs[3];\r
2351     IrTcl_SetObj *p = clientData;\r
2352 \r
2353     if (argc < 2)\r
2354     {\r
2355         interp->result = "wrong # args";\r
2356         return TCL_ERROR;\r
2357     }\r
2358     tabs[0].tab = ir_set_method_tab;\r
2359     tabs[0].obj = p;\r
2360     tabs[1].tab = ir_set_c_method_tab;\r
2361     tabs[1].obj = &p->set_inher;\r
2362     tabs[2].tab = NULL;\r
2363 \r
2364     return ir_method (interp, argc, argv, tabs);\r
2365 }\r
2366 \r
2367 /* \r
2368  * ir_set_obj_delete: IR Set Object disposal\r
2369  */\r
2370 static void ir_set_obj_delete (ClientData clientData)\r
2371 {\r
2372     IrTcl_Methods tabs[3];\r
2373     IrTcl_SetObj *p = clientData;\r
2374 \r
2375     logf (LOG_DEBUG, "ir set delete");\r
2376 \r
2377     tabs[0].tab = ir_set_method_tab;\r
2378     tabs[0].obj = p;\r
2379     tabs[1].tab = ir_set_c_method_tab;\r
2380     tabs[1].obj = &p->set_inher;\r
2381     tabs[2].tab = NULL;\r
2382 \r
2383     ir_method (NULL, -1, NULL, tabs);\r
2384 \r
2385     free (p);\r
2386 }\r
2387 \r
2388 /*\r
2389  * ir_set_obj_mk: IR Set Object creation\r
2390  */\r
2391 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,\r
2392                           int argc, char **argv)\r
2393 {\r
2394     IrTcl_Methods tabs[3];\r
2395     IrTcl_SetObj *obj;\r
2396 \r
2397     if (argc < 2 || argc > 3)\r
2398     {\r
2399         interp->result = "wrong # args";\r
2400         return TCL_ERROR;\r
2401     }\r
2402     obj = ir_tcl_malloc (sizeof(*obj));\r
2403     logf (LOG_DEBUG, "ir set create");\r
2404     if (argc == 3)\r
2405     {\r
2406         Tcl_CmdInfo parent_info;\r
2407         int i;\r
2408         IrTcl_SetCObj *dst;\r
2409         IrTcl_SetCObj *src;\r
2410 \r
2411         if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))\r
2412         {\r
2413             interp->result = "No parent";\r
2414             return TCL_ERROR;\r
2415         }\r
2416         obj->parent = (IrTcl_Obj *) parent_info.clientData;\r
2417 \r
2418         dst = &obj->set_inher;\r
2419         src = &obj->parent->set_inher;\r
2420 \r
2421         if ((dst->num_databaseNames = src->num_databaseNames))\r
2422             dst->databaseNames =\r
2423                 ir_tcl_malloc (sizeof (*dst->databaseNames)\r
2424                                * dst->num_databaseNames);\r
2425         else\r
2426             dst->databaseNames = NULL;\r
2427         for (i = 0; i < dst->num_databaseNames; i++)\r
2428             if (ir_tcl_strdup (interp, &dst->databaseNames[i],\r
2429                            src->databaseNames[i]) == TCL_ERROR)\r
2430                 return TCL_ERROR;\r
2431         if (ir_tcl_strdup (interp, &dst->queryType, src->queryType)\r
2432             == TCL_ERROR)\r
2433             return TCL_ERROR;\r
2434 \r
2435         if (ir_tcl_strdup (interp, &dst->referenceId, src->referenceId)\r
2436             == TCL_ERROR)\r
2437             return TCL_ERROR;\r
2438 \r
2439         if (ir_tcl_strdup (interp, &dst->elementSetNames, src->elementSetNames)\r
2440             == TCL_ERROR)\r
2441             return TCL_ERROR;\r
2442 \r
2443         if (ir_tcl_strdup (interp, &dst->smallSetElementSetNames,\r
2444                            src->smallSetElementSetNames)\r
2445             == TCL_ERROR)\r
2446             return TCL_ERROR;\r
2447 \r
2448         if (ir_tcl_strdup (interp, &dst->mediumSetElementSetNames,\r
2449                            src->mediumSetElementSetNames)\r
2450             == TCL_ERROR)\r
2451             return TCL_ERROR;\r
2452 \r
2453         if (src->preferredRecordSyntax && \r
2454             (dst->preferredRecordSyntax \r
2455              = ir_tcl_malloc (sizeof(*dst->preferredRecordSyntax))))\r
2456             *dst->preferredRecordSyntax = *src->preferredRecordSyntax;\r
2457         else\r
2458             dst->preferredRecordSyntax = NULL;\r
2459         dst->replaceIndicator = src->replaceIndicator;\r
2460         dst->smallSetUpperBound = src->smallSetUpperBound;\r
2461         dst->largeSetLowerBound = src->largeSetLowerBound;\r
2462         dst->mediumSetPresentNumber = src->mediumSetPresentNumber;\r
2463     }   \r
2464     else\r
2465         obj->parent = NULL;\r
2466 \r
2467     tabs[0].tab = ir_set_method_tab;\r
2468     tabs[0].obj = obj;\r
2469     tabs[1].tab = NULL;\r
2470 \r
2471     if (ir_method (interp, 0, NULL, tabs) == TCL_ERROR)\r
2472         return TCL_ERROR;\r
2473 \r
2474     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,\r
2475                        (ClientData) obj, ir_set_obj_delete);\r
2476     return TCL_OK;\r
2477 }\r
2478 \r
2479 /* ------------------------------------------------------- */\r
2480 \r
2481 /*\r
2482  * do_scan: Perform scan \r
2483  */\r
2484 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)\r
2485 {\r
2486     Z_ScanRequest *req;\r
2487     Z_APDU *apdu;\r
2488     IrTcl_ScanObj *obj = o;\r
2489     IrTcl_Obj *p = obj->parent;\r
2490     oident bib1;\r
2491 #if CCL2RPN\r
2492     struct ccl_rpn_node *rpn;\r
2493     int pos;\r
2494 #endif\r
2495 \r
2496     if (argc <= 0)\r
2497         return TCL_OK;\r
2498     if (argc != 3)\r
2499     {\r
2500         interp->result = "wrong # args";\r
2501         return TCL_ERROR;\r
2502     }\r
2503     if (!p->set_inher.num_databaseNames)\r
2504     {\r
2505         interp->result = "no databaseNames";\r
2506         return TCL_ERROR;\r
2507     }\r
2508     if (!p->cs_link)\r
2509     {\r
2510         interp->result = "scan: not connected";\r
2511         return TCL_ERROR;\r
2512     }\r
2513 \r
2514     bib1.proto = p->protocol_type;\r
2515     bib1.class = CLASS_ATTSET;\r
2516     bib1.value = VAL_BIB1;\r
2517 \r
2518     apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest);\r
2519     req = apdu->u.scanRequest;\r
2520 \r
2521     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);\r
2522     req->num_databaseNames = p->set_inher.num_databaseNames;\r
2523     req->databaseNames = p->set_inher.databaseNames;\r
2524     req->attributeSet = oid_getoidbyent (&bib1);\r
2525 \r
2526 #if !CCL2RPN\r
2527     if (!(req->termListAndStartPoint = p_query_scan (p->odr_out, argv[2])))\r
2528     {\r
2529         Tcl_AppendResult (interp, "Syntax error in query", NULL);\r
2530         return TCL_ERROR;\r
2531     }\r
2532 #else\r
2533     rpn = ccl_find_str(p->bibset, argv[2], &r, &pos);\r
2534     if (r)\r
2535     {\r
2536         Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL);\r
2537         return TCL_ERROR;\r
2538     }\r
2539     ccl_pr_tree (rpn, stderr);\r
2540     fprintf (stderr, "\n");\r
2541     if (!(req->termListAndStartPoint = ccl_scan_query (rpn)))\r
2542         return TCL_ERROR;\r
2543 #endif\r
2544     req->stepSize = &obj->stepSize;\r
2545     req->numberOfTermsRequested = &obj->numberOfTermsRequested;\r
2546     req->preferredPositionInResponse = &obj->preferredPositionInResponse;\r
2547     logf (LOG_DEBUG, "stepSize=%d", *req->stepSize);\r
2548     logf (LOG_DEBUG, "numberOfTermsRequested=%d",\r
2549           *req->numberOfTermsRequested);\r
2550     logf (LOG_DEBUG, "preferredPositionInResponse=%d",\r
2551           *req->preferredPositionInResponse);\r
2552     \r
2553     return ir_tcl_send_APDU (interp, p, apdu, "scan", argv[0]);\r
2554 }\r
2555 \r
2556 /*\r
2557  * do_stepSize: Set/get replace Step Size\r
2558  */\r
2559 static int do_stepSize (void *obj, Tcl_Interp *interp,\r
2560                         int argc, char **argv)\r
2561 {\r
2562     IrTcl_ScanObj *p = obj;\r
2563     if (argc <= 0)\r
2564     {\r
2565         p->stepSize = 0;\r
2566         return TCL_OK;\r
2567     }\r
2568     return get_set_int (&p->stepSize, interp, argc, argv);\r
2569 }\r
2570 \r
2571 /*\r
2572  * do_numberOfTermsRequested: Set/get Number of Terms requested\r
2573  */\r
2574 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,\r
2575                                       int argc, char **argv)\r
2576 {\r
2577     IrTcl_ScanObj *p = obj;\r
2578 \r
2579     if (argc <= 0)\r
2580     {\r
2581         p->numberOfTermsRequested = 20;\r
2582         return TCL_OK;\r
2583     }\r
2584     return get_set_int (&p->numberOfTermsRequested, interp, argc, argv);\r
2585 }\r
2586 \r
2587 \r
2588 /*\r
2589  * do_preferredPositionInResponse: Set/get preferred Position\r
2590  */\r
2591 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,\r
2592                                            int argc, char **argv)\r
2593 {\r
2594     IrTcl_ScanObj *p = obj;\r
2595 \r
2596     if (argc <= 0)\r
2597     {\r
2598         p->preferredPositionInResponse = 1;\r
2599         return TCL_OK;\r
2600     }\r
2601     return get_set_int (&p->preferredPositionInResponse, interp, argc, argv);\r
2602 }\r
2603 \r
2604 /*\r
2605  * do_scanStatus: Get scan status\r
2606  */\r
2607 static int do_scanStatus (void *obj, Tcl_Interp *interp,\r
2608                           int argc, char **argv)\r
2609 {\r
2610     IrTcl_ScanObj *p = obj;\r
2611 \r
2612     if (argc <= 0)\r
2613         return TCL_OK;\r
2614     return get_set_int (&p->scanStatus, interp, argc, argv);\r
2615 }\r
2616 \r
2617 /*\r
2618  * do_numberOfEntriesReturned: Get number of Entries returned\r
2619  */\r
2620 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,\r
2621                                        int argc, char **argv)\r
2622 {\r
2623     IrTcl_ScanObj *p = obj;\r
2624 \r
2625     if (argc <= 0)\r
2626         return TCL_OK;\r
2627     return get_set_int (&p->numberOfEntriesReturned, interp, argc, argv);\r
2628 }\r
2629 \r
2630 /*\r
2631  * do_positionOfTerm: Get position of Term\r
2632  */\r
2633 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,\r
2634                               int argc, char **argv)\r
2635 {\r
2636     IrTcl_ScanObj *p = obj;\r
2637 \r
2638     if (argc <= 0)\r
2639         return TCL_OK;\r
2640     return get_set_int (&p->positionOfTerm, interp, argc, argv);\r
2641 }\r
2642 \r
2643 /*\r
2644  * do_scanLine: get Scan Line (surrogate or normal) after response\r
2645  */\r
2646 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)\r
2647 {\r
2648     IrTcl_ScanObj *p = obj;\r
2649     int i;\r
2650     char numstr[20];\r
2651 \r
2652     if (argc == 0)\r
2653     {\r
2654         p->entries_flag = 0;\r
2655         p->entries = NULL;\r
2656         p->nonSurrogateDiagnosticNum = 0;\r
2657         p->nonSurrogateDiagnosticList = 0;\r
2658         return TCL_OK;\r
2659     }\r
2660     else if (argc == -1)\r
2661     {\r
2662         p->entries_flag = 0;\r
2663         /* release entries */\r
2664         p->entries = NULL;\r
2665 \r
2666         ir_deleteDiags (&p->nonSurrogateDiagnosticList, \r
2667                         &p->nonSurrogateDiagnosticNum);\r
2668         return TCL_OK;\r
2669     }\r
2670     if (argc != 3)\r
2671     {\r
2672         interp->result = "wrong # args";\r
2673         return TCL_ERROR;\r
2674     }\r
2675     if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)\r
2676         return TCL_ERROR;\r
2677     if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries\r
2678         || i >= p->num_entries || i < 0)\r
2679         return TCL_OK;\r
2680     switch (p->entries[i].which)\r
2681     {\r
2682     case Z_Entry_termInfo:\r
2683         Tcl_AppendElement (interp, "T");\r
2684         if (p->entries[i].u.term.buf)\r
2685             Tcl_AppendElement (interp, p->entries[i].u.term.buf);\r
2686         else\r
2687             Tcl_AppendElement (interp, "");\r
2688         sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);\r
2689         Tcl_AppendElement (interp, numstr);\r
2690         break;\r
2691     case Z_Entry_surrogateDiagnostic:\r
2692         Tcl_AppendElement (interp, "SD");\r
2693         return ir_diagResult (interp, p->entries[i].u.diag.list,\r
2694                               p->entries[i].u.diag.num);\r
2695         break;\r
2696     }\r
2697     return TCL_OK;\r
2698 }\r
2699 \r
2700 static IrTcl_Method ir_scan_method_tab[] = {\r
2701     { 0, "scan",                    do_scan },\r
2702     { 0, "stepSize",                do_stepSize },\r
2703     { 0, "numberOfTermsRequested",  do_numberOfTermsRequested },\r
2704     { 0, "preferredPositionInResponse", do_preferredPositionInResponse },\r
2705     { 0, "scanStatus",              do_scanStatus },\r
2706     { 0, "numberOfEntriesReturned", do_numberOfEntriesReturned },\r
2707     { 0, "positionOfTerm",          do_positionOfTerm },\r
2708     { 0, "scanLine",                do_scanLine },\r
2709     { 0, NULL, NULL}\r
2710 };\r
2711 \r
2712 /* \r
2713  * ir_scan_obj_method: IR Scan Object methods\r
2714  */\r
2715 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,\r
2716                                int argc, char **argv)\r
2717 {\r
2718     IrTcl_Methods tabs[2];\r
2719 \r
2720     if (argc < 2)\r
2721     {\r
2722         interp->result = "wrong # args";\r
2723         return TCL_ERROR;\r
2724     }\r
2725     tabs[0].tab = ir_scan_method_tab;\r
2726     tabs[0].obj = clientData;\r
2727     tabs[1].tab = NULL;\r
2728 \r
2729     return ir_method (interp, argc, argv, tabs);\r
2730 }\r
2731 \r
2732 /* \r
2733  * ir_scan_obj_delete: IR Scan Object disposal\r
2734  */\r
2735 static void ir_scan_obj_delete (ClientData clientData)\r
2736 {\r
2737     IrTcl_Methods tabs[2];\r
2738     IrTcl_ScanObj *obj = clientData;\r
2739 \r
2740     tabs[0].tab = ir_scan_method_tab;\r
2741     tabs[0].obj = obj;\r
2742     tabs[1].tab = NULL;\r
2743 \r
2744     ir_method (NULL, -1, NULL, tabs);\r
2745     free (obj);\r
2746 }\r
2747 \r
2748 /* \r
2749  * ir_scan_obj_mk: IR Scan Object creation\r
2750  */\r
2751 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,\r
2752                            int argc, char **argv)\r
2753 {\r
2754     Tcl_CmdInfo parent_info;\r
2755     IrTcl_ScanObj *obj;\r
2756     IrTcl_Methods tabs[2];\r
2757 \r
2758     if (argc != 3)\r
2759     {\r
2760         interp->result = "wrong # args";\r
2761         return TCL_ERROR;\r
2762     }\r
2763     if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))\r
2764     {\r
2765         interp->result = "No parent";\r
2766         return TCL_ERROR;\r
2767     }\r
2768     obj = ir_tcl_malloc (sizeof(*obj));\r
2769     obj->parent = (IrTcl_Obj *) parent_info.clientData;\r
2770 \r
2771     tabs[0].tab = ir_scan_method_tab;\r
2772     tabs[0].obj = obj;\r
2773     tabs[1].tab = NULL;\r
2774 \r
2775     if (ir_method (interp, 0, NULL, tabs) == TCL_ERROR)\r
2776         return TCL_ERROR;\r
2777     Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,\r
2778                        (ClientData) obj, ir_scan_obj_delete);\r
2779     return TCL_OK;\r
2780 }\r
2781 \r
2782 /* ------------------------------------------------------- */\r
2783 \r
2784 static void ir_initResponse (void *obj, Z_InitResponse *initrs)\r
2785 {\r
2786     IrTcl_Obj *p = obj;\r
2787 \r
2788     p->initResult = *initrs->result ? 1 : 0;\r
2789     if (!*initrs->result)\r
2790         logf (LOG_DEBUG, "Connection rejected by target");\r
2791     else\r
2792         logf (LOG_DEBUG, "Connection accepted by target");\r
2793 \r
2794     get_referenceId (&p->set_inher.referenceId, initrs->referenceId);\r
2795 \r
2796     free (p->targetImplementationId);\r
2797     ir_tcl_strdup (p->interp, &p->targetImplementationId,\r
2798                initrs->implementationId);\r
2799     free (p->targetImplementationName);\r
2800     ir_tcl_strdup (p->interp, &p->targetImplementationName,\r
2801                initrs->implementationName);\r
2802     free (p->targetImplementationVersion);\r
2803     ir_tcl_strdup (p->interp, &p->targetImplementationVersion,\r
2804                initrs->implementationVersion);\r
2805 \r
2806     p->maximumRecordSize = *initrs->maximumRecordSize;\r
2807     p->preferredMessageSize = *initrs->preferredMessageSize;\r
2808     \r
2809     memcpy (&p->options, initrs->options, sizeof(initrs->options));\r
2810     memcpy (&p->protocolVersion, initrs->protocolVersion,\r
2811             sizeof(initrs->protocolVersion));\r
2812     free (p->userInformationField);\r
2813     p->userInformationField = NULL;\r
2814     if (initrs->userInformationField)\r
2815     {\r
2816         int len;\r
2817 \r
2818         if (initrs->userInformationField->which == ODR_EXTERNAL_octet && \r
2819             (p->userInformationField =\r
2820              ir_tcl_malloc ((len = \r
2821                              initrs->userInformationField->\r
2822                              u.octet_aligned->len) +1)))\r
2823         {\r
2824             memcpy (p->userInformationField,\r
2825                     initrs->userInformationField->u.octet_aligned->buf,\r
2826                         len);\r
2827             (p->userInformationField)[len] = '\0';\r
2828         }\r
2829     }\r
2830 }\r
2831 \r
2832 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num)\r
2833 {\r
2834     int i;\r
2835     for (i = 0; i<*dst_num; i++)\r
2836         free (dst_list[i]->addinfo);\r
2837     free (*dst_list);\r
2838     *dst_list = NULL;\r
2839     *dst_num = 0;\r
2840 }\r
2841 \r
2842 static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num,\r
2843                     Z_DiagRec **list, int num)\r
2844 {\r
2845     int i;\r
2846     char *addinfo;\r
2847 \r
2848     *dst_num = num;\r
2849     *dst_list = ir_tcl_malloc (sizeof(**dst_list) * num);\r
2850     for (i = 0; i<num; i++)\r
2851     {\r
2852         switch (list[i]->which)\r
2853         {\r
2854         case Z_DiagRec_defaultFormat:\r
2855             (*dst_list)[i].condition = *list[i]->u.defaultFormat->condition;\r
2856             addinfo = list[i]->u.defaultFormat->addinfo;\r
2857             if (addinfo && \r
2858                 ((*dst_list)[i].addinfo = ir_tcl_malloc (strlen(addinfo)+1)))\r
2859                 strcpy ((*dst_list)[i].addinfo, addinfo);\r
2860             break;\r
2861         default:\r
2862             (*dst_list)[i].addinfo = NULL;\r
2863             (*dst_list)[i].condition = 0;\r
2864         }\r
2865     }\r
2866 }\r
2867 \r
2868 static void ir_handleRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj,\r
2869                               const char *elements)\r
2870 {\r
2871     IrTcl_Obj *p = o;\r
2872 \r
2873     int offset;\r
2874     IrTcl_RecordList *rl;\r
2875 \r
2876     setobj->which = zrs->which;\r
2877     setobj->recordFlag = 1;\r
2878     \r
2879     ir_deleteDiags (&setobj->nonSurrogateDiagnosticList,\r
2880                     &setobj->nonSurrogateDiagnosticNum);\r
2881     if (zrs->which == Z_Records_DBOSD)\r
2882     {\r
2883         setobj->numberOfRecordsReturned = \r
2884             zrs->u.databaseOrSurDiagnostics->num_records;\r
2885         logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned);\r
2886         for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)\r
2887         {\r
2888             rl = new_IR_record (setobj, setobj->start + offset,\r
2889                                 zrs->u.databaseOrSurDiagnostics->\r
2890                                 records[offset]->which,\r
2891                                 elements);\r
2892             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)\r
2893             {\r
2894                 ir_handleDiags (&rl->u.surrogateDiagnostics.list,\r
2895                                 &rl->u.surrogateDiagnostics.num,\r
2896                                 &zrs->u.databaseOrSurDiagnostics->\r
2897                                 records[offset]->u.surrogateDiagnostic,\r
2898                                 1);\r
2899             } \r
2900             else\r
2901             {\r
2902                 Z_DatabaseRecord *zr; \r
2903                 Z_External *oe;\r
2904                 struct oident *ident;\r
2905                 \r
2906                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]\r
2907                     ->u.databaseRecord;\r
2908                 oe = (Z_External*) zr;\r
2909                 rl->u.dbrec.size = zr->u.octet_aligned->len;\r
2910 \r
2911                 if ((ident = oid_getentbyoid (oe->direct_reference)))\r
2912                     rl->u.dbrec.type = ident->value;\r
2913                 else\r
2914                     rl->u.dbrec.type = VAL_USMARC;\r
2915 \r
2916                 if (oe->which == ODR_EXTERNAL_octet && rl->u.dbrec.size > 0)\r
2917                 {\r
2918                     char *buf = (char*) zr->u.octet_aligned->buf;\r
2919                     if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size)))\r
2920                         memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size);\r
2921                 }\r
2922                 else if (rl->u.dbrec.type == VAL_SUTRS && \r
2923                          oe->which == Z_External_sutrs)\r
2924                 {\r
2925                     odr_setbuf (p->odr_in, (char*) oe->u.single_ASN1_type->buf,\r
2926                                 oe->u.single_ASN1_type->len, 0);\r
2927                     if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1)))\r
2928                     {\r
2929                         memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf,\r
2930                                 oe->u.sutrs->len);\r
2931                         rl->u.dbrec.buf[oe->u.sutrs->len] = '\0';\r
2932                     }\r
2933                     rl->u.dbrec.size = oe->u.sutrs->len;\r
2934                 }\r
2935                 else if (rl->u.dbrec.type == VAL_GRS1 && \r
2936                          oe->which == Z_External_grs1)\r
2937                 {\r
2938                     ir_tcl_read_grs (oe->u.grs1, &rl->u.dbrec.u.grs1);\r
2939                     rl->u.dbrec.buf = NULL;\r
2940                 }\r
2941                 else\r
2942                     rl->u.dbrec.buf = NULL;\r
2943             }\r
2944         }\r
2945     }\r
2946     else if (zrs->which == Z_Records_multipleNSD)\r
2947     {\r
2948         logf (LOG_DEBUG, "multipleNonSurrogateDiagnostic %d",\r
2949               zrs->u.multipleNonSurDiagnostics->num_diagRecs);\r
2950         setobj->numberOfRecordsReturned = 0;\r
2951         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,\r
2952                         &setobj->nonSurrogateDiagnosticNum,\r
2953                         zrs->u.multipleNonSurDiagnostics->diagRecs,\r
2954                         zrs->u.multipleNonSurDiagnostics->num_diagRecs);\r
2955     }\r
2956     else\r
2957     {\r
2958         logf (LOG_DEBUG, "NonSurrogateDiagnostic");\r
2959         setobj->numberOfRecordsReturned = 0;\r
2960         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,\r
2961                         &setobj->nonSurrogateDiagnosticNum,\r
2962                         &zrs->u.nonSurrogateDiagnostic,\r
2963                         1);\r
2964     }\r
2965 }\r
2966 \r
2967 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs,\r
2968                                IrTcl_SetObj *setobj)\r
2969 {    \r
2970     Z_Records *zrs = searchrs->records;\r
2971 \r
2972     logf (LOG_DEBUG, "Received search response");\r
2973     if (!setobj)\r
2974     {\r
2975         logf (LOG_DEBUG, "Search response, no object!");\r
2976         return;\r
2977     }\r
2978     setobj->searchStatus = searchrs->searchStatus ? 1 : 0;\r
2979     get_referenceId (&setobj->set_inher.referenceId, searchrs->referenceId);\r
2980     setobj->resultCount = *searchrs->resultCount;\r
2981     if (searchrs->presentStatus)\r
2982         setobj->presentStatus = *searchrs->presentStatus;\r
2983     if (searchrs->nextResultSetPosition)\r
2984         setobj->nextResultSetPosition = *searchrs->nextResultSetPosition;\r
2985 \r
2986     logf (LOG_DEBUG, "Search response %d, %d hits", \r
2987           setobj->searchStatus, setobj->resultCount);\r
2988     if (zrs)\r
2989     {\r
2990         const char *es;\r
2991         if (setobj->resultCount <= setobj->set_inher.smallSetUpperBound)\r
2992             es = setobj->set_inher.smallSetElementSetNames;\r
2993         else \r
2994             es = setobj->set_inher.mediumSetElementSetNames;\r
2995         ir_handleRecords (o, zrs, setobj, es);\r
2996     }\r
2997     else\r
2998         setobj->recordFlag = 0;\r
2999 }\r
3000 \r
3001 \r
3002 static void ir_presentResponse (void *o, Z_PresentResponse *presrs,\r
3003                                 IrTcl_SetObj *setobj)\r
3004 {\r
3005     Z_Records *zrs = presrs->records;\r
3006     \r
3007     logf (LOG_DEBUG, "Received present response");\r
3008     if (!setobj)\r
3009     {\r
3010         logf (LOG_DEBUG, "Present response, no object!");\r
3011         return;\r
3012     }\r
3013     setobj->presentStatus = *presrs->presentStatus;\r
3014     get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId);\r
3015     setobj->nextResultSetPosition = *presrs->nextResultSetPosition;\r
3016     if (zrs)\r
3017         ir_handleRecords (o, zrs, setobj, setobj->set_inher.elementSetNames);\r
3018     else\r
3019     {\r
3020         setobj->recordFlag = 0;\r
3021         logf (LOG_DEBUG, "No records!");\r
3022     }\r
3023 }\r
3024 \r
3025 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs,\r
3026                              IrTcl_ScanObj *scanobj)\r
3027 {\r
3028     IrTcl_Obj *p = o;\r
3029     \r
3030     logf (LOG_DEBUG, "Received scanResponse");\r
3031 \r
3032     get_referenceId (&p->set_inher.referenceId, scanrs->referenceId);\r
3033     scanobj->scanStatus = *scanrs->scanStatus;\r
3034     logf (LOG_DEBUG, "scanStatus=%d", scanobj->scanStatus);\r
3035 \r
3036     if (scanrs->stepSize)\r
3037         scanobj->stepSize = *scanrs->stepSize;\r
3038     logf (LOG_DEBUG, "stepSize=%d", scanobj->stepSize);\r
3039 \r
3040     scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;\r
3041     logf (LOG_DEBUG, "numberOfEntriesReturned=%d",\r
3042           scanobj->numberOfEntriesReturned);\r
3043 \r
3044     if (scanrs->positionOfTerm)\r
3045         scanobj->positionOfTerm = *scanrs->positionOfTerm;\r
3046     else\r
3047         scanobj->positionOfTerm = -1;\r
3048     logf (LOG_DEBUG, "positionOfTerm=%d", scanobj->positionOfTerm);\r
3049 \r
3050     free (scanobj->entries);\r
3051     scanobj->entries = NULL;\r
3052 \r
3053     ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList,\r
3054                     &scanobj->nonSurrogateDiagnosticNum);\r
3055     if (scanrs->entries)\r
3056     {\r
3057         int i;\r
3058         Z_Entry *ze;\r
3059 \r
3060         scanobj->entries_flag = 1;\r
3061         scanobj->which = scanrs->entries->which;\r
3062         switch (scanobj->which)\r
3063         {\r
3064         case Z_ListEntries_entries:\r
3065             scanobj->num_entries = scanrs->entries->u.entries->num_entries;\r
3066             scanobj->entries = ir_tcl_malloc (scanobj->num_entries * \r
3067                                        sizeof(*scanobj->entries));\r
3068             for (i=0; i<scanobj->num_entries; i++)\r
3069             {\r
3070                 ze = scanrs->entries->u.entries->entries[i];\r
3071                 scanobj->entries[i].which = ze->which;\r
3072                 switch (ze->which)\r
3073                 {\r
3074                 case Z_Entry_termInfo:\r
3075                     if (ze->u.termInfo->term->which == Z_Term_general)\r
3076                     {\r
3077                         int l = ze->u.termInfo->term->u.general->len;\r
3078                         scanobj->entries[i].u.term.buf = ir_tcl_malloc (1+l);\r
3079                         memcpy (scanobj->entries[i].u.term.buf, \r
3080                                 ze->u.termInfo->term->u.general->buf,\r
3081                                 l);\r
3082                         scanobj->entries[i].u.term.buf[l] = '\0';\r
3083                     }\r
3084                     else\r
3085                         scanobj->entries[i].u.term.buf = NULL;\r
3086                     if (ze->u.termInfo->globalOccurrences)\r
3087                         scanobj->entries[i].u.term.globalOccurrences = \r
3088                             *ze->u.termInfo->globalOccurrences;\r
3089                     else\r
3090                         scanobj->entries[i].u.term.globalOccurrences = 0;\r
3091                     break;\r
3092                 case Z_Entry_surrogateDiagnostic:\r
3093                     ir_handleDiags (&scanobj->entries[i].u.diag.list,\r
3094                                     &scanobj->entries[i].u.diag.num,\r
3095                                     &ze->u.surrogateDiagnostic,\r
3096                                     1);\r
3097                     break;\r
3098                 }\r
3099             }\r
3100             break;\r
3101         case Z_ListEntries_nonSurrogateDiagnostics:\r
3102             ir_handleDiags (&scanobj->nonSurrogateDiagnosticList,\r
3103                             &scanobj->nonSurrogateDiagnosticNum,\r
3104                             scanrs->entries->u.nonSurrogateDiagnostics->\r
3105                             diagRecs,\r
3106                             scanrs->entries->u.nonSurrogateDiagnostics->\r
3107                             num_diagRecs);\r
3108             break;\r
3109         }\r
3110     }\r
3111     else\r
3112         scanobj->entries_flag = 0;\r
3113 }\r
3114 \r
3115 /*\r
3116  * ir_select_read: handle incoming packages\r
3117  */\r
3118 void ir_select_read (ClientData clientData)\r
3119 {\r
3120     IrTcl_Obj *p = clientData;\r
3121     Z_APDU *apdu;\r
3122     int r;\r
3123     IrTcl_Request *rq;\r
3124     char *object_name;\r
3125     Tcl_CmdInfo cmd_info;\r
3126 \r
3127     if (p->state == IR_TCL_R_Connecting)\r
3128     {\r
3129         r = cs_rcvconnect (p->cs_link);\r
3130         if (r == 1)\r
3131         {\r
3132             logf (LOG_WARN, "cs_rcvconnect returned 1");\r
3133             return;\r
3134         }\r
3135         p->state = IR_TCL_R_Idle;\r
3136         ir_select_remove_write (cs_fileno (p->cs_link), p);\r
3137         if (r < 0)\r
3138         {\r
3139             logf (LOG_DEBUG, "cs_rcvconnect error");\r
3140             if (p->failback)\r
3141             {\r
3142                 p->failInfo = IR_TCL_FAIL_CONNECT;\r
3143                 IrTcl_eval (p->interp, p->failback);\r
3144             }\r
3145             do_disconnect (p, NULL, 2, NULL);\r
3146             return;\r
3147         }\r
3148         p->state = IR_TCL_R_Idle;\r
3149         if (p->callback)\r
3150             IrTcl_eval (p->interp, p->callback);\r
3151         if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle)\r
3152             ir_tcl_send_q (p, p->request_queue, "x");\r
3153         return;\r
3154     }\r
3155     do\r
3156     {\r
3157         /* signal one more use of ir object - callbacks must not\r
3158            release the ir memory (p pointer) */\r
3159         p->state = IR_TCL_R_Reading;\r
3160         ++(p->ref_count);\r
3161 \r
3162         /* read incoming APDU */\r
3163         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) <= 0)\r
3164         {\r
3165             logf (LOG_DEBUG, "cs_get failed, code %d", r);\r
3166             ir_select_remove (cs_fileno (p->cs_link), p);\r
3167             do_disconnect (p, NULL, 2, NULL);\r
3168             if (p->failback)\r
3169             {\r
3170                 p->failInfo = IR_TCL_FAIL_READ;\r
3171                 IrTcl_eval (p->interp, p->failback);\r
3172             }\r
3173             /* release ir object now if callback deleted it */\r
3174             ir_obj_delete (p);\r
3175             return;\r
3176         }        \r
3177         if (r == 1)\r
3178             return ;\r
3179         /* got complete APDU. Now decode */\r
3180         odr_setbuf (p->odr_in, p->buf_in, r, 0);\r
3181         logf (LOG_DEBUG, "cs_get ok, got %d", r);\r
3182         if (!z_APDU (p->odr_in, &apdu, 0))\r
3183         {\r
3184             logf (LOG_DEBUG, "%s", odr_errmsg (odr_geterror (p->odr_in)));\r
3185             do_disconnect (p, NULL, 2, NULL);\r
3186             if (p->failback)\r
3187             {\r
3188                 p->failInfo = IR_TCL_FAIL_IN_APDU;\r
3189                 IrTcl_eval (p->interp, p->failback);\r
3190             }\r
3191             /* release ir object now if failback deleted it */\r
3192             ir_obj_delete (p);\r
3193             return;\r
3194         }\r
3195         /* handle APDU and invoke callback */\r
3196         rq = p->request_queue;\r
3197         if (!rq)\r
3198         {\r
3199             logf (LOG_FATAL, "Internal error. No queue entry");\r
3200             exit (1);\r
3201         }\r
3202         object_name = rq->object_name;\r
3203         logf (LOG_DEBUG, "getCommandInfo (%s)", object_name);\r
3204         if (Tcl_GetCommandInfo (p->interp, object_name, &cmd_info))\r
3205         {\r
3206             switch(apdu->which)\r
3207             {\r
3208             case Z_APDU_initResponse:\r
3209                 ir_initResponse (p, apdu->u.initResponse);\r
3210                 break;\r
3211             case Z_APDU_searchResponse:\r
3212                 ir_searchResponse (p, apdu->u.searchResponse,\r
3213                                    (IrTcl_SetObj *) cmd_info.clientData);\r
3214                 break;\r
3215             case Z_APDU_presentResponse:\r
3216                 ir_presentResponse (p, apdu->u.presentResponse,\r
3217                                     (IrTcl_SetObj *) cmd_info.clientData);\r
3218                 break;\r
3219             case Z_APDU_scanResponse:\r
3220                 ir_scanResponse (p, apdu->u.scanResponse, \r
3221                                  (IrTcl_ScanObj *) cmd_info.clientData);\r
3222                 break;\r
3223             default:\r
3224                 logf (LOG_WARN, "Received unknown APDU type (%d)",\r
3225                       apdu->which);\r
3226                 do_disconnect (p, NULL, 2, NULL);\r
3227                 if (p->failback)\r
3228                 {\r
3229                     p->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;\r
3230                     IrTcl_eval (p->interp, p->failback);\r
3231                 }\r
3232                 return;\r
3233             }\r
3234         }\r
3235         p->request_queue = rq->next;\r
3236         p->state = IR_TCL_R_Idle;\r
3237         \r
3238         if (rq->callback)\r
3239             IrTcl_eval (p->interp, rq->callback);\r
3240         free (rq->buf_out);\r
3241         free (rq->callback);\r
3242         free (rq->object_name);\r
3243         free (rq);\r
3244         odr_reset (p->odr_in);\r
3245         if (p->ref_count == 1)\r
3246         {\r
3247             ir_obj_delete (p);\r
3248             return;\r
3249         }\r
3250         --(p->ref_count);\r
3251     } while (p->cs_link && cs_more (p->cs_link));\r
3252     if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle)\r
3253         ir_tcl_send_q (p, p->request_queue, "x");\r
3254 }\r
3255 \r
3256 /*\r
3257  * ir_select_write: handle outgoing packages - not yet written.\r
3258  */\r
3259 void ir_select_write (ClientData clientData)\r
3260 {\r
3261     IrTcl_Obj *p = clientData;\r
3262     int r;\r
3263     IrTcl_Request *rq;\r
3264 \r
3265     logf (LOG_DEBUG, "In write handler");\r
3266     if (p->state == IR_TCL_R_Connecting)\r
3267     {\r
3268         r = cs_rcvconnect (p->cs_link);\r
3269         if (r == 1)\r
3270             return;\r
3271         p->state = IR_TCL_R_Idle;\r
3272         if (r < 0)\r
3273         {\r
3274             logf (LOG_DEBUG, "cs_rcvconnect error");\r
3275             ir_select_remove_write (cs_fileno (p->cs_link), p);\r
3276             if (p->failback)\r
3277             {\r
3278                 p->failInfo = IR_TCL_FAIL_CONNECT;\r
3279                 IrTcl_eval (p->interp, p->failback);\r
3280             }\r
3281             do_disconnect (p, NULL, 2, NULL);\r
3282             return;\r
3283         }\r
3284         ir_select_remove_write (cs_fileno (p->cs_link), p);\r
3285         if (p->callback)\r
3286             IrTcl_eval (p->interp, p->callback);\r
3287         return;\r
3288     }\r
3289     rq = p->request_queue;\r
3290     if (!rq || !rq->buf_out)\r
3291         return;\r
3292     assert (rq);\r
3293     if ((r=cs_put (p->cs_link, rq->buf_out, rq->len_out)) < 0)\r
3294     {\r
3295         logf (LOG_DEBUG, "select write fail");\r
3296         if (p->failback)\r
3297         {\r
3298             p->failInfo = IR_TCL_FAIL_WRITE;\r
3299             IrTcl_eval (p->interp, p->failback);\r
3300         }\r
3301         free (rq->buf_out);\r
3302         rq->buf_out = NULL;\r
3303         do_disconnect (p, NULL, 2, NULL);\r
3304     }\r
3305     else if (r == 0)            /* remove select bit */\r
3306     {\r
3307         p->state = IR_TCL_R_Waiting;\r
3308         ir_select_remove_write (cs_fileno (p->cs_link), p);\r
3309         free (rq->buf_out);\r
3310         rq->buf_out = NULL;\r
3311     }\r
3312 }\r
3313 \r
3314 /* ------------------------------------------------------- */\r
3315 \r
3316 /*\r
3317  * Irtcl_init: Registration of TCL commands.\r
3318  */\r
3319 int Irtcl_Init (Tcl_Interp *interp)\r
3320 {\r
3321     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,\r
3322                        (Tcl_CmdDeleteProc *) NULL);\r
3323     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,\r
3324                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\r
3325     Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,\r
3326                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\r
3327     return TCL_OK;\r
3328 }\r
3329 \r