adns/adns.c

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