wais-tcl.c

   1 /*
   2  * NWI - Nordic Web Index
   3  * Technical Knowledge Centre & Library of Denmark (DTV)
   4  *
   5  * Wais extension to IrTcl
   6  *
   7  * $Log: wais-tcl.c,v $
   8  * Revision 1.2  1996-03-07 12:43:44  adam
   9  * Better error handling. WAIS target closed before failback is invoked.
  10  *
  11  * Revision 1.1  1996/02/29  15:28:08  adam
  12  * First version of Wais extension to IrTcl.
  13  *
  14  */
  15
  16 #include <stdio.h>
  17 #include <stdlib.h>
  18 #include <assert.h>
  19
  20 /* YAZ headers ... */
  21 #include <comstack.h>
  22 #include <tcpip.h>
  23 #include <oid.h>
  24
  25 /* IrTcl internal header */
  26 #include <ir-tclp.h>
  27
  28 /* FreeWAIS-sf header */
  29 #include <ui.h>
  30
  31 typedef struct {
  32     int           position;
  33     any           *documentID;
  34     long          score;
  35     long          documentLength;
  36     long          lines;
  37     char          *headline;
  38     char          *documentText;
  39 } WaisTcl_Record;
  40
  41 typedef struct WaisTcl_Records {
  42     WaisTcl_Record *record;
  43     struct WaisTcl_Records *next;
  44 } WaisTcl_Records;
  45
  46 typedef struct {
  47     IrTcl_Obj     *irtcl_obj;
  48     Tcl_Interp    *interp;
  49     int           ref_count;
  50     COMSTACK      wais_link;
  51     char          *hostname;
  52     char          *buf_out;
  53     int           len_out;
  54     int           max_out;
  55     char          *object;
  56 } WaisTcl_Obj;
  57
  58 typedef struct {
  59     WaisTcl_Obj   *parent;
  60     IrTcl_SetObj  *irtcl_set_obj;
  61     Tcl_Interp    *interp;
  62     WaisTcl_Records *records;
  63     char          *diag;
  64     char          *addinfo;
  65     int           maxDocs;
  66 } WaisSetTcl_Obj;
  67
  68 static void wais_obj_delete (ClientData clientData);
  69 static void wais_select_notify (ClientData clientData, int r, int w, int e);
  70 static int do_disconnect (void *obj, Tcl_Interp *interp,
  71                           int argc, char **argv);
  72
  73 /* --- N E T W O R K    I / O ----------------------------------------- */
  74
  75 static void wais_select_write (ClientData clientData)
  76 {
  77     WaisTcl_Obj *p = clientData;
  78     int r;
  79
  80     logf (LOG_DEBUG, "Wais write handler fd=%d", cs_fileno(p->wais_link));
  81     switch (p->irtcl_obj->state)
  82     {
  83     case IR_TCL_R_Connecting:
  84         logf(LOG_DEBUG, "write wais: connect");
  85         r = cs_rcvconnect (p->wais_link);
  86         if (r == 1)
  87             return;
  88         p->irtcl_obj->state = IR_TCL_R_Idle;
  89         if (r < 0)
  90         {
  91             logf (LOG_DEBUG, "cs_rcvconnect error");
  92             do_disconnect (p, NULL, 2, NULL);
  93             p->irtcl_obj->failInfo = IR_TCL_FAIL_CONNECT;
  94             if (p->irtcl_obj->failback)
  95                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
  96             return;
  97         }
  98         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
  99                            clientData, 1, 0, 0);
 100         if (p->irtcl_obj->callback)
 101             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 102         break;
 103     case IR_TCL_R_Writing:
 104         if ((r=cs_put (p->wais_link, p->buf_out, p->len_out)) < 0)
 105         {
 106             logf (LOG_DEBUG, "cs_put write fail");
 107             do_disconnect (p, NULL, 2, NULL);
 108             if (p->irtcl_obj->failback)
 109             {
 110                 p->irtcl_obj->failInfo = IR_TCL_FAIL_WRITE;
 111                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 112             }
 113         }
 114         else if (r == 0)            /* remove select bit */
 115         {
 116             logf(LOG_DEBUG, "Write completed");
 117             p->irtcl_obj->state = IR_TCL_R_Waiting;
 118
 119             ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 120                                clientData, 1, 0, 0);
 121         }
 122         break;
 123     default:
 124         logf (LOG_FATAL|LOG_ERRNO, "Wais read. state=%d", p->irtcl_obj->state);
 125         abort ();
 126     }
 127 }
 128
 129 static WaisTcl_Record *wais_lookup_record_pos (WaisSetTcl_Obj *p, int pos)
 130 {
 131     WaisTcl_Records *recs;
 132
 133     for (recs = p->records; recs; recs = recs->next)
 134         if (recs->record->position == pos)
 135             return recs->record;
 136     return NULL;
 137 }
 138
 139 static WaisTcl_Record *wais_lookup_record_pos_bf (WaisSetTcl_Obj *p, int pos)
 140 {
 141     WaisTcl_Record *rec;
 142
 143     rec = wais_lookup_record_pos (p, pos);
 144     if (!rec)
 145     {
 146         return NULL;
 147     }
 148     if (rec->documentText ||
 149         !p->irtcl_set_obj->recordElements ||
 150         !*p->irtcl_set_obj->recordElements ||
 151         strcmp (p->irtcl_set_obj->recordElements, "F"))
 152         return rec;
 153     return NULL;
 154 }
 155
 156 static WaisTcl_Record *wais_lookup_record_id (WaisSetTcl_Obj *p, any *id)
 157 {
 158     WaisTcl_Records *recs;
 159
 160     for (recs = p->records; recs; recs = recs->next)
 161         if (recs->record->documentID->size == id->size &&
 162             !memcmp (recs->record->documentID->bytes, id->bytes, id->size))
 163             return recs->record;
 164     return NULL;
 165 }
 166
 167 static void wais_delete_record (WaisTcl_Record *rec)
 168 {
 169     freeAny (rec->documentID);
 170     free (rec->headline);
 171     free (rec->documentText);
 172     free (rec);
 173 }
 174
 175 static void wais_delete_records (WaisSetTcl_Obj *p)
 176 {
 177     WaisTcl_Records *recs, *recs1;
 178
 179     for (recs = p->records; recs; recs = recs1)
 180     {
 181         recs1 = recs->next;
 182         wais_delete_record (recs->record);
 183         free (recs);
 184     }
 185     p->records = NULL;
 186 }
 187
 188 static void wais_add_record_brief (WaisSetTcl_Obj *p,
 189                                    int position,
 190                                    any *documentID,
 191                                    long score,
 192                                    long documentLength,
 193                                    long lines,
 194                                    char *headline)
 195 {
 196     WaisTcl_Record *rec;
 197     WaisTcl_Records *recs;
 198
 199     rec = wais_lookup_record_pos (p, position);
 200     if (!rec)
 201     {
 202         rec = ir_tcl_malloc (sizeof(*rec));
 203
 204         recs = ir_tcl_malloc (sizeof(*recs));
 205         recs->record = rec;
 206         recs->next = p->records;
 207         p->records = recs;
 208     }
 209     else
 210     {
 211         freeAny (rec->documentID);
 212         free (rec->headline);
 213         if (rec->documentText)
 214             free (rec->documentText);
 215     }
 216     rec->position = position;
 217     rec->documentID = duplicateAny (documentID);
 218     rec->score = score;
 219     rec->documentLength = documentLength;
 220     rec->lines = lines;
 221     ir_tcl_strdup (NULL, &rec->headline, headline);
 222     rec->documentText = NULL;
 223 }
 224
 225 static void wais_add_record_full (WaisSetTcl_Obj *p,
 226                                   any *documentID,
 227                                   any *documentText)
 228 {
 229     WaisTcl_Record *rec;
 230     rec = wais_lookup_record_id (p, documentID);
 231
 232     if (!rec)
 233     {
 234         logf (LOG_DEBUG, "Adding text. Didn't find corresponding brief");
 235         return ;
 236     }
 237     if (rec->documentText)
 238         free (rec->documentText);
 239     rec->documentText = ir_tcl_malloc (documentText->size+1);
 240     memcpy (rec->documentText, documentText->bytes, documentText->size);
 241     rec->documentText[documentText->size] = '\0';
 242     logf (LOG_DEBUG, "Adding text record: \n%.20s", rec->documentText);
 243 }
 244
 245 static void wais_handle_search_response (WaisSetTcl_Obj *p,
 246                                          SearchResponseAPDU *responseAPDU)
 247 {
 248     if (responseAPDU->DatabaseDiagnosticRecords)
 249     {
 250         WAISSearchResponse *ddr = responseAPDU->DatabaseDiagnosticRecords;
 251
 252         p->irtcl_set_obj->searchStatus = 1;
 253
 254         p->irtcl_set_obj->nextResultSetPosition =
 255             responseAPDU->NextResultSetPosition;
 256         p->irtcl_set_obj->numberOfRecordsReturned =
 257             responseAPDU->NumberOfRecordsReturned;
 258
 259         if (!p->irtcl_set_obj->resultCount)
 260         {
 261             if (responseAPDU->NumberOfRecordsReturned >
 262                 responseAPDU->ResultCount)
 263                 p->irtcl_set_obj->resultCount =
 264                     responseAPDU->NumberOfRecordsReturned;
 265             else
 266                 p->irtcl_set_obj->resultCount =
 267                     responseAPDU->ResultCount;
 268         }
 269         free (p->diag);
 270         p->diag = NULL;
 271         free (p->addinfo);
 272         p->addinfo = NULL;
 273         if (ddr->Diagnostics)
 274         {
 275             diagnosticRecord **dr = ddr->Diagnostics;
 276             if (dr[0])
 277             {
 278                 logf (LOG_DEBUG, "Diagnostic response. %s : %s",
 279                       dr[0]->DIAG ? dr[0]->DIAG : "<null>",
 280                       dr[0]->ADDINFO ? dr[0]->ADDINFO : "<null>");
 281                 ir_tcl_strdup (NULL, &p->diag, dr[0]->DIAG);
 282                 ir_tcl_strdup (NULL, &p->addinfo, dr[0]->ADDINFO);
 283             }
 284             else
 285                 logf (LOG_DEBUG, "Diagnostic response");
 286         }
 287         if (ddr->DocHeaders)
 288         {
 289             int i;
 290             logf (LOG_DEBUG, "Adding doc header entries");
 291             for (i = 0; ddr->DocHeaders[i]; i++)
 292             {
 293                 WAISDocumentHeader *head = ddr->DocHeaders[i];
 294
 295                 logf (LOG_DEBUG, "%4d -->%.*s<--", i+1,
 296                       head->DocumentID->size, head->DocumentID->bytes);
 297                 wais_add_record_brief (p, i+1, head->DocumentID,
 298                                        head->Score, head->DocumentLength,
 299                                        head->Lines, head->Headline);
 300             }
 301             logf (LOG_DEBUG, "got %d DBOSD records", i);
 302         }
 303         if (ddr->Text)
 304         {
 305             int i;
 306             logf (LOG_DEBUG, "Adding text entries");
 307             for (i = 0; ddr->Text[i]; i++)
 308             {
 309                 logf (LOG_DEBUG, " -->%.*s<--",
 310                       ddr->Text[i]->DocumentID->size,
 311                       ddr->Text[i]->DocumentID->bytes);
 312                 wais_add_record_full (p,
 313                                       ddr->Text[i]->DocumentID,
 314                                       ddr->Text[i]->DocumentText);
 315             }
 316         }
 317         freeWAISSearchResponse (ddr);
 318     }
 319     else
 320     {
 321         logf (LOG_DEBUG, "No records!");
 322     }
 323     freeSearchResponseAPDU (responseAPDU);
 324 }
 325
 326
 327 static void wais_select_read (ClientData clientData)
 328 {
 329     SearchResponseAPDU *searchRAPDU;
 330     ClientData objectClientData;
 331     WaisTcl_Obj *p = clientData;
 332     char *pdup;
 333     int r;
 334
 335     logf (LOG_DEBUG, "Wais read handler fd=%d", cs_fileno(p->wais_link));
 336     do
 337     {
 338         /* signal one more use of ir object - callbacks must not
 339            release the ir memory (p pointer) */
 340         p->irtcl_obj->state = IR_TCL_R_Reading;
 341
 342         /* read incoming APDU */
 343         if ((r=cs_get (p->wais_link, &p->irtcl_obj->buf_in,
 344                        &p->irtcl_obj->len_in)) <= 0)
 345         {
 346             p->ref_count = 2;
 347             logf (LOG_DEBUG, "cs_get failed, code %d", r);
 348             do_disconnect (p, NULL, 2, NULL);
 349             p->irtcl_obj->failInfo = IR_TCL_FAIL_READ;
 350             if (p->irtcl_obj->failback)
 351                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 352             /* release wais object now if callback deleted it */
 353             wais_obj_delete (p);
 354             return;
 355         }
 356         if (r == 1)
 357         {
 358             logf(LOG_DEBUG, "PDU Fraction read");
 359             return ;
 360         }
 361         logf (LOG_DEBUG, "cs_get ok, total size %d", r);
 362         /* got complete APDU. Now decode */
 363
 364         p->ref_count = 2;
 365         /* determine set/ir object corresponding to response */
 366         objectClientData = 0;
 367         if (p->object)
 368         {
 369             Tcl_CmdInfo cmd_info;
 370
 371             if (Tcl_GetCommandInfo (p->interp, p->object, &cmd_info))
 372                 objectClientData = cmd_info.clientData;
 373             free (p->object);
 374             p->object = NULL;
 375         }
 376         pdup = p->irtcl_obj->buf_in + HEADER_LENGTH;
 377         switch (peekPDUType (pdup))
 378         {
 379         case initResponseAPDU:
 380             p->irtcl_obj->eventType = "init";
 381             logf (LOG_DEBUG, "Got Wais Init response");
 382             break;
 383         case searchResponseAPDU:
 384             p->irtcl_obj->eventType = "search";
 385             logf (LOG_DEBUG, "Got Wais Search response");
 386
 387             readSearchResponseAPDU (&searchRAPDU, pdup);
 388             if (!searchRAPDU)
 389             {
 390                 logf (LOG_WARN, "Couldn't decode Wais search APDU",
 391                       peekPDUType (pdup));
 392                 p->irtcl_obj->failInfo = IR_TCL_FAIL_IN_APDU;
 393                 do_disconnect (p, NULL, 2, NULL);
 394                 if (p->irtcl_obj->failback)
 395                     ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 396                 wais_obj_delete (p);
 397                 return ;
 398             }
 399             if (objectClientData)
 400                 wais_handle_search_response (objectClientData, searchRAPDU);
 401             break;
 402         default:
 403             logf (LOG_WARN, "Received unknown Wais APDU type %d",
 404                   peekPDUType (pdup));
 405             do_disconnect (p, NULL, 2, NULL);
 406             p->irtcl_obj->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;
 407             if (p->irtcl_obj->failback)
 408                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 409             wais_obj_delete (p);
 410             return ;
 411         }
 412         p->irtcl_obj->state = IR_TCL_R_Idle;
 413
 414         if (p->irtcl_obj->callback)
 415             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 416         if (p->ref_count == 1)
 417         {
 418             wais_obj_delete (p);
 419             return;
 420         }
 421         --(p->ref_count);
 422     } while (p->wais_link && cs_more (p->wais_link));
 423 }
 424
 425 static void wais_select_notify (ClientData clientData, int r, int w, int e)
 426 {
 427     if (w)
 428         wais_select_write (clientData);
 429     if (r)
 430         wais_select_read (clientData);
 431 }
 432
 433 static int wais_send_apdu (Tcl_Interp *interp, WaisTcl_Obj *p,
 434                            const char *msg, const char *object)
 435 {
 436     int r;
 437
 438     if (p->object)
 439     {
 440         logf (LOG_DEBUG, "Cannot send. object=%s", p->object);
 441         return TCL_ERROR;
 442     }
 443     r = cs_put (p->wais_link, p->buf_out, p->len_out);
 444     if (r < 0)
 445     {
 446         p->irtcl_obj->state = IR_TCL_R_Idle;
 447         p->irtcl_obj->failInfo = IR_TCL_FAIL_WRITE;
 448         do_disconnect (p, NULL, 2, NULL);
 449         if (p->irtcl_obj->failback)
 450         {
 451             ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 452             return TCL_OK;
 453         }
 454         else
 455         {
 456             interp->result = "Write failed when sending Wais PDU";
 457             return TCL_ERROR;
 458         }
 459     }
 460     ir_tcl_strdup (NULL, &p->object, object);
 461     if (r == 1)
 462     {
 463         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 464                            p, 1, 1, 0);
 465         logf (LOG_DEBUG, "Send part of wais %s APDU", msg);
 466         p->irtcl_obj->state = IR_TCL_R_Writing;
 467     }
 468     else
 469     {
 470         logf (LOG_DEBUG, "Send %s (%d bytes) fd=%d", msg, p->len_out,
 471               cs_fileno(p->wais_link));
 472         p->irtcl_obj->state = IR_TCL_R_Waiting;
 473     }
 474     return TCL_OK;
 475 }
 476
 477 /* --- A S S O C I A T I O N S ----------------------------------------- */
 478
 479 static int do_connect (void *obj, Tcl_Interp *interp,
 480                        int argc, char **argv)
 481 {
 482     void *addr;
 483     WaisTcl_Obj *p = obj;
 484     int r;
 485
 486     if (argc <= 0)
 487         return TCL_OK;
 488     else if (argc == 2)
 489     {
 490         Tcl_AppendResult (interp, p->hostname, NULL);
 491         return TCL_OK;
 492     }
 493     if (p->hostname)
 494     {
 495         interp->result = "already connected";
 496         return TCL_ERROR;
 497     }
 498     if (strcmp (p->irtcl_obj->comstackType, "wais"))
 499     {
 500         interp->result = "only wais comstack supported";
 501         return TCL_ERROR;
 502     }
 503     p->wais_link = cs_create (tcpip_type, 0, PROTO_WAIS);
 504     addr = tcpip_strtoaddr (argv[2]);
 505     if (!addr)
 506     {
 507         interp->result = "tcpip_strtoaddr fail";
 508         return TCL_ERROR;
 509     }
 510     logf (LOG_DEBUG, "tcp/ip wais connect %s", argv[2]);
 511
 512     if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 513         return TCL_ERROR;
 514     r = cs_connect (p->wais_link, addr);
 515     logf(LOG_DEBUG, "cs_connect returned %d fd=%d", r,
 516          cs_fileno(p->wais_link));
 517     if (r < 0)
 518     {
 519         interp->result = "wais connect fail";
 520         do_disconnect (p, NULL, 2, NULL);
 521         return TCL_ERROR;
 522     }
 523     p->irtcl_obj->eventType = "connect";
 524     if (r == 1)
 525     {
 526         p->irtcl_obj->state = IR_TCL_R_Connecting;
 527         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 528                            p, 1, 1, 0);
 529     }
 530     else
 531     {
 532         p->irtcl_obj->state = IR_TCL_R_Idle;
 533         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 534                            p, 1, 0, 0);
 535         if (p->irtcl_obj->callback)
 536             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 537     }
 538     return TCL_OK;
 539 }
 540
 541 static int do_disconnect (void *obj, Tcl_Interp *interp,
 542                           int argc, char **argv)
 543 {
 544     WaisTcl_Obj *p = obj;
 545
 546     if (argc == 0)
 547     {
 548         p->wais_link = NULL;
 549         p->hostname = NULL;
 550         p->object = NULL;
 551         return TCL_OK;
 552     }
 553     if (p->hostname)
 554     {
 555         ir_tcl_select_set (NULL, cs_fileno(p->wais_link), NULL, 0, 0, 0);
 556
 557         free (p->hostname);
 558         p->hostname = NULL;
 559         cs_close (p->wais_link);
 560         p->wais_link = NULL;
 561         free (p->object);
 562         p->object = NULL;
 563     }
 564     return TCL_OK;
 565 }
 566
 567 static int do_init (void *obj, Tcl_Interp *interp, int argc, char **argv)
 568 {
 569     WaisTcl_Obj *p = obj;
 570
 571     if (argc <= 0)
 572         return TCL_OK;
 573     p->irtcl_obj->initResult = 0;
 574     if (!p->hostname)
 575     {
 576         interp->result = "not connected";
 577         return TCL_ERROR;
 578     }
 579     p->irtcl_obj->initResult = 1;
 580     p->irtcl_obj->eventType = "init";
 581     if (p->irtcl_obj->callback)
 582         ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 583     return TCL_OK;
 584 }
 585
 586 static int do_options (void *obj, Tcl_Interp *interp, int argc, char **argv)
 587 {
 588     WaisTcl_Obj *p = obj;
 589
 590     if (argc <= 0)
 591         return TCL_OK;
 592     if (argc != 2)
 593         return TCL_OK;
 594     Tcl_AppendElement (p->interp, "search");
 595     Tcl_AppendElement (p->interp, "present");
 596     return TCL_OK;
 597 }
 598
 599
 600 static IrTcl_Method wais_method_tab[] = {
 601 { "connect",                     do_connect, NULL },
 602 { "disconnect",                  do_disconnect, NULL },
 603 { "init",                        do_init, NULL },
 604 { "options",                     do_options, NULL },
 605 { NULL, NULL}
 606 };
 607
 608
 609 int wais_obj_init(ClientData clientData, Tcl_Interp *interp,
 610                   int argc, char **argv, ClientData *subData,
 611                   ClientData parentData)
 612 {
 613     IrTcl_Methods tab[3];
 614     WaisTcl_Obj *obj;
 615     ClientData subP;
 616     int r;
 617
 618     if (argc != 2)
 619     {
 620         interp->result = "wrong # args";
 621         return TCL_ERROR;
 622     }
 623     obj = ir_tcl_malloc (sizeof(*obj));
 624     obj->ref_count = 1;
 625     obj->interp = interp;
 626
 627     logf (LOG_DEBUG, "wais object create %s", argv[1]);
 628
 629     r = (*ir_obj_class.ir_init)(clientData, interp, argc, argv, &subP, 0);
 630     if (r == TCL_ERROR)
 631         return TCL_ERROR;
 632     obj->irtcl_obj = subP;
 633
 634     obj->max_out = 2048;
 635     obj->buf_out = ir_tcl_malloc (obj->max_out);
 636
 637     free (obj->irtcl_obj->comstackType);
 638     ir_tcl_strdup (NULL, &obj->irtcl_obj->comstackType, "wais");
 639
 640     tab[0].tab = wais_method_tab;
 641     tab[0].obj = obj;
 642     tab[1].tab = NULL;
 643
 644     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
 645     {
 646         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
 647         /* cleanup missing ... */
 648         return TCL_ERROR;
 649     }
 650     *subData = obj;
 651     return TCL_OK;
 652 }
 653
 654
 655 /*
 656  * wais_obj_delete: Wais Object disposal
 657  */
 658 static void wais_obj_delete (ClientData clientData)
 659 {
 660     WaisTcl_Obj *obj = clientData;
 661     IrTcl_Methods tab[3];
 662
 663     --(obj->ref_count);
 664     if (obj->ref_count > 0)
 665         return;
 666
 667     logf (LOG_DEBUG, "wais object delete");
 668
 669     tab[0].tab = wais_method_tab;
 670     tab[0].obj = obj;
 671     tab[1].tab = NULL;
 672
 673     ir_tcl_method (NULL, -1, NULL, tab, NULL);
 674
 675     (*ir_obj_class.ir_delete)((ClientData) obj->irtcl_obj);
 676
 677     free (obj->buf_out);
 678     free (obj);
 679 }
 680
 681 /*
 682  * wais_obj_method: Wais Object methods
 683  */
 684 static int wais_obj_method (ClientData clientData, Tcl_Interp *interp,
 685                             int argc, char **argv)
 686 {
 687     IrTcl_Methods tab[3];
 688     WaisTcl_Obj *p = clientData;
 689     int r;
 690
 691     if (argc < 2)
 692         return TCL_ERROR;
 693
 694     tab[0].tab = wais_method_tab;
 695     tab[0].obj = p;
 696     tab[1].tab = NULL;
 697
 698     if (ir_tcl_method (interp, argc, argv, tab, &r) == TCL_ERROR)
 699     {
 700         return (*ir_obj_class.ir_method)((ClientData) p->irtcl_obj,
 701                                          interp, argc, argv);
 702     }
 703     return r;
 704 }
 705
 706 /*
 707  * wais_obj_mk: Wais Object creation
 708  */
 709 static int wais_obj_mk (ClientData clientData, Tcl_Interp *interp,
 710                         int argc, char **argv)
 711 {
 712     ClientData subData;
 713     int r = wais_obj_init (clientData, interp, argc, argv, &subData, 0);
 714
 715     if (r == TCL_ERROR)
 716         return TCL_ERROR;
 717     Tcl_CreateCommand (interp, argv[1], wais_obj_method,
 718                        subData, wais_obj_delete);
 719     return TCL_OK;
 720 }
 721
 722 /* --- S E T S ---------------------------------------------------------- */
 723
 724 static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv)
 725 {
 726     WaisSetTcl_Obj *obj = o;
 727     WaisTcl_Obj *p = obj->parent;
 728     int i, start, number;
 729     static char *element_names[3];
 730     long left;
 731     char *retp;
 732     any *waisQuery;
 733     SearchAPDU *waisSearch;
 734     DocObj **docObjs;
 735
 736     if (argc <= 0)
 737         return TCL_OK;
 738     if (argc >= 3)
 739     {
 740         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
 741             return TCL_ERROR;
 742     }
 743     else
 744         start = 1;
 745     if (argc >= 4)
 746     {
 747         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
 748             return TCL_ERROR;
 749     }
 750     else
 751         number = 10;
 752     if (!p->wais_link)
 753     {
 754         interp->result = "present: not connected";
 755         return TCL_ERROR;
 756     }
 757     element_names[0] = " ";
 758     element_names[1] = ES_DocumentText;
 759     element_names[2] = NULL;
 760
 761     docObjs = ir_tcl_malloc (sizeof(*docObjs) * (number+1));
 762     for (i = 0; i<number; i++)
 763     {
 764         WaisTcl_Record *rec;
 765
 766         rec = wais_lookup_record_pos (obj, i+start);
 767         if (!rec)
 768         {
 769             interp->result = "present request out of range";
 770             return TCL_ERROR;
 771         }
 772         docObjs[i] = makeDocObjUsingLines (rec->documentID, "TEXT", 0,
 773                                            rec->lines);
 774     }
 775     docObjs[i] = NULL;
 776     waisQuery = makeWAISTextQuery (docObjs);
 777     waisSearch =
 778         makeSearchAPDU (30L,                          /* small */
 779                         5000L,                        /* large */
 780                         30L,                          /* medium */
 781                         (boolean) obj->irtcl_set_obj->
 782                         set_inher.replaceIndicator,   /* replace indicator */
 783                         obj->irtcl_set_obj->
 784                         setName,                      /* result set name */
 785                         obj->irtcl_set_obj->set_inher.databaseNames,
 786                         QT_TextRetrievalQuery,        /* query type */
 787                         element_names,                /* element name */
 788                         NULL,                         /* reference ID */
 789                         waisQuery);
 790
 791     left = p->max_out;
 792     retp = writeSearchAPDU (waisSearch, p->buf_out + HEADER_LENGTH, &left);
 793     p->len_out = p->max_out - left;
 794
 795     for (i = 0; i<number; i++)
 796         CSTFreeDocObj (docObjs[i]);
 797     free (docObjs);
 798
 799     CSTFreeWAISTextQuery (waisQuery);
 800     freeSearchAPDU (waisSearch);
 801     if (!retp)
 802     {
 803         interp->result = "Couldn't encode Wais text search APDU";
 804         return TCL_ERROR;
 805     }
 806     writeWAISPacketHeader (p->buf_out, (long) (p->len_out), (long) 'z', "wais",
 807                            (long) NO_COMPRESSION,
 808                            (long) NO_ENCODING,
 809                            (long) HEADER_VERSION);
 810
 811     p->len_out += HEADER_LENGTH;
 812     return wais_send_apdu (interp, p, "search", argv[0]);
 813 }
 814
 815 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
 816 {
 817     WaisSetTcl_Obj *obj = o;
 818     WaisTcl_Obj *p = obj->parent;
 819     WAISSearch *waisQuery;
 820     SearchAPDU *waisSearch;
 821     char *retp;
 822     long left;
 823     DocObj **docObjs = NULL;
 824
 825     if (argc <= 0)
 826         return TCL_OK;
 827     if (argc < 3 || argc > 4)
 828     {
 829         interp->result = "wrong # args";
 830         return TCL_ERROR;
 831     }
 832     if (argc == 4)
 833     {
 834         docObjs = ir_tcl_malloc (2 * sizeof(*docObjs));
 835
 836         docObjs[0] = ir_tcl_malloc (sizeof(**docObjs));
 837         docObjs[0]->DocumentID = stringToAny (argv[3]);
 838         docObjs[0]->Type = NULL;
 839         docObjs[0]->ChunkCode = (long) CT_document;
 840
 841         docObjs[1] = NULL;
 842     }
 843     if (!obj->irtcl_set_obj->set_inher.num_databaseNames)
 844     {
 845         interp->result = "no databaseNames";
 846         return TCL_ERROR;
 847     }
 848     logf (LOG_DEBUG, "parent = %p", p);
 849     if (!p->hostname)
 850     {
 851         interp->result = "not connected";
 852         return TCL_ERROR;
 853     }
 854     obj->irtcl_set_obj->resultCount = 0;
 855     obj->irtcl_set_obj->searchStatus = 0;
 856     waisQuery =
 857         makeWAISSearch (argv[2],         /* seed words */
 858                         docObjs,         /* doc ptrs */
 859                         0,               /* text list */
 860                         1L,              /* date factor */
 861                         0L,              /* begin date range */
 862                         0L,              /* end date range */
 863                         obj->maxDocs);   /* max docs retrieved */
 864
 865     waisSearch =
 866         makeSearchAPDU (30L,                          /* small */
 867                         5000L,                        /* large */
 868                         30L,                          /* medium */
 869                         (boolean) obj->irtcl_set_obj->
 870                         set_inher.replaceIndicator,   /* replace indicator */
 871                         obj->irtcl_set_obj->
 872                         setName,                      /* result set name */
 873                         obj->irtcl_set_obj->set_inher.databaseNames,
 874                         QT_RelevanceFeedbackQuery,
 875                                                      /* query type */
 876                         NULL,                         /* element name */
 877                         NULL,                         /* reference ID */
 878                         waisQuery);
 879
 880     left = p->max_out;
 881     retp = writeSearchAPDU (waisSearch, p->buf_out + HEADER_LENGTH, &left);
 882     p->len_out = p->max_out - left;
 883
 884     CSTFreeWAISSearch (waisQuery);
 885     freeSearchAPDU (waisSearch);
 886     if (docObjs)
 887     {
 888         CSTFreeDocObj (docObjs[0]);
 889         free (docObjs);
 890     }
 891     if (!retp)
 892     {
 893         interp->result = "Couldn't encode Wais search APDU";
 894         return TCL_ERROR;
 895     }
 896     writeWAISPacketHeader (p->buf_out, (long) (p->len_out), (long) 'z', "wais",
 897                            (long) NO_COMPRESSION,
 898                            (long) NO_ENCODING,
 899                            (long) HEADER_VERSION);
 900
 901     p->len_out += HEADER_LENGTH;
 902     return wais_send_apdu (interp, p, "search", argv[0]);
 903 }
 904
 905 /*
 906  * do_responseStatus: Return response status (present or search)
 907  */
 908 static int do_responseStatus (void *o, Tcl_Interp *interp,
 909                              int argc, char **argv)
 910 {
 911     WaisSetTcl_Obj *obj = o;
 912
 913     if (argc == 0)
 914     {
 915         obj->diag = NULL;
 916         obj->addinfo = NULL;
 917         return TCL_OK;
 918     }
 919     else if (argc == -1)
 920     {
 921         free (obj->diag);
 922         free (obj->addinfo);
 923     }
 924     if (obj->diag)
 925     {
 926         Tcl_AppendElement (interp, "NSD");
 927
 928         Tcl_AppendElement (interp, obj->diag);
 929         Tcl_AppendElement (interp, obj->diag);
 930
 931         Tcl_AppendElement (interp, obj->addinfo ? obj->addinfo : "");
 932         return TCL_OK;
 933     }
 934     Tcl_AppendElement (interp, "DBOSD");
 935     return TCL_OK;
 936 }
 937
 938 /*
 939  * do_maxDocs: Set number of documents to be retrieved in ranked query
 940  */
 941 static int do_maxDocs (void *o, Tcl_Interp *interp, int argc, char **argv)
 942 {
 943     WaisSetTcl_Obj *obj = o;
 944
 945     if (argc <= 0)
 946     {
 947         obj->maxDocs = 100;
 948         return TCL_OK;
 949     }
 950     return ir_tcl_get_set_int (&obj->maxDocs, interp, argc, argv);
 951 }
 952
 953
 954 /*
 955  * do_type: Return type (if any) at position.
 956  */
 957 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)
 958 {
 959     WaisSetTcl_Obj *obj = o;
 960     int offset;
 961     WaisTcl_Record *rec;
 962
 963     if (argc == 0)
 964     {
 965         obj->records = NULL;
 966         return TCL_OK;
 967     }
 968     else if (argc == -1)
 969     {
 970         wais_delete_records (obj);
 971         return TCL_OK;
 972     }
 973     if (argc != 3)
 974     {
 975         sprintf (interp->result, "wrong # args");
 976         return TCL_ERROR;
 977     }
 978     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 979         return TCL_ERROR;
 980     rec = wais_lookup_record_pos_bf (obj, offset);
 981     if (!rec)
 982     {
 983         logf (LOG_DEBUG, "No record at position %d", offset);
 984         return TCL_OK;
 985     }
 986     interp->result = "DB";
 987     return TCL_OK;
 988 }
 989
 990
 991 /*
 992  * do_recordType: Return record type (if any) at position.
 993  */
 994 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
 995 {
 996     WaisSetTcl_Obj *obj = o;
 997     int offset;
 998     WaisTcl_Record *rec;
 999
1000     if (argc <= 0)
1001     {
1002         return TCL_OK;
1003     }
1004     if (argc != 3)
1005     {
1006         sprintf (interp->result, "wrong # args");
1007         return TCL_ERROR;
1008     }
1009     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1010         return TCL_ERROR;
1011
1012     rec = wais_lookup_record_pos_bf (obj, offset);
1013     if (!rec)
1014         return TCL_OK;
1015
1016     Tcl_AppendElement (interp, "WAIS");
1017     return TCL_OK;
1018 }
1019
1020 /*
1021  * do_getWAIS: Return WAIS record at position.
1022  */
1023 static int do_getWAIS (void *o, Tcl_Interp *interp, int argc, char **argv)
1024 {
1025     WaisSetTcl_Obj *obj = o;
1026     int offset;
1027     WaisTcl_Record *rec;
1028     char prbuf[1024];
1029
1030     if (argc <= 0)
1031     {
1032         return TCL_OK;
1033     }
1034     if (argc != 4)
1035     {
1036         sprintf (interp->result, "wrong # args: should be"
1037                  " \"assoc getWAIS pos field\"\n"
1038                  " field is one of:\n"
1039                  " score headline documentLength text lines documentID");
1040         return TCL_ERROR;
1041     }
1042     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1043         return TCL_ERROR;
1044     rec = wais_lookup_record_pos_bf (obj, offset);
1045     if (!rec)
1046         return TCL_OK;
1047     if (!strcmp (argv[3], "score"))
1048     {
1049         sprintf (prbuf, "%ld", (long) rec->score);
1050         Tcl_AppendElement (interp, prbuf);
1051     }
1052     else if (!strcmp (argv[3], "headline"))
1053     {
1054         Tcl_AppendElement (interp, rec->headline);
1055     }
1056     else if (!strcmp (argv[3], "documentLength"))
1057     {
1058         sprintf (prbuf, "%ld", (long) rec->documentLength);
1059         Tcl_AppendElement (interp, prbuf);
1060     }
1061     else if (!strcmp (argv[3], "text"))
1062     {
1063         Tcl_AppendElement (interp, rec->documentText);
1064     }
1065     else if (!strcmp (argv[3], "lines"))
1066     {
1067         sprintf (prbuf, "%ld", (long) rec->lines);
1068         Tcl_AppendElement (interp, prbuf);
1069     }
1070     else if (!strcmp (argv[3], "documentID"))
1071     {
1072         if (rec->documentID->size >= sizeof(prbuf))
1073         {
1074             interp->result = "bad documentID";
1075             return TCL_ERROR;
1076         }
1077         memcpy (prbuf, rec->documentID->bytes, rec->documentID->size);
1078         prbuf[rec->documentID->size] = '\0';
1079         Tcl_AppendElement (interp, prbuf);
1080     }
1081     return TCL_OK;
1082 }
1083
1084
1085 static IrTcl_Method wais_set_method_tab[] = {
1086 { "maxDocs",                     do_maxDocs, NULL },
1087 { "search",                      do_search, NULL },
1088 { "present",                     do_present, NULL },
1089 { "responseStatus",              do_responseStatus, NULL },
1090 { "type",                        do_type, NULL },
1091 { "recordType",                  do_recordType, NULL },
1092 { "getWAIS",                     do_getWAIS, NULL },
1093 { NULL, NULL}
1094 };
1095
1096 /*
1097  * wais_obj_method: Wais Set Object methods
1098  */
1099 static int wais_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1100                             int argc, char **argv)
1101 {
1102     IrTcl_Methods tab[3];
1103     WaisSetTcl_Obj *p = clientData;
1104     int r;
1105
1106     if (argc < 2)
1107         return TCL_ERROR;
1108
1109     tab[0].tab = wais_set_method_tab;
1110     tab[0].obj = p;
1111     tab[1].tab = NULL;
1112
1113     if (ir_tcl_method (interp, argc, argv, tab, &r) == TCL_ERROR)
1114     {
1115         return (*ir_set_obj_class.ir_method)((ClientData) p->irtcl_set_obj,
1116                                              interp, argc, argv);
1117     }
1118     return r;
1119 }
1120
1121 int wais_set_obj_init (ClientData clientData, Tcl_Interp *interp,
1122                        int argc, char **argv, ClientData *subData,
1123                        ClientData parentData)
1124 {
1125     IrTcl_Methods tab[3];
1126     WaisSetTcl_Obj *obj;
1127     ClientData subP;
1128     int r;
1129
1130     assert (parentData);
1131     if (argc != 3)
1132         return TCL_ERROR;
1133     obj = ir_tcl_malloc (sizeof(*obj));
1134     obj->parent = (WaisTcl_Obj *) parentData;
1135     logf (LOG_DEBUG, "parent = %p", obj->parent);
1136     obj->interp = interp;
1137     obj->diag = NULL;
1138     obj->addinfo = NULL;
1139
1140     logf (LOG_DEBUG, "wais set object create %s", argv[1]);
1141
1142     r = (*ir_set_obj_class.ir_init)(clientData, interp, argc, argv, &subP,
1143                                     obj->parent->irtcl_obj);
1144     if (r == TCL_ERROR)
1145         return TCL_ERROR;
1146     obj->irtcl_set_obj = subP;
1147
1148     tab[0].tab = wais_set_method_tab;
1149     tab[0].obj = obj;
1150     tab[1].tab = NULL;
1151
1152     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
1153     {
1154         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
1155         /* cleanup missing ... */
1156         return TCL_ERROR;
1157     }
1158     *subData = obj;
1159     return TCL_OK;
1160 }
1161
1162
1163 /*
1164  * wais_set_obj_delete: Wais Set Object disposal
1165  */
1166 static void wais_set_obj_delete (ClientData clientData)
1167 {
1168     WaisSetTcl_Obj *obj = clientData;
1169     IrTcl_Methods tab[3];
1170
1171     logf (LOG_DEBUG, "wais set object delete");
1172
1173     tab[0].tab = wais_set_method_tab;
1174     tab[0].obj = obj;
1175     tab[1].tab = NULL;
1176
1177     ir_tcl_method (NULL, -1, NULL, tab, NULL);
1178
1179     (*ir_set_obj_class.ir_delete)((ClientData) obj->irtcl_set_obj);
1180
1181     free (obj);
1182 }
1183
1184 /*
1185  * wais_set_obj_mk: Wais Set Object creation
1186  */
1187 static int wais_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1188                             int argc, char **argv)
1189 {
1190     int r;
1191     ClientData subData;
1192     Tcl_CmdInfo parent_info;
1193
1194     if (argc != 3)
1195     {
1196         interp->result = "wrong # args: should be"
1197             " \"wais-set set assoc?\"";
1198         return TCL_ERROR;
1199     }
1200     parent_info.clientData = 0;
1201     if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
1202     {
1203         interp->result = "No parent";
1204         return TCL_ERROR;
1205     }
1206     r = wais_set_obj_init (clientData, interp, argc, argv, &subData,
1207                            parent_info.clientData);
1208     if (r == TCL_ERROR)
1209         return TCL_ERROR;
1210     Tcl_CreateCommand (interp, argv[1], wais_set_obj_method,
1211                        subData, wais_set_obj_delete);
1212     return TCL_OK;
1213 }
1214
1215
1216 /*
1217  * do_htmlToken
1218  */
1219 int do_htmlToken (ClientData clientData, Tcl_Interp *interp,
1220                   int argc, char **argv)
1221 {
1222     const char *src;
1223     char *tmp_buf = NULL;
1224     int tmp_size = 0;
1225     int r;
1226
1227     if (argc != 4)
1228     {
1229         interp->result = "wrong # args: should be"
1230             " \"htmlToken var list command\"";
1231         return TCL_ERROR;
1232     }
1233     src = argv[2];
1234     while (*src)
1235     {
1236         const char *src1;
1237
1238         if (*src == ' ' || *src == '\t' || *src == '\n' ||
1239             *src == '\r' || *src == '\f')
1240         {
1241             src++;
1242             continue;
1243         }
1244         src1 = src + 1;
1245         if (*src == '<')
1246         {
1247             while (*src1 != '>' && *src1 != '\n' ** src1)
1248                 src1++;
1249             if (*src1 == '>')
1250                 src1++;
1251         }
1252         else
1253         {
1254             while (*src1 != '<' && *src1)
1255                 src1++;
1256         }
1257         if (src1 - src >= tmp_size)
1258         {
1259             free (tmp_buf);
1260             tmp_size = src1 - src + 256;
1261             tmp_buf = ir_tcl_malloc (tmp_size);
1262         }
1263         memcpy (tmp_buf, src, src1 - src);
1264         tmp_buf[src1-src] = '\0';
1265         Tcl_SetVar (interp, argv[1], tmp_buf, 0);
1266         r = Tcl_Eval (interp, argv[3]);
1267         if (r != TCL_OK && r != TCL_CONTINUE)
1268             break;
1269         src = src1;
1270     }
1271     if (r == TCL_CONTINUE)
1272         r = TCL_OK;
1273     free (tmp_buf);
1274     return r;
1275 }
1276
1277 /* --- R E G I S T R A T I O N ---------------------------------------- */
1278 /*
1279  * Waistcl_init: Registration of TCL commands.
1280  */
1281 int Waistcl_Init (Tcl_Interp *interp)
1282 {
1283     Tcl_CreateCommand (interp,  "wais", wais_obj_mk, (ClientData) NULL,
1284                        (Tcl_CmdDeleteProc *) NULL);
1285     Tcl_CreateCommand (interp,  "wais-set", wais_set_obj_mk,
1286                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1287     Tcl_CreateCommand (interp, "htmlToken", do_htmlToken,
1288                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1289     return TCL_OK;
1290 }
1291