client2/explain.tcl

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