82380f1316a1e7b6fb4c2c0a8cb96fb10b660282
[egate.git] / www / z39util.tcl
1 #
2 # $Id: z39util.tcl,v 1.6 1995/11/09 15:24:37 adam Exp $
3 #
4 proc saveState {} {
5     uplevel #0 {
6     set f [open "tcl.state.${sessionId}" w]
7     foreach var [info globals] {
8         if {$var == "f"} continue
9         if {$var == "sessionId"} continue
10         if {$var == "errorInfo"} continue
11         if {[catch {set names [array names $var]}]} {
12             eval "set v \$${var}"
13             puts $f "set ${var} \{$v\}"
14         } else {
15             foreach n $names {
16                 eval "set v \$${var}(\$n)"
17                 puts $f "set ${var}($n) \{$v\}"
18             }
19             catch {
20                 eval "set v \$${var}"
21                 puts $f "set ${var} \{$v\}"
22             }
23         }
24     }
25     close $f
26     }
27 }
28
29 proc search-response {sno} {
30     global sessionWait
31
32     set status [z39.$sno responseStatus]
33     if {[lindex $status 0] == "NSD"} {
34         z39.$sno nextResultSetPosition 0
35         set code [lindex $status 1]
36         set msg [lindex $status 2]
37         set addinfo [lindex $status 3]
38         html "<h2>Error NSD$code: $msg: $addinfo </h2><br>\n"
39         set sessionWait -2
40     } else {
41         set sessionWait 1
42     }
43 }
44
45 proc ok-response {} {
46     global sessionWait
47     set sessionWait 1
48 }
49
50 proc fail-response {} {
51     global sessionWait
52     set sessionWait -1
53 }
54
55 proc display-brief {zset no} {
56     global env
57     global setNo
58     global sessionId
59
60     set type [$zset type $no]
61     if {$type == "SD"} {
62         set err [lindex [$zset diag $no] 1]
63         set add [lindex [$zset diag $no] 2]
64         if {$add != {}} {
65             set add " :${add}"
66         }
67         html "${no} Error ${err}${add} <br>\n"
68         return
69     }
70     if {$type != "DB"} {
71         return
72     }
73     html "${no} "
74     set rtype [$zset recordType $no]
75     if {$rtype == "SUTRS"} {
76         html [join [$zset getSutrs $no]]
77         html "<br>\n"
78         return
79     } 
80     if {![catch {
81         set title [lindex [$zset getMarc $no field 245 * a] 0]
82         set year [lindex [$zset getMarc $no field 260 * c] 0]
83     } ] } {
84         html {<a href="http:} $env(SCRIPT_NAME) /
85         html $sessionId {/showfull.egw/} $setNo + $no + full 
86         html {"> } $title {</a>} " <i> ${year} </i>"
87     }
88     html "<br>\n"
89 }
90
91 proc display-raw {zset no} {
92     set type [$zset type $no]
93     if {$type == "SD"} {
94         set err [lindex [$zset diag $no] 1]
95         set add [lindex [$zset diag $no] 2]
96         if {$add != {}} {
97             set add " :${add}"
98         }
99         html "<h3>${no}</h3>\n"
100         html "Error ${err}${add} <br>\n"
101         return
102     }
103     if {$type != "DB"} {
104         return
105     }
106     set rtype [$zset recordType $no]
107     if {$rtype == "SUTRS"} {
108         html [join [$zset getSutrs $no]] "<br>\n"
109         return
110     } 
111     if {[catch {set r [$zset getMarc $no line * * *]}]} {
112         html "Unknown record type: $rtype <br>\n"
113         return
114     }
115     foreach line $r {
116         set tag [lindex $line 0]
117         set indicator [lindex $line 1]
118         set fields [lindex $line 2]
119         set l [string length $indicator]
120         html "$tag "
121         if {$l > 0} {
122             for {set i 0} {$i < $l} {incr i} {
123                 if {[string index $indicator $i] == " "} {
124                     html "-"
125                 } else {
126                     html [string index $tag $i]
127                 }
128             }
129         }
130         foreach field $fields {
131             set id [lindex $field 0]
132             set data [lindex $field 1]
133             if {$id != ""} {
134                 html " <b>\$$id</b> "
135             }
136             html $data
137         }
138         htmlr {<br>}
139     }
140 }
141
142 proc put-marc-contents {cc} {
143     set ref ""
144     if {[string first :// $cc] > 0} {
145         foreach urltype {gopher http ftp mailto} {
146             if {[string first ${urltype}:// $cc] == 0} {
147                 set ref $urltype
148                 break
149             }
150         }
151     } 
152     if {$ref != ""} {
153         html {<a href="}
154     }
155     html $cc
156     if {$ref != ""} {
157         html {">} $urltype { reference</a>}
158     }
159 }
160
161 proc dl-marc-field {zset no tag id la lb sep} {
162     set n 0
163     set c [$zset getMarc $no field $tag * $id]
164     set len [llength $c]
165     if {$len == 0} {
166         return 0
167     }
168     if {$len > 1 && "x$lb" != "x"} {
169         html "<dt><b>$lb</b>\n<dd>"
170     } else {
171         html "<dt><b>$la</b>\n<dd>"
172     }
173     foreach cc $c {
174         if {$n > 0} {
175             html $sep
176         }
177         put-marc-contents $cc
178         incr n
179     }
180     return $n
181 }
182
183 proc dd-marc-field {zset no tag id start stop} {
184     set n 0
185     set c [$zset getMarc $no field $tag * $id]
186     set len [llength $c]
187     if {$len == 0} {
188         return 0
189     }
190     foreach cc $c {
191         html $start
192         put-marc-contents $cc
193         html $stop
194         incr n
195     }
196     return $n
197 }
198
199 proc dl-marc-field-rec {zset no tag lead start stop startid sep} {
200     set n 0
201     set lines [$zset getMarc $no line $tag * *]
202     foreach line $lines {
203         foreach field [lindex $line 2] {
204             if {$n == 0} {
205                 html "<dt><b>$lead</b>"
206                 html "\n<dd>"
207             }
208             set id [lindex $field 0]
209             if {$id == $startid} {
210                 if {$n > 0} {
211                     html $stop
212                 }
213                 html $start
214                 incr n
215                 html [lindex $field 1]
216             } else {
217                 html $sep
218                 html [lindex $field 1]
219             }
220         }
221     }
222     if {$n > 0} {
223         html $stop
224     }
225 }
226
227 proc display-full {zset no} {
228     set type [$zset type $no]
229     if {$type == "SD"} {
230         set err [lindex [$zset diag $no] 1]
231         set add [lindex [$zset diag $no] 2]
232         if {$add != {}} {
233             set add " :${add}"
234         }
235         html "Error ${err}${add} <br>\n"
236         return
237     }
238     if {$type != "DB"} {
239         return
240     }
241     set rtype [$zset recordType $no]
242     if {$rtype == "SUTRS"} {
243         html [join [$zset getSutrs $no]] "<br>\n"
244         return
245     } 
246     if {[catch {set r [$zset getMarc $no line * * *]}]} {
247         html "Unknown record type: $rtype <br>\n"
248         return
249     }
250     html "<dl>\n"
251     set n [dl-marc-field $zset $no 700 a "Author" "Authors" "<br>\n"]
252     if {$n == 0} {
253         set n [dl-marc-field $zset $no 100 a "Author" "Authors" "<br>\n"]
254     }
255     set n [dl-marc-field $zset $no 710 a "Corporate Name" {} ", "]
256     if {$n == 0} {
257         set n [dl-marc-field $zset $no 710 a "Corporate Name" {} ", "]
258     }
259     set n [dl-marc-field $zset $no 245 {a} "Title" {} " "]
260     if {$n > 0} {
261         dd-marc-field $zset $no 245 b "<em>" "</em>"
262         dd-marc-field $zset $no 245 c " " ""
263     } else {
264         dl-marc-field $zset $no 245 {[ab]} "Title" {} " "
265     }
266     dl-marc-field $zset $no 520 a "Abstract" {} ", "
267     dl-marc-field $zset $no 072 * "Subject code" "Subject codes" ", "
268     dl-marc-field $zset $no 650 * "Subject" {} ", "
269     dl-marc-field $zset $no 260 * "Publisher" {} " "
270     dl-marc-field $zset $no 300 * "Physical Description" {} " "
271
272     dl-marc-field $zset $no 500 a "Notes" {} ", "
273
274     dl-marc-field-rec $zset $no 510 "References" "" "<br>\n" "a" ", "
275
276     dl-marc-field $zset $no 350 a "Price" {} ", "
277     dl-marc-field $zset $no 362 a "Dates of publication" {} ", "
278     dl-marc-field $zset $no 850 a "Holdings" {} ", "
279
280     dl-marc-field $zset $no 010 a "LC control number" {} ", "
281     dl-marc-field $zset $no 010 b "NUCMC control number" {} ", "
282     dl-marc-field $zset $no 020 a "ISBN" {} ", "
283     dl-marc-field $zset $no 022 a "ISSN" {} ", "
284     set url [$zset getMarc $no field 856 * u]
285     set sp [$zset getMarc $no field 856 * 3]
286     if {"x$url" != "x"} {
287         html "<dt><b>URL</b>\n"
288         if {"x$sp" == "x"} {
289             set sp reference
290         }
291         html {<dd><a href="} $url {">} [join $sp] "</a>\n"
292     }
293     dl-marc-field $zset $no 037 * "Acquisition" {} "<br>\n"
294     dl-marc-field $zset $no 787 {[rstw6]} "Related information" {} "<br>\n"
295     dl-marc-field $zset $no 001 * "Local control number" {} ", "
296     html "</dl>\n"
297 }
298
299
300 proc display-rec {from to dfunc zz} {
301     global setNo
302
303     while {$from <= $to} { 
304         eval "$dfunc $zz.$setNo $from"
305         incr from
306     }
307 }
308
309 proc build-query {t} {
310     global targets
311
312     set op {}
313     set q {}
314     for {set i 1} {$i < 4} {incr i} {
315         set term1 [wform entry$i]
316         regsub {\+} $term1 " " term
317         if {$term != ""} {
318             set field [wform menu$i]
319             foreach x [lindex $targets($t) 2] {
320                 if {[lindex $x 0] == $field} {
321                     set attr [lindex $x 1]
322                 }
323             }
324             switch $op {
325             And
326                 { set q "@and $q ${attr} \{${term}\}" }
327             Or
328                 { set q "@or $q ${attr} \{${term}\}" }
329             {And not}
330                 { set q "@not $q ${attr} \{${term}\}" }
331             {}
332                 { set q "${attr} \{${term}\}" }
333             }
334             set op [wform logic$i]
335         }
336     }
337     return $q
338 }
339
340 proc z39search {setNo piggy} {
341     global hist
342     global sessionWait
343
344     set host $hist($setNo,host)
345     if {[catch {z39 failback fail-response}]} {
346         ir z39
347     }
348     if {[catch {set oldHost [z39 connect]}]} {
349         set oldHost ""
350     }
351     z39 callback ok-response
352     z39 failback fail-response
353     if {$oldHost != $host} {
354         catch {z39 disconnect}
355
356         html "Connecting to target " $host " <br>\n"
357         set sessionWait 0
358         if {[catch {z39 connect $host}]} {
359             html "Cannot connect to target ${host} <br>\n"
360             return 0
361         } elseif {$sessionWait == 0} {
362             zwait sessionWait
363             if {$sessionWait != 1} {
364                 html "Cannot connect to target ${host} <br>\n"
365                 return 0
366             }
367         }
368         z39 idAuthentication $hist($setNo,idAuthentication)
369         set sessionWait 0
370         if {[catch {z39 init}]} {
371             html "Cannot initialize with target ${host} <br>\n"
372             return 0
373         }
374         if {[catch {zwait sessionWait 60}]} {
375             html "Cannot initialize with target ${host} <br>\n"
376             z39 disconnect
377             return 0
378         }
379         if {$sessionWait != "1"} {
380             html "Cannot initialize with target ${host} <br>\n"
381             z39 disconnect
382             return 0
383         }
384     }
385     if {![catch {z39.$setNo smallSetUpperBound 0}]} {
386         return 1
387     }
388     ir-set z39.$setNo z39
389     eval z39.$setNo databaseNames $hist($setNo,database)
390
391     z39.$setNo preferredRecordSyntax USMARC
392
393     z39 callback search-response $setNo
394     if {$piggy} {
395         z39.$setNo largeSetLowerBound 999999
396         z39.$setNo smallSetUpperBound 0
397         z39.$setNo mediumSetPresentNumber $hist($setNo,maxPresent)
398     } else {
399         z39.$setNo largeSetLowerBound 2
400         z39.$setNo smallSetUpperBound 0
401         z39.$setNo mediumSetPresentNumber 0
402     }
403     set sessionWait 0
404     z39.$setNo search $hist($setNo,query)
405
406     if {[catch {zwait sessionWait 600}]} {
407         html "</body></html>\n"
408         z39 disconnect
409         return 0
410     }
411         
412     if {$sessionWait != 1} {
413         html "</body></html>\n"
414         z39 disconnect
415         return 0
416     }
417     set status [z39.$setNo responseStatus]
418     if {[lindex $status 0] == "NSD"} {
419         set code [lindex $status 1]
420         set msg [lindex $status 2]
421         set addinfo [lindex $status 3]
422         html "<h2>Error NSD$code: $msg: $addinfo </h2><br>\n"
423         return 0
424     }
425     set hist($setNo,hits) [z39.$setNo resultCount]
426     return 1
427 }
428
429 proc init-m-response {i} {
430     global zstatus
431     global zleft
432
433     wlog debug "init-m-response"
434
435     set zstatus($i) 1
436     incr zleft -1
437 }
438
439 proc connect-m-response {i} {
440     global zstatus
441     global zleft
442
443     wlog debug "connect-m-response"
444     z39$i callback [list init-m-response $i]
445     if {[catch {z39$i init}]} {
446         set zstatus($i) -1
447         incr zleft -1
448     }
449 }
450
451 proc fail-m-response {i} {
452     global zstatus
453     global zleft
454     
455     wlog debug "fail-m-response"
456     set zstatus($i) -1
457     incr zleft -1
458 }
459
460 proc search-m-response {setNo i} {
461     global zleft
462     global zstatus
463
464     incr zleft -1
465     set zstatus($i) 2
466 }
467
468 proc z39msearch {setNo piggy} {
469     global zleft
470     global zstatus
471     global hist
472
473     set not $hist($setNo,0,host)
474
475     for {set i 1} {$i <= $not} {incr i} {
476         set host $hist($setNo,$i,host)
477         if {[catch {z39 failback fail-response}]} {
478             ir z39$i
479         }
480         if {[catch {set oldHost [z39$i connect]}]} {
481             set oldHost ""
482         }
483         if {$oldHost != $host} {
484             catch {z39$i disconnect}
485         }
486         z39$i callback [list connect-m-response $i]
487         z39$i failback [list fail-m-response $i]
488     }
489     set zleft 0
490     for {set i 1} {$i <= $not} {incr i} {
491         set oldHost [z39$i connect]
492         set host $hist($setNo,$i,host)
493         if {$oldHost == $host} {
494             set zstatus($i) 1
495             continue
496         }
497         html "Connecting to target " $host " <br>\n"
498         set zstatus($i) -1
499         if {![catch {z39$i connect $host}]} {
500             incr zleft
501         } 
502     }
503     while {$zleft > 0} {
504         wlog debug "Waiting for init response"
505         if {[catch {zwait zleft 10}]} {
506             break
507         }
508     }
509     set zleft 0
510     for {set i 1} {$i <= $not} {incr i} {
511         html "host " $hist($setNo,$i,host) ": "
512         if {$zstatus($i) >= 1} {
513             html "ok <br>\n"
514             ir-set z39$i.$setNo z39$i
515             set hist($setNo,$i,offset) 0
516             eval z39$i.$setNo databaseNames $hist($setNo,$i,database)
517             z39$i.$setNo preferredRecordSyntax USMARC
518             z39$i callback [list search-m-response $setNo $i]
519
520             if {$piggy} {
521                 z39$i.$setNo largeSetLowerBound 999999
522                 z39$i.$setNo smallSetUpperBound 0
523                 z39$i.$setNo mediumSetPresentNumber $hist($setNo,maxPresent)
524             } else {
525                 z39$i.$setNo largeSetLowerBound 2
526                 z39$i.$setNo smallSetUpperBound 0
527                 z39$i.$setNo mediumSetPresentNumber 0
528             }
529             set zstatus($i) 1
530             wlog debug "search " $hist($setNo,$i,query)
531             z39$i.$setNo search $hist($setNo,$i,query)
532             incr zleft
533         } else {
534             html "fail <br>\n"
535         }
536     }
537     while {$zleft > 0} {
538         wlog debug "Waiting for search response"
539         if {[catch {zwait zleft 30}]} {
540             break
541         }
542     }
543     for {set i 1} {$i <= $not} {incr i} {
544         if {$zstatus($i) != 2} continue
545         set status [z39$i.$setNo responseStatus]
546         if {[lindex $status 0] != "NSD"} {
547             set hist($setNo,$i,offset) [z39$i.$setNo numberOfRecordsReturned]
548         }
549     }
550 }
551
552 proc z39present {setNo setOffset setMax dfunc} {
553     global hist
554     global sessionWait
555
556     set toGet [expr 1 + $setMax - $setOffset]
557     while {$setMax > 0 && $toGet > 0} {
558         for {set got 0} {$got < $toGet} {incr got} {
559             if {[z39.$setNo type [expr $setOffset + $got]] == ""} {
560                 break
561             }
562         }
563         if {$got < $toGet} {
564             set sessionWait 0
565             z39.$setNo present $setOffset $toGet
566             if {[catch {zwait sessionWait 300}]} {
567                 z39 disconnect
568                 break
569             }
570             if {$sessionWait != "1"} {
571                 break
572             }
573             set got [z39.$setNo numberOfRecordsReturned]
574             if {$got <= 0} {
575                 break
576             }
577         }
578         display-rec $setOffset [expr $got + $setOffset - 1] $dfunc z39
579         set setOffset [expr $got + $setOffset]
580         set toGet [expr 1 + $setMax - $setOffset]
581         wflush
582     }
583 }
584
585 proc z39history {} {
586     global nextSetNo
587     global hist
588     global env
589     global sessionId
590     global targets
591
592     if {![info exists nextSetNo]} {
593         return
594     }
595     html "<hr><h3>History</h3><dl>\n"
596     for {set setNo 1} {$setNo < $nextSetNo} {incr setNo} {
597         html {<dt> <a href="http:} $env(SCRIPT_NAME)
598         html / $sessionId {/search.egw/} $setNo + 1
599         html + [expr $hist($setNo,maxPresent) - 1]
600         html {"> } [lindex $targets($hist($setNo,host)) 0]
601         if {[llength $hist($setNo,database)] > 1} {
602             html ": "
603             foreach b $hist($setNo,database) {
604                 html " $b"
605             }
606         }
607         html "</a>\n"
608         html "<dd> "
609         if {[info exists hist($setNo,hits)]} {
610             html $hist($setNo,hits) " hits"
611         } else {
612             html failed
613         }
614         html "\n"
615     }
616     html "</dl>\n"
617 }