client.tcl

   1 # IR toolkit for tcl/tk
   2 # (c) Index Data 1995
   3 # See the file LICENSE for details.
   4 # Sebastian Hammer, Adam Dickmeiss
   5 #
   6 # $Log: client.tcl,v $
   7 # Revision 1.49  1995-06-20 14:16:42  adam
   8 # More work on cancel mechanism.
   9 #
  10 # Revision 1.48  1995/06/20  08:07:23  adam
  11 # New setting: failInfo.
  12 # Working on better cancel mechanism.
  13 #
  14 # Revision 1.47  1995/06/19  14:05:29  adam
  15 # Bug fix: asked for SUTRS.
  16 #
  17 # Revision 1.46  1995/06/19  13:06:06  adam
  18 # New define: IR_TCL_VERSION.
  19 #
  20 # Revision 1.45  1995/06/19  08:08:44  adam
  21 # client.tcl: hotTargets now contain both database and target name.
  22 # ir-tcl.c: setting protocol edited. Errors in callbacks are logged
  23 # by logf(LOG_WARN, ...) calls.
  24 #
  25 # Revision 1.44  1995/06/16  14:55:18  adam
  26 # Book logo mirrored.
  27 #
  28 # Revision 1.43  1995/06/16  14:41:05  adam
  29 # Scan line entries can be copied to a search entry.
  30 #
  31 # Revision 1.42  1995/06/16  12:28:13  adam
  32 # Implemented preferredRecordSyntax.
  33 # Minor changes in diagnostic handling.
  34 # Record list deleted when connection closes.
  35 #
  36 # Revision 1.41  1995/06/14  15:07:59  adam
  37 # Bug fix in cascade-target-list. Uses yaz-version.h.
  38 #
  39 # Revision 1.40  1995/06/14  13:37:17  adam
  40 # Setting recordType implemented.
  41 # Setting implementationVersion implemented.
  42 # Settings implementationId / implementationName edited.
  43 #
  44 # Revision 1.39  1995/06/14  12:16:22  adam
  45 # hotTargets, textWrap and displayFormat saved in clientg.tcl.
  46 #
  47 # Revision 1.38  1995/06/14  07:22:45  adam
  48 # Target definitions can be deleted.
  49 # Listbox used in the query definition dialog.
  50 #
  51 # Revision 1.37  1995/06/13  14:37:59  adam
  52 # Work on query setup.
  53 # Better about origin/target.
  54 # Better presentation formats.
  55 #
  56 # Revision 1.36  1995/06/13  07:42:14  adam
  57 # Bindings removed from text widgets.
  58 #
  59 # Revision 1.35  1995/06/12  15:17:31  adam
  60 # Text widget used in main window (instead of listbox) to support
  61 # better presentation formats.
  62 #
  63 # Revision 1.34  1995/06/12  07:59:07  adam
  64 # More work on geometry handling.
  65 #
  66 # Revision 1.33  1995/06/09  11:17:35  adam
  67 # Start work on geometry management.
  68 #
  69 # Revision 1.32  1995/06/07  09:16:37  adam
  70 # New presentation format.
  71 #
  72 # Revision 1.31  1995/06/06  16:31:09  adam
  73 # Bug fix: target names couldn't contain blanks.
  74 # Bug fix: scan.
  75 #
  76 # Revision 1.30  1995/06/06  11:35:41  adam
  77 # Work on scan. Display of old sets.
  78 #
  79 # Revision 1.29  1995/06/05  14:11:18  adam
  80 # Bug fix in present-more.
  81 #
  82 # Revision 1.28  1995/06/02  14:52:13  adam
  83 # Minor changes really.
  84 #
  85 # Revision 1.27  1995/06/02  14:29:42  adam
  86 # Work on scan interface - up/down buttons.
  87 #
  88 # Revision 1.26  1995/06/01  16:36:46  adam
  89 # About buttons. Minor bug fixes.
  90 #
  91 # Revision 1.25  1995/05/31  13:09:57  adam
  92 # Client searches/presents may be interrupted.
  93 # New moving book-logo.
  94 #
  95 # Revision 1.24  1995/05/31  08:36:24  adam
  96 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
  97 # New method: referenceId. More work on scan.
  98 #
  99 # Revision 1.23  1995/05/29  10:33:41  adam
 100 # README and rename of startup script.
 101 #
 102 # Revision 1.22  1995/05/26  11:44:09  adam
 103 # Bugs fixed. More work on MARC utilities and queries. Test
 104 # client is up-to-date again.
 105 #
 106 # Revision 1.21  1995/05/11  15:34:46  adam
 107 # Scan request changed a bit. This version works with RLG.
 108 #
 109 # Revision 1.20  1995/04/21  16:31:57  adam
 110 # New radiobutton: protocol (z39v2/SR).
 111 #
 112 # Revision 1.19  1995/04/18  16:11:50  adam
 113 # First version of graphical Scan. Some work on query-by-form.
 114 #
 115 # Revision 1.18  1995/04/10  10:50:22  adam
 116 # Result-set name defaults to suffix of ir-set name.
 117 # Started working on scan. Not finished at this point.
 118 #
 119 # Revision 1.17  1995/03/31  09:34:57  adam
 120 # Search-button disabled when there is no connection.
 121 #
 122 # Revision 1.16  1995/03/31  08:56:36  adam
 123 # New button "Search".
 124 #
 125 # Revision 1.15  1995/03/28  12:45:22  adam
 126 # New ir method failback: called on disconnect/protocol error.
 127 # New ir set/get method: protocol: SR / Z3950.
 128 # Simple popup and disconnect when failback is invoked.
 129 #
 130 # Revision 1.14  1995/03/22  16:07:55  adam
 131 # Minor changes.
 132 #
 133 # Revision 1.13  1995/03/21  17:27:26  adam
 134 # Short-hand keys in setup.
 135 #
 136 # Revision 1.12  1995/03/21  13:41:03  adam
 137 # Comstack cs_create not used too often. Non-blocking connect.
 138 #
 139 # Revision 1.11  1995/03/21  10:39:06  adam
 140 # Diagnostic error message displayed with tkerror.
 141 #
 142 # Revision 1.10  1995/03/20  15:24:06  adam
 143 # Diagnostic records saved on searchResponse.
 144 #
 145 # Revision 1.9  1995/03/17  18:26:16  adam
 146 # Non-blocking i/o used now. Database names popup as cascade items.
 147 #
 148 # Revision 1.8  1995/03/17  15:45:00  adam
 149 # Improved target/database setup.
 150 #
 151 # Revision 1.7  1995/03/16  17:54:03  adam
 152 # Minor changes really.
 153 #
 154 # Revision 1.6  1995/03/15  19:10:20  adam
 155 # Database setup in protocol-setup (rather target setup).
 156 #
 157 # Revision 1.5  1995/03/15  13:59:23  adam
 158 # Minor changes.
 159 #
 160 # Revision 1.4  1995/03/14  17:32:29  adam
 161 # Presentation of full Marc record in popup window.
 162 #
 163 # Revision 1.3  1995/03/12  19:31:52  adam
 164 # Pattern matching implemented when retrieving MARC records. More
 165 # diagnostic functions.
 166 #
 167 # Revision 1.2  1995/03/10  18:00:15  adam
 168 # Actual presentation in line-by-line format. RPN query support.
 169 #
 170 # Revision 1.1  1995/03/09  16:15:07  adam
 171 # First presentRequest attempts. Hot-target list.
 172 #
 173 #
 174 set hotTargets {}
 175 set hotInfo {}
 176 set busy 0
 177
 178 set libDir ""
 179
 180 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} Z39}
 181 set hostid Default
 182 set settingsChanged 0
 183 set setNo 0
 184 set lastSetNo 0
 185 set cancelFlag 0
 186 set scanEnable 0
 187 set fullMarcSeq 0
 188 set displayFormat 1
 189 set popupMarcdf 0
 190 set textWrap word
 191 set delayRequest {}
 192
 193 set queryTypes {Simple}
 194 set queryButtons { { {I 0} {I 1} {I 2} } }
 195 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
 196         {Subject {1=21}} {Any {1=1016}} } }
 197 wm minsize . 0 0
 198
 199 set setOffset 0
 200 set setMax 0
 201
 202 proc read-formats {} {
 203     global displayFormats
 204     set formats [glob -nocomplain formats/*.tcl]
 205     foreach f $formats {
 206         source $f
 207         set l [expr [string length $f] - 5]
 208         lappend displayFormats [string range $f 8 $l]
 209     }
 210 }
 211
 212 proc set-wrap {m} {
 213     global textWrap
 214
 215     set textWrap $m
 216     .data.record configure -wrap $m
 217 }
 218
 219 proc dputs {m} {
 220     puts $m
 221 }
 222
 223 proc set-display-format {f} {
 224     global displayFormat
 225     global setNo
 226     global busy
 227
 228     set displayFormat $f
 229     if {$setNo == 0} {
 230         return
 231     }
 232     if {!$busy} {
 233         .bot.a.status configure -text "Reformatting"
 234     }
 235     update idletasks
 236     add-title-lines 0 10000 1
 237     if {!$busy} {
 238         .bot.a.status configure -text "Ready"
 239     }
 240 }
 241
 242 proc initBindings {} {
 243     set w Text
 244     bind $w <1> {}
 245     bind $w <Double-1> {}
 246     bind $w <Triple-1> {}
 247     bind $w <B1-Motion> {}
 248     bind $w <Shift-1> {}
 249     bind $w <Shift-B1-Motion> {}
 250     bind $w <2> {}
 251     bind $w <B2-Motion> {}
 252     bind $w <Any-KeyPress> {}
 253     bind $w <Return> {}
 254     bind $w <BackSpace> {}
 255     bind $w <Delete> {}
 256     bind $w <Control-h> {}
 257     bind $w <Control-d> {}
 258     bind $w <Control-v> {}
 259
 260     set w Listbox
 261     bind $w <B1-Motion> {}
 262     bind $w <Shift-B1-Motion> {}
 263
 264     set w Entry
 265 }
 266
 267 proc post-menu {wbutton wmenu} {
 268     $wmenu activate none
 269     focus $wmenu
 270     $wmenu post [winfo rootx $wbutton] \
 271             [expr [winfo rooty $wbutton]+[winfo height $wbutton]]
 272
 273 }
 274
 275 proc destroyGW {w} {
 276     global windowGeometry
 277     set windowGeometry($w) [wm geometry $w]
 278 }
 279 proc toplevelG {w} {
 280     global windowGeometry
 281
 282     toplevel $w
 283     if {[info exists windowGeometry($w)]} {
 284         set g $windowGeometry($w)
 285         if {$g != ""} {
 286             wm geometry $w $g
 287         }
 288     }
 289     bind $w <Destroy> [list destroyGW $w]
 290 }
 291
 292 if {[file readable "clientrc.tcl"]} {
 293     source "clientrc.tcl"
 294 }
 295
 296 if {[file readable "clientg.tcl"]} {
 297     source "clientg.tcl"
 298 }
 299
 300 set queryButtonsFind [lindex $queryButtons 0]
 301 set queryInfoFind [lindex $queryInfo 0]
 302
 303 proc top-down-window {w} {
 304     frame $w.top -relief raised -border 1
 305     frame $w.bot -relief raised -border 1
 306
 307     pack  $w.top -side top -fill both -expand yes
 308     pack  $w.bot -fill both
 309 }
 310
 311 proc top-down-ok-cancel {w ok-action g} {
 312     frame $w.bot.left -relief sunken -border 1
 313     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
 314     button $w.bot.left.ok -width 6 -text {Ok} \
 315             -command ${ok-action}
 316     pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
 317     button $w.bot.cancel -width 6 -text {Cancel} \
 318             -command [list destroy $w]
 319     pack $w.bot.cancel -side left -expand yes
 320
 321     if {$g} {
 322         grab $w
 323         tkwait window $w
 324     }
 325 }
 326
 327 proc bottom-buttons {w buttonList g} {
 328     set i 0
 329     set l [llength $buttonList]
 330
 331     frame $w.bot.$i -relief sunken -border 1
 332     pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
 333     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 334             -command [lindex $buttonList [expr $i+1]]
 335     pack $w.bot.$i.ok -expand yes -ipadx 3 -ipady 2 -padx 3 -pady 3 -side left
 336
 337     incr i 2
 338     while {$i < $l} {
 339         button $w.bot.$i -text [lindex $buttonList $i] \
 340                 -command [lindex $buttonList [expr $i+1]]
 341         pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 342         incr i 2
 343     }
 344     if {$g} {
 345         # Grab ...
 346         grab $w
 347         tkwait window $w
 348     }
 349 }
 350
 351 proc cancel-operation {} {
 352     global cancelFlag
 353     global busy
 354     global delayRequest
 355
 356     if {$busy} {
 357         set cancelFlag 1
 358         set delayRequest {}
 359         show-status Cancel 0 1
 360     }
 361 }
 362
 363 proc show-target {target base} {
 364     global profile
 365
 366     if {$target == ""} {
 367         .bot.a.target configure -text ""
 368         return
 369     }
 370     if {$base == ""} {
 371          .bot.a.target configure -text "$target"
 372     } else {
 373          .bot.a.target configure -text "$target - $base"
 374     }
 375 }
 376
 377 proc show-logo {v1} {
 378     global busy
 379     if {$busy != 0} {
 380         incr v1
 381         if {$v1==10} {
 382             set v1 1
 383         }
 384         .bot.logo configure -bitmap @book${v1}
 385         after 140 [list show-logo $v1]
 386         return
 387     }
 388     while {1} {
 389         .bot.logo configure -bitmap @book1
 390         tkwait variable busy
 391         if {$busy} {
 392             show-logo 1
 393             return
 394         }
 395     }
 396 }
 397
 398 proc show-status {status b sb} {
 399     global busy
 400     global scanEnable
 401     global setOffset
 402     global setMax
 403     global setNo
 404
 405     .bot.a.status configure -text "$status"
 406     if {$b == 1} {
 407         if {$busy == 0} {set busy 1}
 408     } else {
 409         set busy 0
 410     }
 411     if {$sb == {}} {
 412         return
 413     }
 414     if {$sb} {
 415         .top.service configure -state normal
 416         .mid.search configure -state normal
 417         if {$scanEnable} {
 418             .mid.scan configure -state normal
 419         }
 420         if {$setNo == 0} {
 421             .top.service.m disable 1
 422         } elseif {$setOffset > 0 && $setOffset <= [z39.$setNo resultCount]} {
 423             .top.service.m enable 1
 424             .mid.present configure -state normal
 425         } else {
 426             .top.service.m disable 1
 427         }
 428         if {[winfo exists .scan-window]} {
 429             .scan-window.bot.2 configure -state normal
 430             .scan-window.bot.4 configure -state normal
 431         }
 432     } else {
 433         .top.service configure -state disabled
 434         .mid.search configure -state disabled
 435         .mid.scan configure -state disabled
 436         .mid.present configure -state disabled
 437
 438         if {[winfo exists .scan-window]} {
 439             .scan-window.bot.2 configure -state disabled
 440             .scan-window.bot.4 configure -state disabled
 441         }
 442     }
 443 }
 444
 445 proc show-message {msg} {
 446     .bot.a.message configure -text "$msg"
 447 }
 448
 449 proc insertWithTags {w text args} {
 450     set start [$w index insert]
 451     $w insert insert $text
 452     foreach tag [$w tag names $start] {
 453         $w tag remove $tag $start insert
 454     }
 455     foreach i $args {
 456         $w tag add $i $start insert
 457     }
 458 }
 459
 460 proc popup-license {} {
 461     set w .popup-licence
 462     toplevel $w
 463
 464     wm title $w "License"
 465
 466     wm minsize $w 0 0
 467
 468     top-down-window $w
 469
 470     text $w.top.t -width 80 -height 10 -wrap word \
 471         -yscrollcommand [list $w.top.s set]
 472     scrollbar $w.top.s -command [list $w.top.t yview]
 473
 474     pack $w.top.s -side right -fill y
 475     pack $w.top.t -expand yes -fill both
 476
 477     set f [open "LICENSE" r]
 478     while {[gets $f buf] != -1} {
 479         $w.top.t insert end $buf
 480         $w.top.t insert end "\n"
 481     }
 482     close $f
 483     bottom-buttons $w [list {Close} [list destroy $w]] 1
 484 }
 485
 486 proc about-target {} {
 487     set w .about-target-w
 488     global hostid
 489
 490     toplevel $w
 491
 492     wm title $w "About target"
 493     top-down-window $w
 494
 495     frame $w.top.a -relief ridge -border 2
 496     frame $w.top.p -relief ridge -border 2
 497
 498     pack $w.top.a $w.top.p -side top -fill x
 499
 500     label $w.top.a.about -text "About"
 501     label $w.top.a.irtcl -text $hostid \
 502             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
 503     pack $w.top.a.about $w.top.a.irtcl -side top
 504
 505     set i [z39 targetImplementationName]
 506     label $w.top.p.in -text "Implementation name: $i"
 507     set i [z39 targetImplementationId]
 508     label $w.top.p.ii -text "Implementation id: $i"
 509     set i [z39 targetImplementationVersion]
 510     label $w.top.p.iv -text "Implementation version: $i"
 511     set i [z39 options]
 512     label $w.top.p.op -text "Protocol options: $i"
 513
 514     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
 515
 516     bottom-buttons $w [list {Close} [list destroy $w]] 1
 517 }
 518
 519 proc about-origin-logo {n} {
 520     set w .about-origin-w
 521     if {![winfo exists $w]} {
 522         return
 523     }
 524     incr n
 525     if {$n==10} {
 526         set n 1
 527     }
 528     $w.top.a.logo configure -bitmap @book$n
 529     after 140 [list about-origin-logo $n]
 530 }
 531
 532 proc about-origin {} {
 533     set w .about-origin-w
 534
 535     if {[winfo exists $w]} {
 536         destroy $w
 537     }
 538     toplevel $w
 539
 540     wm title $w "About IrTcl"
 541     place-force $w .
 542     top-down-window $w
 543
 544     frame $w.top.a -relief ridge -border 2
 545     frame $w.top.p -relief ridge -border 2
 546
 547     pack $w.top.a $w.top.p -side top -fill x
 548
 549     label $w.top.a.irtcl -text "IrTcl" \
 550             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
 551     label $w.top.a.logo -bitmap @book1
 552     pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
 553
 554     set i [z39 implementationName]
 555     label $w.top.p.in -text "Implementation name: $i"
 556     set i [z39 implementationId]
 557     label $w.top.p.ii -text "Implementation id: $i"
 558     set i [z39 implementationVersion]
 559     label $w.top.p.iv -text "Implementation version: $i"
 560
 561     pack $w.top.p.in $w.top.p.ii $w.top.p.iv -side top -anchor nw
 562
 563     about-origin-logo 1
 564     bottom-buttons $w [list {Close} [list destroy $w] \
 565                             {License} [list popup-license]] 0
 566 }
 567
 568 proc popup-marc {sno no b df} {
 569     global fullMarcSeq
 570     global displayFormats
 571     global popupMarcdf
 572
 573     if {[z39.$sno type $no] != "DB"} {
 574         return
 575     }
 576     if {$b} {
 577         set w .full-marc-$fullMarcSeq
 578         incr fullMarcSeq
 579         set df $popupMarcdf
 580     } else {
 581         set w .full-marc
 582         set df $popupMarcdf
 583     }
 584     if {[winfo exists $w]} {
 585         set new 0
 586     } else {
 587
 588         toplevelG $w
 589
 590         wm minsize $w 0 0
 591
 592         frame $w.top -relief raised -border 1
 593         frame $w.bot -relief raised -border 1
 594
 595         pack  $w.top -side top -fill both -expand yes
 596         pack  $w.bot -fill both
 597
 598         text $w.top.record -width 60 -height 5 -wrap word \
 599                 -yscrollcommand [list $w.top.s set]
 600         scrollbar $w.top.s -command [list $w.top.record yview]
 601
 602         if {[tk colormodel .] == "color"} {
 603             $w.top.record tag configure marc-tag -foreground blue
 604             $w.top.record tag configure marc-id -foreground red
 605         } else {
 606             $w.top.record tag configure marc-tag -foreground black
 607             $w.top.record tag configure marc-id -foreground black
 608         }
 609         $w.top.record tag configure marc-data -foreground black
 610         set new 1
 611     }
 612     $w.top.record delete 0.0 end
 613     set recordType [z39.$sno recordType $no]
 614     wm title $w "$recordType record #$no"
 615
 616     set ffunc [lindex $displayFormats $df]
 617     set ffunc "display-$ffunc"
 618
 619     $ffunc $sno $no $w.top.record 0
 620
 621     if {$new} {
 622         bind $w.top.record <Return> {destroy .full-marc}
 623
 624         pack $w.top.s -side right -fill y
 625         pack $w.top.record -expand yes -fill both
 626
 627         if {$b} {
 628             bottom-buttons $w [list \
 629                 {Close} [list destroy $w]] 0
 630         } else {
 631             bottom-buttons $w [list \
 632                     {Close} [list destroy $w] \
 633                     {Duplicate} [list popup-marc $sno $no 1 0]] 0
 634             menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
 635             menu $w.bot.formats.m
 636             set i 0
 637             foreach f $displayFormats {
 638                 $w.bot.formats.m add radiobutton -label $f \
 639                         -variable popupMarcdf -value $i \
 640                         -command [list display-$f $sno $no $w.top.record 0]
 641                 incr i
 642             }
 643             pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
 644                     -padx 3 -pady 3 -side left
 645         }
 646     } else {
 647         set i 0
 648         foreach f $displayFormats {
 649             $w.bot.formats.m entryconfigure $i \
 650                     -command [list display-$f $sno $no $w.top.record 0]
 651             incr i
 652         }
 653     }
 654 }
 655
 656 proc update-target-hotlist {target base} {
 657     global hotTargets
 658
 659     set len [llength $hotTargets]
 660     if {$len > 0} {
 661         .top.target.m delete 6 [expr 6+[llength $hotTargets]]
 662     }
 663     set i 0
 664     foreach e $hotTargets {
 665         if {$target == [lindex $e 0] && $base == [lindex $e 1]} {
 666             set hotTargets [lreplace $hotTargets $i $i]
 667             break
 668         }
 669         incr i
 670     }
 671     set hotTargets [linsert $hotTargets 0 [list $target $base]]
 672     set-target-hotlist
 673 }
 674
 675 proc set-target-hotlist {} {
 676     global hotTargets
 677
 678     set i 1
 679     foreach e $hotTargets {
 680         set target [lindex $e 0]
 681         set base [lindex $e 1]
 682         if {$base == ""} {
 683             .top.target.m add command -label "$i $target" -command \
 684                 [list reopen-target $target {}]
 685         } else {
 686             .top.target.m add command -label "$i $target - $base" -command \
 687                 [list reopen-target $target $base]
 688         }
 689         incr i
 690         if {$i > 8} {
 691              break
 692         }
 693     }
 694 }
 695
 696 proc reopen-target {target base} {
 697     close-target
 698     open-target $target $base
 699     update-target-hotlist $target $base
 700 }
 701
 702 proc define-target-action {} {
 703     global profile
 704
 705     set target [.target-define.top.target.entry get]
 706     if {$target == ""} {
 707         return
 708     }
 709     foreach n [array names profile] {
 710         if {$n == $target} {
 711             protocol-setup $n
 712             return
 713         }
 714     }
 715     set seq [lindex $profile(Default) 12]
 716     dputs "seq=${seq}"
 717     set profile($target) $profile(Default)
 718     set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
 719
 720     protocol-setup $target
 721     destroy .target-define
 722 }
 723
 724 proc fail-response {target} {
 725     set c [lindex [z39 failInfo] 0]
 726     set m [lindex [z39 failInfo] 1]
 727     close-target
 728     tkerror "$m ($c)"
 729 }
 730
 731 proc connect-response {target base} {
 732     dputs "connect-response"
 733     show-target $target $base
 734     init-request
 735 }
 736
 737 proc open-target {target base} {
 738     global profile
 739     global hostid
 740
 741     z39 disconnect
 742     z39 comstack [lindex $profile($target) 6]
 743     z39 protocol [lindex $profile($target) 11]
 744     z39 idAuthentication [lindex $profile($target) 3]
 745     z39 maximumRecordSize [lindex $profile($target) 4]
 746     z39 preferredMessageSize [lindex $profile($target) 5]
 747     dputs "maximumRecordSize="
 748     dputs [z39 maximumRecordSize]
 749     dputs "preferredMessageSize="
 750     dputs [z39 preferredMessageSize]
 751     show-status {Connecting} 1 0
 752     if {$base == ""} {
 753         z39 databaseNames [lindex [lindex $profile($target) 7] 0]
 754     } else {
 755         z39 databaseNames $base
 756     }
 757     z39 failback [list fail-response $target]
 758     z39 callback [list connect-response $target $base]
 759     update idletasks
 760     set err [catch {
 761         z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
 762         } errorMessage]
 763     if {$err} {
 764         tkerror $errorMessage
 765         show-status Ready 0 {}
 766         return
 767     }
 768 #    z39 options search present scan namedResultSets triggerResourceCtrl
 769     set hostid $target
 770     .top.target.m disable 0
 771     .top.target.m enable 1
 772     .top.target.m enable 2
 773 }
 774
 775 proc close-target {} {
 776     global hostid
 777     global cancelFlag
 778     global setNo
 779
 780     set cancelFlag 0
 781     set setNo 0
 782     .bot.a.set configure -text ""
 783     set hostid Default
 784     z39 disconnect
 785     show-target {} {}
 786     show-status {Not connected} 0 0
 787     init-title-lines
 788     show-message {}
 789     .top.target.m disable 1
 790     .top.target.m disable 2
 791     .top.target.m enable 0
 792 }
 793
 794 proc load-set-action {} {
 795     global setNo
 796
 797     incr setNo
 798     ir-set z39.$setNo z39
 799
 800     set fname [.load-set.top.filename.entry get]
 801     destroy .load-set
 802     if {$fname != ""} {
 803         show-status {Loading} 1 {}
 804         update
 805         z39.$setNo loadFile $fname
 806
 807         set no [z39.$setNo numberOfRecordsReturned]
 808         add-title-lines $setNo $no 1
 809     }
 810     set l [format "%-4d %7d" $setNo $no]
 811     .top.rset.m add command -label $l \
 812             -command [list add-title-lines $setNo 10000 1]
 813     show-status {Ready} 0 {}
 814 }
 815
 816 proc load-set {} {
 817     set w .load-set
 818
 819     set oldFocus [focus]
 820     toplevel $w
 821
 822     place-force $w .
 823     top-down-window $w
 824
 825     frame $w.top.filename
 826     pack $w.top.filename -side top -anchor e -pady 2
 827
 828     entry-fields $w.top {filename} \
 829             {{Filename:}} \
 830             {load-set-action} {destroy .load-set}
 831
 832     top-down-ok-cancel $w {load-set-action} 1
 833     focus $oldFocus
 834 }
 835
 836 proc init-request {} {
 837     global setNo
 838     global cancelFlag
 839
 840     if {$cancelFlag} {
 841         close-target
 842         return
 843     }
 844     z39 callback {init-response}
 845     show-status {Initializing} 1 {}
 846     set err [catch {z39 init} errorMessage]
 847     if {$err} {
 848         tkerror $errorMessage
 849         show-status Ready 0 {}
 850     }
 851 }
 852
 853 proc init-response {} {
 854     global cancelFlag
 855     global scanEnable
 856
 857     if {$cancelFlag} {
 858         close-target
 859         return
 860     }
 861     if {![z39 initResult]} {
 862         show-status {Ready} 0 1
 863         set u [z39 userInformationField]
 864         close-target
 865         tkerror "Connection rejected by target: $u"
 866     } else {
 867         if {[lsearch [z39 options] scan] >= 0} {
 868             set scanEnable 1
 869         } else {
 870             set scanEnable 0
 871         }
 872         show-status {Ready} 0 1
 873     }
 874 }
 875
 876 proc search-request {bflag} {
 877     global setNo
 878     global profile
 879     global hostid
 880     global busy
 881     global cancelFlag
 882     global delayRequest
 883
 884     set target $hostid
 885
 886     dputs "search-request"
 887     show-message {}
 888     if {!$bflag && $busy} {
 889         dputs "busy: search-request ignored"
 890         return
 891     }
 892     if {$cancelFlag} {
 893         dputs "cancelFlag"
 894         show-status {Searching} 1 0
 895         set delayRequest {search-request 1}
 896         return
 897     }
 898     set delayRequest {}
 899
 900     set query [index-query]
 901     if {$query==""} {
 902         return
 903     }
 904     incr setNo
 905     ir-set z39.$setNo z39
 906
 907     if {[lindex $profile($target) 10] == 1} {
 908         z39.$setNo setName $setNo
 909         dputs "setName=${setNo}"
 910     } else {
 911         z39.$setNo setName Default
 912         dputs "setName=Default"
 913     }
 914     if {[lindex $profile($target) 8] == 1} {
 915         z39.$setNo queryType rpn
 916     }
 917     if {[lindex $profile($target) 9] == 1} {
 918         z39.$setNo queryType ccl
 919     }
 920     z39 callback {search-response}
 921     z39.$setNo search $query
 922     show-status {Searching} 1 0
 923 }
 924
 925 proc scan-copy {y entry} {
 926     set w .scan-window
 927     set no [$w.top.list nearest $y]
 928     dputs "no=$no"
 929     .lines.$entry.e delete 0 end
 930     .lines.$entry.e insert 0 [string range [$w.top.list get $no] 8 end]
 931 }
 932
 933 proc scan-request {} {
 934     set w .scan-window
 935
 936     global profile
 937     global hostid
 938     global scanView
 939     global scanTerm
 940     global curIndexEntry
 941     global queryButtonsFind
 942     global queryInfoFind
 943     global cancelFlag
 944     global delayRequest
 945
 946     dputs "scan-request"
 947     if {$cancelFlag} {
 948         dputs "cancelFlag"
 949         show-status {Scanning} 1 0
 950         set delayRequest scan-request
 951         return
 952     }
 953     set delayRequest {}
 954
 955     set target $hostid
 956     set scanView 0
 957     set scanTerm {}
 958
 959     set b [lindex $queryButtonsFind $curIndexEntry]
 960     set attr {}
 961     foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
 962         set attr "@attr $a $attr"
 963     }
 964     set title [lindex [lindex $queryInfoFind [lindex $b 1]] 0]
 965     ir-scan z39.scan z39
 966
 967     if {![winfo exists $w]} {
 968         toplevelG $w
 969
 970         wm minsize $w 0 0
 971
 972         top-down-window $w
 973
 974         entry $w.top.entry -relief sunken
 975         pack $w.top.entry -fill x -padx 4 -pady 2
 976         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
 977         if {1} {
 978             listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
 979                     -font fixed
 980             scrollbar $w.top.scroll -orient vertical -border 1
 981             pack $w.top.list -side left -fill both -expand yes
 982             pack $w.top.scroll -side right -fill y
 983             $w.top.scroll config -command [list $w.top.list yview]
 984         } else {
 985             listbox $w.top.list -font fixed -geometry 60x14
 986             pack $w.top.list -side left -fill both -expand yes
 987         }
 988
 989         bottom-buttons $w [list {Close} [list destroy $w] \
 990                 {Up} [list scan-up $attr] \
 991                 {Down} [list scan-down $attr]] 0
 992         bind $w.top.list <Up> [list scan-up $attr]
 993         bind $w.top.list <Down> [list scan-down $attr]
 994     }
 995     bind $w.top.list <Double-Button-1> [list scan-copy %y $curIndexEntry]
 996     wm title $w "Scan $title"
 997
 998     z39 callback [list scan-response $attr 0 35]
 999     z39.scan numberOfTermsRequested 5
1000     z39.scan preferredPositionInResponse 1
1001     z39.scan scan "${attr} 0"
1002
1003     show-status {Scanning} 1 0
1004 }
1005
1006 proc scan-term-h {attr} {
1007     global busy
1008     global scanTerm
1009
1010     if {$busy} {
1011         return
1012     }
1013     set w .scan-window
1014     set nScanTerm [$w.top.entry get]
1015     if {$nScanTerm == $scanTerm} {
1016         return
1017     }
1018     set scanTerm $nScanTerm
1019     z39 callback [list scan-response $attr 0 35]
1020     z39.scan numberOfTermsRequested 5
1021     z39.scan preferredPositionInResponse 1
1022     dputs "${attr} \{${scanTerm}\}"
1023     if {$scanTerm == ""} {
1024         z39.scan scan "${attr} 0"
1025     } else {
1026         z39.scan scan "${attr} \{${scanTerm}\}"
1027     }
1028     show-status {Scanning} 1 0
1029 }
1030
1031 proc scan-response {attr start toget} {
1032     global cancelFlag
1033     global delayRequest
1034     global scanTerm
1035     global scanView
1036
1037     set w .scan-window
1038     dputs "In scan-response"
1039     set m [z39.scan numberOfEntriesReturned]
1040     dputs $m
1041     dputs attr=$attr
1042     dputs start=$start
1043     dputs toget=$toget
1044
1045     if {![winfo exists .scan-window]} {
1046         if {$cancelFlag} {
1047             set cancelFlag 0
1048             dputs "Handling cancel"
1049             if {$delayRequest != ""} {
1050                 eval $delayRequest
1051             }
1052             return
1053         }
1054         show-status {Ready} 0 1
1055         return
1056     }
1057     set nScanTerm [$w.top.entry get]
1058     if {$nScanTerm != $scanTerm} {
1059         z39 callback [list scan-response $attr 0 35]
1060         z39.scan numberOfTermsRequested 5
1061         z39.scan preferredPositionInResponse 1
1062         set scanTerm $nScanTerm
1063         dputs "${attr} \{${scanTerm}\}"
1064         if {$scanTerm == ""} {
1065             z39.scan scan "${attr} 0"
1066         } else {
1067             z39.scan scan "${attr} \{${scanTerm}\}"
1068         }
1069         show-status {Scanning} 1 0
1070         return
1071     }
1072     set status [z39.scan scanStatus]
1073     if {$status == 6} {
1074         tkerror "Scan fail"
1075         show-status {Ready} 0 1
1076         set cancelFlag 0
1077         return
1078     }
1079     if {$toget < 0} {
1080         for {set i 0} {$i < $m} {incr i} {
1081             set term [lindex [z39.scan scanLine $i] 1]
1082             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1083             $w.top.list insert $i "$nostr $term"
1084         }
1085         incr scanView $m
1086         $w.top.list yview $scanView
1087     } else {
1088         $w.top.list delete $start end
1089         for {set i 0} {$i < $m} {incr i} {
1090             set term [lindex [z39.scan scanLine $i] 1]
1091             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1092             $w.top.list insert end "$nostr $term"
1093         }
1094     }
1095     if {$cancelFlag} {
1096         dputs "Handling cancel"
1097         set cancelFlag 0
1098         if {$delayRequest != ""} {
1099             eval $delayRequest
1100         }
1101         return
1102     }
1103     set delayRequest {}
1104     if {$toget > 0 && $m > 1 && $m < $toget} {
1105         set ntoget [expr $toget - $m + 1]
1106         dputs ntoget=$ntoget
1107         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
1108         set q $term
1109         dputs "down continue: $q"
1110         if {$ntoget > 10} {
1111             z39.scan numberOfTermsRequested 10
1112         } else {
1113             z39.scan numberOfTermsRequested $ntoget
1114         }
1115         z39.scan preferredPositionInResponse 1
1116         dputs "${attr} \{$q\}"
1117         z39.scan scan "${attr} \{$q\}"
1118         return
1119     }
1120     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
1121         set ntoget [expr - $toget - $m]
1122         dputs ntoget=$ntoget
1123         z39 callback [list scan-response $attr 0 -$ntoget]
1124         set q [string range [$w.top.list get 0] 8 end]
1125         dputs "up continue: $q"
1126         if {$ntoget > 10} {
1127             z39.scan numberOfTermsRequested 10
1128             z39.scan preferredPositionInResponse 11
1129         } else {
1130             z39.scan numberOfTermsRequested $ntoget
1131             z39.scan preferredPositionInResponse [incr ntoget]
1132         }
1133         dputs "${attr} \{$q\}"
1134         z39.scan scan "${attr} \{$q\}"
1135         return
1136     }
1137     show-status {Ready} 0 1
1138 }
1139
1140 proc scan-down {attr} {
1141     global scanView
1142     global cancelFlag
1143     global delayRequest
1144
1145     dputs {scan-down}
1146     if {$cancelFlag} {
1147         dputs "cancelFlag"
1148         show-status {Scanning down} 1 0
1149         set delayRequest [list scan-down $attr]
1150         return
1151     }
1152     set delayRequest {}
1153
1154     set w .scan-window
1155     set scanView [expr $scanView + 5]
1156     set s [$w.top.list size]
1157     if {$scanView > $s} {
1158         z39 callback [list scan-response $attr [expr $s - 1] 25]
1159         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
1160         dputs "down: $q"
1161         z39.scan numberOfTermsRequested 10
1162         z39.scan preferredPositionInResponse 1
1163         show-status {Scanning} 1 0
1164         dputs "${attr} \{$q\}"
1165         z39.scan scan "${attr} \{$q\}"
1166         return
1167     }
1168     $w.top.list yview $scanView
1169 }
1170
1171 proc scan-up {attr} {
1172     global scanView
1173     global cancelFlag
1174     global delayRequest
1175
1176     dputs {scan-up}
1177     if {$cancelFlag} {
1178         dputs "cancelFlag"
1179         show-status {Scanning up} 1 0
1180         set delayRequest [list scan-up $attr]
1181         return
1182     }
1183     set delayRequest {}
1184
1185     set w .scan-window
1186     set scanView [expr $scanView - 5]
1187     if {$scanView < 0} {
1188         z39 callback [list scan-response $attr 0 -25]
1189         set q [string range [$w.top.list get 0] 8 end]
1190         dputs "up: $q"
1191         z39.scan numberOfTermsRequested 10
1192         z39.scan preferredPositionInResponse 11
1193         show-status {Scanning} 1 0
1194         z39.scan scan "${attr} \{$q\}"
1195         return
1196     }
1197     $w.top.list yview $scanView
1198 }
1199
1200 proc search-response {} {
1201     global setNo
1202     global setOffset
1203     global setMax
1204     global cancelFlag
1205     global busy
1206     global delayRequest
1207
1208     dputs "In search-response"
1209     if {$cancelFlag} {
1210         dputs "Handling cancel"
1211         set cancelFlag 0
1212         if {$delayRequest != ""} {
1213             eval $delayRequest
1214         }
1215         return
1216     }
1217     set delayRequest {}
1218     init-title-lines
1219     set setMax [z39.$setNo resultCount]
1220     show-message "${setMax} hits"
1221     set l [format "%-4d %7d" $setNo $setMax]
1222     .top.rset.m add command -label $l \
1223             -command [list add-title-lines $setNo 10000 1]
1224     if {$setMax <= 0} {
1225         show-status {Ready} 0 1
1226         set status [z39.$setNo responseStatus]
1227         if {[lindex $status 0] == "NSD"} {
1228             set code [lindex $status 1]
1229             set msg [lindex $status 2]
1230             set addinfo [lindex $status 3]
1231             tkerror "NSD$code: $msg: $addinfo"
1232         }
1233         return
1234     }
1235     if {$setMax > 20} {
1236         set setMax 20
1237     }
1238     set setOffset 1
1239     show-status {Ready} 0 1
1240     z39 callback {present-response}
1241     z39.$setNo present $setOffset 1
1242     show-status {Retrieving} 1 0
1243 }
1244
1245 proc present-more {number} {
1246     global setNo
1247     global setOffset
1248     global setMax
1249     global busy
1250     global cancelFlag
1251     global delayRequest
1252
1253     dputs "present-more"
1254     if {$cancelFlag} {
1255         show-status {Retrieving} 1 0
1256         set delayRequest "present-more $number"
1257         return
1258     }
1259     set delayRequest {}
1260
1261     if {$setNo == 0} {
1262         dputs "setNo=$setNo"
1263         return
1264     }
1265     set max [z39.$setNo resultCount]
1266     if {$max <= $setOffset} {
1267         dputs "max=$max"
1268         dputs "setOffset=$setOffset"
1269         return
1270     }
1271     if {$number == ""} {
1272         set setMax $max
1273     } else {
1274         incr setMax $number
1275         if {$setMax > $max} {
1276             set setMax $max
1277         }
1278     }
1279     z39 callback {present-response}
1280
1281     set toGet [expr $setMax - $setOffset + 1]
1282     if {$toGet <= 0} {
1283         return
1284     }
1285     if {$toGet > 3} {
1286         set toGet 3
1287     }
1288     z39.$setNo present $setOffset $toGet
1289     show-status {Retrieving} 1 0
1290 }
1291
1292 proc init-title-lines {} {
1293     .data.record delete 0.0 end
1294 }
1295
1296 proc title-press {y setno} {
1297     show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
1298 }
1299
1300 proc add-title-lines {setno no offset} {
1301     global displayFormats
1302     global displayFormat
1303     global lastSetNo
1304
1305     if {$setno == 0} {
1306         set setno $lastSetNo
1307     } else {
1308         set lastSetNo $setno
1309     }
1310     if {$offset == 1} {
1311         .bot.a.set configure -text $setno
1312         .data.record delete 0.0 end
1313     }
1314     set ffunc [lindex $displayFormats $displayFormat]
1315     set ffunc "display-$ffunc"
1316     for {set i 0} {$i < $no} {incr i} {
1317         set o [expr $i + $offset]
1318         set type [z39.$setno type $o]
1319         if {$type == ""} {
1320             break
1321         }
1322         .data.record tag bind r$o <Any-Enter> {}
1323         .data.record tag bind r$o <Any-Leave> {}
1324         set insert0 [.data.record index insert]
1325         $ffunc $setno $o .data.record 1
1326         .data.record tag add r$o $insert0 insert
1327         .data.record tag bind r$o <1> \
1328                 [list popup-marc $setno $o 0 0]
1329         update idletasks
1330     }
1331 }
1332
1333 proc present-response {} {
1334     global setNo
1335     global setOffset
1336     global setMax
1337     global cancelFlag
1338     global delayRequest
1339
1340     dputs "In present-response"
1341     set no [z39.$setNo numberOfRecordsReturned]
1342     dputs "Returned $no records, setOffset $setOffset"
1343     add-title-lines $setNo $no $setOffset
1344     set setOffset [expr $setOffset + $no]
1345     if {$cancelFlag} {
1346         dputs "Handling cancel"
1347         set cancelFlag 0
1348         if {$delayRequest != ""} {
1349             eval $delayRequest
1350         }
1351         return
1352     }
1353     set status [z39.$setNo responseStatus]
1354     if {[lindex $status 0] == "NSD"} {
1355         show-status {Ready} 0 1
1356         set code [lindex $status 1]
1357         set msg [lindex $status 2]
1358         set addinfo [lindex $status 3]
1359         tkerror "NSD$code: $msg: $addinfo"
1360         return
1361     }
1362     if {$no > 0 && $setOffset <= $setMax} {
1363         dputs "present-request from ${setOffset}"
1364         set toGet [expr $setMax - $setOffset + 1]
1365         if {$toGet > 3} {
1366             set toGet 3
1367         }
1368         z39.$setNo present $setOffset $toGet
1369     } else {
1370         show-status {Ready} 0 1
1371     }
1372 }
1373
1374 proc left-cursor {w} {
1375     set i [$w index insert]
1376     if {$i > 0} {
1377         incr i -1
1378         $w icursor $i
1379     }
1380 }
1381
1382 proc right-cursor {w} {
1383     set i [$w index insert]
1384     incr i
1385     $w icursor $i
1386 }
1387
1388 proc bind-fields {list returnAction escapeAction} {
1389     set max [expr [llength $list]-1]
1390     for {set i 0} {$i < $max} {incr i} {
1391         bind [lindex $list $i] <Return> $returnAction
1392         bind [lindex $list $i] <Escape> $escapeAction
1393         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1394         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1395         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1396     }
1397     bind [lindex $list $i] <Return> $returnAction
1398     bind [lindex $list $i] <Escape> $escapeAction
1399     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
1400     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1401     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1402     focus [lindex $list 0]
1403 }
1404
1405 proc entry-fields {parent list tlist returnAction escapeAction} {
1406     set alist {}
1407     set i 0
1408     foreach field $list {
1409         set label ${parent}.${field}.label
1410         set entry ${parent}.${field}.entry
1411         label $label -text [lindex $tlist $i] -anchor e
1412         entry $entry -width 32 -relief sunken
1413         pack $label -side left
1414         pack $entry -side right
1415         lappend alist $entry
1416         incr i
1417     }
1418     bind-fields $alist $returnAction $escapeAction
1419 }
1420
1421 proc define-target-dialog {} {
1422     set w .target-define
1423
1424     toplevel $w
1425     place-force $w .
1426     top-down-window $w
1427     frame $w.top.target
1428     pack $w.top.target \
1429             -side top -anchor e -pady 2
1430     entry-fields $w.top {target} \
1431             {{Target:}} \
1432             {define-target-action} {destroy .target-define}
1433     top-down-ok-cancel $w {define-target-action} 1
1434 }
1435
1436 proc protocol-setup-delete {target} {
1437     global profile
1438     global settingsChanged
1439
1440     set a [alert "Are you sure you want to delete the target \
1441 definition $target ?"]
1442     if {$a} {
1443         set wno [lindex $profile($target) 12]
1444         set w .setup-${wno}
1445         destroy $w
1446         unset profile($target)
1447         set settingsChanged 1
1448         cascade-target-list
1449     }
1450 }
1451
1452 proc protocol-setup-action {target} {
1453     global profile
1454     global csRadioType
1455     global protocolRadioType
1456     global settingsChanged
1457     global RPNCheck
1458     global CCLCheck
1459     global ResultSetCheck
1460
1461     set wno [lindex $profile($target) 12]
1462     set w .setup-${wno}
1463
1464     set b {}
1465     set settingsChanged 1
1466     set len [$w.top.databases.list size]
1467     for {set i 0} {$i < $len} {incr i} {
1468         lappend b [$w.top.databases.list get $i]
1469     }
1470     set profile($target) [list [$w.top.description.entry get] \
1471             [$w.top.host.entry get] \
1472             [$w.top.port.entry get] \
1473             [$w.top.idAuthentication.entry get] \
1474             [$w.top.maximumRecordSize.entry get] \
1475             [$w.top.preferredMessageSize.entry get] \
1476             $csRadioType \
1477             $b \
1478             $RPNCheck \
1479             $CCLCheck \
1480             $ResultSetCheck \
1481             $protocolRadioType \
1482             $wno]
1483
1484     cascade-target-list
1485     dputs $profile($target)
1486     destroy $w
1487 }
1488
1489 proc place-force {window parent} {
1490     set g [wm geometry $parent]
1491
1492     set p1 [string first + $g]
1493     set p2 [string last + $g]
1494
1495     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1496     set y [expr 60+[string range $g [expr $p2 +1] end]]
1497     wm geometry $window +${x}+${y}
1498 }
1499
1500 proc add-database-action {target} {
1501     global profile
1502
1503     set wno [lindex $profile($target) 12]
1504     set w .setup-${wno}
1505
1506     $w.top.databases.list insert end \
1507             [.database-select.top.database.entry get]
1508     destroy .database-select
1509 }
1510
1511 proc add-database {target} {
1512     global profile
1513
1514     set w .database-select
1515
1516     set oldFocus [focus]
1517     toplevel $w
1518
1519     set wno [lindex $profile($target) 12]
1520     place-force $w .setup-${wno}
1521
1522     top-down-window $w
1523
1524     frame $w.top.database
1525
1526     pack $w.top.database -side top -anchor e -pady 2
1527
1528     entry-fields $w.top {database} \
1529             {{Database to add:}} \
1530             [list add-database-action $target] {destroy .database-select}
1531
1532     top-down-ok-cancel $w [list add-database-action $target] 1
1533     focus $oldFocus
1534 }
1535
1536 proc delete-database {target} {
1537     global profile
1538
1539     set wno [lindex $profile($target) 12]
1540     set w .setup-${wno}
1541     set l {}
1542     foreach i [$w.top.databases.list curselection] {
1543         set b [$w.top.databases.list get $i]
1544         set l "$l $b"
1545     }
1546     set a [alert "Are you sure you want to remove the database(s)${l}?"]
1547     if {$a} {
1548         foreach i [lsort -decreasing \
1549                 [$w.top.databases.list curselection]] {
1550             $w.top.databases.list delete $i
1551         }
1552     }
1553 }
1554
1555 proc protocol-setup {target} {
1556     global profile
1557     global csRadioType
1558     global protocolRadioType
1559     global RPNCheck
1560     global CCLCheck
1561     global ResultSetCheck
1562
1563     set wno [lindex $profile($target) 12]
1564     set w .setup-${wno}
1565
1566     toplevelG $w
1567
1568     wm title $w "Setup $target"
1569
1570     top-down-window $w
1571
1572     if {$target == ""} {
1573         set target Default
1574     }
1575     dputs target
1576     dputs $profile($target)
1577
1578     frame $w.top.host
1579     frame $w.top.port
1580     frame $w.top.description
1581     frame $w.top.idAuthentication
1582     frame $w.top.maximumRecordSize
1583     frame $w.top.preferredMessageSize
1584     frame $w.top.cs-type -relief ridge -border 2
1585     frame $w.top.protocol -relief ridge -border 2
1586     frame $w.top.query -relief ridge -border 2
1587     frame $w.top.databases -relief ridge -border 2
1588
1589     # Maximum/preferred/idAuth ...
1590     pack $w.top.description $w.top.host $w.top.port \
1591             $w.top.idAuthentication $w.top.maximumRecordSize \
1592             $w.top.preferredMessageSize -side top -anchor e -pady 2
1593
1594     entry-fields $w.top {description host port idAuthentication \
1595             maximumRecordSize preferredMessageSize} \
1596             {{Description:} {Host:} {Port:} {Id Authentication:} \
1597             {Maximum Record Size:} {Preferred Message Size:}} \
1598             [list protocol-setup-action $target] [list destroy $w]
1599
1600     foreach sub {description host port idAuthentication \
1601             maximumRecordSize preferredMessageSize} {
1602         dputs $sub
1603         bind $w.top.$sub.entry <Control-a> [list add-database $target]
1604         bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1605     }
1606     $w.top.description.entry insert 0 [lindex $profile($target) 0]
1607     $w.top.host.entry insert 0 [lindex $profile($target) 1]
1608     $w.top.port.entry insert 0 [lindex $profile($target) 2]
1609     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1610     $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1611     $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1612     set csRadioType [lindex $profile($target) 6]
1613     set RPNCheck [lindex $profile($target) 8]
1614     set CCLCheck [lindex $profile($target) 9]
1615     set ResultSetCheck [lindex $profile($target) 10]
1616     set protocolRadioType [lindex $profile($target) 11]
1617     if {$protocolRadioType == ""} {
1618         set protocolRadioType Z39
1619     }
1620
1621     # Databases ....
1622     pack $w.top.databases -side left -pady 4 -padx 4 -expand yes -fill both
1623
1624     label $w.top.databases.label -text "Databases"
1625     button $w.top.databases.add -text "Add" \
1626             -command [list add-database $target]
1627     button $w.top.databases.delete -text "Delete" \
1628             -command [list delete-database $target]
1629     listbox $w.top.databases.list -geometry 20x6 \
1630             -yscrollcommand "$w.top.databases.scroll set"
1631     scrollbar $w.top.databases.scroll -orient vertical -border 1
1632     pack $w.top.databases.label -side top -fill x \
1633             -padx 2 -pady 2
1634     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1635             -padx 2 -pady 2
1636     pack $w.top.databases.list -side left -fill both -expand yes \
1637             -padx 2 -pady 2
1638     pack $w.top.databases.scroll -side right -fill y \
1639             -padx 2 -pady 2
1640     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1641
1642     foreach b [lindex $profile($target) 7] {
1643         $w.top.databases.list insert end $b
1644     }
1645
1646     # Transport ...
1647     pack $w.top.cs-type -pady 4 -padx 4 -side top -fill x
1648
1649     label $w.top.cs-type.label -text "Transport"
1650     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1651             -variable csRadioType -value tcpip
1652     radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1653             -variable csRadioType -value mosi
1654
1655     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1656             -padx 4 -side top -fill x
1657
1658     # Protocol ...
1659     pack $w.top.protocol -pady 4 -padx 4 -side top -fill x
1660
1661     label $w.top.protocol.label -text "Protocol"
1662     radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1663             -variable protocolRadioType -value Z39
1664     radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1665             -variable protocolRadioType -value SR
1666
1667     pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1668             -padx 4 -side top -fill x
1669
1670     # Query ...
1671     pack $w.top.query -pady 4 -padx 4 -side top -fill x
1672
1673     label $w.top.query.label -text "Query support"
1674     checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1675     checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1676     checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1677
1678     pack $w.top.query.label -side top
1679     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1680             -padx 4 -side top -fill x
1681
1682     # Ok-cancel
1683     bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1684             {Delete} [list protocol-setup-delete $target] \
1685             {Cancel} [list destroy $w]] 0
1686 }
1687
1688 proc database-select-action {} {
1689     set w .database-select.top
1690     set b {}
1691     foreach indx [$w.databases.list curselection] {
1692         lappend b [$w.databases.list get $indx]
1693     }
1694     if {$b != ""} {
1695         z39 databaseNames $b
1696     }
1697     destroy .database-select
1698 }
1699
1700 proc database-select {} {
1701     set w .database-select
1702     global profile
1703     global hostid
1704
1705     toplevel $w
1706
1707     place-force $w .
1708
1709     top-down-window $w
1710
1711     frame $w.top.databases -relief ridge -border 2
1712
1713     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1714
1715     label $w.top.databases.label -text "List"
1716     listbox $w.top.databases.list -geometry 20x6 \
1717             -yscrollcommand "$w.top.databases.scroll set"
1718     scrollbar $w.top.databases.scroll -orient vertical -border 1
1719     pack $w.top.databases.label -side top -fill x \
1720             -padx 2 -pady 2
1721     pack $w.top.databases.list -side left -fill both -expand yes \
1722             -padx 2 -pady 2
1723     pack $w.top.databases.scroll -side right -fill y \
1724             -padx 2 -pady 2
1725     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1726
1727     foreach b [lindex $profile($hostid) 7] {
1728         $w.top.databases.list insert end $b
1729     }
1730     top-down-ok-cancel $w {database-select-action} 1
1731 }
1732
1733 proc cascade-target-list {} {
1734     global profile
1735
1736     foreach sub [winfo children .top.target.m.clist] {
1737         destroy $sub
1738     }
1739     .top.target.m.clist delete 0 last
1740     foreach n [array names profile] {
1741         if {$n != "Default"} {
1742             set nl [lindex $profile($n) 12]
1743             if {[llength [lindex $profile($n) 7]] > 1} {
1744                 .top.target.m.clist add cascade -label $n \
1745                         -menu .top.target.m.clist.$nl
1746                 menu .top.target.m.clist.$nl
1747                 foreach b [lindex $profile($n) 7] {
1748                     .top.target.m.clist.$nl add command -label $b \
1749                             -command [list reopen-target $n $b]
1750                 }
1751             } else {
1752                 .top.target.m.clist add command -label $n \
1753                         -command [list reopen-target $n {}]
1754             }
1755         }
1756     }
1757     .top.target.m.slist delete 0 last
1758     foreach n [array names profile] {
1759         if {$n != "Default"} {
1760             .top.target.m.slist add command -label $n \
1761                     -command [list protocol-setup $n]
1762         }
1763     }
1764 }
1765
1766 proc query-select {i} {
1767     global queryButtonsFind
1768     global queryInfoFind
1769     global queryButtons
1770     global queryInfo
1771
1772     set queryInfoFind [lindex $queryInfo $i]
1773     set queryButtonsFind [lindex $queryButtons $i]
1774
1775     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1776 }
1777
1778 proc query-new-action {} {
1779     global queryTypes
1780     global queryButtons
1781     global queryInfo
1782     global settingsChanged
1783
1784     set settingsChanged 1
1785     lappend queryTypes [.query-new.top.index.entry get]
1786     lappend queryButtons {}
1787     lappend queryInfo {}
1788
1789     destroy .query-new
1790     cascade-query-list
1791 }
1792
1793 proc query-new {} {
1794     set w .query-new
1795
1796     toplevel $w
1797     place-force $w .
1798     top-down-window $w
1799     frame $w.top.index
1800     pack $w.top.index \
1801             -side top -anchor e -pady 2
1802     entry-fields $w.top index \
1803             {{Query Name:}} \
1804             query-new-action {destroy .query-new}
1805     top-down-ok-cancel $w query-new-action 1
1806 }
1807
1808 proc query-delete-action {queryNo} {
1809     global queryTypes
1810     global queryButtons
1811     global queryInfo
1812     global settingsChanged
1813
1814     set settingsChanged 1
1815
1816     set queryTypes [lreplace $queryTypes $queryNo $queryNo]
1817     set queryButtons [lreplace $queryButtons $queryNo $queryNo]
1818     set queryInfo [lreplace $queryInfo $queryNo $queryNo]
1819     destroy .query-delete
1820     cascade-query-list
1821 }
1822
1823 proc query-delete {queryNo} {
1824     global queryTypes
1825
1826     set w .query-delete
1827
1828     toplevel $w
1829     place-force $w .
1830     top-down-window $w
1831     set n [lindex $queryTypes $queryNo]
1832
1833     label $w.top.warning -bitmap warning
1834     message $w.top.quest -text "Are you sure you want to delete the \
1835 query type $n ?"  -aspect 200
1836     pack $w.top.warning $w.top.quest -side left -expand yes -padx 10 -pady 5
1837     bottom-buttons $w [list {Ok} [list query-delete-action $queryNo] \
1838                             {Cancel} [list destroy $w]] 1
1839 }
1840
1841 proc cascade-query-list {} {
1842     global queryTypes
1843     set w .top.options.m.query
1844
1845     set i 0
1846     $w.slist delete 0 last
1847     foreach n $queryTypes {
1848         $w.slist add command -label $n -command [list query-setup $i]
1849         incr i
1850     }
1851
1852     set i 0
1853     $w.clist delete 0 last
1854     foreach n $queryTypes {
1855         $w.clist add command -label $n -command [list query-select $i]
1856         incr i
1857     }
1858     set i 0
1859     $w.dlist delete 0 last
1860     foreach n $queryTypes {
1861         $w.dlist add command -label $n -command [list query-delete $i]
1862         incr i
1863     }
1864 }
1865
1866 proc save-geometry {} {
1867     global windowGeometry
1868     global hotTargets
1869     global textWrap
1870     global displayFormat
1871     global popupMarcdf
1872
1873     set windowGeometry(.) [wm geometry .]
1874
1875     set f [open "clientg.tcl" w]
1876
1877     puts $f "set hotTargets \{ $hotTargets \}"
1878     puts $f "set textWrap $textWrap"
1879     puts $f "set displayFormat $displayFormat"
1880     puts $f "set popupMarcdf $popupMarcdf"
1881     foreach n [array names windowGeometry] {
1882         puts -nonewline $f "set \{windowGeometry($n)\} \{"
1883         puts -nonewline $f $windowGeometry($n)
1884         puts $f "\}"
1885     }
1886     close $f
1887 }
1888
1889 proc save-settings {} {
1890     global profile
1891     global settingsChanged
1892     global queryTypes
1893     global queryButtons
1894     global queryInfo
1895
1896     set f [open "clientrc.tcl" w]
1897     puts $f "# Setup file"
1898
1899     foreach n [array names profile] {
1900         puts -nonewline $f "set \{profile($n)\} \{"
1901         puts -nonewline $f $profile($n)
1902         puts $f "\}"
1903     }
1904     puts -nonewline $f "set queryTypes \{"
1905     puts -nonewline $f $queryTypes
1906     puts $f "\}"
1907
1908     puts -nonewline $f "set queryButtons \{"
1909     puts -nonewline $f $queryButtons
1910     puts $f "\}"
1911
1912     puts -nonewline $f "set queryInfo \{"
1913     puts -nonewline $f $queryInfo
1914     puts $f "\}"
1915     close $f
1916     set settingsChanged 0
1917 }
1918
1919 proc alert {ask} {
1920     set w .alert
1921
1922     global alertAnswer
1923
1924     toplevel $w
1925     place-force $w .
1926     top-down-window $w
1927
1928     label $w.top.warning -bitmap warning
1929     message $w.top.message -text $ask -aspect 200 \
1930             -font -Adobe-Times-Medium-R-Normal-*-180-*
1931
1932     pack $w.top.warning $w.top.message -side left -pady 5 -padx 10 -expand yes
1933
1934     set alertAnswer 0
1935     top-down-ok-cancel $w {alert-action} 1
1936     return $alertAnswer
1937 }
1938
1939 proc alert-action {} {
1940     global alertAnswer
1941     set alertAnswer 1
1942     destroy .alert
1943 }
1944
1945 proc exit-action {} {
1946     global settingsChanged
1947
1948     if {$settingsChanged} {
1949         set a [alert "you haven't saved your settings. Do you wish to save?"]
1950         if {$a} {
1951             save-settings
1952         }
1953     }
1954     save-geometry
1955     exit 0
1956 }
1957
1958 proc listbuttonaction {w name h user i} {
1959     $w configure -text [lindex $name 0]
1960     $h [lindex $name 1] $user $i
1961 }
1962
1963 proc listbuttonx {button no names handle user} {
1964     if {[winfo exists $button]} {
1965         $button configure -text [lindex [lindex $names $no] 0]
1966         ${button}.m delete 0 last
1967     } else {
1968         menubutton $button -text [lindex [lindex $names $no] 0] \
1969                 -width 10 -menu ${button}.m -relief raised -border 1
1970         menu ${button}.m
1971     }
1972     set i 0
1973     foreach name $names {
1974         ${button}.m add command -label [lindex $name 0] \
1975                 -command [list listbuttonaction ${button} $name \
1976                 $handle $user $i]
1977         incr i
1978     }
1979 }
1980
1981 proc listbutton {button no names} {
1982     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1983             -relief raised -border 1
1984     menu ${button}.m
1985     foreach name $names {
1986         ${button}.m add command -label $name \
1987                 -command [list ${button} configure -text $name]
1988     }
1989 }
1990
1991 proc listbuttonv-action {button var names i} {
1992     global $var
1993
1994     set $var [lindex $names [expr $i+1]]
1995     $button configure -text [lindex $names $i]
1996 }
1997
1998 proc listbuttonv {button var names} {
1999     global $var
2000
2001     set n "-"
2002     eval "set val $$var"
2003     set l [llength $names]
2004     for {set i 1} {$i < $l} {incr i 2} {
2005         if {$val == [lindex $names $i]} {
2006             incr i -1
2007             set n [lindex $names $i]
2008             break
2009         }
2010     }
2011     if {[winfo exists $button]} {
2012         $button configure -text $n
2013         return
2014     }
2015     menubutton $button -text $n -menu ${button}.m \
2016             -relief raised -border 1
2017     menu ${button}.m
2018     for {set i 0} {$i < $l} {incr i 2} {
2019         ${button}.m add command -label [lindex $names $i] \
2020                 -command [list listbuttonv-action $button $var $names $i]
2021     }
2022 }
2023
2024 proc query-add-index-action {queryNo} {
2025     set w .query-setup
2026
2027     global queryInfoTmp
2028     global queryButtonsTmp
2029
2030     set newI [.query-add-index.top.index.entry get]
2031     lappend queryInfoTmp [list $newI {}]
2032     $w.top.index.list insert end $newI
2033     destroy .query-add-index
2034     #destroy $w.top.lines
2035     #frame $w.top.lines -relief ridge -border 2
2036     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2037     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2038 }
2039
2040 proc query-add-line {queryNo} {
2041     set w .query-setup
2042
2043     global queryInfoTmp
2044     global queryButtonsTmp
2045
2046     lappend queryButtonsTmp {I 0}
2047
2048     #destroy $w.top.lines
2049     #frame $w.top.lines -relief ridge -border 2
2050     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2051     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2052 }
2053
2054 proc query-del-line {queryNo} {
2055     set w .query-setup
2056
2057     global queryInfoTmp
2058     global queryButtonsTmp
2059
2060     set l [llength $queryButtonsTmp]
2061     if {$l <= 0} {
2062         return
2063     }
2064     incr l -1
2065     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
2066     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2067 }
2068
2069 proc query-add-index {queryNo} {
2070     set w .query-add-index
2071
2072     toplevel $w
2073     place-force $w .query-setup
2074     top-down-window $w
2075     frame $w.top.index
2076     pack $w.top.index \
2077             -side top -anchor e -pady 2
2078     entry-fields $w.top {index} \
2079             {{Index Name:}} \
2080             [list query-add-index-action $queryNo] [list destroy $w]
2081     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
2082 }
2083
2084 proc query-setup-action {queryNo} {
2085     global queryButtons
2086     global queryInfo
2087     global queryButtonsTmp
2088     global queryInfoTmp
2089     global queryButtonsFind
2090     global queryInfoFind
2091
2092     global settingsChanged
2093
2094     set settingsChanged 1
2095
2096     set queryInfo [lreplace $queryInfo $queryNo $queryNo \
2097             $queryInfoTmp]
2098     set queryButtons [lreplace $queryButtons $queryNo $queryNo \
2099             $queryButtonsTmp]
2100     set queryInfoFind $queryInfoTmp
2101     set queryButtonsFind $queryButtonsTmp
2102
2103     destroy .query-setup
2104     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
2105 }
2106
2107 proc activate-e-index {value no i} {
2108     global queryButtonsTmp
2109     global queryIndexTmp
2110
2111     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
2112     dputs $queryButtonsTmp
2113     set queryIndexTmp $i
2114 }
2115
2116 proc activate-index {value no i} {
2117     global queryButtonsFind
2118
2119     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
2120
2121     dputs "queryButtonsFind $queryButtonsFind"
2122 }
2123
2124 proc update-attr {} {
2125     set w .index-setup
2126     listbuttonv $w.top.relation.b relationTmpValue\
2127             {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
2128             {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
2129             {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
2130     listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
2131             {First in field} 1 {First in subfield} 2 {Any position in field} 3}
2132     listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
2133             {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list}  6 \
2134             {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
2135             {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
2136             {local-number} 107 {string} 108 {numeric string} 109}
2137     listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
2138             {Left} 2 {Left and right} 3 {No truncation} 100 \
2139             {Process #} 101 {Re-1} 102 {Re-2} 103}
2140     listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
2141             {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
2142 }
2143
2144 proc use-attr {init} {
2145     set attr {
2146         {None}                           0
2147         {Personal name}                  1
2148         {Corporate name}                 2
2149         {Conference name}                3
2150         {Title}                          4
2151         {Title-series}                   5
2152         {Title-uniform}                  6
2153         {ISBN}                           7
2154         {ISSN}                           8
2155         {LC card number}                 9
2156         {BNB card number}                10
2157         {BGF(sic) number}                11
2158         {Local number}                   12
2159         {Dewey classification}           13
2160         {UDC classification}             14
2161         {Bliss classification}           15
2162         {LC call number}                 16
2163         {NLM call number}                17
2164         {NAL call number}                18
2165         {MOS call number}                19
2166         {Local classification}           20
2167         {Subject heading}                21
2168         {Subject-RAMEAU}                 22
2169         {BDI-index-subject}              23
2170         {INSPEC-subject}                 24
2171         {MESH-subject}                   25
2172         {PA-subject}                     26
2173         {LC-subject-heading}             27
2174         {RVM-subject-heading}            28
2175         {Local subject index}            29
2176         {Date}                           30
2177         {Date of publication}            31
2178         {Date of acquisition}            32
2179         {Title-key}                      33
2180         {Title-collective}               34
2181         {Title-parallel}                 35
2182         {Title-cover}                    36
2183         {Title-added-title-page}         37
2184         {Title-caption}                  38
2185         {Title-running}                  39
2186         {Title-spine}                    40
2187         {Title-other-variant}            41
2188         {Title-former}                   42
2189         {Title-abbreviated}              43
2190         {Title-expanded}                 44
2191         {Subject-PRECIS}                 45
2192         {Subject-RSWK}                   46
2193         {Subject-subdivision}            47
2194         {Number-natl-bibliography}       48
2195         {Number-legal-deposit}           49
2196         {Number-govt-publication}        50
2197         {Number-publisher-for-music}     51
2198         {Number-DB}                      52
2199         {Number-local-call}              53
2200         {Code-language}                  54
2201         {Code-geographic-area}           55
2202         {Code-institution}               56
2203         {Name and title}                 57
2204         {Name-geographic}                58
2205         {Place-publication}              59
2206         {CODEN}                          60
2207         {Microform-generation}           61
2208         {Abstract}                       62
2209         {Note}                           63
2210         {Author-title}                 1000
2211         {Record type}                  1001
2212         {Name}                         1002
2213         {Author}                       1003
2214         {Author-name-personal}         1004
2215         {Author-name-corporate}        1005
2216         {Author-name-conference}       1006
2217         {Identifier-standard}          1007
2218         {Subject-LC-children's}        1008
2219         {Subject-name-personal}        1009
2220         {Body of text}                 1010
2221         {Date/time added to database}  1011
2222         {Date/time last modified}      1012
2223         {Authority/format identifier}  1013
2224         {Concept-text}                 1014
2225         {Concept-reference}            1015
2226         {Any}                          1016
2227         {Server choice}                1017
2228         {Publisher}                    1018
2229         {Record source}                1019
2230         {Editor}                       1020
2231         {Bib-level}                    1021
2232         {Geographic class}             1022
2233         {Indexed by}                   1023
2234         {Map scale}                    1024
2235         {Music key}                    1025
2236         {Related periodical}           1026
2237         {Report number}                1027
2238         {Stock number}                 1028
2239         {Thematic number}              1030
2240         {Material type}                1031
2241         {Doc ID}                       1032
2242         {Host item}                    1033
2243         {Content type}                 1034
2244         {Anywhere}                     1035
2245     }
2246     set w .index-setup
2247     global useTmpValue
2248     set l [llength $attr]
2249
2250     if {$init} {
2251         set s 0
2252         set lno 0
2253         for {set i 0} {$i < $l} {incr i} {
2254             $w.top.use.list insert end [lindex $attr $i]
2255             incr i
2256             if {$useTmpValue == [lindex $attr $i]} {
2257                 set s $lno
2258             }
2259             incr lno
2260         }
2261         $w.top.use.list select from $s
2262         $w.top.use.list select to $s
2263         incr s -3
2264         if {$s < 0} {
2265             set s 0
2266         }
2267         $w.top.use.list yview $s
2268     } else {
2269         set lno [lindex [$w.top.use.list curselection] 0]
2270         set i [expr $lno+$lno+1]
2271         set useTmpValue [lindex $attr $i]
2272         dputs "useTmpValue=$useTmpValue"
2273     }
2274 }
2275
2276 proc index-setup-action {oldAttr queryNo indexNo} {
2277     set attr [lindex $oldAttr 0]
2278
2279     global useTmpValue
2280     global relationTmpValue
2281     global structureTmpValue
2282     global truncationTmpValue
2283     global completenessTmpValue
2284     global positionTmpValue
2285     global queryInfoTmp
2286
2287     use-attr 0
2288
2289     dputs "index-setup-action"
2290     dputs "queryNo $queryNo"
2291     dputs "indexNo $indexNo"
2292     if {$useTmpValue > 0} {
2293         lappend attr "1=$useTmpValue"
2294     }
2295     if {$relationTmpValue > 0} {
2296         lappend attr "2=$relationTmpValue"
2297     }
2298     if {$positionTmpValue > 0} {
2299         lappend attr "3=$positionTmpValue"
2300     }
2301     if {$structureTmpValue > 0} {
2302         lappend attr "4=$structureTmpValue"
2303     }
2304     if {$truncationTmpValue > 0} {
2305         lappend attr "5=$truncationTmpValue"
2306     }
2307     if {$completenessTmpValue > 0} {
2308         lappend attr "6=$completenessTmpValue"
2309     }
2310     dputs "new attr $attr"
2311     set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
2312     destroy .index-setup
2313 }
2314
2315 proc index-setup {attr queryNo indexNo} {
2316     set w .index-setup
2317
2318     global relationTmpValue
2319     global structureTmpValue
2320     global truncationTmpValue
2321     global completenessTmpValue
2322     global positionTmpValue
2323     global useTmpValue
2324     set relationTmpValue 0
2325     set truncationTmpValue 0
2326     set structureTmpValue 0
2327     set positionTmpValue 0
2328     set completenessTmpValue 0
2329     set useTmpValue 0
2330
2331     set len [llength $attr]
2332     for {set i 1} {$i < $len} {incr i} {
2333         set q [lindex $attr $i]
2334         set l [string first = $q]
2335         if {$l > 0} {
2336             set t [string range $q 0 [expr $l - 1]]
2337             set v [string range $q [expr $l + 1] end]
2338             switch $t {
2339                 1
2340                 { set useTmpValue $v }
2341                 2
2342                 { set relationTmpValue $v }
2343                 3
2344                 { set positionTmpValue $v }
2345                 4
2346                 { set structureTmpValue $v }
2347                 5
2348                 { set truncationTmpValue $v }
2349                 6
2350                 { set completenessTmpValue $v }
2351             }
2352         }
2353     }
2354     if {[winfo exists $w]} {
2355         destroy $w
2356     }
2357     toplevelG $w
2358
2359     set n [lindex $attr 0]
2360     wm title $w "Index setup $n"
2361
2362     top-down-window $w
2363
2364     frame $w.top.use -relief ridge -border 2
2365     frame $w.top.relation -relief ridge -border 2
2366     frame $w.top.position -relief ridge -border 2
2367     frame $w.top.structure -relief ridge -border 2
2368     frame $w.top.truncation -relief ridge -border 2
2369     frame $w.top.completeness -relief ridge -border 2
2370
2371     update-attr
2372
2373     # Use Attributes
2374
2375     pack $w.top.use -side left -pady 6 -padx 6 -fill y
2376
2377     label $w.top.use.label -text "Use"
2378     listbox $w.top.use.list -geometry 26x10 \
2379             -yscrollcommand "$w.top.use.scroll set"
2380     scrollbar $w.top.use.scroll -orient vertical -border 1
2381     pack $w.top.use.label -side top -fill x \
2382             -padx 2 -pady 2
2383     pack $w.top.use.list -side left -fill both -expand yes \
2384             -padx 2 -pady 2
2385     pack $w.top.use.scroll -side right -fill y \
2386             -padx 2 -pady 2
2387     $w.top.use.scroll config -command "$w.top.use.list yview"
2388
2389     use-attr 1
2390
2391     # Relation Attributes
2392
2393     pack $w.top.relation -pady 6 -padx 6 -side top
2394     label $w.top.relation.label -text "Relation" -width 18
2395
2396     pack $w.top.relation.label $w.top.relation.b -fill x
2397
2398     # Position Attributes
2399
2400     pack $w.top.position -pady 6 -padx 6 -side top
2401     label $w.top.position.label -text "Position" -width 18
2402
2403     pack $w.top.position.label $w.top.position.b -fill x
2404
2405     # Structure Attributes
2406
2407     pack $w.top.structure -pady 6 -padx 6 -side top
2408     label $w.top.structure.label -text "Structure" -width 18
2409
2410     pack $w.top.structure.label $w.top.structure.b -fill x
2411
2412     # Truncation Attributes
2413
2414     pack $w.top.truncation -pady 6 -padx 6 -side top
2415     label $w.top.truncation.label -text "Truncation" -width 18
2416
2417     pack $w.top.truncation.label $w.top.truncation.b -fill x
2418
2419     # Completeness Attributes
2420
2421     pack $w.top.completeness -pady 6 -padx 6 -side top
2422     label $w.top.completeness.label -text "Completeness" -width 18
2423
2424     pack $w.top.completeness.label $w.top.completeness.b -fill x
2425
2426     # Ok-cancel
2427     bottom-buttons $w [list \
2428             {Ok} [list index-setup-action $attr $queryNo $indexNo] \
2429             {Cancel} [list destroy $w]] 0
2430
2431 }
2432
2433 proc query-edit-index {queryNo} {
2434     global queryInfoTmp
2435     set w .query-setup
2436
2437     set i [lindex [$w.top.index.list curselection] 0]
2438     if {$i == ""} {
2439         return
2440     }
2441     set attr [lindex $queryInfoTmp $i]
2442     dputs "Editing no $i $attr"
2443     index-setup $attr $queryNo $i
2444 }
2445
2446 proc query-delete-index {queryNo} {
2447     global queryInfoTmp
2448     global queryButtonsTmp
2449     set w .query-setup
2450
2451     set i [lindex [$w.top.index.list curselection] 0]
2452     if {$i == ""} {
2453         return
2454     }
2455     set queryInfoTmp [lreplace $queryInfoTmp $i $i]
2456     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2457     $w.top.index.list delete $i
2458 }
2459
2460 proc query-setup {queryNo} {
2461     set w .query-setup
2462
2463     global queryTypes
2464     global queryButtons
2465     global queryInfo
2466     global queryButtonsTmp
2467     global queryInfoTmp
2468     global queryIndexTmp
2469
2470     set queryIndexTmp 0
2471     set queryName [lindex $queryTypes $queryNo]
2472     set queryInfoTmp [lindex $queryInfo $queryNo]
2473     set queryButtonsTmp [lindex $queryButtons $queryNo]
2474
2475     toplevelG $w
2476
2477     wm minsize $w 0 0
2478     wm title $w "Query setup $queryName"
2479
2480     top-down-window $w
2481
2482     frame $w.top.lines -relief ridge -border 2
2483
2484     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2485
2486     # Index Lines
2487
2488     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2489
2490     button $w.top.lines.add -text "Add" \
2491             -command [list query-add-line $queryNo]
2492     button $w.top.lines.del -text "Remove" \
2493             -command [list query-del-line $queryNo]
2494
2495     pack $w.top.lines.del -fill x -side bottom
2496     pack $w.top.lines.add -fill x -pady 10 -side bottom
2497
2498     # Indexes
2499
2500     frame $w.top.index -relief ridge -border 2
2501     pack $w.top.index -pady 6 -padx 6 -side right -fill y
2502
2503     listbox $w.top.index.list -yscrollcommand [list $w.top.index.scroll set]
2504     scrollbar $w.top.index.scroll -orient vertical -border 1 \
2505         -command [list $w.top.index.list yview]
2506     bind $w.top.index.list <2> [list query-edit-index $queryNo]
2507
2508     pack $w.top.index.list -side left -fill both -expand yes -padx 2 -pady 2
2509     pack $w.top.index.scroll -side right -fill y -padx 2 -pady 2
2510
2511     $w.top.index.list select from 0
2512     $w.top.index.list select to 0
2513
2514     foreach x $queryInfoTmp {
2515         $w.top.index.list insert end [lindex $x 0]
2516     }
2517     # Bottom
2518     bottom-buttons $w [list \
2519             {Ok} [list query-setup-action $queryNo] \
2520             {Add index} [list query-add-index $queryNo] \
2521             {Edit index} [list query-edit-index $queryNo] \
2522             {Delete index} [list query-delete-index $queryNo] \
2523             {Cancel} [list destroy $w]] 0
2524 }
2525
2526 proc index-clear {} {
2527     global queryButtonsFind
2528
2529     set i 0
2530     foreach b $queryButtonsFind {
2531         .lines.$i.e delete 0 end
2532         incr i
2533     }
2534 }
2535
2536 proc index-query {} {
2537     global queryButtonsFind
2538     global queryInfoFind
2539
2540     set i 0
2541     set qs {}
2542
2543     foreach b $queryButtonsFind {
2544         set term [string trim [.lines.$i.e get]]
2545         if {$term != ""} {
2546             set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
2547
2548             set len [string length $term]
2549             incr len -1
2550             set left 0
2551             set right 0
2552             if {[string index $term $len] == "?"} {
2553                 set right 1
2554                 set term [string range $term 0 [expr $len - 1]]
2555             }
2556             if {[string index $term 0] == "?"} {
2557                 set left 1
2558                 set term [string range $term 1 end]
2559             }
2560             set term "\{${term}\}"
2561             if {$right && $left} {
2562                 set term "@attr 5=3 ${term}"
2563             } elseif {$right} {
2564                 set term "@attr 5=1 ${term}"
2565             } elseif {$left} {
2566                 set term "@attr 5=2 ${term}"
2567             }
2568             foreach a $attr {
2569                 set term "@attr $a ${term}"
2570             }
2571             if {$qs != ""} {
2572                 set qs "@and ${qs} ${term}"
2573             } else {
2574                 set qs $term
2575             }
2576         }
2577         incr i
2578     }
2579     dputs "qs=  $qs"
2580     return $qs
2581 }
2582
2583 proc index-focus-in {w i} {
2584     global curIndexEntry
2585
2586     $w.$i configure -background red
2587     set curIndexEntry $i
2588 }
2589
2590 proc index-lines {w realOp buttonInfo queryInfo handle} {
2591     set i 0
2592     foreach b $buttonInfo {
2593         if {! [winfo exists $w.$i]} {
2594             frame $w.$i -background white -border 1
2595         }
2596         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
2597
2598         if {$realOp} {
2599             if {! [winfo exists $w.$i.e]} {
2600                 entry $w.$i.e -width 32 -relief sunken -border 1
2601                 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
2602                 bind $w.$i.e <FocusOut> [list $w.$i configure \
2603                         -background white]
2604                 pack $w.$i.l -side left
2605                 pack $w.$i.e -side left -fill x -expand yes
2606                 pack $w.$i -side top -fill x -padx 2 -pady 2
2607                 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2608                 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2609                 bind $w.$i.e <Return> {search-request 0}
2610             }
2611         } else {
2612             pack $w.$i.l -side left
2613             pack $w.$i -side top -fill x -padx 2 -pady 2
2614         }
2615         incr i
2616     }
2617     set j $i
2618     while {[winfo exists $w.$j]} {
2619         destroy $w.$j
2620         incr j
2621     }
2622     if {! $realOp} {
2623         return
2624     }
2625     set j 0
2626     incr i -1
2627     while {$j < $i} {
2628         set k [expr $j+1]
2629         bind $w.$j.e <Tab> "focus $w.$k.e"
2630         set j $k
2631     }
2632     if {$i >= 0} {
2633         bind $w.$i.e <Tab> "focus $w.0.e"
2634         focus $w.0.e
2635     }
2636 }
2637
2638 proc search-fields {w buttondefs} {
2639     set i 0
2640     foreach buttondef $buttondefs {
2641         frame $w.$i -background white
2642
2643         listbutton $w.$i.l 0 $buttondef
2644         entry $w.$i.e -width 32 -relief sunken
2645
2646         pack $w.$i.l -side left
2647         pack $w.$i.e -side left -fill x -expand yes
2648
2649         pack $w.$i -side top -fill x -padx 2 -pady 2
2650
2651         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2652         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2653
2654         incr i
2655     }
2656     set j 0
2657     incr i -1
2658     while {$j < $i} {
2659         set k [expr $j+1]
2660         bind $w.$j.e <Tab> "focus $w.$k.e \n
2661         $w.$k configure -background red \n
2662         $w.$j configure -background white"
2663         set j $k
2664     }
2665     bind $w.$i.e <Tab> "focus $w.0.e \n
2666         $w.0 configure -background red \n
2667         $w.$i configure -background white"
2668     focus $w.0.e
2669     $w.0 configure -background red
2670 }
2671
2672 if {[info exists windowGeometry(.)]} {
2673     set g $windowGeometry(.)
2674     if {$g != ""} {
2675         wm geometry . $g
2676     }
2677 }
2678
2679 read-formats
2680
2681 frame .top  -border 1 -relief raised
2682 frame .lines  -border 1 -relief raised
2683 frame .mid  -border 1 -relief raised
2684 frame .data -border 1 -relief raised
2685 frame .bot  -border 1 -relief raised
2686 pack .top .lines .mid -side top -fill x
2687 pack .data -side top -fill both -expand yes
2688 pack .bot -fill x
2689
2690 menubutton .top.file -text "File" -menu .top.file.m
2691 menu .top.file.m
2692 .top.file.m add command -label "Save settings" -command {save-settings}
2693 .top.file.m add separator
2694 .top.file.m add command -label "Exit" -command {exit-action}
2695
2696 menubutton .top.target -text "Target" -menu .top.target.m
2697 menu .top.target.m
2698 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
2699 .top.target.m add command -label "Disconnect" -command {close-target}
2700 .top.target.m add command -label "About" -command {about-target}
2701 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
2702 .top.target.m add command -label "Setup new" -command {define-target-dialog}
2703 .top.target.m add separator
2704 set-target-hotlist
2705
2706 .top.target.m disable 1
2707 .top.target.m disable 2
2708
2709 menu .top.target.m.clist
2710 menu .top.target.m.slist
2711 cascade-target-list
2712
2713 menubutton .top.service -text "Service" -menu .top.service.m
2714 menu .top.service.m
2715 .top.service.m add command -label "Database" -command {database-select}
2716 .top.service.m add cascade -label "Present" -menu .top.service.m.present
2717 menu .top.service.m.present
2718 .top.service.m.present add command -label "10 More" \
2719         -command [list present-more 10]
2720 .top.service.m.present add command -label "All" \
2721         -command [list present-more {}]
2722 .top.service.m add command -label "Search" -command {search-request 0}
2723 .top.service.m add command -label "Scan" -command {scan-request}
2724
2725 .top.service configure -state disabled
2726
2727 menubutton .top.rset -text "Set" -menu .top.rset.m
2728 menu .top.rset.m
2729 .top.rset.m add command -label "Load" -command {load-set}
2730 .top.rset.m add separator
2731
2732 menubutton .top.options -text "Options" -menu .top.options.m
2733 menu .top.options.m
2734 .top.options.m add cascade -label "Query" -menu .top.options.m.query
2735 .top.options.m add cascade -label "Format" -menu .top.options.m.formats
2736 .top.options.m add cascade -label "Wrap" -menu .top.options.m.wrap
2737
2738 menu .top.options.m.query
2739 .top.options.m.query add cascade -label "Select" \
2740         -menu .top.options.m.query.clist
2741 .top.options.m.query add cascade -label "Edit" \
2742         -menu .top.options.m.query.slist
2743 .top.options.m.query add command -label "New" \
2744         -command {query-new}
2745 .top.options.m.query add cascade -label "Delete" \
2746         -menu .top.options.m.query.dlist
2747
2748 menu .top.options.m.query.slist
2749 menu .top.options.m.query.clist
2750 menu .top.options.m.query.dlist
2751 cascade-query-list
2752
2753 menu .top.options.m.formats
2754 set i 0
2755 foreach f $displayFormats {
2756     .top.options.m.formats add radiobutton -label $f -value $i \
2757             -command [list set-display-format $i] -variable displayFormat
2758     incr i
2759 }
2760
2761 menu .top.options.m.wrap
2762 .top.options.m.wrap add radiobutton -label "Character" \
2763         -value char -variable textWrap -command {set-wrap char}
2764 .top.options.m.wrap add radiobutton -label "Word" \
2765         -value word -variable textWrap -command {set-wrap word}
2766 .top.options.m.wrap add radiobutton -label "None" \
2767         -value none -variable textWrap -command {set-wrap none}
2768
2769 menubutton .top.help -text "Help" -menu .top.help.m
2770 menu .top.help.m
2771
2772 .top.help.m add command -label "Help on help" \
2773         -command {tkerror "Help on help not available. Sorry"}
2774 .top.help.m add command -label "About" -command {about-origin}
2775
2776 pack .top.file .top.target .top.service .top.rset .top.options -side left
2777 pack .top.help -side right
2778
2779 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
2780
2781 button .mid.search -width 7 -text {Search} -command {search-request 0} \
2782         -state disabled
2783 button .mid.scan -width 7 -text {Scan} \
2784         -command scan-request -state disabled
2785 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
2786         -state disabled
2787
2788 button .mid.clear -width 7 -text {Clear} -command index-clear
2789 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
2790         -fill y -padx 5 -pady 3
2791
2792 text .data.record -height 2 -width 20 -wrap none \
2793         -yscrollcommand [list .data.scroll set] -wrap $textWrap
2794 scrollbar .data.scroll -command [list .data.record yview]
2795 pack .data.scroll -side right -fill y
2796 pack .data.record -expand yes -fill both
2797 initBindings
2798
2799 if {[tk colormodel .] == "color"} {
2800     .data.record tag configure marc-tag -foreground blue
2801     .data.record tag configure marc-id -foreground red
2802 } else {
2803     .data.record tag configure marc-tag -foreground black
2804     .data.record tag configure marc-id -foreground black
2805 }
2806 .data.record tag configure marc-data -foreground black
2807
2808 button .bot.logo  -bitmap @book1 -command cancel-operation
2809 frame .bot.a
2810 pack .bot.a -side left -fill x
2811 pack .bot.logo -side right -padx 2 -pady 2
2812
2813 message .bot.a.target -text "" -aspect 1000 -border 1
2814
2815 label .bot.a.status -text "Not connected" -width 15 -relief \
2816         sunken -anchor w -border 1
2817 label .bot.a.set -text "" -width 5 -relief \
2818         sunken -anchor w -border 1
2819 label .bot.a.message -text "" -width 15 -relief \
2820         sunken -anchor w -border 1
2821
2822 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
2823 pack .bot.a.status .bot.a.set .bot.a.message \
2824         -side left -padx 2 -pady 2
2825
2826 ir z39
2827
2828 show-logo 1
2829