adns/adns.c

   1 /*
   2  */
   3 /*
   4  * adns lookup TYPE DOMAIN [QUERY-OPTIONS]                    => [list RDATA]
   5  *    if no or dontknow, throws an exception, with errorCode one of
   6  *         ADNS permfail 300 nxdomain {No such domain}
   7  *         ADNS permfail 301 nodata {No such data}
   8  *         ADNS tempfail ERROR-CODE ERROR-NAME ERROR-STRING
   9  *    where
  10  *         ERROR-CODE is the numerical adns status value
  11  *         ERROR-NAME is the symbolic adns status value (in lowercase)
  12  *         ERROR-STRING is the result of adns_strstatus
  13  *
  14  * adns synch TYPE DOMAIN [QUERY-OPTIONS]                     => RESULTS
  15  *        RESULTS is [list ok|permfail|tempfail
  16  *                         ERROR-CODE ERROR-NAME ERROR-STRING  \
  17  *                         OWNER CNAME                         \
  18  *                         [list RDATA ...]]
  19  *        OWNER is the RR owner
  20  *        CNAME is the empty string or the canonical name if we went
  21  *                  via a CNAME
  22  *
  23  * adns asynch ON-YES ON-NO ON-DONTKNOW XARGS \
  24  *             TYPE DOMAIN \
  25  *             [QUERY-OPTIONS]                               => QUERY-ID
  26  *        calls, later,
  27  *           [concat ON-YES|ON-NO|ON-DONTKNOW XARGS RESULTS]
  28  * adns asynch-cancel QUERY-ID
  29  *
  30  * QUERY-OPTIONS are zero or more of
  31  *         -resolver RESOLVER  (see adns new-resolver)
  32  *                 default is to use a default resolver
  33  *         -search
  34  *         -usevc
  35  *         -quoteok-query
  36  *         -quoteok-anshost
  37  *         -quotefail-cname
  38  *         -cname-loose
  39  *         -cname-forbid
  40  *         -reverse
  41  *         -reverse-any ZONE-A-LIKE
  42  *
  43  * adns new-resolver [RES-OPTIONS...]                         => RESOLVER
  44  *        options:
  45  *         -errfile stdout|stderr       (stderr is the default)
  46  *         -noerrprint
  47  *         -errcallback CALLBACK    results in  eval CALLBACK [list MESSAGE]
  48  *         -noenv|-debug|-logpid
  49  *         -checkc-entex
  50  *         -checkc-freq
  51  *         -config CONFIG-STRING
  52  *
  53  * adns set-default-resolver RESOLVER
  54  *        cancels any outstanding queries from a previous anonymous
  55  *        default resolver
  56  *
  57  * adns destroy-resolver RESOLVER
  58  *        cancels outstanding queries
  59  */
  60
  61 #define _GNU_SOURCE
  62
  63 #include <stdio.h>
  64
  65 #include <adns.h>
  66
  67 #include "chiark_tcl_adns.h"
  68
  69 /*---------- important types and forward declarations ----------*/
  70
  71 typedef struct Query Query;
  72 typedef struct Resolver Resolver;
  73 typedef struct OptionInfo OptionInfo;
  74
  75 static void asynch_sethandlers(Resolver *res);
  76 static void asynch_cancelhandlers(Resolver *res);
  77 static void asynch_perturbed(Resolver *res);
  78
  79 static void asynch_query_dispose(Tcl_Interp *interp, Query *query);
  80
  81 #define ASSOC_DEFAULTRES "adns-defaultresolver"
  82
  83 /*---------- common resolver/query option processing ----------*/
  84
  85 typedef struct {
  86   /* this struct type is used to hold both resolver and query options */
  87   /* common to resolver and query: */
  88   unsigned long aflags;
  89   unsigned long sflags;
  90   /* resolver: */
  91   FILE *errfile;
  92   Tcl_Obj *errcallback;
  93   const char *config_string;
  94   /* query: */
  95   Resolver *resolver;
  96   const char *reverseany;
  97 } OptionParse;
  98
  99 struct OptionInfo {
 100   const char *name;
 101   int (*fn)(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
 102             OptionParse *op);
 103   int takesarg;
 104   unsigned long flags_add, flags_remove;
 105 };
 106
 107 enum {
 108   oisf_reverse=     0x0002
 109 };
 110
 111 static int oiufn_f(const OptionInfo *oi, unsigned long *flags) {
 112   *flags &= ~oi->flags_remove;
 113   *flags |= oi->flags_add;
 114   return TCL_OK;
 115 }
 116 static int oifn_fa(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
 117                    OptionParse *op) { return oiufn_f(oi,&op->aflags); }
 118 static int oifn_fs(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
 119                    OptionParse *op) { return oiufn_f(oi,&op->sflags); }
 120
 121 static int oifn_reverse_any(Tcl_Interp *ip, const OptionInfo *oi,
 122                             Tcl_Obj *arg, OptionParse *op) {
 123   return cht_pat_string(ip,arg,&op->reverseany);
 124 }
 125
 126 #define OIFA1(t,f,r) { "-" #f, oifn_fa, 0, adns_##t##_##f, r }
 127 #define OIFA2(t,f,g) { "-" #f "-" #g, oifn_fa, 0, adns_##t##_##f##_##g, 0 }
 128 #define OIFS(f) { "-" #f, oifn_fs, 0, oisf_##f, 0 }
 129 #define OICA(o) { "-" #o, oifn_##o, 1 }
 130
 131 static void optparse_blank(OptionParse *op) {
 132   memset(op,0,sizeof(*op));
 133   op->errfile= stderr;
 134   op->errcallback= 0;
 135   op->config_string= 0;
 136 }
 137
 138 static int parse_options(Tcl_Interp *ip, int objc, Tcl_Obj *const *objv,
 139                          const OptionInfo opttable[], OptionParse *op) {
 140   const OptionInfo *oi;
 141   const void *oi_v;
 142   Tcl_Obj *arg;
 143   int rc;
 144
 145   objc--; objv++;
 146   for (;;) {
 147     if (!objc--) break;
 148     rc= cht_pat_enum(ip, *objv++, &oi_v, opttable, sizeof(OptionInfo),
 149                  "query or resolver option");
 150     if (rc) return rc;
 151     oi= oi_v;
 152
 153     if (oi->takesarg) {
 154       if (!objc--) {
 155         cht_setstringresult(ip,"missing value for option");
 156         return TCL_ERROR;
 157       }
 158       arg= *objv++;
 159     } else {
 160       arg= 0;
 161     }
 162     rc= oi->fn(ip,oi,arg,op);
 163     if (rc) return rc;
 164   }
 165   return TCL_OK;
 166 }
 167
 168 /*---------- resolver management ----------*/
 169
 170 struct Resolver {
 171   int ix; /* first! */
 172   Tcl_Interp *interp;
 173   adns_state ads;
 174   Tcl_TimerToken timertoken;
 175   int maxfd;
 176   fd_set handling[3];
 177   ScriptToInvoke errcallback;
 178   Tcl_Obj *errstring_accum;
 179 };
 180
 181 /* The default resolver is recorded using Tcl_SetAssocData with key
 182  * ASSOC_DEFAULTRES to record the Resolver*.  If it was explicitly
 183  * created with `adns new-resolver' then ix will be >=0, and the
 184  * resolver will be destroyed - leaving no default - when explicitly
 185  * requested.  If it was implicitly created (by starting a query when
 186  * there is no default) then ix will be -1.  */
 187
 188 static int oifn_errfile(Tcl_Interp *ip, const OptionInfo *oi,
 189                         Tcl_Obj *arg, OptionParse *op) {
 190   int rc;
 191   const char *str;
 192
 193   rc= cht_pat_string(ip,arg,&str);  if (rc) return rc;
 194   if (!strcmp(str,"stderr")) op->errfile= stderr;
 195   else if (!strcmp(str,"stdout")) op->errfile= stdout;
 196   else return cht_staticerr(ip,"-errfile argument must be stderr or stdout",0);
 197
 198   op->aflags &= ~adns_if_noerrprint;
 199   op->errcallback= 0;
 200   return TCL_OK;
 201 }
 202
 203 static int oifn_errcallback(Tcl_Interp *ip, const OptionInfo *oi,
 204                             Tcl_Obj *arg, OptionParse *op) {
 205   op->errcallback= arg;
 206   op->aflags &= ~adns_if_noerrprint;
 207   op->errfile= 0;
 208   return TCL_OK;
 209 }
 210
 211 static int oifn_config(Tcl_Interp *ip, const OptionInfo *oi,
 212                        Tcl_Obj *arg, OptionParse *op) {
 213   return cht_pat_string(ip,arg,&op->config_string);
 214 }
 215
 216 static const OptionInfo resolver_optioninfos[]= {
 217   OIFA1(if,noenv, 0),
 218   OIFA1(if,debug, adns_if_noerrprint),
 219   OIFA1(if,logpid, adns_if_noerrprint),
 220   OIFA1(if,noerrprint, adns_if_debug),
 221   OIFA2(if,checkc,entex),
 222   OIFA2(if,checkc,freq),
 223   OICA(errfile),
 224   OICA(errcallback),
 225   OICA(config),
 226   { 0 }
 227 };
 228
 229 static void adnslogfn_flushmessage(Resolver *res) {
 230   cht_scriptinv_invoke(&res->errcallback, 1, &res->errstring_accum);
 231   Tcl_SetObjLength(res->errstring_accum, 0);
 232 }
 233
 234 static void adnslogfn_callback(adns_state ads, void *logfndata,
 235                                const char *fmt, va_list al) {
 236   Resolver *res= logfndata;
 237   int l, newline;
 238   char *str;
 239
 240   l= vasprintf(&str,fmt,al);
 241   if (l<0) {
 242     cht_posixerr(res->interp,errno,"construct adns log callback string");
 243     Tcl_BackgroundError(res->interp);
 244   }
 245
 246   if (l==0) { free(str); return; }
 247   if ((newline= l>0 && str[l-1]=='\n')) l--;
 248
 249   if (!res->errstring_accum) {
 250     res->errstring_accum= Tcl_NewStringObj(str,l);
 251     Tcl_IncrRefCount(res->errstring_accum);
 252   } else {
 253     Tcl_AppendToObj(res->errstring_accum,str,l);
 254   }
 255   free(str);
 256
 257   if (newline)
 258     adnslogfn_flushmessage(res);
 259 }
 260
 261 static Resolver *default_resolver(Tcl_Interp *ip) {
 262   return Tcl_GetAssocData(ip,ASSOC_DEFAULTRES,0);
 263 }
 264
 265 static void destroy_resolver(Tcl_Interp *ip, Resolver *res) {
 266   void *query_v;
 267   int logstring_len;
 268   char *rstr;
 269   adns_query aqu;
 270
 271   if (res == default_resolver(ip))
 272     Tcl_DeleteAssocData(ip,ASSOC_DEFAULTRES);
 273
 274   if (res->errstring_accum) {
 275     rstr= Tcl_GetStringFromObj(res->errstring_accum, &logstring_len);
 276     assert(rstr);
 277     if (logstring_len)
 278       adnslogfn_flushmessage(res);
 279   }
 280
 281   if (res->ads) {
 282     /* although adns would throw these away for us, we need to
 283      * destroy our own data too and only adns has a list of them */
 284     for (;;) {
 285       adns_forallqueries_begin(res->ads);
 286       aqu= adns_forallqueries_next(res->ads, &query_v);
 287       if (!aqu) break;
 288       asynch_query_dispose(ip, query_v);
 289     }
 290     adns_finish(res->ads);
 291     res->ads= 0;
 292   }
 293   asynch_cancelhandlers(res);
 294   cht_scriptinv_cancel(&res->errcallback);
 295   Tcl_EventuallyFree(res, Tcl_Free);
 296 }
 297
 298 static void destroy_resolver_idtabcb(Tcl_Interp *ip, void *resolver_v) {
 299   destroy_resolver(ip,resolver_v);
 300 }
 301 static void destroy_resolver_defcb(ClientData resolver_v, Tcl_Interp *ip) {
 302   destroy_resolver(ip,resolver_v);
 303 }
 304
 305 int cht_do_adns_destroy_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) {
 306   cht_tabledataid_disposing(ip,res_v,&adnstcl_resolvers);
 307   destroy_resolver(ip,res_v);
 308   return TCL_OK;
 309 }
 310
 311 static int create_resolver(Tcl_Interp *ip, const OptionParse *op,
 312                            Resolver **res_r) {
 313   Resolver *res=0;
 314   int rc, i, ec;
 315
 316   res= TALLOC(sizeof(*res));  assert(res);
 317   res->ix= -1;
 318   res->interp= ip;
 319   res->ads= 0;
 320   res->timertoken= 0;
 321   res->maxfd= 0;
 322   for (i=0; i<3; i++) FD_ZERO(&res->handling[i]);
 323   cht_scriptinv_init(&res->errcallback);
 324   res->errstring_accum= 0;
 325
 326   if (op->errcallback)
 327     cht_scriptinv_set(&res->errcallback, ip, op->errcallback, 0);
 328
 329   ec= adns_init_logfn(&res->ads,
 330                       op->aflags | adns_if_noautosys,
 331                       op->config_string,
 332                       op->errcallback ? adnslogfn_callback : 0,
 333                       op->errcallback ? (void*)res : (void*)op->errfile);
 334   if (ec) { rc= cht_posixerr(ip,ec,"create adns resolver"); goto x_rc; }
 335
 336   *res_r= res;
 337   return TCL_OK;
 338
 339  x_rc:
 340   if (res) {
 341     if (res->ads) adns_finish(res->ads);
 342     TFREE(res);
 343   }
 344   return rc;
 345 }
 346
 347 int cht_do_adns_new_resolver(ClientData cd, Tcl_Interp *ip,
 348                          int objc, Tcl_Obj *const *objv,
 349                          void **result) {
 350   OptionParse op;
 351   Resolver *res=0;
 352   int rc;
 353
 354   optparse_blank(&op);
 355   rc= parse_options(ip,objc,objv,resolver_optioninfos,&op);
 356   if (rc) return rc;
 357
 358   if (op.aflags & adns_if_noerrprint) {
 359     op.errfile= 0;
 360     op.errcallback= 0;
 361   }
 362
 363   rc= create_resolver(ip, &op, &res);
 364   if (rc) return rc;
 365
 366   *result= res;
 367   return TCL_OK;
 368 }
 369
 370 int cht_do_adns_set_default_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) {
 371   Resolver *res= res_v;
 372   Tcl_DeleteAssocData(ip,ASSOC_DEFAULTRES);
 373   Tcl_SetAssocData(ip, ASSOC_DEFAULTRES, 0, res);
 374   return TCL_OK;
 375 }
 376
 377 const IdDataSpec cht_adnstcl_resolvers= {
 378   "adns-res", "adns-resolvers-table", destroy_resolver_idtabcb
 379 };
 380
 381 /*---------- query, query option and answers - common stuff ----------*/
 382
 383 #define RRTYPE_EXACTLY(t) { #t, adns_r_##t }
 384 #define RRTYPE_RAW(t) { #t, adns_r_##t##_raw }
 385 #define RRTYPE_PLUS(t) { #t "+", adns_r_##t }
 386 #define RRTYPE_MINUS(t) { #t "-", adns_r_##t##_raw }
 387
 388 const AdnsTclRRTypeInfo cht_adnstclrrtypeinfo_entries[]= {
 389   RRTYPE_EXACTLY(a),
 390   RRTYPE_EXACTLY(cname),
 391   RRTYPE_EXACTLY(hinfo),
 392   RRTYPE_EXACTLY(addr),
 393
 394   RRTYPE_RAW(ns),
 395   RRTYPE_RAW(mx),
 396
 397   RRTYPE_EXACTLY(soa),
 398   RRTYPE_EXACTLY(ptr),
 399   RRTYPE_EXACTLY(rp),
 400
 401   RRTYPE_MINUS(soa),
 402   RRTYPE_MINUS(ptr),
 403   RRTYPE_MINUS(rp),
 404   { 0 }
 405 };
 406
 407 static int oifn_resolver(Tcl_Interp *ip, const OptionInfo *oi,
 408                          Tcl_Obj *arg, OptionParse *op) {
 409   void *val_v;
 410   int rc;
 411
 412   rc= cht_pat_iddata(ip,arg,&val_v,&adnstcl_resolvers);
 413   if (rc) return rc;
 414   op->resolver= val_v;
 415   return TCL_OK;
 416 }
 417
 418 static const OptionInfo query_optioninfos[]= {
 419   OIFA1(qf,search,0),
 420   OIFA1(qf,usevc,0),
 421   OIFA2(qf,quoteok,query),
 422   OIFA2(qf,quoteok,anshost),
 423   OIFA2(qf,quotefail,cname),
 424   OIFA2(qf,cname,loose),
 425   OIFA2(qf,cname,forbid),
 426   OICA(resolver),
 427   OIFS(reverse),
 428   { "-reverse-any", oifn_reverse_any, 1 },
 429   { 0 }
 430 };
 431
 432 static int query_submit(Tcl_Interp *ip,
 433                         const AdnsTclRRTypeInfo *type, const char *domain,
 434                         int queryopts_objc, Tcl_Obj *const *queryopts_objv,
 435                         adns_query *aqu_r, void *context, Resolver **res_r) {
 436   struct sockaddr sa;
 437   static const int aftry[]= { AF_INET, AF_INET6 };
 438   OptionParse op;
 439   OptionParse res_op;
 440   int rc, r, ec;
 441   adns_state ads;
 442
 443   op.aflags= adns_qf_owner;
 444   op.sflags= 0;
 445   op.resolver= 0;
 446   op.reverseany= 0;
 447   rc= parse_options(ip, queryopts_objc,queryopts_objv, query_optioninfos,&op);
 448   if (rc) return rc;
 449
 450   if (!op.resolver) {
 451     op.resolver= default_resolver(ip);
 452     if (!op.resolver) {
 453       optparse_blank(&res_op);
 454       rc= create_resolver(ip, &res_op, &op.resolver);
 455       if (rc) return rc;
 456
 457       Tcl_SetAssocData(ip, ASSOC_DEFAULTRES,
 458                        destroy_resolver_defcb, op.resolver);
 459     }
 460   }
 461
 462   *res_r= op.resolver;
 463
 464   if (op.reverseany || (op.sflags & oisf_reverse)) {
 465     const int *af;
 466     for (af=aftry; af < af + sizeof(af)/sizeof(*af); af++) {
 467       memset(&sa,0,sizeof(sa));
 468       sa.sa_family= *af;
 469       r= inet_pton(*af,domain,&sa);
 470       if (!r) goto af_found;
 471     }
 472     return cht_staticerr(ip,"invalid address for adns reverse submit","");
 473   af_found:;
 474   }
 475
 476   ads= op.resolver->ads;
 477
 478   if (op.reverseany) {
 479     ec= adns_submit_reverse_any(ads, &sa, op.reverseany,
 480                                 type->number, op.aflags, context, aqu_r);
 481   } else if (op.sflags & oisf_reverse) {
 482     ec= adns_submit_reverse(ads, &sa,
 483                             type->number, op.aflags, context, aqu_r);
 484   } else {
 485     ec= adns_submit(ads, domain,
 486                     type->number, op.aflags, context, aqu_r);
 487   }
 488   if (ec)
 489     return cht_posixerr(ip,ec,"submit adns query");
 490
 491   return TCL_OK;
 492 }
 493
 494 #define RESULTSTATUS_LLEN 4
 495 #define RESULTLIST_LLEN 7
 496
 497 static void make_resultstatus(Tcl_Interp *ip, adns_status status,
 498                               Tcl_Obj *results[RESULTSTATUS_LLEN]) {
 499   results[0]= cht_ret_string(ip, adns_errtypeabbrev(status));
 500   results[1]= cht_ret_int(ip, status);
 501   results[2]= cht_ret_string(ip, adns_errabbrev(status));
 502   results[3]= cht_ret_string(ip, adns_strerror(status));
 503 }
 504
 505 static Tcl_Obj *make_resultrdata(Tcl_Interp *ip, adns_answer *answer) {
 506   Tcl_Obj **rdata, *rl;
 507   int i, rrsz;
 508   adns_status st;
 509   char *datap, *rdatastring;
 510
 511   rdata= TALLOC(sizeof(*rdata) * answer->nrrs);
 512   for (i=0, datap=answer->rrs.untyped;
 513        i<answer->nrrs;
 514        i++, datap += rrsz) {
 515     st= adns_rr_info(answer->type, 0,0, &rrsz, datap, &rdatastring);
 516     assert(!st);
 517     rdata[i]= cht_ret_string(ip, rdatastring);
 518     free(rdatastring);
 519   }
 520   rl= Tcl_NewListObj(answer->nrrs, rdata);
 521   TFREE(rdata);
 522   return rl;
 523 }
 524
 525 static void make_resultlist(Tcl_Interp *ip, adns_answer *answer,
 526                             Tcl_Obj *results[RESULTLIST_LLEN]) {
 527
 528   make_resultstatus(ip, answer->status, results);
 529   assert(RESULTSTATUS_LLEN==4);
 530   results[4]= cht_ret_string(ip, answer->owner);
 531   results[5]= cht_ret_string(ip, answer->cname ? answer->cname : "");
 532   results[6]= make_resultrdata(ip, answer);
 533 }
 534
 535 /*---------- synchronous query handling ----------*/
 536
 537 static int synch(Tcl_Interp *ip, const AdnsTclRRTypeInfo *rrtype,
 538                  const char *domain,
 539                  int objc, Tcl_Obj *const *objv, adns_answer **answer_r) {
 540   adns_query aqu;
 541   Resolver *res;
 542   int rc, ec;
 543
 544   rc= query_submit(ip,rrtype,domain,objc,objv,&aqu,0,&res);
 545   if (rc) return rc;
 546
 547   ec= adns_wait(res->ads,&aqu,answer_r,0);
 548   assert(!ec);
 549
 550   asynch_perturbed(res);
 551   return TCL_OK;
 552 }
 553
 554 int cht_do_adns_lookup(ClientData cd, Tcl_Interp *ip,
 555                    const AdnsTclRRTypeInfo *rrtype,
 556                    const char *domain,
 557                    int objc, Tcl_Obj *const *objv,
 558                    Tcl_Obj **result) {
 559   int rc;
 560   adns_answer *answer;
 561
 562   rc= synch(ip,rrtype,domain,objc,objv,&answer);  if (rc) return rc;
 563
 564   if (answer->status) {
 565     Tcl_Obj *problem[RESULTSTATUS_LLEN];
 566     make_resultstatus(ip, answer->status, problem);
 567     *result= Tcl_NewListObj(RESULTSTATUS_LLEN, problem);
 568   } else {
 569     *result= make_resultrdata(ip, answer);
 570   }
 571   free(answer);
 572   return TCL_OK;
 573 }
 574
 575 int cht_do_adns_synch(ClientData cd, Tcl_Interp *ip,
 576                   const AdnsTclRRTypeInfo *rrtype,
 577                   const char *domain,
 578                   int objc, Tcl_Obj *const *objv,
 579                   Tcl_Obj **result) {
 580   int rc;
 581   adns_answer *answer;
 582   Tcl_Obj *results[RESULTLIST_LLEN];
 583
 584   rc= synch(ip,rrtype,domain,objc,objv,&answer);  if (rc) return rc;
 585   make_resultlist(ip,answer,results);
 586   free(answer);
 587   *result= Tcl_NewListObj(RESULTLIST_LLEN, results);
 588   return TCL_OK;
 589 }
 590
 591 /*---------- asynchronous query handling ----------*/
 592
 593 struct Query {
 594   int ix; /* first! */
 595   Resolver *res;
 596   adns_query aqu;
 597   ScriptToInvoke on_yes, on_no, on_fail;
 598   Tcl_Obj *xargs;
 599 };
 600
 601 static void asynch_check_now(Resolver *res);
 602
 603 static void asynch_timerhandler(void *res_v) {
 604   Resolver *res= res_v;
 605   res->timertoken= 0;
 606   adns_processtimeouts(res->ads,0);
 607   asynch_check_now(res);
 608 }
 609
 610 static void asynch_filehandler(void *res_v, int mask) {
 611   Resolver *res= res_v;
 612   int ec;
 613
 614   ec= adns_processany(res->ads);
 615   if (ec) adns_globalsystemfailure(res->ads);
 616   asynch_check_now(res);
 617 }
 618
 619 static void asynch_sethandlers_generic(Resolver *res,
 620                                        int shutdown /*from _cancelhandlers*/,
 621                                        int immediate /*from _perturbed*/) {
 622   fd_set want[3];
 623   int maxfd;
 624   struct timeval tv_buf, *timeout;
 625   int i, fd;
 626
 627   timeout= 0;
 628   maxfd= 0;
 629   for (i=0; i<3; i++) FD_ZERO(&want[i]);
 630
 631   if (!shutdown)
 632     adns_beforeselect(res->ads,&maxfd,&want[0],&want[1],&want[2],
 633                       &timeout,&tv_buf,0);
 634
 635   for (fd= 0; fd < maxfd || fd < res->maxfd; fd++)
 636     for (i=0; i<3; i++)
 637       if (!!FD_ISSET(fd, &res->handling[i])
 638           != !!FD_ISSET(fd, &want[i])) {
 639         int mask=0;
 640         if (FD_ISSET(fd, &want[0])) mask |= TCL_READABLE;
 641         if (FD_ISSET(fd, &want[1])) mask |= TCL_WRITABLE;
 642         if (FD_ISSET(fd, &want[2])) mask |= TCL_EXCEPTION;
 643         if (mask) {
 644           Tcl_CreateFileHandler(fd,mask,asynch_filehandler,res);
 645           FD_SET(fd, &res->handling[i]);
 646         } else {
 647           Tcl_DeleteFileHandler(fd);
 648           FD_CLR(fd, &res->handling[i]);
 649         }
 650       }
 651   res->maxfd= maxfd;
 652
 653   Tcl_DeleteTimerHandler(res->timertoken);
 654
 655   if (immediate) {
 656     res->timertoken= Tcl_CreateTimerHandler(0,asynch_timerhandler,res);
 657   } else if (timeout) {
 658     int milliseconds;
 659
 660     if (timeout->tv_sec >= INT_MAX/1000 - 1)
 661       milliseconds= INT_MAX;
 662     else
 663       milliseconds= timeout->tv_sec * 1000 +
 664         (timeout->tv_usec + 999) / 1000;
 665
 666     res->timertoken=
 667       Tcl_CreateTimerHandler(milliseconds,asynch_timerhandler,res);
 668   }
 669 }
 670
 671 static void asynch_sethandlers(Resolver *res) {
 672   asynch_sethandlers_generic(res,0,0);
 673 }
 674 static void asynch_cancelhandlers(Resolver *res) {
 675   asynch_sethandlers_generic(res,1,0);
 676 }
 677 static void asynch_perturbed(Resolver *res) {
 678   asynch_sethandlers_generic(res,0,1);
 679 }
 680
 681 static void asynch_check_now(Resolver *res) {
 682   Tcl_Interp *interp= res->interp;
 683   adns_query aqu;
 684   adns_answer *answer;
 685   void *query_v;
 686   Query *query;
 687   ScriptToInvoke *si;
 688   int ec;
 689   Tcl_Obj *results[RESULTLIST_LLEN];
 690
 691   Tcl_Preserve(res);
 692
 693   for (;;) {
 694     if (!res->ads) { /* oh, it has been destroyed! */
 695       Tcl_Release(res);
 696       return;
 697     }
 698
 699     aqu= 0;
 700     ec= adns_check(res->ads, &aqu, &answer, &query_v);
 701     if (ec==ESRCH || ec==EAGAIN) break;
 702     assert(!ec);
 703     query= query_v;
 704
 705     query->aqu= 0;
 706     cht_tabledataid_disposing(interp, query, &adnstcl_queries);
 707
 708     si= (!answer->status ? &query->on_yes
 709          : answer->status > adns_s_max_tempfail ? &query->on_no
 710          : &query->on_fail);
 711
 712     make_resultlist(interp, answer, results);
 713     free(answer);
 714     cht_scriptinv_invoke(si, RESULTLIST_LLEN, results);
 715     asynch_query_dispose(interp, query);
 716   }
 717
 718   asynch_sethandlers(res);
 719
 720   Tcl_Release(res);
 721 }
 722
 723 int cht_do_adns_asynch(ClientData cd, Tcl_Interp *ip,
 724                    Tcl_Obj *on_yes, Tcl_Obj *on_no,
 725                    Tcl_Obj *on_fail, Tcl_Obj *xargs,
 726                    const AdnsTclRRTypeInfo *rrtype, const char *domain,
 727                    int objc, Tcl_Obj *const *objv, void **result) {
 728   Query *query;
 729   int rc;
 730   Resolver *res= 0;
 731
 732   query= TALLOC(sizeof(*query));
 733   query->ix= -1;
 734   query->aqu= 0;
 735   cht_scriptinv_init(&query->on_yes);
 736   cht_scriptinv_init(&query->on_no);
 737   cht_scriptinv_init(&query->on_fail);
 738   query->xargs= 0;
 739
 740   rc= query_submit(ip,rrtype,domain,objc,objv,&query->aqu,query,&query->res);
 741   if (rc) goto x_rc;
 742
 743   res= query->res;
 744
 745   rc= cht_scriptinv_set(&query->on_yes, ip,on_yes, xargs);  if (rc) goto x_rc;
 746   rc= cht_scriptinv_set(&query->on_no,  ip,on_no,  xargs);  if (rc) goto x_rc;
 747   rc= cht_scriptinv_set(&query->on_fail,ip,on_fail,xargs);  if (rc) goto x_rc;
 748   query->xargs= xargs;
 749   Tcl_IncrRefCount(xargs);
 750   *result= query;
 751   query= 0; /* do not dispose */
 752   rc= TCL_OK;
 753
 754  x_rc:
 755   if (query) asynch_query_dispose(ip, query);
 756   if (res) asynch_perturbed(res);
 757   return rc;
 758 }
 759
 760 int cht_do_adns_asynch_cancel(ClientData cd, Tcl_Interp *ip, void *query_v) {
 761   Query *query= query_v;
 762   Resolver *res= query->res;
 763   asynch_query_dispose(ip, query);
 764   asynch_perturbed(res);
 765   return TCL_OK;
 766 }
 767
 768 static void asynch_query_dispose(Tcl_Interp *interp, Query *query) {
 769   cht_tabledataid_disposing(interp, query, &adnstcl_queries);
 770   cht_scriptinv_cancel(&query->on_yes);
 771   cht_scriptinv_cancel(&query->on_no);
 772   cht_scriptinv_cancel(&query->on_fail);
 773   if (query->xargs) Tcl_DecrRefCount(query->xargs);
 774   if (query->aqu) adns_cancel(query->aqu);
 775   TFREE(query);
 776 }
 777
 778 static void destroy_query_idtabcb(Tcl_Interp *interp, void *query_v) {
 779   asynch_query_dispose(interp, query_v);
 780 }
 781
 782 const IdDataSpec adnstcl_queries= {
 783   "adns", "adns-query-table", destroy_query_idtabcb
 784 };
 785
 786 /*---------- main hooks for tcl ----------*/
 787
 788 int cht_do_adnstoplevel_adns(ClientData cd, Tcl_Interp *ip,
 789                       const Adns_SubCommand *subcmd,
 790                       int objc, Tcl_Obj *const *objv) {
 791   return subcmd->func(0,ip,objc,objv);
 792 }
 793
 794 extern int Chiark_tcl_adns_Init(Tcl_Interp *ip); /* called by Tcl's "load" */
 795 int Chiark_tcl_adns_Init(Tcl_Interp *ip) {
 796   return cht_initextension(ip, cht_adnstoplevel_entries, 0);
 797 }