New setting: failInfo.

Working on better cancel mechanism.

diff --git a/client.tcl b/client.tcl
index 0e22966..31f724b 100644 (file)
--- a/client.tcl
+++ b/client.tcl
@@ -4,7 +4,11 @@
 # Sebastian Hammer, Adam Dickmeiss
 #
 # $Log: client.tcl,v $
-# Revision 1.47  1995-06-19 14:05:29  adam
+# Revision 1.48  1995-06-20 08:07:23  adam
+# New setting: failInfo.
+# Working on better cancel mechanism.
+#
+# Revision 1.47  1995/06/19  14:05:29  adam
 # Bug fix: asked for SUTRS.
 #
 # Revision 1.46  1995/06/19  13:06:06  adam
@@ -182,6 +186,7 @@ set fullMarcSeq 0
 set displayFormat 1
 set popupMarcdf 0
 set textWrap word
+set delayRequest {}
 
 set queryTypes {Simple}
 set queryButtons { { {I 0} {I 1} {I 2} } }
@@ -210,7 +215,7 @@ proc set-wrap {m} {
 }
 
 proc dputs {m} {
-#    puts $m
+    puts $m
 }
 
 proc set-display-format {f} {
@@ -344,10 +349,12 @@ proc bottom-buttons {w buttonList g} {
 proc cancel-operation {} {
     global cancelFlag
     global busy
+    global delayRequest
 
     set cancelFlag 1
+    set delayRequest {}
     if {$busy} {
-        show-status Canceling 0 {}
+        show-status Cancel 0 1
     }
 }
 
@@ -716,8 +723,10 @@ proc define-target-action {} {
 }
 
 proc fail-response {target} {
+    set c [lindex [z39 failInfo] 0]
+    set m [lindex [z39 failInfo] 1]
     close-target
-    tkerror "Target connection closed or protocol error"
+    tkerror "$m ($c)"
 }
 
 proc connect-response {target base} {
@@ -872,12 +881,23 @@ proc search-request {} {
     global busy
     global cancelFlag
     global searchEnable
+    global delayRequest
 
     set target $hostid
 
-    if {$searchEnable == 0} {
+    dputs "search-request"
+    if {$searchEnable < 0} {
+        dputs "searchEnable == 0"
+        return
+    }
+    if {$cancelFlag} {
+        dputs "cancelFlag"
+        show-status {Searching} 1 0
+        set delayRequest search-request
         return
     }
+    set delayRequest {} 
+
     set query [index-query]
     if {$query==""} {
         return
@@ -1139,8 +1159,18 @@ proc search-response {} {
     global setMax
     global cancelFlag
     global busy
+    global delayRequest
 
     dputs "In search-response"
+    if {$cancelFlag} {
+        dputs "Handling cancel"
+        set cancelFlag 0
+        if {$delayRequest != ""} {
+            $delayRequest
+        }
+        return
+    }
+    set delayRequest {}
     init-title-lines
     set setMax [z39.$setNo resultCount]
     show-message "${setMax} hits"
@@ -1163,10 +1193,6 @@ proc search-response {} {
     }
     set setOffset 1
     show-status {Ready} 0 1
-    if {$cancelFlag} {
-        set cancelFlag 0
-        return
-    }
     z39 callback {present-response}
     z39.$setNo present $setOffset 1
     show-status {Retrieving} 1 0
@@ -1176,9 +1202,18 @@ proc present-more {number} {
     global setNo
     global setOffset
     global setMax
+    global busy
+    global cancelFlag
+    global delayRequest
 
-    dputs "setOffset=$setOffset"
     dputs "present-more"
+    if {$cancelFlag} {
+        show-status {Retrieving} 1 0
+        set delayRequest [list present-request $number]
+        return
+    }
+    set delayRequest {}
+
     if {$setNo == 0} {
         dputs "setNo=$setNo"
        return
@@ -1256,7 +1291,16 @@ proc present-response {} {
     global setOffset
     global setMax
     global cancelFlag
+    global delayRequest
 
+    if {$cancelFlag} {
+        dputs "Handling cancel"
+        set cancelFlag 0
+        if {$delayRequest != ""} {
+            $delayRequest
+        }
+        return
+    }
     dputs "In present-response"
     set no [z39.$setNo numberOfRecordsReturned]
     dputs "Returned $no records, setOffset $setOffset"
@@ -1271,11 +1315,6 @@ proc present-response {} {
         tkerror "NSD$code: $msg: $addinfo"
         return
     }
-    if {$cancelFlag} {
-        show-status {Ready} 0 1
-        set cancelFlag 0
-        return
-    }
     if {$no > 0 && $setOffset <= $setMax} {
         dputs "present-request from ${setOffset}"
         set toGet [expr $setMax - $setOffset + 1]

diff --git a/ir-tcl.c b/ir-tcl.c
index 468bf3a..d2c1881 100644 (file)
--- a/ir-tcl.c
+++ b/ir-tcl.c
@@ -5,7 +5,11 @@
  * Sebastian Hammer, Adam Dickmeiss
  *
  * $Log: ir-tcl.c,v $
- * Revision 1.44  1995-06-19 17:01:20  adam
+ * 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
@@ -646,6 +650,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,
@@ -755,7 +801,7 @@ static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
                                         int argc, char **argv)
 {
     IrTcl_Obj *p = obj;
-
+    
     if (argc == 0)
     {
         p->targetImplementationName = NULL;
@@ -1309,6 +1355,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 },
@@ -2817,7 +2864,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;
         }
@@ -2835,7 +2885,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 */
@@ -2850,7 +2903,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 */
@@ -2874,7 +2930,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);
@@ -2909,7 +2968,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;
         }
@@ -2922,7 +2984,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 */

diff --git a/ir-tclp.h b/ir-tclp.h
index eec7017..0898d3a 100644 (file)
--- a/ir-tclp.h
+++ b/ir-tclp.h
@@ -5,7 +5,11 @@
  * Sebastian Hammer, Adam Dickmeiss
  *
  * $Log: ir-tclp.h,v $
- * Revision 1.10  1995-06-16 12:28:20  adam
+ * Revision 1.11  1995-06-20 08:07:35  adam
+ * New setting: failInfo.
+ * Working on better cancel mechanism.
+ *
+ * Revision 1.10  1995/06/16  12:28:20  adam
  * Implemented preferredRecordSyntax.
  * Minor changes in diagnostic handling.
  * Record list deleted when connection closes.
@@ -90,6 +94,7 @@ typedef struct {
     char       *cs_type;
     int         protocol_type;
     int         connectFlag;
+    int         failInfo;
     COMSTACK    cs_link;
 
     int         preferredMessageSize;
@@ -220,4 +225,10 @@ struct ir_named_entry {
 int ir_tcl_get_marc (Tcl_Interp *interp, const char *buf,
                      int argc, char **argv);
 char *ir_tcl_fread_marc (FILE *inf, size_t *size);
+
+#define IR_TCL_FAIL_CONNECT      1
+#define IR_TCL_FAIL_READ         2
+#define IR_TCL_FAIL_WRITE        3
+#define IR_TCL_FAIL_IN_APDU      4
+#define IR_TCL_FAIL_UNKNOWN_APDU 5
 #endif