explain.tcl

   1 # IR toolkit for tcl/tk
   2 # (c) Index Data 1995-1998
   3 # See the file LICENSE for details.
   4 # Sebastian Hammer, Adam Dickmeiss
   5 #
   6 # Explain Driver
   7 #
   8 # $Log: explain.tcl,v $
   9 # Revision 1.6  1999-11-30 14:05:58  adam
  10 # Updated for new location of YAZ headers.
  11 #
  12 # Revision 1.5  1998/05/20 12:27:43  adam
  13 # Better Explain support.
  14 #
  15 # Revision 1.4  1998/04/02 14:32:00  adam
  16 # Minor changes to EXPLAIN driver.
  17 #
  18 # Revision 1.3  1998/02/12 13:32:42  adam
  19 # Updated configuration system.
  20 #
  21
  22 # Procedure explain-search
  23 #  Issue search request with explain-attribute set and specific
  24 #  category.
  25 proc explain-search-request {target zz category finish response fresponse} {
  26     z39 callback [list explain-search-response $target $zz $category $finish \
  27             $response $fresponse]
  28     ir-set $zz z39
  29     $zz databaseNames IR-Explain-1
  30     $zz preferredRecordSyntax explain
  31     $zz search "@attrset exp1 @attr 1=1 @attr 2=3 @attr 3=3 @attr 4=3 $category"
  32 }
  33
  34 # Procedure explain-search-response
  35 #  Deal with search response.
  36 proc explain-search-response {target zz category finish response fresponse} {
  37     global cancelFlag
  38
  39     apduDump
  40     if {$cancelFlag} {
  41         close-target
  42         return
  43     }
  44     set status [$zz responseStatus]
  45     if {![string compare [lindex $status 0] NSD]} {
  46         $fresponse $target $zz $category $finish
  47         return
  48     }
  49     set cnt [$zz resultCount]
  50     if {$cnt <= 0} {
  51         $fresponse $target $zz $category $finish
  52         return
  53     }
  54     set rr [$zz numberOfRecordsReturned]
  55     set cnt [expr $cnt - $rr]
  56     if {$cnt <= 0} {
  57         explain-present-response $target $zz $category $finish \
  58             $response $fresponse
  59         return
  60     }
  61     z39 callback [list explain-present-response $target $zz $category $finish \
  62                       $response $fresponse]
  63     incr rr
  64     $zz present $rr $cnt
  65 }
  66
  67 # Procedure explain-present-response
  68 #  Deal with explain present response.
  69 proc explain-present-response {target zz category finish response fresponse} {
  70     global cancelFlag
  71
  72     apduDump
  73     if {$cancelFlag} {
  74         close-target
  75         return
  76     }
  77     set cnt [$zz resultCount]
  78     ir-log debug "cnt=$cnt"
  79     for {set i 1} {$i <= $cnt} {incr i} {
  80         if {[string compare [$zz type $i] DB]} {
  81             $fresponse $target $zz $category $finish
  82             return
  83         }
  84         if {[string compare [$zz recordType $i] Explain]} {
  85             $fresponse $target $zz $category $finish
  86             return
  87         }
  88     }
  89     $response $target $zz $category $finish
  90 }
  91
  92
  93 # Procedure explain-check-0
  94 #  Phase 0: CategoryList
  95 proc explain-check-0 {target zz category finish} {
  96     show-status Explaining 1 0
  97     show-message CategoryList
  98     explain-search-request $target z39.categoryList CategoryList $finish \
  99             explain-check-5 explain-check-fail
 100 }
 101
 102 # Procedure explain-check-5
 103 #  TargetInfo
 104 proc explain-check-5 {target zz category finish} {
 105     show-status Explaining 1 0
 106     show-message TargetInfo
 107
 108     explain-search-request $target z39.targetInfo TargetInfo $finish \
 109             explain-check-10 explain-check-fail
 110 }
 111
 112 # Procedure explain-check-10
 113 #  DatabaseInfo
 114 proc explain-check-10 {target zz category finish} {
 115     show-status Explaining 1 0
 116     show-message DatabaseInfo
 117     explain-search-request $target z39.databaseInfo DatabaseInfo \
 118         $finish explain-check-15 explain-check-fail
 119 }
 120
 121 # Procedure explain-check-15
 122 #  AttributeDetails
 123 proc explain-check-15 {target zz category finish} {
 124     show-status Explaining 1 0
 125     show-message AttributeDetails
 126     explain-search-request $target z39.attributeDetails AttributeDetails \
 127         $finish explain-check-ok explain-check-ok
 128 }
 129
 130 # Proedure explain-check-fail
 131 #  Deal with explain check failure - call finish handler
 132 proc explain-check-fail {target zz category finish} {
 133     eval $finish [list $target]
 134 }
 135
 136 proc prettyDump {x} {
 137     foreach y $x {
 138         prettyDumpR $y 0
 139     }
 140 }
 141
 142 proc prettyDumpR {x ind} {
 143     for {set i 0} {$i < $ind} {incr i} {
 144         puts -nonewline " "
 145     }
 146     set i 0
 147     foreach y $x {
 148         if {$i == 0} {
 149             if {![string compare $y text]} {
 150                 puts $x
 151                 return
 152             }
 153             puts $y
 154         } else {
 155             prettyDumpR $y [expr $ind + 2]
 156         }
 157         incr i
 158     }
 159 }
 160
 161 # Procedure explain-check-ok
 162 proc explain-check-ok {target zz category finish} {
 163     global profile settingsChanged
 164
 165     set crec [z39.categoryList getExplain 1 categoryList]
 166     dputs "--- categoryList"
 167     dputs $crec
 168
 169     set rec [z39.targetInfo getExplain 1]
 170
 171     set trec [z39.targetInfo getExplain 1 targetInfo]
 172     dputs "--- targetInfo"
 173     dputs $rec
 174
 175     set no 1
 176     while {1} {
 177         if {[catch {set rec \
 178                 [z39.databaseInfo getExplain $no databaseInfo]}]} break
 179         dputs "--- databaseInfo $no"
 180         dputs $rec
 181
 182         lappend dbRecs $rec
 183         set db [lindex [lindex $rec 1] 1]
 184         if {![string length $db]} break
 185         lappend dbList $db
 186         incr no
 187     }
 188     if {[info exists dbList]} {
 189         set profile($target,databases) $dbList
 190     }
 191     cascade-target-list
 192
 193
 194     set no 1
 195     while {1} {
 196         if {[catch {set rec \
 197                 [z39.attributeDetails getExplain $no attributeDetails]}]} break
 198         dputs "--- attributeDetails $no"
 199         dputs $rec
 200         incr no
 201     }
 202     set data [lindex [lindex [lindex [lindex [lindex $trec 12] 1] 1] 1] 1]
 203     if {[string length $data]} {
 204         set profile($target,descripton) $data
 205     }
 206
 207     set profile($target,namedResultSets) [lindex [lindex $trec 4] 1]
 208     set profile($target,timeLastExplain) [clock seconds]
 209     set profile($target,targetInfoName) [lindex [lindex $trec 1] 1]
 210     set profile($target,recentNews) [lindex [lindex $trec 2] 1]
 211     set profile($target,maxResultSets) [lindex [lindex $trec 6] 1]
 212     set profile($target,maxResultSize) [lindex [lindex $trec 7] 1]
 213     set profile($target,maxTerms) [lindex [lindex $trec 8] 1]
 214     set profile($target,multipleDatabases) [lindex [lindex $trec 5] 1]
 215     set profile($target,welcomeMessage) \
 216         [lindex [lindex [lindex [lindex [lindex $trec 10] 1] 1] 1] 1]
 217
 218     set settingsChanged 1
 219
 220     eval $finish [list $target]
 221 }
 222
 223 # Procedure explain-refresh
 224 proc explain-refresh {target finish} {
 225     explain-check-0 $target {} {} $finish
 226 }
 227
 228 # Procedure explain-check
 229 #   Checks target for explain database.
 230 #   Evals "$finish $target" on finish.
 231 proc explain-check {target finish} {
 232     global profile
 233
 234     set refresh 0
 235     set time [clock seconds]
 236     set etime $profile($target,timeLastExplain)
 237     if {[string length $etime]} {
 238         # Check last explain. If 1 day since last explain do explain egain.
 239         # 1 day = 86400
 240         if {$time > [expr 180 + $etime]} {
 241             set refresh 1
 242         }
 243     } else {
 244         # Check last init. If never init or 1 week after do explain anyway.
 245         # 1 week = 604800
 246         set etime $profile($target,timeLastInit)
 247         if {![string length $etime]} {
 248             set refresh 1
 249         } elseif {$time > [expr 604800 + $etime]} {
 250             set refresh 1
 251         }
 252     }
 253     if {$refresh} {
 254         explain-refresh $target $finish
 255     } else {
 256         eval $finish [list $target]
 257     }
 258 }