X-Git-Url: http://lists.indexdata.com/cgi-bin?a=blobdiff_plain;f=ir-tcl.c;h=7f9fc2fc968baf75b3b7c5053216a03ac327797d;hb=c35c5cc9a0456642119e21bfa63eeaf14cbf0415;hp=f49c97b571a2fd29dae55b7057935e51e57a3aee;hpb=a78acc150da77d8c6ef548642dc29622427687a0;p=ir-tcl-moved-to-github.git

diff --git a/ir-tcl.c b/ir-tcl.c
index f49c97b..7f9fc2f 100644
--- a/ir-tcl.c
+++ b/ir-tcl.c
@@ -5,7 +5,38 @@
  * Sebastian Hammer, Adam Dickmeiss
  *
  * $Log: ir-tcl.c,v $
- * Revision 1.43  1995-06-19 13:06:08  adam
+ * Revision 1.50  1995-07-20 08:09:49  adam
+ * client.tcl: Targets removed from hotTargets list when targets
+ *  are removed/modified.
+ * ir-tcl.c: More work on triggerResourceControl.
+ *
+ * Revision 1.49  1995/06/30  12:39:21  adam
+ * Bug fix: loadFile didn't set record type.
+ * The MARC routines are a little less strict in the interpretation.
+ * Script display.tcl replaces the old marc.tcl.
+ * New interactive script: shell.tcl.
+ *
+ * Revision 1.48  1995/06/27  19:03:50  adam
+ * Bug fix in do_present in ir-tcl.c: p->set_child member weren't set.
+ * nextResultSetPosition used instead of setOffset.
+ *
+ * Revision 1.47  1995/06/25  10:25:04  adam
+ * Working on triggerResourceControl. Description of compile/install
+ * procedure moved to ir-tcl.sgml.
+ *
+ * Revision 1.46  1995/06/22  13:15:06  adam
+ * Feature: SUTRS. Setting getSutrs implemented.
+ * Work on display formats.
+ * Preferred record syntax can be set by the user.
+ *
+ * Revision 1.45  1995/06/20  08:07:30  adam
+ * New setting: failInfo.
+ * Working on better cancel mechanism.
+ *
+ * Revision 1.44  1995/06/19  17:01:20  adam
+ * Minor changes.
+ *
+ * Revision 1.43  1995/06/19  13:06:08  adam
  * New define: IR_TCL_VERSION.
  *
  * Revision 1.42  1995/06/19  08:08:52  adam
@@ -246,7 +277,9 @@ int IrTcl_eval (Tcl_Interp *interp, const char *command)
     strcpy (tmp, command);
     r = Tcl_Eval (interp, tmp);
     if (r == TCL_ERROR)
-        logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine, interp->result);
+        logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine, 
+              interp->result);
+    Tcl_FreeResult (interp);
     free (tmp);
     return r;
 }
@@ -345,7 +378,8 @@ int ir_method (Tcl_Interp *interp, int argc, char **argv, IrTcl_Methods *tab)
 
     if (argc <= 0)
         return TCL_OK;
-    Tcl_AppendResult (interp, "Bad method. Possible methods:", NULL);
+    Tcl_AppendResult (interp, "Bad method: ", argv[1], 
+                      ". Possible methods:", NULL);
     for (tab_i = tab; tab_i->tab; tab_i++)
         for (t = tab_i->tab; t->name; t++)
             Tcl_AppendResult (interp, " ", t->name, NULL);
@@ -483,6 +517,39 @@ static void get_referenceId (char **dst, Z_ReferenceId *src)
 /* ------------------------------------------------------- */
 
 /*
+ * ir-tcl_send_APDU: send APDU
+ */
+static int ir_tcl_send_APDU (Tcl_Interp *interp, IrTcl_Obj *p, Z_APDU *apdu, 
+                             const char *msg)
+{
+    int r;
+
+    if (!z_APDU (p->odr_out, &apdu, 0))
+    {
+        Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
+                          NULL);
+        odr_reset (p->odr_out);
+        return TCL_ERROR;
+    }
+    p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
+    odr_reset (p->odr_out);
+    if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
+    {     
+        sprintf (interp->result, "cs_put failed in %s", msg);
+        do_disconnect (p, NULL, 2, NULL);
+        return TCL_ERROR;
+    }
+    else if (r == 1)
+    {
+        ir_select_add_write (cs_fileno(p->cs_link), p);
+        logf (LOG_DEBUG, "Sent part of %s (%d bytes)", msg, p->slen);
+    }
+    else
+        logf (LOG_DEBUG, "Sent whole %s (%d bytes)", msg, p->slen);
+    return TCL_OK;
+}
+
+/*
  * do_init_request: init method on IR object
  */
 static int do_init_request (void *obj, Tcl_Interp *interp,
@@ -491,7 +558,6 @@ static int do_init_request (void *obj, Tcl_Interp *interp,
     Z_APDU *apdu;
     IrTcl_Obj *p = obj;
     Z_InitRequest *req;
-    int r;
 
     if (argc <= 0)
         return TCL_OK;
@@ -500,7 +566,6 @@ static int do_init_request (void *obj, Tcl_Interp *interp,
         interp->result = "not connected";
         return TCL_ERROR;
     }
-    odr_reset (p->odr_out);
     apdu = zget_APDU (p->odr_out, Z_APDU_initRequest);
     req = apdu->u.initRequest;
 
@@ -546,28 +611,7 @@ static int do_init_request (void *obj, Tcl_Interp *interp,
     req->implementationVersion = p->implementationVersion;
     req->userInformationField = 0;
 
-    if (!z_APDU (p->odr_out, &apdu, 0))
-    {
-        Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
-                          NULL);
-        odr_reset (p->odr_out);
-        return TCL_ERROR;
-    }
-    p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
-    if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
-    {     
-        interp->result = "cs_put failed in init";
-        do_disconnect (p, NULL, 2, NULL);
-        return TCL_ERROR;
-    }
-    else if (r == 1)
-    {
-        ir_select_add_write (cs_fileno(p->cs_link), p);
-        logf (LOG_DEBUG, "Sent part of initializeRequest (%d bytes)", p->slen);
-    }
-    else
-        logf (LOG_DEBUG, "Sent whole initializeRequest (%d bytes)", p->slen);
-    return TCL_OK;
+    return ir_tcl_send_APDU (interp, p, apdu, "init");
 }
 
 /*
@@ -633,6 +677,7 @@ static int do_options (void *obj, Tcl_Interp *interp,
         ODR_MASK_ZERO (&p->options);
 	ODR_MASK_SET (&p->options, 0);
 	ODR_MASK_SET (&p->options, 1);
+        ODR_MASK_SET (&p->options, 4);
 	ODR_MASK_SET (&p->options, 7);
 	ODR_MASK_SET (&p->options, 14);
 	return TCL_OK;
@@ -641,6 +686,48 @@ static int do_options (void *obj, Tcl_Interp *interp,
 }
 
 /*
+ * do_failInfo: Get fail information
+ */
+static int do_failInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)
+{
+    char buf[16], *cp;
+    IrTcl_Obj *p = obj;
+
+    if (argc <= 0)
+    {
+        p->failInfo = 0;
+	return TCL_OK;
+    }
+    sprintf (buf, "%d", p->failInfo);
+    switch (p->failInfo)
+    {
+    case 0:
+        cp = "ok";
+        break;
+    case IR_TCL_FAIL_CONNECT:
+        cp = "connect failed";
+        break;
+    case IR_TCL_FAIL_READ:
+        cp = "connection closed";
+        break;
+    case IR_TCL_FAIL_WRITE:
+        cp = "connection closed";
+        break;
+    case IR_TCL_FAIL_IN_APDU:
+        cp = "failed to decode incoming APDU";
+        break;
+    case IR_TCL_FAIL_UNKNOWN_APDU:
+        cp = "unknown APDU";
+        break;
+    default:
+        cp = "";
+    } 
+    Tcl_AppendElement (interp, buf);
+    Tcl_AppendElement (interp, cp);
+    return TCL_OK;
+}
+
+/*
  * do_preferredMessageSize: Set/get preferred message size
  */
 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
@@ -750,7 +837,7 @@ static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
                                         int argc, char **argv)
 {
     IrTcl_Obj *p = obj;
-
+    
     if (argc == 0)
     {
         p->targetImplementationName = NULL;
@@ -929,8 +1016,6 @@ static int do_connect (void *obj, Tcl_Interp *interp,
                 IrTcl_eval (p->interp, p->callback);
         }
     }
-    if (p->hostname)
-        Tcl_AppendElement (interp, p->hostname);
     return TCL_OK;
 }
 
@@ -963,6 +1048,7 @@ static int do_disconnect (void *obj, Tcl_Interp *interp,
         ODR_MASK_ZERO (&p->options);
 	ODR_MASK_SET (&p->options, 0);
 	ODR_MASK_SET (&p->options, 1);
+	ODR_MASK_SET (&p->options, 4);
 	ODR_MASK_SET (&p->options, 7);
 	ODR_MASK_SET (&p->options, 14);
 
@@ -1022,7 +1108,7 @@ static int do_callback (void *obj, Tcl_Interp *interp,
 	}
 	else
 	    p->callback = NULL;
-        p->interp = irTcl_interp;
+        p->interp = interp;
     }
     return TCL_OK;
 }
@@ -1052,7 +1138,7 @@ static int do_failback (void *obj, Tcl_Interp *interp,
 	}
 	else
 	    p->failback = NULL;
-        p->interp = irTcl_interp;
+        p->interp = interp;
     }
     return TCL_OK;
 }
@@ -1095,6 +1181,32 @@ static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv)
 }
 
 /*
+ * do_triggerResourceControl:
+ */
+static int do_triggerResourceControl (void *obj, Tcl_Interp *interp,
+                                      int argc, char **argv)
+{
+    IrTcl_Obj *p = obj;
+    Z_APDU *apdu;
+    Z_TriggerResourceControlRequest *req;
+    bool_t is_false = 0;
+
+    if (argc <= 0)
+        return TCL_OK;
+    if (!p->cs_link)
+    {
+        interp->result = "not connected";
+        return TCL_ERROR;
+    }
+    apdu = zget_APDU (p->odr_out, Z_APDU_triggerResourceControlRequest);
+    req = apdu->u.triggerResourceControlRequest;
+    *req->requestedAction = Z_TriggerResourceCtrl_cancel;
+    req->resultSetWanted = &is_false; 
+    
+    return ir_tcl_send_APDU (interp, p, apdu, "triggerResourceControl");
+}
+
+/*
  * do_databaseNames: specify database names
  */
 static int do_databaseNames (void *obj, Tcl_Interp *interp,
@@ -1304,6 +1416,7 @@ static IrTcl_Method ir_method_tab[] = {
 { 1, "comstack",                    do_comstack },
 { 1, "protocol",                    do_protocol },
 { 0, "failback",                    do_failback },
+{ 0, "failInfo",                    do_failInfo },
 
 { 1, "connect",                     do_connect },
 { 0, "protocolVersion",             do_protocolVersion },
@@ -1322,6 +1435,7 @@ static IrTcl_Method ir_method_tab[] = {
 { 0, "initResult",                  do_initResult },
 { 0, "disconnect",                  do_disconnect },
 { 0, "callback",                    do_callback },
+{ 0, "triggerResourceControl",      do_triggerResourceControl },
 { 0, NULL, NULL}
 };
 
@@ -1452,13 +1566,14 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
     Z_APDU *apdu;
     Odr_oct ccl_query;
     IrTcl_SetObj *obj = o;
-    IrTcl_Obj *p = obj->parent;
+    IrTcl_Obj *p;
     int r;
     oident bib1;
 
     if (argc <= 0)
         return TCL_OK;
 
+    p = obj->parent;
     p->set_child = o;
     if (argc != 3)
     {
@@ -1475,7 +1590,6 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
         interp->result = "not connected";
         return TCL_ERROR;
     }
-    odr_reset (p->odr_out);
     apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest);
     req = apdu->u.searchRequest;
 
@@ -1505,6 +1619,7 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
         ident.proto = p->protocol_type;
         ident.class = CLASS_RECSYN;
         ident.value = *obj->set_inher.preferredRecordSyntax;
+        logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
         req->preferredRecordSyntax = odr_oiddup (p->odr_out, 
                                                  oid_getoidbyent (&ident));
     }
@@ -1564,28 +1679,7 @@ static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
         interp->result = "unknown query method";
         return TCL_ERROR;
     }
-    if (!z_APDU (p->odr_out, &apdu, 0))
-    {
-        interp->result = odr_errlist [odr_geterror (p->odr_out)];
-        odr_reset (p->odr_out);
-        return TCL_ERROR;
-    } 
-    p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
-    if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
-    {
-        interp->result = "cs_put failed in search";
-        return TCL_ERROR;
-    }
-    else if (r == 1)
-    {
-        ir_select_add_write (cs_fileno(p->cs_link), p);
-        logf (LOG_DEBUG, "Sent part of searchRequest (%d bytes)", p->slen);
-    }
-    else
-    {
-        logf (LOG_DEBUG, "Whole search request (%d bytes)", p->slen);
-    }
-    return TCL_OK;
+    return ir_tcl_send_APDU (interp, p, apdu, "search");
 }
 
 /*
@@ -1637,7 +1731,10 @@ static int do_nextResultSetPosition (void *o, Tcl_Interp *interp,
     IrTcl_SetObj *obj = o;
 
     if (argc <= 0)
+    {
+        obj->nextResultSetPosition = 0;
         return TCL_OK;
+    }
     return get_set_int (&obj->nextResultSetPosition, interp, argc, argv);
 }
 
@@ -1851,6 +1948,41 @@ static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
     return ir_tcl_get_marc (interp, rl->u.dbrec.buf, argc, argv);
 }
 
+/*
+ * do_getSutrs: Get SUTRS Record
+ */
+static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv)
+{
+    IrTcl_SetObj *obj = o;
+    int offset;
+    IrTcl_RecordList *rl;
+
+    if (argc <= 0)
+        return TCL_OK;
+    if (argc < 3)
+    {
+        sprintf (interp->result, "wrong # args");
+        return TCL_ERROR;
+    }
+    if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
+        return TCL_ERROR;
+    rl = find_IR_record (obj, offset);
+    if (!rl)
+    {
+        Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
+        return TCL_ERROR;
+    }
+    if (rl->which != Z_NamePlusRecord_databaseRecord)
+    {
+        Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
+        return TCL_ERROR;
+    }
+    if (rl->u.dbrec.type != VAL_SUTRS)
+        return TCL_OK;
+    Tcl_AppendElement (interp, rl->u.dbrec.buf);
+    return TCL_OK;
+}
+
 
 /*
  * do_responseStatus: Return response status (present or search)
@@ -1899,12 +2031,11 @@ static int do_present (void *o, Tcl_Interp *interp,
                        int argc, char **argv)
 {
     IrTcl_SetObj *obj = o;
-    IrTcl_Obj *p = obj->parent;
+    IrTcl_Obj *p;
     Z_APDU *apdu;
     Z_PresentRequest *req;
     int start;
     int number;
-    int r;
 
     if (argc <= 0)
         return TCL_OK;
@@ -1927,7 +2058,9 @@ static int do_present (void *o, Tcl_Interp *interp,
         interp->result = "not connected";
         return TCL_ERROR;
     }
-    odr_reset (p->odr_out);
+    p = obj->parent;
+    p->set_child = obj;
+
     obj->start = start;
     obj->number = number;
 
@@ -1941,32 +2074,21 @@ static int do_present (void *o, Tcl_Interp *interp,
     
     req->resultSetStartPoint = &start;
     req->numberOfRecordsRequested = &number;
-    req->preferredRecordSyntax = 0;
-
-    if (!z_APDU (p->odr_out, &apdu, 0))
-    {
-        interp->result = odr_errlist [odr_geterror (p->odr_out)];
-        odr_reset (p->odr_out);
-        return TCL_ERROR;
-    } 
-    p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
-    if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
-    {
-        interp->result = "cs_put failed in present";
-        return TCL_ERROR;
-    }
-    else if (r == 1)
+    if (obj->set_inher.preferredRecordSyntax)
     {
-        ir_select_add_write (cs_fileno(p->cs_link), p);
-        logf (LOG_DEBUG, "Part of present request, start=%d, num=%d" 
-              " (%d bytes)", start, number, p->slen);
+        struct oident ident;
+
+        ident.proto = p->protocol_type;
+        ident.class = CLASS_RECSYN;
+        ident.value = *obj->set_inher.preferredRecordSyntax;
+        logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
+        req->preferredRecordSyntax = odr_oiddup (p->odr_out, 
+                                                 oid_getoidbyent (&ident));
     }
     else
-    {
-        logf (LOG_DEBUG, "Whole present request, start=%d, num=%d"
-              " (%d bytes)", start, number, p->slen);
-    }
-    return TCL_OK;
+        req->preferredRecordSyntax = 0;
+     
+    return ir_tcl_send_APDU (interp, p, apdu, "present");
 }
 
 /*
@@ -2000,6 +2122,7 @@ static int do_loadFile (void *o, Tcl_Interp *interp,
         IrTcl_RecordList *rl;
 
         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
+        rl->u.dbrec.type = VAL_USMARC;
         rl->u.dbrec.buf = buf;
 	rl->u.dbrec.size = size;
         no++;
@@ -2020,6 +2143,7 @@ static IrTcl_Method ir_set_method_tab[] = {
     { 0, "present",                 do_present },
     { 0, "type",                    do_type },
     { 0, "getMarc",                 do_getMarc },
+    { 0, "getSutrs",                do_getSutrs },
     { 0, "recordType",              do_recordType },
     { 0, "diag",                    do_diag },
     { 0, "responseStatus",          do_responseStatus },
@@ -2158,7 +2282,6 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
     Z_APDU *apdu;
     IrTcl_ScanObj *obj = o;
     IrTcl_Obj *p = obj->parent;
-    int r;
     oident bib1;
 #if CCL2RPN
     struct ccl_rpn_node *rpn;
@@ -2183,7 +2306,6 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
         interp->result = "not connected";
 	return TCL_ERROR;
     }
-    odr_reset (p->odr_out);
 
     bib1.proto = p->protocol_type;
     bib1.class = CLASS_ATTSET;
@@ -2223,29 +2345,8 @@ static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
           *req->numberOfTermsRequested);
     logf (LOG_DEBUG, "preferredPositionInResponse=%d",
           *req->preferredPositionInResponse);
-
-    if (!z_APDU (p->odr_out, &apdu, 0))
-    {
-        interp->result = odr_errlist [odr_geterror (p->odr_out)];
-        odr_reset (p->odr_out);
-        return TCL_ERROR;
-    } 
-    p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
-    if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
-    {
-        interp->result = "cs_put failed in scan";
-        return TCL_ERROR;
-    }
-    else if (r == 1)
-    {
-        ir_select_add_write (cs_fileno(p->cs_link), p);
-        logf (LOG_DEBUG, "Sent part of scanRequest (%d bytes)", p->slen);
-    }
-    else
-    {
-        logf (LOG_DEBUG, "Whole scan request (%d bytes)", p->slen);
-    }
-    return TCL_OK;
+    
+    return ir_tcl_send_APDU (interp, p, apdu, "scan");
 }
 
 /*
@@ -2602,22 +2703,43 @@ static void ir_handleRecords (void *o, Z_Records *zrs)
             {
                 Z_DatabaseRecord *zr; 
                 Odr_external *oe;
+                struct oident *ident;
                 
                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
                     ->u.databaseRecord;
                 oe = (Odr_external*) zr;
 		rl->u.dbrec.size = zr->u.octet_aligned->len;
+
                 rl->u.dbrec.type = VAL_USMARC;
+                if ((ident = oid_getentbyoid (oe->direct_reference)))
+                    rl->u.dbrec.type = ident->value;
                 if (oe->which == ODR_EXTERNAL_octet && rl->u.dbrec.size > 0)
                 {
-                    const char *buf = (char*) zr->u.octet_aligned->buf;
+                    char *buf = (char*) zr->u.octet_aligned->buf;
                     if ((rl->u.dbrec.buf = malloc (rl->u.dbrec.size)))
 		        memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size);
-                    if (oe->direct_reference)
+                }
+                else if (rl->u.dbrec.type == VAL_SUTRS && 
+                         oe->which == ODR_EXTERNAL_single)
+                {
+                    Odr_oct *rc;
+                    
+                    logf (LOG_DEBUG, "Decoding SUTRS");
+                    odr_setbuf (p->odr_in, (char*) oe->u.single_ASN1_type->buf,
+                                oe->u.single_ASN1_type->len, 0);
+                    if (!z_SUTRS(p->odr_in, &rc, 0))
                     {
-                        struct oident *ident = 
-                            oid_getentbyoid (oe->direct_reference);
-                        rl->u.dbrec.type = ident->value;
+                        logf (LOG_WARN, "Cannot decode SUTRS");
+                        rl->u.dbrec.buf = NULL;
+                    }
+                    else 
+                    {
+                        if ((rl->u.dbrec.buf = malloc (rc->len+1)))
+                        {
+                            memcpy (rl->u.dbrec.buf, rc->buf, rc->len);
+                            rl->u.dbrec.buf[rc->len] = '\0';
+                        }
+                        rl->u.dbrec.size = rc->len;
                     }
                 }
                 else
@@ -2812,7 +2934,10 @@ void ir_select_read (ClientData clientData)
         {
             logf (LOG_DEBUG, "cs_rcvconnect error");
             if (p->failback)
+            {
+                p->failInfo = IR_TCL_FAIL_CONNECT;
                 IrTcl_eval (p->interp, p->failback);
+            }
             do_disconnect (p, NULL, 2, NULL);
             return;
         }
@@ -2830,7 +2955,10 @@ void ir_select_read (ClientData clientData)
             logf (LOG_DEBUG, "cs_get failed, code %d", r);
             ir_select_remove (cs_fileno (p->cs_link), p);
             if (p->failback)
+            {
+                p->failInfo = IR_TCL_FAIL_READ;
                 IrTcl_eval (p->interp, p->failback);
+            }
             do_disconnect (p, NULL, 2, NULL);
 
 	    /* relase ir object now if callback deleted it */
@@ -2845,7 +2973,10 @@ void ir_select_read (ClientData clientData)
         {
             logf (LOG_DEBUG, "%s", odr_errlist [odr_geterror (p->odr_in)]);
             if (p->failback)
+            {
+                p->failInfo = IR_TCL_FAIL_IN_APDU;
                 IrTcl_eval (p->interp, p->failback);
+            }
             do_disconnect (p, NULL, 2, NULL);
 
 	    /* release ir object now if failback deleted it */
@@ -2869,7 +3000,10 @@ void ir_select_read (ClientData clientData)
         default:
             logf (LOG_WARN, "Received unknown APDU type (%d)", apdu->which);
             if (p->failback)
+            {
+                p->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;
                 IrTcl_eval (p->interp, p->failback);
+            }
             do_disconnect (p, NULL, 2, NULL);
         }
         odr_reset (p->odr_in);
@@ -2904,7 +3038,10 @@ void ir_select_write (ClientData clientData)
             logf (LOG_DEBUG, "cs_rcvconnect error");
             ir_select_remove_write (cs_fileno (p->cs_link), p);
             if (p->failback)
+            {
+                p->failInfo = IR_TCL_FAIL_CONNECT;
                 IrTcl_eval (p->interp, p->failback);
+            }
             do_disconnect (p, NULL, 2, NULL);
             return;
         }
@@ -2917,7 +3054,10 @@ void ir_select_write (ClientData clientData)
     {   
         logf (LOG_DEBUG, "select write fail");
         if (p->failback)
+        {
+            p->failInfo = IR_TCL_FAIL_WRITE;
             IrTcl_eval (p->interp, p->failback);
+        }
         do_disconnect (p, NULL, 2, NULL);
     }
     else if (r == 0)            /* remove select bit */