client.tcl

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