ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  *
   5  * $Id: ir-tcl.c,v 1.2 1995-03-08 07:28:29 adam Exp $
   6  */
   7
   8 #include <stdlib.h>
   9 #include <stdio.h>
  10 #include <sys/time.h>
  11 #include <assert.h>
  12
  13 #include <comstack.h>
  14 #include <tcpip.h>
  15 #include <xmosi.h>
  16
  17 #include <odr.h>
  18 #include <proto.h>
  19
  20 #include <tcl.h>
  21
  22 #include "ir-tcl.h"
  23
  24 typedef struct {
  25     COMSTACK cs_link;
  26
  27     int preferredMessageSize;
  28     int maximumMessageSize;
  29     Odr_bitmask options;
  30     Odr_bitmask protocolVersion;
  31     char *idAuthentication;
  32     char *implementationName;
  33     char *implementationId;
  34
  35     char *buf_out;
  36     int  len_out;
  37
  38     char *buf_in;
  39     int  len_in;
  40
  41     ODR odr_in;
  42     ODR odr_out;
  43     ODR odr_pr;
  44
  45     Tcl_Interp *interp;
  46     char *callback;
  47 } IRObj;
  48
  49 typedef struct {
  50     IRObj *parent;
  51 } IRSetObj;
  52
  53 typedef struct {
  54     char *name;
  55     int (*method) (void * obj, Tcl_Interp *interp, int argc, char **argv);
  56 } IRMethod;
  57
  58 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
  59
  60 /*
  61  * get_parent_info: Returns information about parent object.
  62  */
  63 static int get_parent_info (Tcl_Interp *interp, const char *name,
  64                             Tcl_CmdInfo *parent_info)
  65 {
  66     char parent_name[128];
  67     const char *csep = strrchr (name, '.');
  68     int pos;
  69
  70     if (!csep)
  71     {
  72         interp->result = "missing .";
  73         return TCL_ERROR;
  74     }
  75     pos = csep-name;
  76     if (pos > 127)
  77         pos = 127;
  78     memcpy (parent_name, name, pos);
  79     parent_name[pos] = '\0';
  80     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
  81         return TCL_ERROR;
  82     return TCL_OK;
  83 }
  84
  85 /*
  86  * ir_method: Search for method in table and invoke method handler
  87  */
  88 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
  89                    IRMethod *tab)
  90 {
  91     while (tab->name)
  92     {
  93         if (!strcmp (tab->name, argv[1]))
  94             return (*tab->method)(obj, interp, argc, argv);
  95         tab++;
  96     }
  97     Tcl_AppendResult (interp, "unknown method: ", argv[1], NULL);
  98     return TCL_ERROR;
  99 }
 100
 101 /*
 102  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 103  */
 104 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 105 {
 106     const char *cp = asc + strlen(asc);
 107     int bitno = 0;
 108
 109     ODR_MASK_ZERO (ob);
 110     do
 111     {
 112         if (*--cp == '1')
 113             ODR_MASK_SET (ob, bitno);
 114         bitno++;
 115     } while (cp != asc);
 116     return bitno;
 117 }
 118
 119 /*
 120  * ir_strdup: Duplicate string
 121  */
 122 int ir_strdup (Tcl_Interp *interp, char** p, char *s)
 123 {
 124     *p = malloc (strlen(s)+1);
 125     if (!*p)
 126     {
 127         interp->result = "malloc fail";
 128         return TCL_ERROR;
 129     }
 130     strcpy (*p, s);
 131     return TCL_OK;
 132 }
 133
 134 /* ------------------------------------------------------- */
 135
 136 /*
 137  * do_init_request: init method on IR object
 138  */
 139 static int do_init_request (void *obj, Tcl_Interp *interp,
 140                        int argc, char **argv)
 141 {
 142     Z_APDU apdu, *apdup;
 143     IRObj *p = obj;
 144     Z_InitRequest req;
 145     char *sbuf;
 146     int slen;
 147
 148     req.referenceId = 0;
 149     req.options = &p->options;
 150     req.protocolVersion = &p->protocolVersion;
 151     req.preferredMessageSize = &p->preferredMessageSize;
 152     req.maximumRecordSize = &p->maximumMessageSize;
 153
 154     req.idAuthentication = p->idAuthentication;
 155     req.implementationId = p->implementationId;
 156     req.implementationName = p->implementationName;
 157     req.implementationVersion = "0.1";
 158     req.userInformationField = 0;
 159
 160     apdu.u.initRequest = &req;
 161     apdu.which = Z_APDU_initRequest;
 162     apdup = &apdu;
 163
 164     if (!z_APDU (p->odr_out, &apdup, 0))
 165     {
 166         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 167         odr_reset (p->odr_out);
 168         return TCL_ERROR;
 169     }
 170     sbuf = odr_getbuf (p->odr_out, &slen);
 171     if (cs_put (p->cs_link, sbuf, slen) < 0)
 172     {
 173         interp->result = "cs_put failed in init";
 174         return TCL_ERROR;
 175     }
 176     printf("Sent initializeRequest (%d bytes).\n", slen);
 177     return TCL_OK;
 178 }
 179
 180 /*
 181  * do_protocolVersion: Set protocol Version
 182  */
 183 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 184                                int argc, char **argv)
 185 {
 186     if (argc == 3)
 187         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 188     return TCL_OK;
 189 }
 190
 191 /*
 192  * do_options: Set options
 193  */
 194 static int do_options (void *obj, Tcl_Interp *interp,
 195                        int argc, char **argv)
 196 {
 197     if (argc == 3)
 198         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 199     return TCL_OK;
 200 }
 201
 202 /*
 203  * do_preferredMessageSize: Set preferred message size
 204  */
 205 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 206                                     int argc, char **argv)
 207 {
 208     if (argc == 3)
 209     {
 210         if (Tcl_GetInt (interp, argv[2],
 211                         &((IRObj *)obj)->preferredMessageSize)==TCL_ERROR)
 212             return TCL_ERROR;
 213     }
 214     sprintf (interp->result, "%d", ((IRObj *)obj)->preferredMessageSize);
 215     return TCL_OK;
 216 }
 217
 218 /*
 219  * do_maximumMessageSize: Set maximum message size
 220  */
 221 static int do_maximumMessageSize (void *obj, Tcl_Interp *interp,
 222                                     int argc, char **argv)
 223 {
 224     if (argc == 3)
 225     {
 226         if (Tcl_GetInt (interp, argv[2],
 227                         &((IRObj *)obj)->maximumMessageSize)==TCL_ERROR)
 228             return TCL_ERROR;
 229     }
 230     sprintf (interp->result, "%d", ((IRObj *)obj)->maximumMessageSize);
 231     return TCL_OK;
 232 }
 233
 234
 235 /*
 236  * do_implementationName: Set Implementation Name.
 237  */
 238 static int do_implementationName (void *obj, Tcl_Interp *interp,
 239                                     int argc, char **argv)
 240 {
 241     if (argc == 3)
 242     {
 243         free (((IRObj*)obj)->implementationName);
 244         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 245             == TCL_ERROR)
 246             return TCL_ERROR;
 247     }
 248     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 249                       (char*) NULL);
 250     return TCL_OK;
 251 }
 252
 253 /*
 254  * do_implementationId: Set Implementation Name.
 255  */
 256 static int do_implementationId (void *obj, Tcl_Interp *interp,
 257                                 int argc, char **argv)
 258 {
 259     if (argc == 3)
 260     {
 261         free (((IRObj*)obj)->implementationId);
 262         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 263             == TCL_ERROR)
 264             return TCL_ERROR;
 265     }
 266     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 267                       (char*) NULL);
 268     return TCL_OK;
 269 }
 270
 271 /*
 272  * do_idAuthentication: Set id Authentication
 273  */
 274 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 275                                 int argc, char **argv)
 276 {
 277     if (argc == 3)
 278     {
 279         free (((IRObj*)obj)->idAuthentication);
 280         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 281             == TCL_ERROR)
 282             return TCL_ERROR;
 283     }
 284     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 285                       (char*) NULL);
 286     return TCL_OK;
 287 }
 288
 289 /*
 290  * do_connect: connect method on IR object
 291  */
 292 static int do_connect (void *obj, Tcl_Interp *interp,
 293                        int argc, char **argv)
 294 {
 295     void *addr;
 296     IRObj *p = obj;
 297
 298     if (argc < 3)
 299     {
 300         interp->result = "missing hostname";
 301         return TCL_ERROR;
 302     }
 303     if (cs_type(p->cs_link) == tcpip_type)
 304     {
 305         addr = tcpip_strtoaddr (argv[2]);
 306         if (!addr)
 307         {
 308             interp->result = "tcpip_strtoaddr fail";
 309             return TCL_ERROR;
 310         }
 311         printf ("tcp/ip connect %s\n", argv[2]);
 312     }
 313     else if (cs_type (p->cs_link) == mosi_type)
 314     {
 315         addr = mosi_strtoaddr (argv[2]);
 316         if (!addr)
 317         {
 318             interp->result = "mosi_strtoaddr fail";
 319             return TCL_ERROR;
 320         }
 321         printf ("mosi connect %s\n", argv[2]);
 322     }
 323     if (cs_connect (p->cs_link, addr) < 0)
 324     {
 325         interp->result = "cs_connect fail";
 326         do_disconnect (p, interp, argc, argv);
 327         return TCL_ERROR;
 328     }
 329     ir_select_add (cs_fileno (p->cs_link), p);
 330     return TCL_OK;
 331 }
 332
 333 /*
 334  * do_disconnect: disconnect method on IR object
 335  */
 336 static int do_disconnect (void *obj, Tcl_Interp *interp,
 337                           int argc, char **argv)
 338 {
 339     IRObj *p = obj;
 340
 341     ir_select_remove (cs_fileno (p->cs_link), p);
 342     if (cs_type (p->cs_link) == tcpip_type)
 343     {
 344         cs_close (p->cs_link);
 345         p->cs_link = cs_create (tcpip_type);
 346     }
 347     else if (cs_type (p->cs_link) == mosi_type)
 348     {
 349         cs_close (p->cs_link);
 350         p->cs_link = cs_create (mosi_type);
 351     }
 352     else
 353     {
 354         interp->result = "unknown comstack type";
 355         return TCL_ERROR;
 356     }
 357     return TCL_OK;
 358 }
 359
 360 /*
 361  * do_comstack: comstack method on IR object
 362  */
 363 static int do_comstack (void *obj, Tcl_Interp *interp,
 364                         int argc, char **argv)
 365 {
 366     if (argc == 3)
 367     {
 368         if (!strcmp (argv[2], "tcpip"))
 369             ((IRObj *)obj)->cs_link = cs_create (tcpip_type);
 370         else if (!strcmp (argv[2], "mosi"))
 371             ((IRObj *)obj)->cs_link = cs_create (mosi_type);
 372         else
 373         {
 374             interp->result = "wrong comstack type";
 375             return TCL_ERROR;
 376         }
 377     }
 378     if (cs_type(((IRObj *)obj)->cs_link) == tcpip_type)
 379         interp->result = "tcpip";
 380     else if (cs_type(((IRObj *)obj)->cs_link) == mosi_type)
 381         interp->result = "comstack";
 382     return TCL_OK;
 383 }
 384
 385 /*
 386  * do_callback: add callback
 387  */
 388 static int do_callback (void *obj, Tcl_Interp *interp,
 389                           int argc, char **argv)
 390 {
 391     IRObj *p = obj;
 392
 393     if (argc == 3)
 394     {
 395         free (p->callback);
 396         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 397             return TCL_ERROR;
 398         p->interp = interp;
 399     }
 400     return TCL_OK;
 401 }
 402
 403 /*
 404  * ir_obj_method: IR Object methods
 405  */
 406 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 407                           int argc, char **argv)
 408 {
 409     static IRMethod tab[] = {
 410     { "comstack", do_comstack },
 411     { "connect", do_connect },
 412     { "protocolVersion", do_protocolVersion },
 413     { "options", do_options },
 414     { "preferredMessageSize", do_preferredMessageSize },
 415     { "maximumMessageSize",   do_maximumMessageSize },
 416     { "implementationName", do_implementationName },
 417     { "implementationId",   do_implementationId },
 418     { "idAuthentication",   do_idAuthentication },
 419     { "init", do_init_request },
 420     { "disconnect", do_disconnect },
 421     { "callback", do_callback },
 422     { NULL, NULL}
 423     };
 424     if (argc < 2)
 425     {
 426         interp->result = "wrong # args";
 427         return TCL_ERROR;
 428     }
 429     return ir_method (clientData, interp, argc, argv, tab);
 430 }
 431
 432 /*
 433  * ir_obj_delete: IR Object disposal
 434  */
 435 static void ir_obj_delete (ClientData clientData)
 436 {
 437     free ( (void*) clientData);
 438 }
 439
 440 /*
 441  * ir_obj_mk: IR Object creation
 442  */
 443 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 444               int argc, char **argv)
 445 {
 446     IRObj *obj;
 447
 448     if (argc != 2)
 449     {
 450         interp->result = "wrong # args";
 451         return TCL_ERROR;
 452     }
 453     obj = malloc (sizeof(*obj));
 454     if (!obj)
 455     {
 456         interp->result = "malloc fail";
 457         return TCL_ERROR;
 458     }
 459     obj->cs_link = cs_create (tcpip_type);
 460
 461     obj->maximumMessageSize = 10000;
 462     obj->preferredMessageSize = 4096;
 463
 464     obj->idAuthentication = NULL;
 465
 466     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 467         == TCL_ERROR)
 468         return TCL_ERROR;
 469
 470     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 471         == TCL_ERROR)
 472         return TCL_ERROR;
 473
 474     ODR_MASK_ZERO (&obj->protocolVersion);
 475     ODR_MASK_SET (&obj->protocolVersion, 0);
 476     ODR_MASK_SET (&obj->protocolVersion, 1);
 477
 478     ODR_MASK_ZERO (&obj->options);
 479     ODR_MASK_SET (&obj->options, 0);
 480
 481     obj->odr_in = odr_createmem (ODR_DECODE);
 482     obj->odr_out = odr_createmem (ODR_ENCODE);
 483     obj->odr_pr = odr_createmem (ODR_PRINT);
 484
 485     obj->len_out = 10000;
 486     obj->buf_out = malloc (obj->len_out);
 487     if (!obj->buf_out)
 488     {
 489         interp->result = "malloc fail";
 490         return TCL_ERROR;
 491     }
 492     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 493
 494     obj->len_in = 0;
 495     obj->buf_in = NULL;
 496
 497     obj->callback = NULL;
 498
 499     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 500                        (ClientData) obj, ir_obj_delete);
 501     return TCL_OK;
 502 }
 503
 504 /* ------------------------------------------------------- */
 505 /*
 506  * do_query: Set query for a Set Object
 507  */
 508 static int do_query (void *obj, Tcl_Interp *interp,
 509                        int argc, char **argv)
 510 {
 511     return TCL_OK;
 512 }
 513
 514
 515 /*
 516  * ir_set_obj_method: IR Set Object methods
 517  */
 518 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
 519                           int argc, char **argv)
 520 {
 521     static IRMethod tab[] = {
 522     { "query", do_query },
 523     { NULL, NULL}
 524     };
 525
 526     if (argc < 2)
 527     {
 528         interp->result = "wrong # args";
 529         return TCL_ERROR;
 530     }
 531     return ir_method (clientData, interp, argc, argv, tab);
 532 }
 533
 534 /*
 535  * ir_set_obj_delete: IR Set Object disposal
 536  */
 537 static void ir_set_obj_delete (ClientData clientData)
 538 {
 539     free ( (void*) clientData);
 540 }
 541
 542 /*
 543  * ir_set_obj_mk: IR Set Object creation
 544  */
 545 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
 546                              int argc, char **argv)
 547 {
 548     Tcl_CmdInfo parent_info;
 549     IRSetObj *obj;
 550
 551     if (argc != 2)
 552     {
 553         interp->result = "wrong # args";
 554         return TCL_ERROR;
 555     }
 556     if (get_parent_info (interp, argv[1], &parent_info) == TCL_ERROR)
 557     {
 558         interp->result = "No parent";
 559         return TCL_ERROR;
 560     }
 561     obj = malloc (sizeof(*obj));
 562     if (!obj)
 563     {
 564         interp->result = "malloc fail";
 565         return TCL_ERROR;
 566     }
 567     obj->parent = (IRObj *) parent_info.clientData;
 568     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
 569                        (ClientData) obj, ir_set_obj_delete);
 570     return TCL_OK;
 571 }
 572
 573 /* ------------------------------------------------------- */
 574
 575 static void ir_searchResponse (void *obj, Z_SearchResponse *searchrs)
 576 {
 577     if (searchrs->searchStatus)
 578         printf("Search was a success.\n");
 579     else
 580             printf("Search was a bloomin' failure.\n");
 581     printf("Number of hits: %d, setno %d\n",
 582            *searchrs->resultCount, 1);
 583 #if 0
 584     if (searchrs->records)
 585         display_records(searchrs->records);
 586 #endif
 587 }
 588
 589 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
 590 {
 591     if (!*initrs->result)
 592         printf("Connection rejected by target.\n");
 593     else
 594         printf("Connection accepted by target.\n");
 595     if (initrs->implementationId)
 596             printf("ID     : %s\n", initrs->implementationId);
 597     if (initrs->implementationName)
 598         printf("Name   : %s\n", initrs->implementationName);
 599     if (initrs->implementationVersion)
 600         printf("Version: %s\n", initrs->implementationVersion);
 601 #if 0
 602     if (initrs->userInformationField)
 603     {
 604         printf("UserInformationfield:\n");
 605         odr_external(&print, (Odr_external**)&initrs->
 606                          userInformationField, 0);
 607     }
 608 #endif
 609 }
 610
 611 static void ir_presentResponse (void *obj, Z_PresentResponse *presrs)
 612 {
 613     printf("Received presentResponse.\n");
 614     if (presrs->records)
 615         printf ("Got records\n");
 616     else
 617         printf("No records\n");
 618 }
 619
 620 void ir_select_proc (ClientData clientData)
 621 {
 622     IRObj *p = clientData;
 623     Z_APDU *apdu;
 624     int r;
 625
 626     do
 627     {
 628         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  < 0)
 629         {
 630             printf ("cs_get failed\n");
 631             return;
 632         }
 633         odr_setbuf (p->odr_in, p->buf_in, r);
 634         printf ("cs_get ok, got %d\n", r);
 635         if (!z_APDU (p->odr_in, &apdu, 0))
 636         {
 637             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
 638             return;
 639         }
 640         if (p->callback)
 641         {
 642             Tcl_Eval (p->interp, p->callback);
 643         }
 644         switch(apdu->which)
 645         {
 646         case Z_APDU_initResponse:
 647             ir_initResponse (NULL, apdu->u.initResponse);
 648             break;
 649         case Z_APDU_searchResponse:
 650             ir_searchResponse (NULL, apdu->u.searchResponse);
 651             break;
 652         case Z_APDU_presentResponse:
 653             ir_presentResponse (NULL, apdu->u.presentResponse);
 654             break;
 655         default:
 656             printf("Received unknown APDU type (%d).\n",
 657                    apdu->which);
 658         }
 659     } while (cs_more (p->cs_link));
 660 }
 661
 662 /* ------------------------------------------------------- */
 663
 664 /*
 665  * ir_tcl_init: Registration of TCL commands.
 666  */
 667 int ir_tcl_init (Tcl_Interp *interp)
 668 {
 669     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
 670                        (Tcl_CmdDeleteProc *) NULL);
 671     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
 672                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
 673     return TCL_OK;
 674 }
 675
 676