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