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