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