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