client2/explain.tcl

   1 proc debug-window {} {
   2         set w .debug-window
   3     toplevel $w
   4
   5     wm title $w "Debug Window"
   6
   7     top-down-window $w
   8         scrollbar $w.top.s -command [list $w.top.t yview]
   9     text $w.top.t -width 60 -height 10 -wrap word -relief flat -borderwidth 0 \
  10         -font fixed -yscroll [list $w.top.s set]
  11     pack $w.top.s -side right -fill y
  12     pack $w.top.t -expand yes -fill both -expand y
  13 }
  14 debug-window
  15
  16 #Procedure get-attributeDetails
  17 #If the target supports explain the Attribute Details are extracted here.
  18 #The number 1.2.840.10003.3.1 is Bib1 and 1.2.840.10003.3.2 is Gils.
  19 proc get-attributeDetails {target base} {
  20         global profile
  21         set index 1
  22         if {[info commands z39.attributeDetails] == "z39.attributeDetails"} {
  23                 foreach arrayname [array names profile] {
  24                         if {[string first $target,AttributeDetails, $arrayname ] != -1} {
  25                                 unset profile($arrayname)
  26                         }
  27                 }
  28                 .debug-window.top.t insert end "Explain\n"
  29                 while {![catch {set rec [z39.attributeDetails getExplain $index attributeDetails]}]} {
  30                         set db [lindex [lindex $rec 1] 1]
  31                         foreach tagset [lrange [lindex $rec 2] 1 end] {
  32                                 if {[lindex [lindex $tagset 0] 1] == "1.2.840.10003.3.1"} {
  33                                         foreach attributeType [lindex $tagset 1] {
  34                                                 if {[lindex [lindex $attributeType 0] 1] == 1} {
  35                                                         foreach attributeValues [lrange [lindex $attributeType 2] 1 end] {
  36                                                                 lappend profile($target,AttributeDetails,$db,Bib1Use) [lindex [lindex [lindex $attributeValues 0] 1] 1]
  37                                                         }
  38                                                 }
  39                                         }
  40                                 }
  41                         }
  42                         incr index
  43                 }
  44                 rename z39.attributeDetails ""
  45         } else {
  46                 .debug-window.top.t insert end "Ingen explain\n"
  47         }
  48 }
  49
  50 #Procedure change-queryInfo {target base}
  51 #The queryInfo array is set according to the attributes obtained by explain.
  52 proc change-queryInfo {target base} {
  53         global queryInfo profile bib1
  54         foreach tag $profile($target,AttributeDetails,$base,Bib1Use) {
  55                 if {$tag < 1037} {
  56                         lappend tempList [list $bib1($tag) 1=$tag]
  57                 }
  58         }
  59         set queryInfo [lreplace $queryInfo 2 2 $tempList]
  60 }
  61
  62
  63 # Procedure explain-search
  64 #  Issue search request with explain-attribute set and specific
  65 #  category.
  66 proc explain-search-request {target zz category finish response fresponse} {
  67     z39 callback [list explain-search-response $target $zz $category $finish \
  68             $response $fresponse]
  69     ir-set $zz z39
  70     $zz databaseNames IR-Explain-1
  71     $zz preferredRecordSyntax explain
  72     $zz search "@attrset exp1 @attr 1=1 @attr 2=3 @attr 3=3 @attr 4=3 $category"
  73 }
  74
  75 # Procedure explain-search-response
  76 #  Deal with search response.
  77 proc explain-search-response {target zz category finish response fresponse} {
  78     global cancelFlag
  79
  80     apduDump
  81     if {$cancelFlag} {
  82         close-target
  83         return
  84     }
  85     set status [$zz responseStatus]
  86     if {![string compare [lindex $status 0] NSD]} {
  87         $fresponse $target $zz $category $finish
  88         return
  89     }
  90     set cnt [$zz resultCount]
  91     if {$cnt <= 0} {
  92         $fresponse $target $zz $category $finish
  93         return
  94     }
  95     set rr [$zz numberOfRecordsReturned]
  96     set cnt [expr $cnt - $rr]
  97     if {$cnt <= 0} {
  98         explain-present-response $target $zz $category $finish $response $fresponse
  99         return
 100     }
 101     z39 callback [list explain-present-response $target $zz $category $finish \
 102                 $response $fresponse]
 103     incr rr
 104     $zz present $rr $cnt
 105 }
 106
 107 # Procedure explain-present-response
 108 #  Deal with explain present response.
 109 proc explain-present-response {target zz category finish response fresponse} {
 110     global cancelFlag
 111
 112     apduDump
 113     if {$cancelFlag} {
 114         close-target
 115         return
 116     }
 117     set cnt [$zz resultCount]
 118     ir-log debug "cnt=$cnt"
 119     for {set i 1} {$i <= $cnt} {incr i} {
 120                 if {[string compare [$zz type $i] DB]} {
 121                     $fresponse $target $zz $category $finish
 122                     return
 123                 }
 124                 if {[string compare [$zz recordType $i] Explain]} {
 125                     $fresponse $target $zz $category $finish
 126                     return
 127                 }
 128     }
 129     $response $target $zz $category $finish
 130 }
 131
 132
 133 # Procedure explain-check-0
 134 #  Phase 0: CategoryList
 135 proc explain-check-0 {target zz category finish} {
 136     show-status Explaining 1 0
 137     show-message CategoryList
 138     explain-search-request $target z39.categoryList CategoryList $finish \
 139                 explain-check-5 explain-check-fail
 140 }
 141
 142 # Procedure explain-check-5
 143 #  TargetInfo
 144 proc explain-check-5 {target zz category finish} {
 145     show-status Explaining 1 0
 146     show-message TargetInfo
 147
 148     explain-search-request $target z39.targetInfo TargetInfo $finish \
 149                 explain-check-10 explain-check-fail
 150 }
 151
 152 # Procedure explain-check-10
 153 #  DatabaseInfo
 154 proc explain-check-10 {target zz category finish} {
 155     show-status Explaining 1 0
 156     show-message DatabaseInfo
 157     explain-search-request $target z39.databaseInfo DatabaseInfo \
 158                 $finish explain-check-15 explain-check-fail
 159 }
 160
 161 # Procedure explain-check-15
 162 #  AttributeDetails
 163 proc explain-check-15 {target zz category finish} {
 164     show-status Explaining 1 0
 165     show-message AttributeDetails
 166     explain-search-request $target z39.attributeDetails AttributeDetails \
 167                 $finish explain-check-ok explain-check-ok
 168 }
 169
 170 # Proedure explain-check-fail
 171 #  Deal with explain check failure - call finish handler
 172 proc explain-check-fail {target zz category finish} {
 173     eval $finish [list $target]
 174 }
 175
 176 proc prettyDump {x} {
 177     foreach y $x {
 178                 prettyDumpR $y 0
 179     }
 180 }
 181
 182 proc prettyDumpR {x ind} {
 183     for {set i 0} {$i < $ind} {incr i} {
 184                 puts -nonewline " "
 185     }
 186     set i 0
 187     foreach y $x {
 188                 if {$i == 0} {
 189                     if {![string compare $y text]} {
 190                                 puts $x
 191                                 return
 192                     }
 193                     puts $y
 194                 } else {
 195                     prettyDumpR $y [expr $ind + 2]
 196                 }
 197                 incr i
 198     }
 199 }
 200
 201 # Procedure explain-check-ok
 202 proc explain-check-ok {target zz category finish} {
 203     global profile settingsChanged
 204
 205     puts ""
 206     puts ""
 207     puts ""
 208     puts ""
 209     set crec [z39.categoryList getExplain 1 categoryList]
 210     puts "--- categoryList"
 211     puts $crec
 212
 213     set rec [z39.targetInfo getExplain 1]
 214     set trec [z39.targetInfo getExplain 1 targetInfo]
 215     puts "--- targetInfo"
 216     puts $rec
 217
 218     set no 1
 219     while {1} {
 220         if {
 221                 [catch {set rec [z39.databaseInfo getExplain $no databaseInfo]}]
 222         } break
 223         puts "--- databaseInfo $no"
 224                 puts $rec
 225         lappend dbRecs $rec
 226         set db [lindex [lindex $rec 1] 1]
 227                 if {![string length $db]} break
 228         lappend dbList $db
 229         incr no
 230     }
 231     if {[info exists dbList]} {
 232         set profile($target,databases) $dbList
 233     }
 234     cascade-target-list
 235
 236     set no 1
 237     while {1} {
 238         if {
 239                 [catch {set rec [z39.attributeDetails getExplain $no attributeDetails]}]
 240                 } break
 241         puts "--- attributeDetails $no"
 242                 puts $rec
 243         incr no
 244     }
 245     set data [lindex [lindex [lindex [lindex [lindex $trec 12] 1] 1] 1] 1]
 246     if {[string length $data]} {
 247         set profile($target,descripton) $data
 248     }
 249
 250     set profile($target,namedResultSets) [lindex [lindex $trec 4] 1]
 251     set profile($target,timeLastExplain) [clock seconds]
 252     set profile($target,targetInfoName) [lindex [lindex $trec 1] 1]
 253     set profile($target,recentNews) [lindex [lindex $trec 2] 1]
 254     set profile($target,maxResultSets) [lindex [lindex $trec 6] 1]
 255     set profile($target,maxResultSize) [lindex [lindex $trec 7] 1]
 256     set profile($target,maxTerms) [lindex [lindex $trec 8] 1]
 257     set profile($target,multipleDatabases) [lindex [lindex $trec 5] 1]
 258     set profile($target,welcomeMessage) \
 259                 [lindex [lindex [lindex [lindex [lindex $trec 10] 1] 1] 1] 1]
 260
 261     set settingsChanged 1
 262
 263     eval $finish [list $target]
 264 }
 265
 266 # Procedure explain-refresh
 267 proc explain-refresh {target finish} {
 268     explain-check-0 $target {} {} $finish
 269 }
 270
 271 # Procedure explain-check
 272 #   Checks target for explain database.
 273 #   Evals "$finish $target" on finish.
 274 proc explain-check {target finish base} {
 275     global profile
 276
 277     set refresh 0
 278     set time [clock seconds]
 279     set etime $profile($target,timeLastExplain)
 280     if {[string length $etime]} {
 281         # Check last explain. If 1 day since last explain do explain again.
 282         # 1 day = 86400
 283         if {$time > [expr 0 + $etime]} {
 284                 set refresh 1
 285         }
 286     } else {
 287         # Check last init. If never init or 1 week after do explain anyway.
 288         # 1 week = 604800
 289         set etime $profile($target,timeLastInit)
 290         if {![string length $etime]} {
 291                 set refresh 1
 292         } elseif {$time > [expr 604800 + $etime]} {
 293                 set refresh 1
 294         }
 295     }
 296     if {$refresh} {
 297                 explain-refresh $target $finish
 298 #               get-attributeDetails $target $base
 299     } else {
 300                 eval $finish [list $target]
 301     }
 302 }