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.36  1995-06-13 07:42:14  adam
   8 # Bindings removed from text widgets.
   9 #
  10 # Revision 1.35  1995/06/12  15:17:31  adam
  11 # Text widget used in main window (instead of listbox) to support
  12 # better presentation formats.
  13 #
  14 # Revision 1.34  1995/06/12  07:59:07  adam
  15 # More work on geometry handling.
  16 #
  17 # Revision 1.33  1995/06/09  11:17:35  adam
  18 # Start work on geometry management.
  19 #
  20 # Revision 1.32  1995/06/07  09:16:37  adam
  21 # New presentation format.
  22 #
  23 # Revision 1.31  1995/06/06  16:31:09  adam
  24 # Bug fix: target names couldn't contain blanks.
  25 # Bug fix: scan.
  26 #
  27 # Revision 1.30  1995/06/06  11:35:41  adam
  28 # Work on scan. Display of old sets.
  29 #
  30 # Revision 1.29  1995/06/05  14:11:18  adam
  31 # Bug fix in present-more.
  32 #
  33 # Revision 1.28  1995/06/02  14:52:13  adam
  34 # Minor changes really.
  35 #
  36 # Revision 1.27  1995/06/02  14:29:42  adam
  37 # Work on scan interface - up/down buttons.
  38 #
  39 # Revision 1.26  1995/06/01  16:36:46  adam
  40 # About buttons. Minor bug fixes.
  41 #
  42 # Revision 1.25  1995/05/31  13:09:57  adam
  43 # Client searches/presents may be interrupted.
  44 # New moving book-logo.
  45 #
  46 # Revision 1.24  1995/05/31  08:36:24  adam
  47 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
  48 # New method: referenceId. More work on scan.
  49 #
  50 # Revision 1.23  1995/05/29  10:33:41  adam
  51 # README and rename of startup script.
  52 #
  53 # Revision 1.22  1995/05/26  11:44:09  adam
  54 # Bugs fixed. More work on MARC utilities and queries. Test
  55 # client is up-to-date again.
  56 #
  57 # Revision 1.21  1995/05/11  15:34:46  adam
  58 # Scan request changed a bit. This version works with RLG.
  59 #
  60 # Revision 1.20  1995/04/21  16:31:57  adam
  61 # New radiobutton: protocol (z39v2/SR).
  62 #
  63 # Revision 1.19  1995/04/18  16:11:50  adam
  64 # First version of graphical Scan. Some work on query-by-form.
  65 #
  66 # Revision 1.18  1995/04/10  10:50:22  adam
  67 # Result-set name defaults to suffix of ir-set name.
  68 # Started working on scan. Not finished at this point.
  69 #
  70 # Revision 1.17  1995/03/31  09:34:57  adam
  71 # Search-button disabled when there is no connection.
  72 #
  73 # Revision 1.16  1995/03/31  08:56:36  adam
  74 # New button "Search".
  75 #
  76 # Revision 1.15  1995/03/28  12:45:22  adam
  77 # New ir method failback: called on disconnect/protocol error.
  78 # New ir set/get method: protocol: SR / Z3950.
  79 # Simple popup and disconnect when failback is invoked.
  80 #
  81 # Revision 1.14  1995/03/22  16:07:55  adam
  82 # Minor changes.
  83 #
  84 # Revision 1.13  1995/03/21  17:27:26  adam
  85 # Short-hand keys in setup.
  86 #
  87 # Revision 1.12  1995/03/21  13:41:03  adam
  88 # Comstack cs_create not used too often. Non-blocking connect.
  89 #
  90 # Revision 1.11  1995/03/21  10:39:06  adam
  91 # Diagnostic error message displayed with tkerror.
  92 #
  93 # Revision 1.10  1995/03/20  15:24:06  adam
  94 # Diagnostic records saved on searchResponse.
  95 #
  96 # Revision 1.9  1995/03/17  18:26:16  adam
  97 # Non-blocking i/o used now. Database names popup as cascade items.
  98 #
  99 # Revision 1.8  1995/03/17  15:45:00  adam
 100 # Improved target/database setup.
 101 #
 102 # Revision 1.7  1995/03/16  17:54:03  adam
 103 # Minor changes really.
 104 #
 105 # Revision 1.6  1995/03/15  19:10:20  adam
 106 # Database setup in protocol-setup (rather target setup).
 107 #
 108 # Revision 1.5  1995/03/15  13:59:23  adam
 109 # Minor changes.
 110 #
 111 # Revision 1.4  1995/03/14  17:32:29  adam
 112 # Presentation of full Marc record in popup window.
 113 #
 114 # Revision 1.3  1995/03/12  19:31:52  adam
 115 # Pattern matching implemented when retrieving MARC records. More
 116 # diagnostic functions.
 117 #
 118 # Revision 1.2  1995/03/10  18:00:15  adam
 119 # Actual presentation in line-by-line format. RPN query support.
 120 #
 121 # Revision 1.1  1995/03/09  16:15:07  adam
 122 # First presentRequest attempts. Hot-target list.
 123 #
 124 #
 125 set hotTargets {}
 126 set hotInfo {}
 127 set busy 0
 128
 129 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
 130 set hostid Default
 131 set settingsChanged 0
 132 set setNo 0
 133 set lastSetNo 0
 134 set cancelFlag 0
 135 set searchEnable 0
 136 set fullMarcSeq 0
 137 set displayFormat 1
 138
 139 set queryTypes {Simple}
 140 set queryButtons { { {I 0} {I 1} {I 2} } }
 141 set queryInfo { { {Title {1=4}} {Author {1=1}} \
 142         {Subject {1=21}} {Any {1=1016}} } }
 143 wm minsize . 0 0
 144
 145 proc read-formats {} {
 146     global displayFormats
 147     set formats [glob -nocomplain formats/*.tcl]
 148     foreach f $formats {
 149         source $f
 150         set l [expr [string length $f] - 5]
 151         lappend displayFormats [string range $f 8 $l]
 152     }
 153 }
 154
 155 proc set-display-format {f} {
 156     global displayFormat
 157     global setNo
 158
 159     set displayFormat $f
 160     if {$setNo == 0} {
 161         return
 162     }
 163     add-title-lines 0 10000 1
 164 }
 165
 166 proc readonlyText {w} {
 167     set w Text
 168     bind $w <1> {}
 169     bind $w <Double-1> {}
 170     bind $w <Triple-1> {}
 171     bind $w <B1-Motion> {}
 172     bind $w <Shift-1> {}
 173     bind $w <Shift-B1-Motion> {}
 174     bind $w <2> {}
 175     bind $w <B2-Motion> {}
 176     bind $w <Any-KeyPress> {}
 177     bind $w <Return> {}
 178     bind $w <BackSpace> {}
 179     bind $w <Delete> {}
 180     bind $w <Control-h> {}
 181     bind $w <Control-d> {}
 182     bind $w <Control-v> {}
 183 }
 184
 185 proc destroyG {w} {
 186     global windowGeometry
 187     set windowGeometry($w) [wm geometry $w]
 188     destroy $w
 189 }
 190
 191 proc toplevelG {w} {
 192     global windowGeometry
 193
 194     toplevel $w
 195     if {[info exists windowGeometry($w)]} {
 196         set g $windowGeometry($w)
 197         if {$g != ""} {
 198             wm geometry $w $g
 199         }
 200     }
 201 }
 202
 203 if {[file readable "clientrc.tcl"]} {
 204     source "clientrc.tcl"
 205 }
 206
 207 if {[file readable "clientg.tcl"]} {
 208     source "clientg.tcl"
 209 }
 210
 211 set queryButtonsFind [lindex $queryButtons 0]
 212 set queryInfoFind [lindex $queryInfo 0]
 213
 214 proc top-down-window {w} {
 215     frame $w.top -relief raised -border 1
 216     frame $w.bot -relief raised -border 1
 217
 218     pack  $w.top -side top -fill both -expand yes
 219     pack  $w.bot -fill both
 220 }
 221
 222 proc top-down-ok-cancel {w ok-action g} {
 223     frame $w.bot.left -relief sunken -border 1
 224     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
 225     button $w.bot.left.ok -width 6 -text {Ok} \
 226             -command ${ok-action}
 227     pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
 228     button $w.bot.cancel -width 6 -text {Cancel} \
 229             -command [list destroy $w]
 230     pack $w.bot.cancel -side left -expand yes
 231
 232     if {$g} {
 233         grab $w
 234         tkwait window $w
 235     }
 236 }
 237
 238 proc bottom-buttons {w buttonList g} {
 239     set i 0
 240     set l [llength $buttonList]
 241
 242     frame $w.bot.$i -relief sunken -border 1
 243     pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
 244     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 245             -command [lindex $buttonList [expr $i+1]]
 246     pack $w.bot.$i.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 247
 248     incr i 2
 249     while {$i < $l} {
 250         button $w.bot.$i -text [lindex $buttonList $i] \
 251                 -command [lindex $buttonList [expr $i+1]]
 252         pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 253         incr i 2
 254     }
 255     if {$g} {
 256         # Grab ...
 257         grab $w
 258         tkwait window $w
 259     }
 260 }
 261
 262 proc cancel-operation {} {
 263     global cancelFlag
 264     global busy
 265
 266     set cancelFlag 1
 267     if {$busy} {
 268         show-status Cancelled 0 {}
 269     }
 270 }
 271
 272 proc show-target {target} {
 273     .bot.a.target configure -text "$target"
 274 }
 275
 276 proc show-logo {v1} {
 277     global busy
 278     if {$busy != 0} {
 279         incr v1 -1
 280         if {$v1==0} {
 281             set v1 9
 282         }
 283         .bot.logo configure -bitmap @book${v1}
 284         after 140 [list show-logo $v1]
 285         return
 286     }
 287     while {1} {
 288         .bot.logo configure -bitmap @book1
 289         tkwait variable busy
 290         if {$busy} {
 291             show-logo 1
 292             return
 293         }
 294     }
 295 }
 296
 297 proc show-status {status b sb} {
 298     global busy
 299     global searchEnable
 300
 301     .bot.a.status configure -text "$status"
 302     if {$b == 1} {
 303         if {$busy == 0} {set busy 1}
 304     } else {
 305         set busy 0
 306     }
 307     if {$sb == {}} {
 308         return
 309     }
 310     if {$sb} {
 311         .top.service configure -state normal
 312         .mid.search configure -state normal
 313         .mid.scan configure -state normal
 314         .mid.present configure -state normal
 315         if {[winfo exists .scan-window]} {
 316             .scan-window.bot.2 configure -state normal
 317             .scan-window.bot.4 configure -state normal
 318         }
 319         set searchEnable 1
 320     } else {
 321         .top.service configure -state disabled
 322         .mid.search configure -state disabled
 323         .mid.scan configure -state disabled
 324         .mid.present configure -state disabled
 325
 326         if {[winfo exists .scan-window]} {
 327             .scan-window.bot.2 configure -state disabled
 328             .scan-window.bot.4 configure -state disabled
 329         }
 330         set searchEnable 0
 331     }
 332 }
 333
 334 proc show-message {msg} {
 335     .bot.a.message configure -text "$msg"
 336 }
 337
 338 proc insertWithTags {w text args} {
 339     set start [$w index insert]
 340     $w insert insert $text
 341     foreach tag [$w tag names $start] {
 342         $w tag remove $tag $start insert
 343     }
 344     foreach i $args {
 345         $w tag add $i $start insert
 346     }
 347 }
 348
 349 proc about-target {} {
 350     set w .about-target-w
 351
 352     toplevelG $w
 353
 354     wm title $w "About target"
 355     top-down-window $w
 356
 357     set i [z39 targetImplementationName]
 358     label $w.top.in -text "Implementation name: $i"
 359     set i [z39 targetImplementationId]
 360     label $w.top.ii -text "Implementation id: $i"
 361     set i [z39 targetImplementationVersion]
 362     label $w.top.iv -text "Implementation version: $i"
 363     set i [z39 options]
 364     label $w.top.op -text "Protocol options: $i"
 365
 366     pack $w.top.in $w.top.ii $w.top.iv $w.top.op -side top -anchor nw
 367
 368     bottom-buttons $w [list {Close} [list destroyG $w]] 1
 369 }
 370
 371 proc about-origin {} {
 372     set w .about-origin-w
 373
 374     toplevelG $w
 375
 376     wm title $w "About IrTcl"
 377     place-force $w .
 378     top-down-window $w
 379
 380     set i [z39 implementationName]
 381     label $w.top.in -text "Implementation name: $i"
 382     set i [z39 implementationId]
 383     label $w.top.ii -text "Implementation id: $i"
 384
 385     pack $w.top.in $w.top.ii -side top -anchor nw
 386
 387     bottom-buttons $w [list {Close} [list destroyG $w]] 1
 388 }
 389
 390 proc popup-marc {sno no b df} {
 391     global fullMarcSeq
 392     global displayFormats
 393     global popupMarcOdf
 394
 395     if {[z39.$sno type $no] != "DB"} {
 396         return
 397     }
 398     if {$b} {
 399         set w .full-marc-$fullMarcSeq
 400         incr fullMarcSeq
 401     } else {
 402         set w .full-marc
 403     }
 404     if {[winfo exists $w]} {
 405         set new 0
 406     } else {
 407
 408         toplevelG $w
 409
 410         wm minsize $w 0 0
 411
 412         frame $w.top -relief raised -border 1
 413         frame $w.bot -relief raised -border 1
 414
 415         pack  $w.top -side top -fill both -expand yes
 416         pack  $w.bot -fill both
 417
 418         text $w.top.record -width 60 -height 5 -wrap word \
 419                 -yscrollcommand [list $w.top.s set]
 420         scrollbar $w.top.s -command [list $w.top.record yview]
 421
 422         if {[tk colormodel .] == "color"} {
 423             $w.top.record tag configure marc-tag -foreground blue
 424             $w.top.record tag configure marc-id -foreground red
 425         } else {
 426             $w.top.record tag configure marc-tag -foreground black
 427             $w.top.record tag configure marc-id -foreground black
 428         }
 429         $w.top.record tag configure marc-data -foreground black
 430         set new 1
 431     }
 432     $w.top.record delete 0.0 end
 433
 434     set ffunc [lindex $displayFormats $df]
 435     set ffunc "display-$ffunc"
 436
 437     $ffunc $sno $no  $w.top.record 0
 438
 439     if {$new} {
 440         bind $w.top.record <Return> {destroy .full-marc}
 441
 442         pack $w.top.s -side right -fill y
 443         pack $w.top.record -expand yes -fill both
 444
 445         if {$b} {
 446             bottom-buttons $w [list \
 447                 {Close} [list destroy $w] \
 448                 {Duplicate} [list popup-marc $sno $no 1 $df]] 0
 449             menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
 450             menu $w.bot.formats.m
 451             set i 0
 452             foreach f $displayFormats {
 453                 $w.bot.formats.m add radiobutton -label $f \
 454                         -command [list display-$f $sno $no $w.top.record 0]
 455                 incr i
 456             }
 457             pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
 458                     -padx 3 -pady 3 -side left
 459         } else {
 460             bottom-buttons $w [list \
 461                 {Close} [list destroyG $w] \
 462                 {Duplicate} [list popup-marc $sno $no 1 $df]] 0
 463             menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
 464             menu $w.bot.formats.m
 465             set i 0
 466             foreach f $displayFormats {
 467                 $w.bot.formats.m add radiobutton -label $f \
 468                         -command [list display-$f $sno $no $w.top.record 0]
 469                 incr i
 470             }
 471             pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
 472                     -padx 3 -pady 3 -side left
 473         }
 474     } else {
 475         set i 0
 476         foreach f $displayFormats {
 477             $w.bot.formats.m entryconfigure $i \
 478                     -command [list display-f $sno $no $w.top.record 0]
 479             incr i
 480         }
 481     }
 482 }
 483
 484 proc update-target-hotlist {target} {
 485     global hotTargets
 486
 487     set len [llength $hotTargets]
 488     if {$len > 0} {
 489         .top.target.m delete 6 [expr 6+[llength $hotTargets]]
 490     }
 491     set indx [lsearch $hotTargets $target]
 492     if {$indx >= 0} {
 493         set hotTargets [lreplace $hotTargets $indx $indx]
 494     }
 495     set hotTargets [linsert $hotTargets 0 $target]
 496     set-target-hotlist
 497 }
 498
 499 proc set-target-hotlist {} {
 500     global hotTargets
 501
 502     set i 1
 503     foreach target $hotTargets {
 504         .top.target.m add command -label "$i $target" -command \
 505                 [list reopen-target $target {}]
 506         incr i
 507         if {$i > 8} {
 508              break
 509         }
 510     }
 511 }
 512
 513 proc reopen-target {target base} {
 514     close-target
 515     open-target $target $base
 516     update-target-hotlist $target
 517 }
 518
 519 proc define-target-action {} {
 520     global profile
 521
 522     set target [.target-define.top.target.entry get]
 523     if {$target == ""} {
 524         return
 525     }
 526     update-target-hotlist $target
 527     foreach n [array names profile] {
 528         if {$n == $target} {
 529             protocol-setup $n
 530             return
 531         }
 532     }
 533     set seq [lindex $profile(Default) 12]
 534     puts "seq=${seq}"
 535     set profile($target) $profile(Default)
 536     set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
 537
 538     protocol-setup $target
 539     destroy .target-define
 540 }
 541
 542 proc fail-response {target} {
 543     close-target
 544     tkerror "Target connection closed or protocol error"
 545 }
 546
 547 proc connect-response {target} {
 548     puts "connect-response"
 549     show-target $target
 550     init-request
 551 }
 552
 553 proc open-target {target base} {
 554     global profile
 555     global hostid
 556
 557     z39 disconnect
 558     z39 comstack [lindex $profile($target) 6]
 559     z39 idAuthentication [lindex $profile($target) 3]
 560     z39 maximumRecordSize [lindex $profile($target) 4]
 561     z39 preferredMessageSize [lindex $profile($target) 5]
 562     puts -nonewline "maximumRecordSize="
 563     puts [z39 maximumRecordSize]
 564     puts -nonewline "preferredMessageSize="
 565     puts [z39 preferredMessageSize]
 566     show-status {Connecting} 0 0
 567     if {$base == ""} {
 568         z39 databaseNames [lindex [lindex $profile($target) 7] 0]
 569     } else {
 570         z39 databaseNames $base
 571     }
 572     z39 failback [list fail-response $target]
 573     z39 callback [list connect-response $target]
 574     z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
 575 #    z39 options search present scan namedResultSets triggerResourceCtrl
 576     show-status {Connecting} 1 {}
 577     set hostid $target
 578     .top.target.m disable 0
 579     .top.target.m enable 1
 580     .top.target.m enable 2
 581 }
 582
 583 proc close-target {} {
 584     global hostid
 585     global cancelFlag
 586
 587     set cancelFlag 0
 588     set hostid Default
 589     z39 disconnect
 590     show-target {}
 591     show-status {Not connected} 0 0
 592     show-message {}
 593     .top.target.m disable 1
 594     .top.target.m disable 2
 595     .top.target.m enable 0
 596 }
 597
 598 proc load-set-action {} {
 599     global setNo
 600
 601     incr setNo
 602     ir-set z39.$setNo z39
 603
 604     set fname [.load-set.top.filename.entry get]
 605     destroy .load-set
 606     if {$fname != ""} {
 607         show-status {Loading} 1 {}
 608         z39.$setNo loadFile $fname
 609
 610         set no [z39.$setNo numberOfRecordsReturned]
 611         add-title-lines $setNo $no 1
 612     }
 613     set l [format "%-4d %7d" $setNo $no]
 614     .top.rset.m add command -label $l \
 615             -command [list add-title-lines $setNo 10000 1]
 616     show-status {Ready} 0 {}
 617 }
 618
 619 proc load-set {} {
 620     set w .load-set
 621
 622     set oldFocus [focus]
 623     toplevel $w
 624
 625     place-force $w .
 626
 627     top-down-window $w
 628
 629     frame $w.top.filename
 630
 631     pack $w.top.filename -side top -anchor e -pady 2
 632
 633     entry-fields $w.top {filename} \
 634             {{Filename:}} \
 635             {load-set-action} {destroy .load-set}
 636
 637     top-down-ok-cancel $w {load-set-action} 1
 638     focus $oldFocus
 639 }
 640
 641 proc init-request {} {
 642     global setNo
 643     global cancelFlag
 644
 645     if {$cancelFlag} {
 646         close-target
 647         return
 648     }
 649     z39 callback {init-response}
 650     show-status {Initializing} 1 {}
 651     z39 init
 652 }
 653
 654 proc init-response {} {
 655     global cancelFlag
 656
 657     if {$cancelFlag} {
 658         close-target
 659         return
 660     }
 661     show-status {Ready} 0 1
 662     if {![z39 initResult]} {
 663         set u [z39 userInformationField]
 664         close-target
 665         tkerror "Connection rejected by target: $u"
 666     }
 667 }
 668
 669 proc search-request {} {
 670     global setNo
 671     global profile
 672     global hostid
 673     global busy
 674     global cancelFlag
 675     global searchEnable
 676
 677     set target $hostid
 678
 679     if {$searchEnable == 0} {
 680         return
 681     }
 682     set query [index-query]
 683     if {$query==""} {
 684         return
 685     }
 686     incr setNo
 687     ir-set z39.$setNo z39
 688
 689     if {[lindex $profile($target) 10] == 1} {
 690         z39.$setNo setName $setNo
 691         puts "setName=${setNo}"
 692     } else {
 693         z39.$setNo setName Default
 694         puts "setName=Default"
 695     }
 696     if {[lindex $profile($target) 8] == 1} {
 697         z39.$setNo queryType rpn
 698     }
 699     if {[lindex $profile($target) 9] == 1} {
 700         z39.$setNo queryType ccl
 701     }
 702     z39 callback {search-response}
 703     z39.$setNo search $query
 704     show-status {Search} 1 0
 705 }
 706
 707 proc scan-request {attr} {
 708     set w .scan-window
 709
 710     global profile
 711     global hostid
 712     global scanView
 713     global scanTerm
 714
 715     set target $hostid
 716     set scanView 0
 717     set scanTerm {}
 718
 719     ir-scan z39.scan z39
 720
 721     if {![winfo exists $w]} {
 722         toplevelG $w
 723
 724         wm title $w "Scan"
 725
 726         wm minsize $w 0 0
 727
 728         top-down-window $w
 729
 730         entry $w.top.entry -relief sunken
 731         pack $w.top.entry -fill x -padx 4 -pady 2
 732         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
 733         if {1} {
 734             listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
 735                     -font fixed
 736             scrollbar $w.top.scroll -orient vertical -border 1
 737             pack $w.top.list -side left -fill both -expand yes
 738             pack $w.top.scroll -side right -fill y
 739             $w.top.scroll config -command [list $w.top.list yview]
 740         } else {
 741             listbox $w.top.list -font fixed -geometry 60x14
 742             pack $w.top.list -side left -fill both -expand yes
 743         }
 744
 745         bottom-buttons $w [list {Close} [list destroyG $w] \
 746                 {Up} [list scan-up $attr] \
 747                 {Down} [list scan-down $attr]] 0
 748         bind $w.top.list <Up> [list scan-up $attr]
 749         bind $w.top.list <Down> [list scan-down $attr]
 750
 751 #       bind $w.top <Any-Enter> [list focus $w.top.entry]
 752     }
 753     z39 callback [list scan-response $attr 0 35]
 754     z39.scan numberOfTermsRequested 5
 755     z39.scan preferredPositionInResponse 1
 756     z39.scan scan "${attr} 0"
 757
 758     show-status {Scan} 1 0
 759 }
 760
 761 proc scan-term-h {attr} {
 762     global busy
 763     global scanTerm
 764
 765     if {$busy} {
 766         return
 767     }
 768     set w .scan-window
 769     set nScanTerm [$w.top.entry get]
 770     if {$nScanTerm == $scanTerm} {
 771         return
 772     }
 773     set scanTerm $nScanTerm
 774     z39 callback [list scan-response $attr 0 35]
 775     z39.scan numberOfTermsRequested 5
 776     z39.scan preferredPositionInResponse 1
 777     puts "${attr} \{${scanTerm}\}"
 778     if {$scanTerm == ""} {
 779         z39.scan scan "${attr} 0"
 780     } else {
 781         z39.scan scan "${attr} \{${scanTerm}\}"
 782     }
 783     show-status {Scan} 1 0
 784 }
 785
 786 proc scan-response {attr start toget} {
 787     global cancelFlag
 788     global scanTerm
 789     global scanView
 790
 791     set w .scan-window
 792     puts "In scan-response"
 793     set m [z39.scan numberOfEntriesReturned]
 794     puts $m
 795     puts attr=$attr
 796     puts start=$start
 797     puts toget=$toget
 798
 799     if {![winfo exists .scan-window]} {
 800         show-status {Ready} 0 1
 801         set cancelFlag 0
 802         return
 803     }
 804     set nScanTerm [$w.top.entry get]
 805     if {$nScanTerm != $scanTerm} {
 806         z39 callback [list scan-response $attr 0 35]
 807         z39.scan numberOfTermsRequested 5
 808         z39.scan preferredPositionInResponse 1
 809         set scanTerm $nScanTerm
 810         puts "${attr} \{${scanTerm}\}"
 811         if {$scanTerm == ""} {
 812             z39.scan scan "${attr} 0"
 813         } else {
 814             z39.scan scan "${attr} \{${scanTerm}\}"
 815         }
 816         show-status {Scan} 1 0
 817         return
 818     }
 819     set status [z39.scan scanStatus]
 820     if {$status == 6} {
 821         tkerror "Scan fail"
 822         show-status {Ready} 0 1
 823         set cancelFlag 0
 824         return
 825     }
 826     if {$toget < 0} {
 827         for {set i 0} {$i < $m} {incr i} {
 828             set term [lindex [z39.scan scanLine $i] 1]
 829             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
 830             $w.top.list insert $i "$nostr $term"
 831         }
 832         incr scanView $m
 833         $w.top.list yview $scanView
 834     } else {
 835         $w.top.list delete $start end
 836         for {set i 0} {$i < $m} {incr i} {
 837             set term [lindex [z39.scan scanLine $i] 1]
 838             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
 839             $w.top.list insert end "$nostr $term"
 840         }
 841     }
 842     if {$cancelFlag} {
 843         show-status {Ready} 0 1
 844         set cancelFlag 0
 845         return
 846     }
 847     if {$toget > 0 && $m > 1 && $m < $toget} {
 848         set ntoget [expr $toget - $m + 1]
 849         puts ntoget=$ntoget
 850         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
 851         set q $term
 852         puts "down continue: $q"
 853         if {$ntoget > 10} {
 854             z39.scan numberOfTermsRequested 10
 855         } else {
 856             z39.scan numberOfTermsRequested $ntoget
 857         }
 858         z39.scan preferredPositionInResponse 1
 859         puts "${attr} \{$q\}"
 860         z39.scan scan "${attr} \{$q\}"
 861         return
 862     }
 863     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
 864         set ntoget [expr - $toget - $m]
 865         puts ntoget=$ntoget
 866         z39 callback [list scan-response $attr 0 -$ntoget]
 867         set q [string range [$w.top.list get 0] 8 end]
 868         puts "up continue: $q"
 869         if {$ntoget > 10} {
 870             z39.scan numberOfTermsRequested 10
 871             z39.scan preferredPositionInResponse 11
 872         } else {
 873             z39.scan numberOfTermsRequested $ntoget
 874             z39.scan preferredPositionInResponse [incr ntoget]
 875         }
 876         puts "${attr} \{$q\}"
 877         z39.scan scan "${attr} \{$q\}"
 878         return
 879     }
 880     show-status {Ready} 0 1
 881 }
 882
 883 proc scan-down {attr} {
 884     global scanView
 885
 886     set w .scan-window
 887     set scanView [expr $scanView + 5]
 888     set s [$w.top.list size]
 889     if {$scanView > $s} {
 890         z39 callback [list scan-response $attr [expr $s - 1] 25]
 891         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
 892         puts "down: $q"
 893         z39.scan numberOfTermsRequested 10
 894         z39.scan preferredPositionInResponse 1
 895         show-status {Scan} 1 0
 896         puts "${attr} \{$q\}"
 897         z39.scan scan "${attr} \{$q\}"
 898         return
 899     }
 900     $w.top.list yview $scanView
 901 }
 902
 903 proc scan-up {attr} {
 904     global scanView
 905
 906     set w .scan-window
 907     set scanView [expr $scanView - 5]
 908     if {$scanView < 0} {
 909         z39 callback [list scan-response $attr 0 -25]
 910         set q [string range [$w.top.list get 0] 8 end]
 911         puts "up: $q"
 912         z39.scan numberOfTermsRequested 10
 913         z39.scan preferredPositionInResponse 11
 914         show-status {Scan} 1 0
 915         z39.scan scan "${attr} \{$q\}"
 916         return
 917     }
 918     $w.top.list yview $scanView
 919 }
 920
 921 proc search-response {} {
 922     global setNo
 923     global setOffset
 924     global setMax
 925     global cancelFlag
 926     global busy
 927
 928     puts "In search-response"
 929     init-title-lines
 930     show-status {Ready} 0 1
 931     set setMax [z39.$setNo resultCount]
 932     show-message "${setMax} hits"
 933     set l [format "%-4d %7d" $setNo $setMax]
 934     .top.rset.m add command -label $l \
 935             -command [list add-title-lines $setNo 10000 1]
 936     if {$setMax <= 0} {
 937         set status [z39.$setNo responseStatus]
 938         if {[lindex $status 0] == "NSD"} {
 939             set code [lindex $status 1]
 940             set msg [lindex $status 2]
 941             set addinfo [lindex $status 3]
 942             tkerror "NSD$code: $msg: $addinfo"
 943         }
 944         return
 945     }
 946     if {$setMax > 20} {
 947         set setMax 20
 948     }
 949     set setOffset 1
 950     if {$cancelFlag} {
 951         set cancelFlag 0
 952         return
 953     }
 954     z39 callback {present-response}
 955     z39.$setNo present $setOffset 1
 956     show-status {Retrieve} 1 0
 957 }
 958
 959 proc present-more {number} {
 960     global setNo
 961     global setOffset
 962     global setMax
 963
 964     puts "setOffset=$setOffset"
 965     puts "present-more"
 966     if {$setNo == 0} {
 967         puts "setNo=$setNo"
 968         return
 969     }
 970     set max [z39.$setNo resultCount]
 971     if {$max <= $setOffset} {
 972         puts "max=$max"
 973         puts "setOffset=$setOffset"
 974         return
 975     }
 976     if {$number == ""} {
 977         set setMax $max
 978     } else {
 979         incr setMax $number
 980         if {$setMax > $max} {
 981             set setMax $max
 982         }
 983     }
 984     z39 callback {present-response}
 985
 986     set toGet [expr $setMax - $setOffset + 1]
 987     if {$toGet <= 0} {
 988         return
 989     }
 990     if {$toGet > 3} {
 991         set toGet 3
 992     }
 993     z39.$setNo present $setOffset $toGet
 994     show-status {Retrieve} 1 0
 995 }
 996
 997 proc init-title-lines {} {
 998     .data.record delete 0.0 end
 999 }
1000
1001 proc title-press {y setno} {
1002     show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
1003 }
1004
1005 proc add-title-lines {setno no offset} {
1006     global displayFormats
1007     global displayFormat
1008     global lastSetNo
1009
1010     if {$setno == 0} {
1011         set setno $lastSetNo
1012     } else {
1013         set lastSetNo $setno
1014     }
1015     if {$offset == 1} {
1016         .bot.a.set configure -text $setno
1017         .data.record delete 0.0 end
1018     }
1019     set ffunc [lindex $displayFormats $displayFormat]
1020     set ffunc "display-$ffunc"
1021     for {set i 0} {$i < $no} {incr i} {
1022         set o [expr $i + $offset]
1023         set type [z39.$setno type $o]
1024         if {$type == ""} {
1025             break
1026         }
1027         set insert0 [.data.record index insert]
1028         $ffunc $setno $o .data.record 1
1029         .data.record tag add r$o $insert0 insert
1030         .data.record tag bind r$o <1> \
1031                 [list popup-marc $setno $o 0 $displayFormat]
1032     }
1033 }
1034
1035 proc present-response {} {
1036     global setNo
1037     global setOffset
1038     global setMax
1039     global cancelFlag
1040
1041     puts "In present-response"
1042     set no [z39.$setNo numberOfRecordsReturned]
1043     puts "Returned $no records, setOffset $setOffset"
1044     add-title-lines $setNo $no $setOffset
1045     set setOffset [expr $setOffset + $no]
1046     set status [z39.$setNo responseStatus]
1047     if {[lindex $status 0] == "NSD"} {
1048         show-status {Ready} 0 1
1049         set code [lindex $status 1]
1050         set msg [lindex $status 2]
1051         set addinfo [lindex $status 3]
1052         tkerror "NSD$code: $msg: $addinfo"
1053         return
1054     }
1055     if {$cancelFlag} {
1056         show-status {Ready} 0 1
1057         set cancelFlag 0
1058         return
1059     }
1060     if {$no > 0 && $setOffset <= $setMax} {
1061         puts "present-request from ${setOffset}"
1062         set toGet [expr $setMax - $setOffset + 1]
1063         if {$toGet > 3} {
1064             set toGet 3
1065         }
1066         z39.$setNo present $setOffset $toGet
1067     } else {
1068         show-status {Finished} 0 1
1069     }
1070 }
1071
1072 proc left-cursor {w} {
1073     set i [$w index insert]
1074     if {$i > 0} {
1075         incr i -1
1076         $w icursor $i
1077     }
1078 }
1079
1080 proc right-cursor {w} {
1081     set i [$w index insert]
1082     incr i
1083     $w icursor $i
1084 }
1085
1086 proc bind-fields {list returnAction escapeAction} {
1087     set max [expr [llength $list]-1]
1088     for {set i 0} {$i < $max} {incr i} {
1089         bind [lindex $list $i] <Return> $returnAction
1090         bind [lindex $list $i] <Escape> $escapeAction
1091         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1092         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1093         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1094     }
1095     bind [lindex $list $i] <Return> $returnAction
1096     bind [lindex $list $i] <Escape> $escapeAction
1097     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
1098     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1099     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1100     focus [lindex $list 0]
1101 }
1102
1103 proc entry-fields {parent list tlist returnAction escapeAction} {
1104     set alist {}
1105     set i 0
1106     foreach field $list {
1107         set label ${parent}.${field}.label
1108         set entry ${parent}.${field}.entry
1109         label $label -text [lindex $tlist $i] -anchor e
1110         entry $entry -width 32 -relief sunken
1111         pack $label -side left
1112         pack $entry -side right
1113         lappend alist $entry
1114         incr i
1115     }
1116     bind-fields $alist $returnAction $escapeAction
1117 }
1118
1119 proc define-target-dialog {} {
1120     set w .target-define
1121
1122     toplevel $w
1123     place-force $w .
1124     top-down-window $w
1125     frame $w.top.target
1126     pack $w.top.target \
1127             -side top -anchor e -pady 2
1128     entry-fields $w.top {target} \
1129             {{Target:}} \
1130             {define-target-action} {destroy .target-define}
1131     top-down-ok-cancel $w {define-target-action} 1
1132 }
1133
1134 proc protocol-setup-action {target} {
1135     global profile
1136     global csRadioType
1137     global protocolRadioType
1138     global settingsChanged
1139     global RPNCheck
1140     global CCLCheck
1141     global ResultSetCheck
1142
1143     set wno [lindex $profile($target) 12]
1144     set w .setup-${wno}
1145
1146     set b {}
1147     set settingsChanged 1
1148     set len [$w.top.databases.list size]
1149     for {set i 0} {$i < $len} {incr i} {
1150         lappend b [$w.top.databases.list get $i]
1151     }
1152     set profile($target) [list [$w.top.description.entry get] \
1153             [$w.top.host.entry get] \
1154             [$w.top.port.entry get] \
1155             [$w.top.idAuthentication.entry get] \
1156             [$w.top.maximumRecordSize.entry get] \
1157             [$w.top.preferredMessageSize.entry get] \
1158             $csRadioType \
1159             $b \
1160             $RPNCheck \
1161             $CCLCheck \
1162             $ResultSetCheck \
1163             $protocolRadioType \
1164             $wno]
1165
1166     cascade-target-list
1167     puts $profile($target)
1168     destroyG $w
1169 }
1170
1171 proc place-force {window parent} {
1172     set g [wm geometry $parent]
1173
1174     set p1 [string first + $g]
1175     set p2 [string last + $g]
1176
1177     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1178     set y [expr 60+[string range $g [expr $p2 +1] end]]
1179     wm geometry $window +${x}+${y}
1180 }
1181
1182 proc add-database-action {target} {
1183     global profile
1184
1185     set wno [lindex $profile($target) 12]
1186     set w .setup-${wno}
1187
1188     $w.top.databases.list insert end \
1189             [.database-select.top.database.entry get]
1190     destroy .database-select
1191 }
1192
1193 proc add-database {target} {
1194     global profile
1195
1196     set w .database-select
1197
1198     set oldFocus [focus]
1199     toplevel $w
1200
1201     set wno [lindex $profile($target) 12]
1202     place-force $w .setup-${wno}
1203
1204     top-down-window $w
1205
1206     frame $w.top.database
1207
1208     pack $w.top.database -side top -anchor e -pady 2
1209
1210     entry-fields $w.top {database} \
1211             {{Database to add:}} \
1212             [list add-database-action $target] {destroy .database-select}
1213
1214     top-down-ok-cancel $w [list add-database-action $target] 1
1215     focus $oldFocus
1216 }
1217
1218 proc delete-database {target} {
1219     global profile
1220
1221     set wno [lindex $profile($target) 12]
1222     set w .setup-${wno}
1223
1224     foreach i [lsort -decreasing \
1225             [$w.top.databases.list curselection]] {
1226         $w.top.databases.list delete $i
1227     }
1228 }
1229
1230 proc protocol-setup {target} {
1231     global profile
1232     global csRadioType
1233     global protocolRadioType
1234     global RPNCheck
1235     global CCLCheck
1236     global ResultSetCheck
1237
1238     set wno [lindex $profile($target) 12]
1239     set w .setup-${wno}
1240
1241     toplevelG $w
1242
1243     wm title $w "Setup $target"
1244
1245     top-down-window $w
1246
1247     if {$target == ""} {
1248         set target Default
1249     }
1250     puts target
1251     puts $profile($target)
1252
1253     frame $w.top.host
1254     frame $w.top.port
1255     frame $w.top.description
1256     frame $w.top.idAuthentication
1257     frame $w.top.maximumRecordSize
1258     frame $w.top.preferredMessageSize
1259     frame $w.top.cs-type -relief ridge -border 2
1260     frame $w.top.protocol -relief ridge -border 2
1261     frame $w.top.query -relief ridge -border 2
1262     frame $w.top.databases -relief ridge -border 2
1263
1264     # Maximum/preferred/idAuth ...
1265     pack $w.top.description $w.top.host $w.top.port \
1266             $w.top.idAuthentication $w.top.maximumRecordSize \
1267             $w.top.preferredMessageSize -side top -anchor e -pady 2
1268
1269     entry-fields $w.top {description host port idAuthentication \
1270             maximumRecordSize preferredMessageSize} \
1271             {{Description:} {Host:} {Port:} {Id Authentication:} \
1272             {Maximum Record Size:} {Preferred Message Size:}} \
1273             [list protocol-setup-action $target] [list destroyG $w]
1274
1275     foreach sub {description host port idAuthentication \
1276             maximumRecordSize preferredMessageSize} {
1277         puts $sub
1278         bind $w.top.$sub.entry <Control-a> [list add-database $target]
1279         bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1280     }
1281     $w.top.description.entry insert 0 [lindex $profile($target) 0]
1282     $w.top.host.entry insert 0 [lindex $profile($target) 1]
1283     $w.top.port.entry insert 0 [lindex $profile($target) 2]
1284     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1285     $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1286     $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1287     set csRadioType [lindex $profile($target) 6]
1288     set RPNCheck [lindex $profile($target) 8]
1289     set CCLCheck [lindex $profile($target) 9]
1290     set ResultSetCheck [lindex $profile($target) 10]
1291     set protocolRadioType [lindex $profile($target) 11]
1292     if {$protocolRadioType == ""} {
1293         set protocolRadioType z39v2
1294     }
1295
1296     # Databases ....
1297     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill both
1298
1299     label $w.top.databases.label -text "Databases"
1300     button $w.top.databases.add -text "Add" \
1301             -command [list add-database $target]
1302     button $w.top.databases.delete -text "Delete" \
1303             -command [list delete-database $target]
1304     listbox $w.top.databases.list -geometry 20x6 \
1305             -yscrollcommand "$w.top.databases.scroll set"
1306     scrollbar $w.top.databases.scroll -orient vertical -border 1
1307     pack $w.top.databases.label -side top -fill x \
1308             -padx 2 -pady 2
1309     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1310             -padx 2 -pady 2
1311     pack $w.top.databases.list -side left -fill both -expand yes \
1312             -padx 2 -pady 2
1313     pack $w.top.databases.scroll -side right -fill y \
1314             -padx 2 -pady 2
1315     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1316
1317     foreach b [lindex $profile($target) 7] {
1318         $w.top.databases.list insert end $b
1319     }
1320
1321     # Transport ...
1322     pack $w.top.cs-type -pady 6 -padx 6 -side top -fill x
1323
1324     label $w.top.cs-type.label -text "Transport"
1325     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1326             -command {puts tcp/ip} -variable csRadioType -value tcpip
1327     radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1328             -command {puts mosi} -variable csRadioType -value mosi
1329
1330     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1331             -padx 4 -side top -fill x
1332
1333     # Protocol ...
1334     pack $w.top.protocol -pady 6 -padx 6 -side top -fill x
1335
1336     label $w.top.protocol.label -text "Protocol"
1337     radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1338             -command {puts z39v2} -variable protocolRadioType -value z39v2
1339     radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1340             -command {puts sr} -variable protocolRadioType -value sr
1341
1342     pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1343             -padx 4 -side top -fill x
1344
1345     # Query ...
1346     pack $w.top.query -pady 6 -padx 6 -side top -fill x
1347
1348     label $w.top.query.label -text "Query support"
1349     checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1350     checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1351     checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1352
1353     pack $w.top.query.label -side top
1354     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1355             -padx 4 -side top -fill x
1356
1357     # Ok-cancel
1358     bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1359             {Cancel} [list destroyG $w]] 0
1360 }
1361
1362 proc database-select-action {} {
1363     set w .database-select.top
1364     set b {}
1365     foreach indx [$w.databases.list curselection] {
1366         lappend b [$w.databases.list get $indx]
1367     }
1368     if {$b != ""} {
1369         z39 databaseNames $b
1370     }
1371     destroy .database-select
1372 }
1373
1374 proc database-select {} {
1375     set w .database-select
1376     global profile
1377     global hostid
1378
1379     toplevel $w
1380
1381     place-force $w .
1382
1383     top-down-window $w
1384
1385     frame $w.top.databases -relief ridge -border 2
1386
1387     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1388
1389     label $w.top.databases.label -text "List"
1390     listbox $w.top.databases.list -geometry 20x6 \
1391             -yscrollcommand "$w.top.databases.scroll set"
1392     scrollbar $w.top.databases.scroll -orient vertical -border 1
1393     pack $w.top.databases.label -side top -fill x \
1394             -padx 2 -pady 2
1395     pack $w.top.databases.list -side left -fill both -expand yes \
1396             -padx 2 -pady 2
1397     pack $w.top.databases.scroll -side right -fill y \
1398             -padx 2 -pady 2
1399     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1400
1401     foreach b [lindex $profile($hostid) 7] {
1402         $w.top.databases.list insert end $b
1403     }
1404     top-down-ok-cancel $w {database-select-action} 1
1405 }
1406
1407 proc cascade-target-list {} {
1408     global profile
1409
1410     foreach sub [winfo children .top.target.m.clist] {
1411         puts "deleting $sub"
1412         destroy $sub
1413     }
1414     .top.target.m.clist delete 0 last
1415     foreach n [array names profile] {
1416         if {$n != "Default"} {
1417             set nl [string tolower $n]
1418             if {[llength [lindex $profile($n) 7]] > 1} {
1419                 .top.target.m.clist add cascade -label $n \
1420                         -menu .top.target.m.clist.$nl
1421                 menu .top.target.m.clist.$nl
1422                 foreach b [lindex $profile($n) 7] {
1423                     .top.target.m.clist.$nl add command -label $b \
1424                             -command [list reopen-target $n $b]
1425                 }
1426             } else {
1427                 .top.target.m.clist add command -label $n \
1428                         -command [list reopen-target $n {}]
1429             }
1430         }
1431     }
1432     .top.target.m.slist delete 0 last
1433     foreach n [array names profile] {
1434         if {$n != "Default"} {
1435             .top.target.m.slist add command -label $n \
1436                     -command [list protocol-setup $n]
1437         }
1438     }
1439 }
1440
1441 proc cascade-query-list {} {
1442     global queryTypes
1443
1444     set i 0
1445     .top.options.m.slist delete 0 last
1446     foreach n $queryTypes {
1447         .top.options.m.slist add command -label $n \
1448                 -command [list query-setup $i]
1449         incr i
1450     }
1451
1452     set i 0
1453     .top.options.m.clist delete 0 last
1454     foreach n $queryTypes {
1455         .top.options.m.clist add command -label $n \
1456                 -command [list query-select $i]
1457         incr i
1458     }
1459 }
1460
1461 proc save-geometry {} {
1462     global windowGeometry
1463
1464     set windowGeometry(.) [wm geometry .]
1465
1466     set f [open "clientg.tcl" w]
1467
1468     foreach n [array names windowGeometry] {
1469         puts -nonewline $f "set \{windowGeometry($n)\} \{"
1470         puts -nonewline $f $windowGeometry($n)
1471         puts $f "\}"
1472     }
1473     close $f
1474 }
1475
1476 proc save-settings {} {
1477     global hotTargets
1478     global profile
1479     global settingsChanged
1480     global queryTypes
1481     global queryButtons
1482     global queryInfo
1483
1484     set f [open "clientrc.tcl" w]
1485     puts $f "# Setup file"
1486     puts $f "set hotTargets \{ $hotTargets \}"
1487
1488     foreach n [array names profile] {
1489         puts -nonewline $f "set \{profile($n)\} \{"
1490         puts -nonewline $f $profile($n)
1491         puts $f "\}"
1492     }
1493     puts -nonewline $f "set queryTypes \{"
1494     puts -nonewline $f $queryTypes
1495     puts $f "\}"
1496
1497     puts -nonewline $f "set queryButtons \{"
1498     puts -nonewline $f $queryButtons
1499     puts $f "\}"
1500
1501     puts -nonewline $f "set queryInfo \{"
1502     puts -nonewline $f $queryInfo
1503     puts $f "\}"
1504     close $f
1505     set settingsChanged 0
1506 }
1507
1508 proc alert {ask} {
1509     set w .alert
1510
1511     global alertAnswer
1512
1513     toplevel $w
1514     place-force $w .
1515     top-down-window $w
1516
1517     message $w.top.message -text $ask
1518
1519     pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
1520
1521     set alertAnswer 0
1522     top-down-ok-cancel $w {alert-action} 1
1523     return $alertAnswer
1524 }
1525
1526 proc alert-action {} {
1527     global alertAnswer
1528     set alertAnswer 1
1529     destroy .alert
1530 }
1531
1532 proc exit-action {} {
1533     global settingsChanged
1534
1535     save-geometry
1536     if {$settingsChanged} {
1537         set a [alert "you havent saved your settings. Do you wish to save?"]
1538         if {$a} {
1539             save-settings
1540         }
1541     }
1542     exit 0
1543 }
1544
1545 proc listbuttonaction {w name h user i} {
1546     $w configure -text [lindex $name 0]
1547     $h [lindex $name 1] $user $i
1548 }
1549
1550 proc listbuttonx {button no names handle user} {
1551     if {[winfo exists $button]} {
1552         $button configure -text [lindex [lindex $names $no] 0]
1553         ${button}.m delete 0 last
1554     } else {
1555         menubutton $button -text [lindex [lindex $names $no] 0] \
1556                 -width 10 -menu ${button}.m -relief raised -border 1
1557         menu ${button}.m
1558     }
1559     set i 0
1560     foreach name $names {
1561         ${button}.m add command -label [lindex $name 0] \
1562                 -command [list listbuttonaction ${button} $name \
1563                 $handle $user $i]
1564         incr i
1565     }
1566 }
1567
1568 proc listbutton {button no names} {
1569     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1570             -relief raised -border 1
1571     menu ${button}.m
1572     foreach name $names {
1573         ${button}.m add command -label $name \
1574                 -command [list ${button} configure -text $name]
1575     }
1576 }
1577
1578 proc listbuttonv-action {button var names i} {
1579     global $var
1580
1581     set $var $i
1582     $button configure -text [lindex $names $i]
1583 }
1584
1585 proc listbuttonv {button var names} {
1586     global $var
1587
1588     set n "-"
1589     eval "set val $$var"
1590     set l [llength $names]
1591     for {set i 1} {$i < $l} {incr i 2} {
1592         if {$val == [lindex $names $i]} {
1593             incr i -1
1594             set n [lindex $names $i]
1595             break
1596         }
1597     }
1598     menubutton $button -text $n -width 10 -menu ${button}.m \
1599             -relief raised -border 1
1600     menu ${button}.m
1601     for {set i 0} {$i < $l} {incr i 2} {
1602         ${button}.m add command -label [lindex $names $i] \
1603                 -command [list listbuttonv-action $button $var $names $i]
1604     }
1605 }
1606
1607 proc query-add-index-action {queryNo} {
1608     set w .setup-query-$queryNo
1609
1610     global queryInfoTmp
1611     global queryButtonsTmp
1612
1613     lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1614
1615     destroy .query-add-index
1616     #destroy $w.top.lines
1617     #frame $w.top.lines -relief ridge -border 2
1618     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1619     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1620 }
1621
1622 proc query-add-line {queryNo} {
1623     set w .setup-query-$queryNo
1624
1625     global queryInfoTmp
1626     global queryButtonsTmp
1627
1628     lappend queryButtonsTmp {I 0}
1629
1630     #destroy $w.top.lines
1631     #frame $w.top.lines -relief ridge -border 2
1632     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1633     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1634 }
1635
1636 proc query-del-line {queryNo} {
1637     set w .setup-query-$queryNo
1638
1639     global queryInfoTmp
1640     global queryButtonsTmp
1641
1642     set l [llength $queryButtonsTmp]
1643     if {$l <= 0} {
1644         return
1645     }
1646     incr l -1
1647     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1648     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1649 }
1650
1651 proc query-add-index {queryNo} {
1652     set w .query-add-index
1653
1654     toplevel $w
1655     place-force $w .setup-query-$queryNo
1656     top-down-window $w
1657     frame $w.top.index
1658     pack $w.top.index \
1659             -side top -anchor e -pady 2
1660     entry-fields $w.top {index} \
1661             {{Index Name:}} \
1662             [list query-add-index-action $queryNo] {destroy .query-add-index}
1663     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1664 }
1665
1666 proc query-setup-action {queryNo} {
1667     global queryButtons
1668     global queryInfo
1669     global queryButtonsTmp
1670     global queryInfoTmp
1671     global queryButtonsFind
1672     global queryInfoFind
1673
1674     set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1675             $queryInfoTmp]
1676     set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1677             $queryButtonsTmp]
1678     set queryInfoFind $queryInfoTmp
1679     set queryButtonsFind $queryButtonsTmp
1680
1681     puts $queryInfo
1682     puts $queryButtons
1683     destroy .setup-query-$queryNo
1684
1685     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1686 }
1687
1688 proc activate-e-index {value no i} {
1689     global queryButtonsTmp
1690
1691     puts $queryButtonsTmp
1692     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1693     puts $queryButtonsTmp
1694     puts "value $value"
1695     puts "no $no"
1696     puts "i $i"
1697 }
1698
1699 proc activate-index {value no i} {
1700     global queryButtonsFind
1701
1702     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1703
1704     puts "queryButtonsFind $queryButtonsFind"
1705     puts "value $value"
1706     puts "no $no"
1707     puts "i $i"
1708 }
1709
1710 proc query-setup {queryNo} {
1711     set w .setup-query-$queryNo
1712     global queryTypes
1713     set queryTypes {Simple}
1714     global queryButtons
1715     global queryInfo
1716     global queryButtonsTmp
1717     global queryInfoTmp
1718
1719     global relationTmpValue
1720     global structureTmpValue
1721     global truncationTmpValue
1722     global completenessTmpValue
1723     global positionTmpValue
1724
1725     set queryName [lindex $queryTypes $queryNo]
1726     set queryInfoTmp [lindex $queryInfo $queryNo]
1727     set queryButtonsTmp [lindex $queryButtons $queryNo]
1728
1729     toplevel $w
1730
1731     wm title $w "Query setup $queryName"
1732     place-force $w .
1733
1734     top-down-window $w
1735
1736     frame $w.top.lines -relief ridge -border 2
1737     frame $w.top.use -relief ridge -border 2
1738     frame $w.top.relation -relief ridge -border 2
1739     frame $w.top.position -relief ridge -border 2
1740     frame $w.top.structure -relief ridge -border 2
1741     frame $w.top.truncation -relief ridge -border 2
1742     frame $w.top.completeness -relief ridge -border 2
1743
1744     # Index Lines
1745
1746     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1747
1748     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1749
1750     # Use Attributes
1751
1752     pack $w.top.use -side left -pady 6 -padx 6 -fill y
1753
1754     label $w.top.use.label -text "Use"
1755     listbox $w.top.use.list -geometry 20x10 \
1756             -yscrollcommand "$w.top.use.scroll set"
1757     scrollbar $w.top.use.scroll -orient vertical -border 1
1758     pack $w.top.use.label -side top -fill x \
1759             -padx 2 -pady 2
1760     pack $w.top.use.list -side left -fill both -expand yes \
1761             -padx 2 -pady 2
1762     pack $w.top.use.scroll -side right -fill y \
1763             -padx 2 -pady 2
1764     $w.top.use.scroll config -command "$w.top.use.list yview"
1765
1766     foreach u {{Personal name} {Corporate name}} {
1767         $w.top.use.list insert end $u
1768     }
1769
1770     # Relation Attributes
1771
1772     pack $w.top.relation -pady 6 -padx 6 -side top
1773     label $w.top.relation.label -text "Relation" -width 18
1774
1775     set relationTmpValue 0
1776     listbuttonv $w.top.relation.b relationTmpValue\
1777             {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
1778             {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
1779             {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
1780
1781     pack $w.top.relation.label $w.top.relation.b -fill x
1782
1783     # Position Attributes
1784
1785     pack $w.top.position -pady 6 -padx 6 -side top
1786     label $w.top.position.label -text "Position" -width 18
1787
1788     set positionTmpValue 0
1789     listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
1790             {First in field} 1 {First in subfield} 2 {Any position in field} 3}
1791
1792     pack $w.top.position.label $w.top.position.b -fill x
1793
1794     # Structure Attributes
1795
1796     pack $w.top.structure -pady 6 -padx 6 -side top
1797     label $w.top.structure.label -text "Structure" -width 18
1798
1799     set structureTmpValue 0
1800     listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
1801             {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list}  6 \
1802             {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
1803             {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
1804             {local-number} 107 {string} 108 {numeric string} 109}
1805
1806     pack $w.top.structure.label $w.top.structure.b -fill x
1807
1808     # Truncation Attributes
1809
1810     pack $w.top.truncation -pady 6 -padx 6 -side top
1811     label $w.top.truncation.label -text "Truncation" -width 18
1812
1813     set truncationTmpValue 0
1814     listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
1815             {Left} 2 {Left and right} 3 {No truncation} 100 \
1816             {Process #} 101 {Re-1} 102 {Re-2} 103}
1817     pack $w.top.truncation.label $w.top.truncation.b -fill x
1818
1819     # Completeness Attributes
1820
1821     pack $w.top.completeness -pady 6 -padx 6 -side top
1822     label $w.top.completeness.label -text "Completeness" -width 18
1823
1824     set completenessTmpValue 0
1825     listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
1826             {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
1827     pack $w.top.completeness.label $w.top.completeness.b -fill x
1828
1829     # Ok-cancel
1830     bottom-buttons $w [list \
1831             {Ok} [list query-setup-action $queryNo] \
1832             {Add index} [list query-add-index $queryNo] \
1833             {Add line} [list query-add-line $queryNo] \
1834             {Delete line} [list query-del-line $queryNo] \
1835             {Cancel} [list destroy $w]] 0
1836 }
1837
1838 proc index-clear {} {
1839     global queryButtonsFind
1840
1841     set i 0
1842     foreach b $queryButtonsFind {
1843         .lines.$i.e delete 0 end
1844         incr i
1845     }
1846 }
1847
1848 proc index-query {} {
1849     global queryButtonsFind
1850     global queryInfoFind
1851
1852     set i 0
1853     set qs {}
1854
1855     foreach b $queryButtonsFind {
1856         set term [string trim [.lines.$i.e get]]
1857         if {$term != ""} {
1858             set attr [lindex [lindex $queryInfoFind [lindex $b 1]] 1]
1859
1860             set term "\{${term}\}"
1861             foreach a $attr {
1862                 set term "@attr $a ${term}"
1863             }
1864             if {$qs != ""} {
1865                 set qs "@and ${qs} ${term}"
1866             } else {
1867                 set qs $term
1868             }
1869         }
1870         incr i
1871     }
1872     puts "qs=  $qs"
1873     return $qs
1874 }
1875
1876 proc index-lines {w realOp buttonInfo queryInfo handle} {
1877     set i 0
1878     foreach b $buttonInfo {
1879         if {! [winfo exists $w.$i]} {
1880             frame $w.$i -background white -border 1
1881         }
1882         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
1883
1884         if {$realOp} {
1885             if {! [winfo exists $w.$i.e]} {
1886                 entry $w.$i.e -width 32 -relief sunken -border 1
1887                 bind $w.$i.e <FocusIn> [list $w.$i configure \
1888                         -background red]
1889                 bind $w.$i.e <FocusOut> [list $w.$i configure \
1890                         -background white]
1891                 pack $w.$i.l -side left
1892                 pack $w.$i.e -side left -fill x -expand yes
1893                 pack $w.$i -side top -fill x -padx 2 -pady 2
1894                 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1895                 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1896                 bind $w.$i.e <Return> search-request
1897             }
1898         } else {
1899             pack $w.$i.l -side left
1900             pack $w.$i -side top -fill x -padx 2 -pady 2
1901         }
1902         incr i
1903     }
1904     set j $i
1905     while {[winfo exists $w.$j]} {
1906         destroy $w.$j
1907         incr j
1908     }
1909     if {! $realOp} {
1910         return
1911     }
1912     set j 0
1913     incr i -1
1914     while {$j < $i} {
1915         set k [expr $j+1]
1916         bind $w.$j.e <Tab> "focus $w.$k.e"
1917         set j $k
1918     }
1919     if {$i >= 0} {
1920         bind $w.$i.e <Tab> "focus $w.0.e"
1921         focus $w.0.e
1922     }
1923 }
1924
1925 proc search-fields {w buttondefs} {
1926     set i 0
1927     foreach buttondef $buttondefs {
1928         frame $w.$i -background white
1929
1930         listbutton $w.$i.l 0 $buttondef
1931         entry $w.$i.e -width 32 -relief sunken
1932
1933         pack $w.$i.l -side left
1934         pack $w.$i.e -side left -fill x -expand yes
1935
1936         pack $w.$i -side top -fill x -padx 2 -pady 2
1937
1938         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1939         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1940
1941         incr i
1942     }
1943     set j 0
1944     incr i -1
1945     while {$j < $i} {
1946         set k [expr $j+1]
1947         bind $w.$j.e <Tab> "focus $w.$k.e \n
1948         $w.$k configure -background red \n
1949         $w.$j configure -background white"
1950         set j $k
1951     }
1952     bind $w.$i.e <Tab> "focus $w.0.e \n
1953         $w.0 configure -background red \n
1954         $w.$i configure -background white"
1955     focus $w.0.e
1956     $w.0 configure -background red
1957 }
1958
1959 if {[info exists windowGeometry(.)]} {
1960     set g $windowGeometry(.)
1961     if {$g != ""} {
1962         wm geometry . $g
1963     }
1964 }
1965
1966 read-formats
1967
1968 frame .top  -border 1 -relief raised
1969 frame .lines  -border 1 -relief raised
1970 frame .mid  -border 1 -relief raised
1971 frame .data -border 1 -relief raised
1972 frame .bot  -border 1 -relief raised
1973 pack .top .lines .mid -side top -fill x
1974 pack .data -side top -fill both -expand yes
1975 pack .bot -fill x
1976
1977 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
1978 menu .top.file.m
1979 .top.file.m add command -label "Save settings" -command {save-settings}
1980 .top.file.m add separator
1981 .top.file.m add command -label "Exit" -command {exit-action}
1982
1983 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
1984 menu .top.target.m
1985 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
1986 .top.target.m add command -label "Disconnect" -command {close-target}
1987 .top.target.m add command -label "About" -command {about-target}
1988 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
1989 .top.target.m add command -label "Setup new" -command {define-target-dialog}
1990 .top.target.m add separator
1991 set-target-hotlist
1992
1993 .top.target.m disable 1
1994 .top.target.m disable 2
1995
1996 menu .top.target.m.clist
1997 menu .top.target.m.slist
1998 cascade-target-list
1999
2000 menubutton .top.service -text "Service" -underline 0 -menu .top.service.m
2001 menu .top.service.m
2002 .top.service.m add command -label "Database" -command {database-select}
2003 .top.service.m add cascade -label "Query type" -menu .top.service.m.querytype
2004 menu .top.service.m.querytype
2005 .top.service.m.querytype add radiobutton -label "RPN"
2006 .top.service.m.querytype add radiobutton -label "CCL"
2007 .top.service.m add cascade -label "Present" -menu .top.service.m.present
2008 menu .top.service.m.present
2009 .top.service.m.present add command -label "More" \
2010         -command [list present-more 10]
2011 .top.service.m.present add command -label "All" \
2012         -command [list present-more {}]
2013 .top.service configure -state disabled
2014
2015 menubutton .top.rset -text "Set" -menu .top.rset.m
2016 menu .top.rset.m
2017 .top.rset.m add command -label "Load" -command {load-set}
2018 .top.rset.m add separator
2019
2020 menubutton .top.options -text "Options" -underline 0 -menu .top.options.m
2021 menu .top.options.m
2022 .top.options.m add cascade -label "Choose query" -menu .top.options.m.clist
2023 .top.options.m add command -label "Define query" -command {new-query-dialog}
2024 .top.options.m add cascade -label "Edit query" -menu .top.options.m.slist
2025 .top.options.m add cascade -label "Format" -menu .top.options.m.formats
2026
2027 menu .top.options.m.slist
2028 menu .top.options.m.clist
2029 menu .top.options.m.formats
2030 cascade-query-list
2031 set i 0
2032 foreach f $displayFormats {
2033     .top.options.m.formats add radiobutton -label $f \
2034             -command [list set-display-format $i]
2035     incr i
2036 }
2037
2038 menubutton .top.help -text "Help" -menu .top.help.m
2039 menu .top.help.m
2040
2041 .top.help.m add command -label "Help on help" \
2042         -command {tkerror "Help on help not available. Sorry"}
2043 .top.help.m add command -label "About" -command {about-origin}
2044
2045 pack .top.file .top.target .top.service .top.rset .top.options -side left
2046 pack .top.help -side right
2047
2048 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
2049
2050 button .mid.search -width 7 -text {Search} -command search-request \
2051         -state disabled
2052 button .mid.scan -width 7 -text {Scan} \
2053         -command [list scan-request "@attr 1=4 @attr 5=1 @attr 4=1"] -state disabled
2054 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
2055         -state disabled
2056
2057 button .mid.clear -width 7 -text {Clear} -command index-clear
2058 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
2059         -fill y -padx 5 -pady 3
2060
2061 text .data.record -height 2 -width 20 -wrap none \
2062         -yscrollcommand [list .data.scroll set]
2063 scrollbar .data.scroll -command [list .data.record yview]
2064 pack .data.scroll -side right -fill y
2065 pack .data.record -expand yes -fill both
2066 readonlyText .data.record
2067
2068 if {[tk colormodel .] == "color"} {
2069     .data.record tag configure marc-tag -foreground blue
2070     .data.record tag configure marc-id -foreground red
2071 } else {
2072     .data.record tag configure marc-tag -foreground black
2073     .data.record tag configure marc-id -foreground black
2074 }
2075 .data.record tag configure marc-data -foreground black
2076
2077 button .bot.logo  -bitmap @book1 -command cancel-operation
2078 frame .bot.a
2079 pack .bot.a -side left -fill x
2080 pack .bot.logo -side right -padx 2 -pady 2
2081
2082 message .bot.a.target -text "" -aspect 1000 -border 1
2083
2084 label .bot.a.status -text "Not connected" -width 15 -relief \
2085         sunken -anchor w -border 1
2086 label .bot.a.set -text "" -width 5 -relief \
2087         sunken -anchor w -border 1
2088 label .bot.a.message -text "" -width 15 -relief \
2089         sunken -anchor w -border 1
2090
2091 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
2092 pack .bot.a.status .bot.a.set .bot.a.message \
2093         -side left -padx 2 -pady 2
2094
2095 #bind . <Any-Enter> {focus .lines.0.e}
2096
2097 ir z39
2098
2099 .top.options.m.formats invoke $displayFormat
2100
2101 show-logo 1
2102