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