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