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