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