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