client2/client.tcl

   1 wm title . "IrTcl Client"
   2 wm iconname . "IrTcl Client"
   3
   4
   5 # Procedure irmenu
   6 proc irmenu {w} {
   7         menu $w -tearoff off
   8 }
   9
  10
  11 # Procedure configure-enable-e {w n}
  12 #  w   is a menu
  13 #  n   menu entry number (0 is first entry)
  14 # Enables menu entry
  15 proc configure-enable-e {w n} {
  16         $w entryconfigure $n -state normal
  17 }
  18
  19 # Procedure configure-disable-e {w n}
  20 #  w   is a menu
  21 #  n   menu entry number (0 is first entry)
  22 # Disables menu entry
  23 proc configure-disable-e {w n} {
  24         $w entryconfigure $n -state disabled
  25 }
  26 set noFocus [list -takefocus 0]
  27
  28
  29 # Define dummy clock function if it is not there.
  30 if {[catch {clock seconds}]} {
  31     proc clock {args} {
  32         return {}
  33     }
  34 }
  35
  36 # Define libdir to the IrTcl configuration directory.
  37 # In the line below LIBDIR will be modified during 'make install'.
  38 set libdir LIBDIR
  39
  40 # If the bitmaps sub directory is present with a bitmap we assume
  41 # the client is run from the source directory in which case we
  42 # set libdir the current directory.
  43 if {[file readable bitmaps/book2]} {
  44     set libdir .
  45 }
  46
  47 # Make a final check to see if libdir was set ok.
  48 if {! [file readable ${libdir}/bitmaps/book2]} {
  49     puts "Cannot locate system files in ${libdir}. You must either run this"
  50     puts "program from the source directory root of ir-tcl or you must assure"
  51     puts "that it is installed - normally in /usr/local/lib/irtcl"
  52     exit 1
  53 }
  54
  55 # Initialize a lot of globals.
  56 set hotTargets {}
  57 set hotInfo {}
  58 set busy 0
  59
  60 set profile(Default,description) {}
  61 set profile(Default,host) {}
  62 set profile(Default,port) 210
  63 set profile(Default,authentication) {}
  64 set profile(Default,maximumRecordSize) 50000
  65 set profile(Default,preferredMessageSize) 30000
  66 set profile(Default,comstack) tcpip
  67 set profile(Default,namedResultSets) 1
  68 set profile(Default,queryRPN) 1
  69 set profile(Default,queryCCL) 0
  70 set profile(Default,protocol) Z39
  71 set profile(Default,windowNumber) 1
  72 set profile(Default,largeSetLowerBound) 2
  73 set profile(Default,smallSetUpperBound) 0
  74 set profile(Default,mediumSetPresentNumber) 0
  75 set profile(Default,presentChunk) 4
  76 set profile(Default,timeDefine) {}
  77 set profile(Default,timeLastInit) {}
  78 set profile(Default,timeLastExplain) {}
  79 set profile(Default,targetInfoName) {}
  80 set profile(Default,recentNews) {}
  81 set profile(Default,maxResultSets) {}
  82 set profile(Default,maxResultSize) {}
  83 set profile(Default,maxTerms) {}
  84 set profile(Default,multipleDatabases) 0
  85 set profile(Default,welcomeMessage) {}
  86
  87 set hostid Default
  88 set currentDb Default
  89 set settingsChanged 0
  90 set setNo 0
  91 set setNoLast 0
  92 set cancelFlag 0
  93 set scanEnable 0
  94 set displayFormat 1
  95 set popupMarcdf 0
  96 set textWrap word
  97 set recordSyntax None
  98 set elementSetNames None
  99 set delayRequest {}
 100 set debugMode 0
 101
 102 set queryTypes {Simple}
 103 set queryButtons { { {I 0} {I 1} {I 2} } }
 104 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
 105         {Subject {1=21}} {Any {1=1016}} } }
 106 set queryAuto 1
 107 wm minsize . 0 0
 108
 109 set setOffset 0
 110 set setMax 0
 111
 112 set font(bb,normal) {Helvetica 24}
 113 set font(bb,bold) {Helvetica 24 bold}
 114 set font(b,normal) {Helvetica 24}
 115 set font(b,bold) {Helvetica 18 bold}
 116 set font(n,normal) {Helvetica 12}
 117 set font(n,bold) {Helvetica 12 bold}
 118 set font(s,bold) {Helvetica 10 bold}
 119 set font(ss,bold) {Helvetica 8 bold}
 120
 121 # Procedure tkerror {err}
 122 #   err   error message
 123 # Override the Tk error handler function.
 124 if {1} {
 125     proc tkerror err {
 126                 global font
 127                 set w .tkerrorw
 128
 129                 if {[winfo exists $w]} {
 130                     destroy $w
 131                 }
 132                 toplevel $w
 133                 wm title $w "Error"
 134
 135                 place-force $w .
 136                 top-down-window $w
 137
 138                 label $w.top.b -bitmap error
 139                 message $w.top.t -aspect 300 -text "Error: $err" -font $font(b,bold)
 140                 pack $w.top.b $w.top.t -side left -padx 10 -pady 10
 141
 142                 bottom-buttons $w [list {Close} [list destroy $w]] 1
 143     }
 144 }
 145
 146 # Read tag set file (if present)
 147 if {[file readable "${libdir}/tagsets.tcl"]} {
 148     source "${libdir}/tagsets.tcl"
 149 }
 150
 151 # Read the global target configuration file.
 152 if {[file readable "${libdir}/irtdb.tcl"]} {
 153     source "${libdir}/irtdb.tcl"
 154 }
 155 # Read the local target configuration file.
 156 if {[file readable "irtdb.tcl"]} {
 157     source "irtdb.tcl"
 158 }
 159
 160 # Read the user configuration file.
 161 if {[file readable "${libdir}/.clientrc.tcl"]} {
 162     source "${libdir}/.clientrc.tcl"
 163 }
 164
 165 source "bib-1.tcl"
 166
 167 # Convert old format to new format...
 168 foreach target [array names profile] {
 169     set timedef [clock seconds]
 170     if {[string first , $target] == -1} {
 171         if {![info exists profile($target,port)]} {
 172             foreach n [array names profile Default,*] {
 173                 set profile($target,[string range $n 8 end]) $profile($n)
 174             }
 175             set profile($target,description) [lindex $profile($target) 0]
 176             set profile($target,host) [lindex $profile($target) 1]
 177             set profile($target,port) [lindex $profile($target) 2]
 178             set profile($target,authentication) [lindex $profile($target) 3]
 179             set profile($target,maximumRecordSize) \
 180                 [lindex $profile($target) 4]
 181             set profile($target,preferredMessageSize) \
 182                 [lindex $profile($target) 5]
 183             set profile($target,comstack) [lindex $profile($target) 6]
 184             set profile($target,databases) [lindex $profile($target) 7]
 185             set profile($target,timeDefine) $timedef
 186             set profile($target,windowNumber) 1
 187         }
 188         unset profile($target)
 189     }
 190 }
 191
 192 # Assign unique ID's to each target's window number
 193 set wno 1
 194 foreach n [array names profile *,windowNumber] {
 195     set profile($n) $wno
 196     incr wno
 197 }
 198 set profile(Default,windowNumber) $wno
 199
 200 # These globals describe the current query type. They are set to the
 201 # first query type.
 202 set queryButtonsFind [lindex $queryButtons 0]
 203 set queryInfoFind [lindex $queryInfo 0]
 204
 205 # Procedure read-formats
 206 # Read all Tcl source files in the subdirectory 'formats'.
 207 # The name of each source will correspond to a display format.
 208 proc read-formats {} {
 209     global displayFormats
 210     global libdir
 211
 212     set oldDir [pwd]
 213     cd ${libdir}/formats
 214     set formats [glob {*.[tT][cC][lL]}]
 215     foreach f $formats {
 216         if {[file readable $f]} {
 217             source $f
 218             set l [string length $f]
 219             set f [string tolower [string range $f 0 [expr $l - 5]]]
 220             lappend displayFormats $f
 221         }
 222     }
 223     cd $oldDir
 224 }
 225
 226 # Procedure set-wrap {m}
 227 #  m    boolean wrap mode
 228 # Handler to enable/disable text wrap in the main record window
 229 proc set-wrap {m} {
 230     global textWrap
 231
 232     set textWrap $m
 233     .data.record configure -wrap $m
 234 }
 235
 236 # Procedure dputs {m}
 237 #  m    string to be printed
 238 # puts utility for debugging.
 239 proc dputs {m} {
 240     global debugMode
 241     if {$debugMode} {
 242         puts $m
 243     }
 244 }
 245
 246 # Procedure apduDump {}
 247 # Logs BER dump of last APDU in window if debugMode is true.
 248 proc apduDump {} {
 249     global debugMode
 250
 251     set w .apdu
 252
 253     if {$debugMode == 0} return
 254     set x [z39 apduInfo]
 255
 256     set offset [lindex $x 1]
 257     set length [lindex $x 0]
 258
 259     if {![winfo exists $w]} {
 260         catch {destroy $w}
 261         toplevelG $w
 262
 263         wm title $w "APDU information"
 264         wm minsize $w 0 0
 265
 266         top-down-window $w
 267
 268         text $w.top.t -font fixed -width 60 -height 12 -wrap word \
 269                         -relief flat -borderwidth 0 \
 270                         -yscrollcommand [list $w.top.s set] -background grey85
 271         scrollbar $w.top.s -command [list $w.top.t yview]
 272         pack $w.top.s -side right -fill y
 273         pack $w.top.t -expand yes -fill both
 274
 275         bottom-buttons $w [list {Close} [list destroy $w]] 0
 276     }
 277     $w.top.t insert end "Length: ${length}\n"
 278     if {$offset != -1} {
 279         $w.top.t insert end "Offset: ${offset}\n"
 280     }
 281     $w.top.t insert end [lindex $x 2]
 282     $w.top.t insert end "---------------------------------\n"
 283
 284 }
 285
 286 # Procedure set-display-format {f}
 287 #  f    display format
 288 # Reformats main record window to use display format given by f
 289 proc set-display-format {f} {
 290     global displayFormat setNo busy
 291
 292     set displayFormat $f
 293     if {$setNo == 0} {
 294         return
 295     }
 296     if {!$busy} {
 297         .bot.a.status configure -text "Reformatting"
 298     }
 299     update idletasks
 300     add-title-lines -1 10000 1
 301 }
 302
 303 # Procedure initBindings
 304 # Disables various default bindings for Text and Listbox widgets.
 305 proc initBindings {} {
 306     global TextBinding
 307
 308     foreach e [bind Text] {
 309         set TextBinding($e) [bind Text $e]
 310         bind Text $e {}
 311     }
 312     set w Listbox
 313     bind $w <B1-Motion> {}
 314     bind $w <Shift-B1-Motion> {}
 315
 316     set w Entry
 317 }
 318
 319 # Procedure TextEditable
 320 # Apply "standard" events to a text widget. It should be editable now.
 321 proc TextEditable {w} {
 322     global TextBinding
 323
 324     foreach e [array names TextBinding] {
 325         bind $w $e $TextBinding($e)
 326     }
 327 }
 328
 329 # Procedure post-menu {wbutton wmenu}
 330 #   wbutton    button widget
 331 #   wmenu      menu widget
 332 # Post menu near button. Note: not used.
 333 proc post-menu {wbutton wmenu} {
 334     $wmenu activate none
 335     focus $wmenu
 336     $wmenu post [winfo rootx $wbutton] \
 337             [expr [winfo rooty $wbutton]+[winfo height $wbutton]]
 338
 339 }
 340
 341 # Procedure destroyGW {w}
 342 #   w     top level widget
 343 # Saves geometry of widget w in windowGeometry array. This
 344 # Procedure is used to save current geometry of a window before
 345 # it is destroyed.
 346 # See also topLevelG.
 347 proc destroyGW {w} {
 348     global windowGeometry
 349     catch {set windowGeometry($w) [wm geometry $w]}
 350 }
 351
 352 # Procedure topLevelG
 353 #   w     top level widget
 354 # Makes a new top level widget named w; sets geometry of window if it
 355 # exists in windowGeometry array. The destroyGW procedure is set
 356 # to be called when the Destroy event occurs.
 357 proc toplevelG {w} {
 358     global windowGeometry
 359
 360     toplevel $w
 361     if {[info exists windowGeometry($w)]} {
 362         set g $windowGeometry($w)
 363         if {$g != ""} {
 364             wm geometry $w $g
 365         }
 366     }
 367     bind $w <Destroy> [list destroyGW $w]
 368 }
 369
 370 # Procedure top-down-window {w}
 371 #  w    window (possibly top level)
 372 # Makes two frames inside w called top and bot.
 373 proc top-down-window {w} {
 374     frame $w.top -relief raised -border 1
 375     frame $w.bot -relief raised -border 1
 376     pack  $w.top -side top -fill both -expand yes
 377     pack  $w.bot -fill both
 378 }
 379
 380 # Procedure top-down-ok-cancel {w ok-action g}
 381 #  w          top level widget with $w.bot-frame
 382 #  ok-action  ok script
 383 #  g          grab flag
 384 # Makes two buttons in the bot frame called Ok and Cancel. The
 385 # ok-action is executed if Ok is pressed. If Cancel is activated
 386 # The window is destroyed. If g is true a grab is performed on the
 387 # window and the procedure waits until the window is destroyed.
 388 proc top-down-ok-cancel {w ok-action g} {
 389     frame $w.bot.left -relief sunken -border 1
 390     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 1 -pady 1
 391     button $w.bot.left.ok -width 4 -text {Ok} -command ${ok-action}
 392     pack $w.bot.left.ok -expand yes -ipadx 1 -ipady 1 -padx 2 -pady 2
 393     button $w.bot.cancel -width 5 -text {Cancel} -command [list destroy $w]
 394     pack $w.bot.cancel -side left -expand yes
 395
 396     if {$g} {
 397         grab $w
 398         tkwait window $w
 399     }
 400 }
 401
 402 # Procedure bottom-buttons {w buttonList g}
 403 #  w          top level widget with $w.bot-frame
 404 #  buttonList button specifications
 405 #  g          grab flag
 406 # Makes a list of buttons in the $w.bot frame. The buttonList is a list
 407 # of button specifications. Each button specification consists of two
 408 # items; the first item is button label name; the second item is a script
 409 # of be executed when that button is executed. A grab is performed if g
 410 # is true and it waits for the window to be destroyed.
 411 proc bottom-buttons {w buttonList g} {
 412     set i 0
 413     set l [llength $buttonList]
 414
 415     frame $w.bot.$i -relief sunken -border 1
 416     pack $w.bot.$i -side left -expand yes -padx 2 -pady 2
 417     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 418                 -command [lindex $buttonList [expr $i+1]]
 419     pack $w.bot.$i.ok -expand yes -padx 2 -pady 2 -side left
 420
 421     incr i 2
 422     while {$i < $l} {
 423         button $w.bot.$i -text [lindex $buttonList $i] \
 424                 -command [lindex $buttonList [expr $i+1]]
 425         pack $w.bot.$i -expand yes -padx 2 -pady 2 -side left
 426         incr i 2
 427     }
 428     if {$g} {
 429         # Grab ...
 430         grab $w
 431         tkwait window $w
 432     }
 433 }
 434
 435 # Procedure cancel-operation
 436 # This handler is invoked when the user wishes to cancel an operation.
 437 # If the system is currently busy a "Cancel" will be displayed in the
 438 # status area and the cancelFlag is set to true indicating that future
 439 # responses from the target should be ignored. The system is no longer
 440 # busy when this procedure exists.
 441 proc cancel-operation {} {
 442     global cancelFlag busy delayRequest
 443
 444     if {$busy} {
 445         set cancelFlag 1
 446         set delayRequest {}
 447         show-status Cancel 0 1
 448     }
 449 }
 450
 451 # Procedure show-target {target base}
 452 #  target     name of target
 453 #  base       name of database
 454 # Displays target name and database name in the target status area.
 455 proc show-target {target base} {
 456     if {![string length $target]} {
 457         .bot.a.target configure -text {}
 458         return
 459     }
 460     if {![string length $base]} {
 461                 .bot.a.target configure -text "$target"
 462     } else {
 463          .bot.a.target configure -text "$target - $base"
 464     }
 465 }
 466
 467 # Procedure show-logo {v1}
 468 #  v1    integer level
 469 # This procedure maintains the book logo in the bottom of the screen.
 470 # It is invoked only once during initialization of windows, etc., and
 471 # by itself. The global 'busy' variable determines whether the logo is
 472 # moving or not.
 473 proc show-logo {v1} {
 474     global busy libdir
 475
 476     if {$busy != 0} {
 477         incr v1
 478         if {$v1==10} {
 479             set v1 1
 480         }
 481         .bot.logo configure -bitmap @${libdir}/bitmaps/book${v1}
 482         after 140 [list show-logo $v1]
 483         return
 484     }
 485     while {1} {
 486         .bot.logo configure -bitmap @${libdir}/bitmaps/book1
 487         tkwait variable busy
 488         if {$busy} {
 489             show-logo 1
 490             return
 491         }
 492     }
 493 }
 494
 495 # Procedure show-status {status b sb}
 496 #  status     status message string
 497 #  b          busy indicator
 498 #  sb         search busy indicator
 499 # Display status information according to 'status' and sets the global
 500 # busy flag 'busy' to b if b is non-empty. If sb is non-empty it indicates
 501 # whether service buttons should be enabled or disabled.
 502 proc show-status {status b sb} {
 503     global busy scanEnable setOffset setMax setNo
 504
 505     .bot.a.status configure -text "$status"
 506     if {$b == 1} {
 507         if {$busy == 0} {set busy 1}
 508     } else {
 509         set busy 0
 510     }
 511     if {$sb == {}} {
 512         return
 513     }
 514     if {$sb} {
 515         .top.service configure -state normal
 516         .mid.search configure -state normal
 517         if {$scanEnable} {
 518             .mid.scan configure -state normal
 519         } else {
 520             configure-disable-e .top.service.m 3
 521         }
 522         if {$setNo == 0} {
 523             configure-disable-e .top.service.m 1
 524         } elseif {[z39.$setNo nextResultSetPosition] > 0 &&
 525             [z39.$setNo nextResultSetPosition] <= [z39.$setNo resultCount]} {
 526             configure-enable-e .top.service.m 1
 527             .mid.present configure -state normal
 528         } else {
 529             configure-disable-e .top.service.m 1
 530             .mid.present configure -state disabled
 531         }
 532         if {[winfo exists .scan-window]} {
 533             .scan-window.bot.2 configure -state normal
 534             .scan-window.bot.4 configure -state normal
 535         }
 536     } else {
 537         .top.service configure -state disabled
 538         .mid.search configure -state disabled
 539         .mid.scan configure -state disabled
 540         .mid.present configure -state disabled
 541
 542         if {[winfo exists .scan-window]} {
 543             .scan-window.bot.2 configure -state disabled
 544             .scan-window.bot.4 configure -state disabled
 545         }
 546     }
 547 }
 548
 549 # Procedure show-message {msg}
 550 #  msg    message string
 551 # Sets message the bottom of the screen to msg.
 552 proc show-message {msg} {
 553     .bot.a.message configure -text "$msg"
 554 }
 555
 556 # Procedure insertWithTags {w text args}
 557 #  w      text widget
 558 #  text   string to be inserted
 559 #  args   list of tags
 560 # Inserts text at the insertion point in widget w. The text is tagged
 561 # with the tags in args.
 562 proc insertWithTags {w text args} {
 563     set start [$w index insert]
 564     $w insert insert $text
 565     foreach tag [$w tag names $start] {
 566         $w tag remove $tag $start insert
 567     }
 568     foreach i $args {
 569         $w tag add $i $start insert
 570     }
 571 }
 572
 573 # Procedure popup-license and displays LICENSE information.
 574 proc popup-license {} {
 575     global libdir
 576     set w .popup-license
 577     toplevel $w
 578
 579     wm title $w "License"
 580     wm minsize $w 0 0
 581
 582     top-down-window $w
 583
 584     text $w.top.t -width 80 -height 10 -wrap word -relief flat -borderwidth 0 \
 585         -font fixed -yscrollcommand [list $w.top.s set]
 586     scrollbar $w.top.s -command [list $w.top.t yview]
 587     pack $w.top.s -side right -fill y
 588     pack $w.top.t -expand yes -fill both
 589
 590     if {[file readable "${libdir}/LICENSE"]} {
 591         set f [open "${libdir}/LICENSE" r]
 592         while {[gets $f buf] != -1} {
 593             $w.top.t insert end $buf
 594             $w.top.t insert end "\n"
 595         }
 596         close $f
 597     }
 598     bottom-buttons $w [list {Close} [list destroy $w]] 1
 599 }
 600
 601 # Procedure about-target
 602 # Displays various information about the current target, such
 603 # as implementation-name, implementation-id, etc.
 604 proc about-target {} {
 605     set w .about-target-w
 606     global hostid font
 607
 608     toplevel $w
 609
 610     wm title $w "About target"
 611     place-force $w .
 612     top-down-window $w
 613
 614     frame $w.top.a -relief ridge -border 2
 615     frame $w.top.p -relief ridge -border 2
 616     pack $w.top.a $w.top.p -side top -fill x
 617
 618     label $w.top.a.about -text "About"
 619     label $w.top.a.irtcl -text $hostid -font $font(bb,bold)
 620     pack $w.top.a.about $w.top.a.irtcl -side top
 621
 622     set i [z39 targetImplementationName]
 623     label $w.top.p.in -text "Implementation name: $i"
 624     set i [z39 targetImplementationId]
 625     label $w.top.p.ii -text "Implementation id: $i"
 626     set i [z39 targetImplementationVersion]
 627     label $w.top.p.iv -text "Implementation version: $i"
 628     set i [z39 options]
 629     label $w.top.p.op -text "Protocol options: $i"
 630     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
 631
 632     bottom-buttons $w [list {Close} [list destroy $w]] 1
 633 }
 634
 635 # Procedure about-origin-logo {n}
 636 #   n    integer level
 637 # Displays book logo in the .about-origin-w widget
 638 proc about-origin-logo {n} {
 639     global libdir
 640     set w .about-origin-w
 641     if {![winfo exists $w]} {
 642         return
 643     }
 644     incr n
 645     if {$n==10} {
 646         set n 1
 647     }
 648     $w.top.a.logo configure -bitmap @${libdir}/bitmaps/book$n
 649     after 140 [list about-origin-logo $n]
 650 }
 651
 652 # Procedure about-origin
 653 # Display various information about origin (this client).
 654 proc about-origin {} {
 655     set w .about-origin-w
 656     global libdir font tk_version
 657
 658     if {[winfo exists $w]} {
 659         destroy $w
 660     }
 661     toplevel $w
 662
 663     wm title $w "About IrTcl"
 664     place-force $w .
 665     top-down-window $w
 666
 667     frame $w.top.a -relief ridge -border 2
 668     frame $w.top.p -relief ridge -border 2
 669     pack $w.top.a $w.top.p -side top -fill x
 670
 671     label $w.top.a.irtcl -text "IrTcl" -font $font(bb,bold)
 672     label $w.top.a.logo -bitmap @${libdir}/bitmaps/book1
 673     pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
 674
 675     set i unknown
 676     catch {set i [z39 implementationName]}
 677     label $w.top.p.in -text "Implementation name: $i"
 678     catch {set i [z39 implementationId]}
 679     label $w.top.p.ii -text "Implementation id: $i"
 680     catch {set i [z39 implementationVersion]}
 681     label $w.top.p.iv -text "Implementation version: $i"
 682     set i $tk_version
 683     label $w.top.p.tk -text "Tk version: $i"
 684     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.tk -side top -anchor nw
 685
 686     about-origin-logo 1
 687     bottom-buttons $w [list {Close} [list destroy $w] \
 688                             {License} [list popup-license]] 0
 689 }
 690
 691 # Procedure popup-marc {sno no b df}
 692 #  sno     result set number
 693 #  no      record position number
 694 #  b       popup window number
 695 #  df      display format
 696 # Displays record in set $sno at position $no in window .full-marc$b.
 697 # The global variable $popupMarcdf holds the current format method.
 698 proc popup-marc {sno no b df} {
 699     global font displayFormats popupMarcdf
 700
 701     if {[z39.$sno type $no] != "DB"} {
 702         return
 703     }
 704     if {$b == -1} {
 705         set b 0
 706         while {[winfo exists .full-marc$b]} {
 707             incr b
 708         }
 709     }
 710     set df $popupMarcdf
 711     set w .full-marc$b
 712     if {![winfo exists $w]} {
 713         toplevelG $w
 714
 715         wm minsize $w 0 0
 716
 717         frame $w.top -relief raised -border 1
 718         frame $w.bot -relief raised -border 1
 719         pack  $w.top -side top -fill both -expand yes
 720         pack  $w.bot -fill both
 721
 722         text $w.top.record -width 60 -height 5 -wrap word -relief flat \
 723             -borderwidth 0 -font fixed \
 724             -yscrollcommand [list $w.top.s set] -background grey85
 725         scrollbar $w.top.s -command [list $w.top.record yview]
 726         $w.top.record tag configure marc-tag -foreground blue
 727         $w.top.record tag configure marc-id -foreground red
 728         $w.top.record tag configure marc-data -foreground black
 729         $w.top.record tag configure marc-head -font $font(n,bold) \
 730                 -background black -foreground white
 731         $w.top.record tag configure marc-pref -font $font(n,normal) -foreground blue
 732         $w.top.record tag configure marc-text -font $font(n,normal) -foreground black
 733         $w.top.record tag configure marc-it -font $font(n,normal) -foreground black
 734
 735         pack $w.top.s -side right -fill y
 736         pack $w.top.record -expand yes -fill both
 737
 738         bottom-buttons $w [list \
 739             {Close} [list destroy $w] \
 740             {Prev} {} \
 741             {Next} {} \
 742             {Duplicate} {}] 0
 743         menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m -relief raised
 744         irmenu $w.bot.formats.m
 745         pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 746     } else {
 747         $w.bot.formats.m delete 0 last
 748     }
 749     set i 0
 750     foreach f $displayFormats {
 751         $w.bot.formats.m add radiobutton -label $f -variable popupMarcdf -value $i \
 752                 -command [list popup-marc $sno $no $b 0]
 753         incr i
 754     }
 755     $w.top.record delete 0.0 end
 756     set recordType [z39.$sno recordType $no]
 757     wm title $w "$recordType record #$no"
 758
 759     $w.bot.2 configure -command [list popup-marc $sno [expr $no-1] $b $df]
 760     $w.bot.4 configure -command [list popup-marc $sno [expr $no+1] $b $df]
 761     if {$no == 1} {
 762         $w.bot.2 configure -state disabled
 763     } else {
 764         $w.bot.2 configure -state normal
 765     }
 766     if {[z39.$sno type [expr $no+1]] != "DB"} {
 767         $w.bot.4 configure -state disabled
 768     } else {
 769         $w.bot.4 configure -state normal
 770     }
 771     $w.bot.6 configure -command [list popup-marc $sno $no -1 0]
 772     set ffunc [lindex $displayFormats $df]
 773     set ffunc "display-$ffunc"
 774
 775     $ffunc $sno $no $w.top.record 0
 776 }
 777
 778 # Procedure update-target-hotlist {target base}
 779 #  target     current target name
 780 #  base       current database name
 781 # Updates the global $hotTargets so that $target and $base are
 782 # moved to the front, i.e. they become the number 1 target/base.
 783 # The target menu is updated by a call to set-target-hotlist.
 784 proc update-target-hotlist {target base} {
 785     global hotTargets
 786
 787     set olen [llength $hotTargets]
 788     set i 0
 789     foreach e $hotTargets {
 790         if {$target == [lindex $e 0] && $base == [lindex $e 1]} {
 791             set hotTargets [lreplace $hotTargets $i $i]
 792             break
 793         }
 794         incr i
 795     }
 796     set hotTargets [linsert $hotTargets 0 [list $target $base]]
 797     set-target-hotlist $olen
 798 }
 799
 800 # Procedure delete-target-hotlist {target}
 801 #  target    target to be deleted
 802 # Updates the global $hotTargets so that $target is removed.
 803 # The target menu is updated by a call to set-target-hotlist.
 804 proc delete-target-hotlist {target} {
 805     global hotTargets
 806
 807     set olen [llength $hotTargets]
 808     set i 0
 809     foreach e $hotTargets {
 810         if {$target == [lindex $e 0]} {
 811             set hotTargets [lreplace $hotTargets $i $i]
 812         }
 813         incr i
 814     }
 815     set-target-hotlist $olen
 816 }
 817
 818 # Procedure set-target-hotlist {olen}
 819 #  olen     number of hot target entries to be deleted from menu
 820 # Updates the target menu with the targets with the first 8 entries
 821 # in the $hotTargets global.
 822 proc set-target-hotlist {olen} {
 823     global hotTargets
 824
 825     if {$olen > 0} {
 826        .top.target.m delete 6 [expr 6+$olen]
 827     }
 828     set i 1
 829     foreach e $hotTargets {
 830         set target [lindex $e 0]
 831         set base [lindex $e 1]
 832         if {![string length $base]} {
 833             .top.target.m add command -label "$i $target" -command \
 834                 [list reopen-target $target {}]
 835         } else {
 836             .top.target.m add command -label "$i $target - $base" -command \
 837                 [list reopen-target $target $base]
 838         }
 839         incr i
 840         if {$i > 8} {
 841              break
 842         }
 843     }
 844 }
 845
 846 # Procedure reopen-target {target base}
 847 #  target    target to be opened
 848 #  base      base to be used
 849 # Closes connection with current target and opens a new connection
 850 # with $target and database $base.
 851 proc reopen-target {target base} {
 852     close-target
 853     open-target $target $base
 854     update-target-hotlist $target $base
 855 }
 856
 857 # Procedure define-target-action
 858 # Prepares the setup of a new target. The name of the target
 859 # is read from the dialog .target-define dialog (procedure
 860 # define-target-dialog) and the target definition window is displayed by
 861 # a call to protocol-setup.
 862 proc define-target-action {} {
 863     global profile
 864
 865     set target [.target-define.top.target.entry get]
 866     if {![string length $target]} {
 867         return
 868     }
 869     foreach n [array names profile *,host] {
 870         if {![string compare $n ${target},host]} {
 871             destroy .target-define
 872             protocol-setup $n
 873             return
 874         }
 875     }
 876     foreach n [array names profile Default,*] {
 877         set profile($target,[string range $n 8 end]) $profile($n)
 878
 879     }
 880     incr profile(Default,windowNumber)
 881
 882     protocol-setup $target
 883     destroy .target-define
 884 }
 885
 886 # Procedure fail-response {target}
 887 #  target   current target
 888 # Error handler (IrTcl failback) that takes care of serious protocol
 889 # errors, connection lost, etc.
 890 proc fail-response {target} {
 891     global debugMode
 892
 893     set c [lindex [z39 failInfo] 0]
 894     set m [lindex [z39 failInfo] 1]
 895     if {$c == 4 || $c == 5} {
 896         set debugMode 1
 897         apduDump
 898     }
 899     close-target
 900     tkerror "$m ($c)"
 901 }
 902
 903 # Procedure connect-response {target base}
 904 #  target   current target
 905 #  base     current database
 906 # IrTcl connect response handler.
 907 proc connect-response {target base} {
 908     dputs "connect-response"
 909     init-request $target $base
 910 }
 911
 912 # Procedure open-target {target base}
 913 #  target   target to be opened
 914 #  base     database to be used
 915 # Opens a new connection with $target/$base.
 916 proc open-target {target base} {
 917     global profile hostid presentChunk currentDb
 918
 919     z39 disconnect
 920     z39 comstack $profile($target,comstack)
 921     z39 protocol $profile($target,protocol)
 922     eval z39 idAuthentication $profile($target,authentication)
 923     z39 maximumRecordSize $profile($target,maximumRecordSize)
 924     z39 preferredMessageSize $profile($target,preferredMessageSize)
 925     dputs "maximumRecordSize=[z39 maximumRecordSize]"
 926     dputs "preferredMessageSize=[z39 preferredMessageSize]"
 927     show-status Connecting 1 0
 928     set x $profile($target,largeSetLowerBound)
 929     if {![string length $x]} {
 930         set x 2
 931     }
 932     z39 largeSetLowerBound $x
 933
 934     set x $profile($target,smallSetUpperBound)
 935     if {![string length $x]} {
 936         set x 0
 937     }
 938     z39 smallSetUpperBound $x
 939
 940     set x $profile($target,mediumSetPresentNumber)
 941     if {![string length $x]} {
 942         set x 0
 943     }
 944     z39 mediumSetPresentNumber $x
 945
 946     set presentChunk $profile($target,presentChunk)
 947     if {![string length $presentChunk]} {
 948         set presentChunk 4
 949     }
 950
 951     z39 failback [list fail-response $target]
 952     z39 callback [list connect-response $target $base]
 953     show-target $target $base
 954     update idletasks
 955     set err [catch {
 956         z39 connect $profile($target,host):$profile($target,port)
 957     } errorMessage]
 958     if {$err} {
 959         set hostid Default
 960         tkerror $errorMessage
 961         show-status "Not connected" 0 {}
 962         show-target {} {}
 963         return
 964     }
 965     set hostid $target
 966     set currentDb $base
 967 #       changeQueryButtons $target $base
 968
 969 #    .top.options.m.query.slist entryconfigure 2 -state normal
 970     configure-disable-e .top.target.m 0
 971     configure-enable-e .top.target.m 1
 972     configure-enable-e .top.target.m 2
 973 }
 974
 975 # Procedure close-target
 976 # Shuts down the connection with current target.
 977 proc close-target {} {
 978     global hostid cancelFlag setNo setNoLast currentDb
 979
 980     set cancelFlag 0
 981     set setNo 0
 982     set setNoLast 0
 983     .bot.a.set configure -text ""
 984     set hostid Default
 985     set currentDb Default
 986     z39 disconnect
 987     show-target {} {}
 988     show-status {Not connected} 0 0
 989     .top.options.m.query.slist entryconfigure 2 -state disabled
 990     init-title-lines
 991     show-message {}
 992     configure-disable-e .top.target.m 1
 993     configure-disable-e .top.target.m 2
 994     .top.rset.m delete 1 last
 995     .top.rset.m add separator
 996     configure-enable-e .top.target.m 0
 997 }
 998
 999 # Procedure load-set-action
1000 # Loads records from a file. The filename is read from the entry
1001 # .load-set.filename.entry (see function load-set)
1002 proc load-set-action {} {
1003     global setNoLast
1004
1005     incr setNoLast
1006     ir-set z39.$setNoLast z39
1007
1008     set fname [.load-set.top.filename.entry get]
1009     destroy .load-set
1010     if {$fname != ""} {
1011         show-status Loading 1 {}
1012         update
1013         z39.$setNoLast loadFile $fname
1014
1015         set no [z39.$setNoLast numberOfRecordsReturned]
1016         add-title-lines $setNoLast $no 1
1017     }
1018     set l [format "%-4d %7d" $setNoLast $no]
1019     .top.rset.m add command -label $l \
1020             -command [list add-title-lines $setNoLast 10000 1]
1021     show-status Ready 0 {}
1022 }
1023
1024 # Procedure load-set
1025 # Dialog that asks for a filename with records to be loaded
1026 # into a result set.
1027 proc load-set {} {
1028     set w .load-set
1029     toplevel $w
1030     set oldFocus [focus]
1031     place-force $w .
1032     top-down-window $w
1033
1034     frame $w.top.filename
1035     pack $w.top.filename -side top -anchor e -pady 2
1036
1037     entry-fields $w.top {filename} \
1038             {{Filename:}} \
1039             {load-set-action} {destroy .load-set}
1040
1041     top-down-ok-cancel $w {load-set-action} 1
1042     focus $oldFocus
1043 }
1044
1045 # Procedure init-request
1046 # Sends an initialize request to the target. This procedure is called
1047 # when a connect has been established.
1048 proc init-request {target base} {
1049     global cancelFlag
1050
1051     if {$cancelFlag} {
1052         close-target
1053         return
1054     }
1055     z39 callback [list init-response $target $base]
1056     show-status Initializing 1 {}
1057     set err [catch {z39 init} errorMessage]
1058     if {$err} {
1059         tkerror $errorMessage
1060         show-status Ready 0 {}
1061     }
1062 }
1063
1064 # Procedure init-response
1065 # Handles and incoming init-response. The service buttons
1066 # are enabled. The global $scanEnable indicates whether the target
1067 # supports scan.
1068 proc init-response {target base} {
1069     global cancelFlag profile scanEnable settingsChanged
1070
1071     dputs {init-response}
1072     apduDump
1073     if {$cancelFlag} {
1074         close-target
1075         return
1076     }
1077     if {![z39 initResult]} {
1078         set u [z39 userInformationField]
1079         close-target
1080         tkerror "Connection rejected by target: $u"
1081     } else {
1082                 z39 failback [list explain-crash $target $base]
1083         explain-check $target [list ready-response $base]
1084     }
1085 }
1086
1087 # Procedure explain-crash
1088 # Handles target that dies during explain.
1089 proc explain-crash {target base} {
1090     global profile settingsChanged
1091
1092     set profile($target,timeLastInit) [clock seconds]
1093     set settingsChanged 1
1094
1095     show-message {}
1096     open-target $target $base
1097 }
1098
1099 # Procedure explain-check
1100 # Stub function to check explain. May be overwritten later.
1101 proc explain-check {target response} {
1102     eval $response [list $target]
1103 }
1104
1105 # Procedure ready-response
1106 # Called after a target has been initialized and, possibly, explained
1107 proc ready-response {base target} {
1108     global profile settingsChanged scanEnable queryAuto
1109
1110     z39 failback [list fail-response $target]
1111     if {[string length $base]} {
1112         set profile($target,timeLastInit) [clock seconds]
1113         set settingsChanged 1
1114
1115         z39 databaseNames $base
1116         cascade-dblist $target $base
1117         show-target $target $base
1118     }
1119     if {[lsearch [z39 options] scan] >= 0} {
1120         set scanEnable 1
1121     } else {
1122         set scanEnable 0
1123     }
1124     .data.record delete 1.0 end
1125     set desc [string trim $profile($target,description)]
1126     if {[string length $desc]} {
1127         .data.record insert end "$desc\n\n"
1128     } else {
1129         .data.record insert end "$target\n\n"
1130     }
1131     set data [string trim $profile($target,welcomeMessage)]
1132     if {[string length $data]} {
1133                 .data.record insert end "Welcome Message:\n$data\n\n"
1134     }
1135     set data [string trim $profile($target,recentNews)]
1136     if {[string length $data]} {
1137         .data.record insert end "News:\n$data\n"
1138     }
1139     ready-response-actions $target $base
1140     show-message {}
1141     show-status Ready 0 1
1142 }
1143
1144 #proc ready-response-actions {target base}
1145 #This procedure take care of all the actions that should start if connect is succesfull.
1146 proc ready-response-actions {target base} {
1147         global profile queryAuto
1148         get-attributeDetails $target $base
1149         changeQueryButtons $target $base
1150         if {[info exists profile($target,AttributeDetails,$base,Bib1Use)] && $queryAuto == 1} {
1151                 changeQueryButtons $target $base
1152                 change-queryInfo $target $base
1153                 query-select 2
1154                 .top.options.m.query.slist entryconfigure 2 -state normal
1155         } else {
1156                 query-select 0
1157                 .top.options.m.query.slist entryconfigure 2 -state disabled
1158         }
1159 }
1160
1161 # Procedure search-request
1162 #  bflag     flag to indicate if this procedure calls itself
1163 # Performs a search. If $busy is 1, the search-request is performed
1164 # at a later time (when another response arrives). This procedure
1165 # sets many search-related Z39-settings. The global $setNo is set
1166 # to the result set number (z39.$setNo).
1167 proc search-request {bflag} {
1168     global setNo setNoLast profile hostid busy cancelFlag delayRequest recordSyntax elementSetNames
1169
1170     set target $hostid
1171
1172     if {![string length [z39 connect]]} {
1173         return
1174     }
1175     dputs "search-request"
1176     show-message {}
1177     if {!$bflag && $busy} {
1178         dputs "busy: search-request ignored"
1179         return
1180     }
1181     if {$cancelFlag} {
1182         dputs "cancelFlag"
1183         show-status Searching 1 0
1184         set delayRequest {search-request 1}
1185         return
1186     }
1187     set delayRequest {}
1188
1189     set query [index-query]
1190     if {![string length $query]} {
1191         return
1192     }
1193     incr setNoLast
1194     set setNo $setNoLast
1195     ir-set z39.$setNo z39
1196
1197     if {$profile($target,namedResultSets)} {
1198         z39.$setNo setName $setNo
1199         dputs "setName=${setNo}"
1200     } else {
1201         z39.$setNo setName default
1202         dputs "setName=default"
1203     }
1204     if {$profile($target,queryRPN)} {
1205                 z39.$setNo queryType rpn
1206     } elseif {$profile($target,queryCCL)} {
1207                 z39.$setNo queryType ccl
1208     }
1209     dputs Setting
1210     dputs $recordSyntax
1211     if {![string compare $recordSyntax None]} {
1212         z39.$setNo preferredRecordSyntax {}
1213     } else {
1214         z39.$setNo preferredRecordSyntax $recordSyntax
1215     }
1216     if {![string compare $elementSetNames None]} {
1217         z39.$setNo elementSetNames {}
1218         z39.$setNo smallSetElementSetNames {}
1219         z39.$setNo mediumSetElementSetNames {}
1220     } else {
1221         z39.$setNo elementSetNames $elementSetNames
1222         z39.$setNo smallSetElementSetNames $elementSetNames
1223         z39.$setNo mediumSetElementSetNames $elementSetNames
1224     }
1225     z39 callback {search-response}
1226     z39.$setNo search $query
1227     show-status Searching 1 0
1228 }
1229
1230 # Procedure scan-copy {y entry}
1231 #  y       y-position of mouse pointer
1232 #  entry   a search entry in the top
1233 # Copies the term in the list nearest $y to the query entry specified
1234 # by $entry
1235 proc scan-copy {y entry} {
1236     set w .scan-window
1237     set no [$w.top.list nearest $y]
1238     dputs "no=$no"
1239     .lines.$entry.e delete 0 end
1240     .lines.$entry.e insert 0 [string range [$w.top.list get $no] 8 end]
1241 }
1242
1243 # Procedure scan-request
1244 # Performs a scan on term "0" with the current attributes in entry
1245 # specified by the global $curIndexEntry.
1246 proc scan-request {} {
1247     set w .scan-window
1248
1249     global profile hostid scanView scanTerm curIndexEntry queryButtonsFind \
1250                 queryInfoFind cancelFlag delayRequest
1251
1252     dputs "scan-request"
1253     if {$cancelFlag} {
1254         dputs "cancelFlag"
1255         show-status Scanning 1 0
1256         set delayRequest scan-request
1257         return
1258     }
1259     set delayRequest {}
1260     set target $hostid
1261     set scanView 0
1262     set scanTerm {}
1263     set b [lindex $queryButtonsFind $curIndexEntry]
1264     set attr {}
1265     foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
1266         set attr "@attr $a $attr"
1267     }
1268     set title [lindex [lindex $queryInfoFind [lindex $b 1]] 0]
1269     ir-scan z39.scan z39
1270
1271     if {![winfo exists $w]} {
1272         toplevelG $w
1273
1274         wm minsize $w 0 0
1275
1276         top-down-window $w
1277
1278         entry $w.top.entry -relief sunken
1279         pack $w.top.entry -fill x -padx 4 -pady 2
1280         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
1281         listbox $w.top.list -yscrollcommand [list $w.top.scroll set] -font fixed
1282         scrollbar $w.top.scroll -orient vertical -border 1
1283         pack $w.top.list -side left -fill both -expand yes
1284         pack $w.top.scroll -side right -fill y
1285         $w.top.scroll config -command [list $w.top.list yview]
1286
1287         bottom-buttons $w [list {Close} [list destroy $w] \
1288                 {Up} [list scan-up $attr] \
1289                 {Down} [list scan-down $attr]] 0
1290         bind $w.top.list <Up> [list scan-up $attr]
1291         bind $w.top.list <Down> [list scan-down $attr]
1292         focus $w.top.entry
1293     }
1294     bind $w.top.list <Double-Button-1> [list scan-copy %y $curIndexEntry]
1295     wm title $w "Scan $title"
1296
1297     z39 callback [list scan-response $attr 0 35]
1298     z39.scan numberOfTermsRequested 5
1299     z39.scan preferredPositionInResponse 1
1300     z39.scan scan "${attr} 0"
1301
1302     show-status Scanning 1 0
1303 }
1304
1305 # Procedure scan-term-h {attr}
1306 # attr    attribute specification
1307 # This procedure is called whenever a key is released in the entry in the
1308 # scan window (.scan-window). A scan is then initiated with the new contents
1309 # of the entry as the starting term.
1310 proc scan-term-h {attr} {
1311     global busy scanTerm
1312
1313     if {$busy} {
1314         return
1315     }
1316     set w .scan-window
1317     set nScanTerm [$w.top.entry get]
1318     if {$nScanTerm == $scanTerm} {
1319         return
1320     }
1321     set scanTerm $nScanTerm
1322     z39 callback [list scan-response $attr 0 35]
1323     z39.scan numberOfTermsRequested 5
1324     z39.scan preferredPositionInResponse 1
1325     dputs "${attr} \{${scanTerm}\}"
1326     if {![string length $scanTerm]} {
1327         z39.scan scan "${attr} 0"
1328     } else {
1329         z39.scan scan "${attr} \{${scanTerm}\}"
1330     }
1331     show-status Scanning 1 0
1332 }
1333
1334 # Procedure scan-response {attr start toget}
1335 #  attr   attribute specification
1336 #  start  position of first term in the response
1337 #  toget  number of total terms to get
1338 # This procedure handles all scan-responses. $start specifies the list
1339 # entry number of the first incoming term. The $toget indicates the total
1340 # number of terms to be retrieved from the target. The $toget may be
1341 # negative in which case, scan is performed 'backwards' (- $toget is
1342 # the total number of terms in this case). This procedure usually calls
1343 # itself several times in order to get small scan-term-list chunks.
1344 proc scan-response {attr start toget} {
1345     global cancelFlag delayRequest scanTerm scanView
1346
1347     set w .scan-window
1348     dputs "In scan-response"
1349     apduDump
1350     set m [z39.scan numberOfEntriesReturned]
1351     dputs $m
1352     dputs attr=$attr
1353     dputs start=$start
1354     dputs toget=$toget
1355
1356     if {![winfo exists .scan-window]} {
1357         if {$cancelFlag} {
1358             set cancelFlag 0
1359             dputs "Handling cancel"
1360             if {$delayRequest != ""} {
1361                 eval $delayRequest
1362             }
1363             return
1364         }
1365         show-status Ready 0 1
1366         return
1367     }
1368     set nScanTerm [$w.top.entry get]
1369     if {$nScanTerm != $scanTerm} {
1370         z39 callback [list scan-response $attr 0 35]
1371         z39.scan numberOfTermsRequested 5
1372         z39.scan preferredPositionInResponse 1
1373         set scanTerm $nScanTerm
1374         dputs "${attr} \{${scanTerm}\}"
1375         if {![string length $scanTerm]} {
1376             z39.scan scan "${attr} 0"
1377         } else {
1378             z39.scan scan "${attr} \{${scanTerm}\}"
1379         }
1380         show-status Scanning 1 0
1381         return
1382     }
1383     set status [z39.scan scanStatus]
1384     if {$status == 6} {
1385         tkerror "Scan fail"
1386         show-status Ready 0 1
1387         set cancelFlag 0
1388         return
1389     }
1390     if {$toget < 0} {
1391         for {set i 0} {$i < $m} {incr i} {
1392             set term [lindex [z39.scan scanLine $i] 1]
1393             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1394             $w.top.list insert $i "$nostr $term"
1395         }
1396         incr scanView $m
1397         $w.top.list yview $scanView
1398     } else {
1399         $w.top.list delete $start end
1400         for {set i 0} {$i < $m} {incr i} {
1401             set term [lindex [z39.scan scanLine $i] 1]
1402             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1403             $w.top.list insert end "$nostr $term"
1404         }
1405     }
1406     if {$cancelFlag} {
1407         dputs "Handling cancel"
1408         set cancelFlag 0
1409         if {$delayRequest != ""} {
1410             eval $delayRequest
1411         }
1412         return
1413     }
1414     set delayRequest {}
1415     if {$toget > 0 && $m > 1 && $m < $toget} {
1416         set ntoget [expr $toget - $m + 1]
1417         dputs ntoget=$ntoget
1418         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
1419         set q $term
1420         dputs "down continue: $q"
1421         if {$ntoget > 10} {
1422             z39.scan numberOfTermsRequested 10
1423         } else {
1424             z39.scan numberOfTermsRequested $ntoget
1425         }
1426         z39.scan preferredPositionInResponse 1
1427         dputs "${attr} \{$q\}"
1428         z39.scan scan "${attr} \{$q\}"
1429         return
1430     }
1431     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
1432         set ntoget [expr - $toget - $m]
1433         dputs ntoget=$ntoget
1434         z39 callback [list scan-response $attr 0 -$ntoget]
1435         set q [string range [$w.top.list get 0] 8 end]
1436         dputs "up continue: $q"
1437         if {$ntoget > 10} {
1438             z39.scan numberOfTermsRequested 10
1439             z39.scan preferredPositionInResponse 11
1440         } else {
1441             z39.scan numberOfTermsRequested $ntoget
1442             z39.scan preferredPositionInResponse [incr ntoget]
1443         }
1444         dputs "${attr} \{$q\}"
1445         z39.scan scan "${attr} \{$q\}"
1446         return
1447     }
1448     show-status Ready 0 1
1449 }
1450
1451 # Procedure scan-down {attr}
1452 #  attr   attribute specification
1453 # This procedure is called when the user hits the Down button the scan
1454 # window. A new scan is initiated with a positive $toget passed to the
1455 # scan-response handler.
1456 proc scan-down {attr} {
1457     global scanView cancelFlag delayRequest
1458
1459     dputs {scan-down}
1460     if {$cancelFlag} {
1461         dputs "cancelFlag"
1462         show-status {Scanning down} 1 0
1463         set delayRequest [list scan-down $attr]
1464         return
1465     }
1466     set delayRequest {}
1467
1468     set w .scan-window
1469     set scanView [expr $scanView + 5]
1470     set s [$w.top.list size]
1471     if {$scanView > $s} {
1472         z39 callback [list scan-response $attr [expr $s - 1] 25]
1473         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
1474         dputs "down: $q"
1475         z39.scan numberOfTermsRequested 10
1476         z39.scan preferredPositionInResponse 1
1477         show-status Scanning 1 0
1478         dputs "${attr} \{$q\}"
1479         z39.scan scan "${attr} \{$q\}"
1480         return
1481     }
1482     $w.top.list yview $scanView
1483 }
1484
1485 # Procedure scan-up {attr}
1486 #  attr   attribute specification
1487 # This procedure is called when the user hits the Up button the scan
1488 # window. A new scan is initiated with a negative $toget passed to the
1489 # scan-response handler.
1490 proc scan-up {attr} {
1491     global scanView cancelFlag delayRequest
1492
1493     dputs {scan-up}
1494     if {$cancelFlag} {
1495         dputs "cancelFlag"
1496         show-status Scanning 1 0
1497         set delayRequest [list scan-up $attr]
1498         return
1499     }
1500     set delayRequest {}
1501
1502     set w .scan-window
1503     set scanView [expr $scanView - 5]
1504     if {$scanView < 0} {
1505         z39 callback [list scan-response $attr 0 -25]
1506         set q [string range [$w.top.list get 0] 8 end]
1507         dputs "up: $q"
1508         z39.scan numberOfTermsRequested 10
1509         z39.scan preferredPositionInResponse 11
1510         show-status Scanning 1 0
1511         z39.scan scan "${attr} \{$q\}"
1512         return
1513     }
1514     $w.top.list yview $scanView
1515 }
1516
1517 # Procedure search-response
1518 # This procedure handles search-responses. If the search is successful
1519 # this procedure will try to retrieve a total of 20 records from the target;
1520 # however not more than $presentChunk records at a time. This procedure
1521 # affects the following globals:
1522 #   $setOffset        current record position offset
1523 #   $setMax           total number of records to be retrieved
1524 proc search-response {} {
1525     global setNo setOffset setMax cancelFlag busy delayRequest presentChunk
1526
1527     apduDump
1528     dputs "In search-response"
1529     if {$cancelFlag} {
1530         dputs "Handling cancel"
1531         set cancelFlag 0
1532         if {$delayRequest != ""} {
1533             eval $delayRequest
1534         }
1535         return
1536     }
1537     set setOffset 0
1538     set delayRequest {}
1539     init-title-lines
1540     set setMax [z39.$setNo resultCount]
1541     show-status Ready 0 1
1542     set status [z39.$setNo responseStatus]
1543     if {![string compare [lindex $status 0] NSD]} {
1544         z39.$setNo nextResultSetPosition 0
1545         set code [lindex $status 1]
1546         set msg [lindex $status 2]
1547         set addinfo [lindex $status 3]
1548         tkerror "NSD$code: $msg: $addinfo"
1549         return
1550     }
1551     show-message "${setMax} hits"
1552     if {$setMax == 0} {
1553         return
1554     }
1555     set setOffset 1
1556     show-status Ready 0 1
1557     set l [format "%-4d %7d" $setNo $setMax]
1558     .top.rset.m add command -label $l -command [list recall-set $setNo]
1559     if {$setMax > 20} {
1560         set setMax 20
1561     }
1562     set no [z39.$setNo numberOfRecordsReturned]
1563     dputs "Returned $no records, setOffset $setOffset"
1564     add-title-lines $setNo $no $setOffset
1565     set setOffset [expr $setOffset + $no]
1566
1567     set toGet [expr $setMax - $setOffset + 1]
1568     if {$toGet > 0} {
1569         if {$setOffset == 1} {
1570             set toGet 1
1571         } elseif {$toGet > $presentChunk} {
1572             set toGet $presentChunk
1573         }
1574         z39 callback {present-response}
1575         z39.$setNo present $setOffset $toGet
1576         show-status Retrieving 1 0
1577     }
1578 }
1579
1580 # Procedure present-more {number}
1581 #  number      number of records to be retrieved
1582 # This procedure starts a present-request. The $number variable indicates
1583 # the total number of records to be retrieved. The global $presentChunk
1584 # specifies the number of records to be retrieved at a time. If $number
1585 # is the empty string all remaining records in the result set are
1586 # retrieved.
1587 proc present-more {number} {
1588     global setNo setOffset setMax busy cancelFlag delayRequest presentChunk
1589
1590     dputs "present-more"
1591     if {$cancelFlag} {
1592         show-status Retrieving 1 0
1593         set delayRequest "present-more $number"
1594         return
1595     }
1596     set delayRequest {}
1597
1598     if {$setNo == 0} {
1599         dputs "setNo=$setNo"
1600         return
1601     }
1602     set setOffset [z39.$setNo nextResultSetPosition]
1603     dputs "setOffest=${setOffset}"
1604     dputs "setNo=${setNo}"
1605     set max [z39.$setNo resultCount]
1606     if {$max < $setOffset} {
1607         dputs "max=$max"
1608         dputs "setOffset=$setOffset"
1609         show-status Ready 0 1
1610         return
1611     }
1612     if {![string length $number]} {
1613         set setMax $max
1614     } else {
1615         incr setMax $number
1616         if {$setMax > $max} {
1617             set setMax $max
1618         }
1619     }
1620     z39 callback {present-response}
1621
1622     set toGet [expr $setMax - $setOffset + 1]
1623     if {$toGet <= 0} {
1624         return
1625     }
1626     if {$toGet > $presentChunk} {
1627         set toGet $presentChunk
1628     }
1629     z39.$setNo present $setOffset $toGet
1630     show-status Retrieving 1 0
1631 }
1632
1633 # Procedure init-title-lines
1634 # Utility that cleans the main record window.
1635 proc init-title-lines {} {
1636     .data.record delete 1.0 end
1637 }
1638
1639 # Procedure recall-set {setno}
1640 #  setno    Set number to recall
1641 proc recall-set {setno} {
1642     add-title-lines $setno 10000 1
1643 }
1644
1645 # Procedure add-title-lines {setno no offset}
1646 #  setno    Set number
1647 #  no       Number of records
1648 #  offset   Starting offset
1649 # This procedure displays the records $offset .. $offset+$no-1 in result
1650 # set $setno in the main record window by using the display format in the
1651 # global $displayFormat
1652 proc add-title-lines {setno no offset} {
1653     global displayFormats displayFormat setNo busy
1654
1655     dputs "add-title-lines offset=${offset} no=${no}"
1656     if {$setno != -1} {
1657         set setNo $setno
1658     } else {
1659         set setno $setNo
1660     }
1661     if {$offset == 1} {
1662         .bot.a.set configure -text $setno
1663         .data.record delete 1.0 end
1664     }
1665     set ffunc [lindex $displayFormats $displayFormat]
1666     dputs "ffunc=$ffunc"
1667     set ffunc "display-$ffunc"
1668     for {set i 0} {$i < $no} {incr i} {
1669         set o [expr $i + $offset]
1670         set type [z39.$setno type $o]
1671         if {![string length $type]} {
1672             dputs "no more at $o"
1673             break
1674         }
1675         .data.record tag bind r$o <Any-Enter> {}
1676         .data.record tag bind r$o <Any-Leave> {}
1677         set insert0 [.data.record index insert]
1678         $ffunc $setno $o .data.record 1
1679         .data.record tag add r$o $insert0 insert
1680         .data.record tag bind r$o <1> [list popup-marc $setno $o 0 0]
1681         update idletasks
1682     }
1683     if {!$busy} {
1684         show-status Ready 0 1
1685     }
1686 }
1687
1688 # Procedure present-response
1689 # Present-response handler. The incoming records are displayed and a new
1690 # present request is performed until all records ($setMax) is returned
1691 # from the target.
1692 proc present-response {} {
1693     global setNo setOffset setMax cancelFlag delayRequest presentChunk
1694
1695     dputs "In present-response"
1696     apduDump
1697     set no [z39.$setNo numberOfRecordsReturned]
1698     dputs "Returned $no records, setOffset $setOffset"
1699     add-title-lines $setNo $no $setOffset
1700     set setOffset [expr $setOffset + $no]
1701     if {$cancelFlag} {
1702         dputs "Handling cancel"
1703         set cancelFlag 0
1704         if {$delayRequest != ""} {
1705             eval $delayRequest
1706         }
1707         return
1708     }
1709     set status [z39.$setNo responseStatus]
1710     if {![string compare [lindex $status 0] NSD]} {
1711         show-status Ready 0 1
1712         set code [lindex $status 1]
1713         set msg [lindex $status 2]
1714         set addinfo [lindex $status 3]
1715         tkerror "NSD$code: $msg: $addinfo"
1716         return
1717     }
1718     if {$no > 0 && $setOffset <= $setMax} {
1719         dputs "present-request from ${setOffset}"
1720         set toGet [expr $setMax - $setOffset + 1]
1721         if {$toGet > $presentChunk} {
1722             set toGet $presentChunk
1723         }
1724         z39.$setNo present $setOffset $toGet
1725     } else {
1726         show-status Ready 0 1
1727     }
1728 }
1729
1730 # Procedure left-cursor {w}
1731 #  w    entry widget
1732 # Tries to move the cursor left in entry window $w
1733 proc left-cursor {w} {
1734     set i [$w index insert]
1735     if {$i > 0} {
1736         incr i -1
1737         $w icursor $i
1738     }
1739     dputs left
1740 }
1741
1742 # Procedure right-cursor {w}
1743 #  w    entry widget
1744 # Tries to move the cursor right in entry window $w
1745 proc right-cursor {w} {
1746     set i [$w index insert]
1747     incr i
1748     dputs right
1749     $w icursor $i
1750 }
1751
1752 # Procedure bind-fields {list returnAction escapeAction}
1753 #  list          list of entry widgets
1754 #  returnAction  return script
1755 #  escapeAction  escape script
1756 # Each widget in list are assigned bindings for <Tab>, <Left>, <Right>,
1757 # <Return> and <Escape>.
1758 proc bind-fields {list returnAction escapeAction} {
1759     set max [expr [llength $list]-1]
1760     for {set i 0} {$i < $max} {incr i} {
1761         bind [lindex $list $i] <Return> $returnAction
1762         bind [lindex $list $i] <Escape> $escapeAction
1763         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1764         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1765         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1766     }
1767     bind [lindex $list $i] <Return> $returnAction
1768     bind [lindex $list $i] <Escape> $escapeAction
1769     bind [lindex $list $i] <Tab>  [list focus [lindex $list 0]]
1770     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1771     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1772     focus [lindex $list 0]
1773 }
1774
1775 # Procedure entry-fields {parent list tlist returnAction escapeAction}
1776 #  list          list of frame widgets
1777 #  tlist         list of text to be used as lead of each entry
1778 #  returnAction  return script
1779 #  escapeAction  escape script
1780 # Makes label and entry widgets in each widget in $list.
1781 proc entry-fields {parent list tlist returnAction escapeAction} {
1782     set alist {}
1783     set i 0
1784     foreach field $list {
1785         set label ${parent}.${field}.label
1786         set entry ${parent}.${field}.entry
1787         label $label -text [lindex $tlist $i] -anchor e
1788         entry $entry -width 32 -relief sunken
1789         pack $label -side left
1790         pack $entry -side right
1791         lappend alist $entry
1792         incr i
1793     }
1794     bind-fields $alist $returnAction $escapeAction
1795 }
1796
1797 # Procedure define-target-dialog
1798 # Dialog that asks for new target to be defined.
1799 proc define-target-dialog {} {
1800     set w .target-define
1801
1802     toplevel $w
1803     place-force $w .
1804     top-down-window $w
1805     frame $w.top.target
1806     pack $w.top.target -side top -anchor e -pady 2
1807     entry-fields $w.top {target} {{Target:}} \
1808             {define-target-action} {destroy .target-define}
1809     top-down-ok-cancel $w {define-target-action} 1
1810 }
1811
1812 # Procedure place-force {window parent}
1813 #  window      new top level widget
1814 #  parent      parent widget used as base
1815 # Sets geometry of $window relative to $parent window.
1816 proc place-force {window parent} {
1817     set g [wm geometry $parent]
1818     set p1 [string first + $g]
1819     set p2 [string last + $g]
1820     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1821     set y [expr 60+[string range $g [expr $p2 +1] end]]
1822     wm geometry $window +${x}+${y}
1823 }
1824
1825 # Procedure add-database-action {target w}
1826 #  target      target to be defined
1827 #  w           top level widget for the target definition
1828 # Adds the contents of .database-select.top.database.entry to list of
1829 # databases.
1830 proc add-database-action {target w} {
1831     global profile
1832
1833     $w.top.databases.list insert end [.database-select.top.database.entry get]
1834     destroy .database-select
1835 }
1836
1837 # Procedure add-database {target wp}
1838 #  target      target to be defined
1839 #  wp          top level widget for the target definition
1840 # Makes a dialog in which the user enters new database
1841 proc add-database {target wp} {
1842     global profile
1843
1844     set w .database-select
1845     toplevel $w
1846     set oldFocus [focus]
1847     place-force $w $wp
1848     top-down-window $w
1849     frame $w.top.database
1850     pack $w.top.database -side top -anchor e -pady 2
1851         entry-fields $w.top {database} {{Database to add:}} \
1852             [list add-database-action $target $wp] {destroy .database-select}
1853
1854     top-down-ok-cancel $w [list add-database-action $target $wp] 1
1855     focus $oldFocus
1856 }
1857
1858
1859 # Procedure delete-database {target w}
1860 #  target     target to be defined
1861 #  w          top level widget for the target definition
1862 # Asks the user if he/she really wishes to delete a database and removes
1863 # the database from the database-list if requested.
1864 proc delete-database {target w} {
1865     global profile
1866
1867     set l {}
1868     foreach i [$w.top.databases.list curselection] {
1869         set b [$w.top.databases.list get $i]
1870         set l "$l $b"
1871     }
1872     set a [alert "Are you sure you want to remove the database(s)${l}?"]
1873     if {$a} {
1874         foreach i [lsort -decreasing \
1875                 [$w.top.databases.list curselection]] {
1876             $w.top.databases.list delete $i
1877         }
1878     }
1879 }
1880
1881 # Procedure advanced-setup {target b}
1882 #  target     target to be defined
1883 #  b          window number of target top level
1884 # Makes a dialog in which the user may modify/view advanced settings
1885 # of a target definition (profile).
1886 proc advanced-setup {target b} {
1887     global profile profileS
1888
1889     set w .advanced-setup-$b
1890     toplevelG $w
1891     wm title $w "Advanced setup $target"
1892     top-down-window $w
1893      if {![string length $target]} {
1894         set target Default
1895     }
1896     dputs target
1897
1898     frame $w.top.largeSetLowerBound
1899     frame $w.top.smallSetUpperBound
1900     frame $w.top.mediumSetPresentNumber
1901     frame $w.top.presentChunk
1902     frame $w.top.maximumRecordSize
1903     frame $w.top.preferredMessageSize
1904
1905     pack $w.top.largeSetLowerBound $w.top.smallSetUpperBound \
1906             $w.top.mediumSetPresentNumber $w.top.presentChunk \
1907             $w.top.maximumRecordSize $w.top.preferredMessageSize \
1908             -side top -anchor e -pady 2
1909
1910     entry-fields $w.top {largeSetLowerBound smallSetUpperBound \
1911             mediumSetPresentNumber presentChunk maximumRecordSize \
1912             preferredMessageSize} \
1913             {{Large Set Lower Bound:} {Small Set Upper Bound:} \
1914             {Medium Set Present Number:} {Present Chunk:} \
1915             {Maximum Record Size:} {Preferred Message Size:}} \
1916             [list advanced-setup-action $target $b] [list destroy $w]
1917
1918     $w.top.largeSetLowerBound.entry configure -textvariable \
1919         profileS($target,largeSetLowerBound)
1920     $w.top.smallSetUpperBound.entry configure -textvariable \
1921         profileS($target,smallSetUpperBound)
1922     $w.top.mediumSetPresentNumber.entry configure -textvariable \
1923         profileS($target,mediumSetPresentNumber)
1924     $w.top.presentChunk.entry configure -textvariable \
1925         profileS($target,presentChunk)
1926     $w.top.maximumRecordSize.entry configure -textvariable \
1927         profileS($target,maximumRecordSize)
1928     $w.top.preferredMessageSize.entry configure -textvariable \
1929         profileS($target,preferredMessageSize)
1930
1931     bottom-buttons $w [list {Ok} [list advanced-setup-action $target $b] \
1932             {Cancel} [list destroy $w]] 0
1933 }
1934
1935 # Procedure advanced-setup-action {target b}
1936 #  target     target to be defined
1937 #  b          window number of target top level
1938 # This procedure is called when the user hits Ok in the advanced target
1939 # setup dialog. The temporary result is stored in the $profileS - array.
1940 proc advanced-setup-action {target b} {
1941     set w .advanced-setup-$b
1942     global profileS
1943
1944     set profileS($target,LSLB) [$w.top.largeSetLowerBound.entry get]
1945     set profileS($target,SSUB) [$w.top.smallSetUpperBound.entry get]
1946     set profileS($target,MSPN) [$w.top.mediumSetPresentNumber.entry get]
1947     set profileS($target,presentChunk) [$w.top.presentChunk.entry get]
1948     set profileS($target,MRS) [$w.top.maximumRecordSize.entry get]
1949     set profileS($target,PMS) [$w.top.preferredMessageSize.entry get]
1950
1951     dputs "advanced-setup-action"
1952     destroy $w
1953 }
1954
1955 # Procedure database-select-action
1956 # Called when the user commits a database select change. See procedure
1957 # database-select.
1958 proc database-select-action {} {
1959     set w .database-select.top
1960     set b {}
1961     foreach indx [$w.databases.list curselection] {
1962         lappend b [$w.databases.list get $indx]
1963     }
1964     if {$b != ""} {
1965         z39 databaseNames $b
1966     }
1967     destroy .database-select
1968 }
1969
1970 # Procedure database-select
1971 # Makes a dialog in which the user may select a database
1972 proc database-select {} {
1973     set w .database-select
1974     global profile hostid
1975
1976     toplevel $w
1977     set oldFocus [focus]
1978     place-force $w .
1979     top-down-window $w
1980
1981     frame $w.top.databases -relief ridge -border 2
1982     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1983
1984     label $w.top.databases.label -text "List"
1985     listbox $w.top.databases.list -width 20 -height 6 \
1986             -yscrollcommand "$w.top.databases.scroll set"
1987     scrollbar $w.top.databases.scroll -orient vertical -border 1
1988     pack $w.top.databases.label -side top -fill x -padx 2 -pady 2
1989     pack $w.top.databases.list -side left -fill both -expand yes -padx 2 -pady 2
1990     pack $w.top.databases.scroll -side right -fill y -padx 2 -pady 2
1991     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1992
1993     foreach b $profile($hostid,databases) {
1994         $w.top.databases.list insert end $b
1995     }
1996     top-down-ok-cancel $w {database-select-action} 1
1997     focus $oldFocus
1998 }
1999
2000 # Procedure cascase-dblist-select
2001 proc cascade-dblist-select {target db} {
2002     show-target $target $db
2003     z39 databaseNames $db
2004     ready-response-actions $target $db
2005 }
2006
2007 # Procedure cascade-dblist
2008 # Makes the Service/database list with proper databases for the target
2009 proc cascade-dblist {target base} {
2010     global profile
2011
2012     set w .top.service.m.dblist
2013     $w delete 0 200
2014     if {[info exists profile($target,databases)]} {
2015                 foreach db $profile($target,databases) {
2016                     $w add command -label $db \
2017                         -command [list cascade-dblist-select $target $db]
2018                 }
2019     }
2020 }
2021
2022 # Procedure cascade-target-list
2023 # Makes all target/databases available in the Target|Connect
2024 # menu as well as all targets in the Target|Setup menu.
2025 # This procedure is called whenever target definitions occur.
2026 proc cascade-target-list {} {
2027     global profile
2028
2029     foreach sub [winfo children .top.target.m.clist] {
2030         destroy $sub
2031     }
2032     .top.target.m.clist delete 0 last
2033     foreach nn [lsort [array names profile *,host]] {
2034                 if {[string length $profile($nn)]} {
2035                     set ll [expr [string length $nn] - 6]
2036                     set n [string range $nn 0 $ll]
2037
2038                     set nl $profile($n,windowNumber)
2039                     if {[info exists profile($n,databases)]} {
2040                                 set ndb [llength $profile($n,databases)]
2041                     } else {
2042                                 set ndb 0
2043                     }
2044                     if {$ndb > 1} {
2045                                 .top.target.m.clist add cascade -label $n \
2046                                     -menu .top.target.m.clist.$nl
2047                                 irmenu .top.target.m.clist.$nl
2048                                 foreach b $profile($n,databases) {
2049                                     .top.target.m.clist.$nl add command -label $b \
2050                                         -command [list reopen-target $n $b]
2051                                 }
2052                     } elseif {$ndb == 1} {
2053                                 .top.target.m.clist add command -label $n -command \
2054                                 [list reopen-target $n [lindex $profile($n,databases) 0]]
2055                     } else {
2056                                 .top.target.m.clist add command -label $n -command \
2057                                 [list reopen-target $n {}]
2058                     }
2059                 }
2060     }
2061     .top.target.m.slist delete 0 last
2062     foreach nn [lsort [array names profile *,host]] {
2063                 set ll [expr [string length $nn] - 6]
2064                 set n [string range $nn 0 $ll]
2065             .top.target.m.slist add command -label $n -command [list protocol-setup $n]
2066     }
2067 }
2068
2069 # Procedure query-select {i}
2070 #  i       Query type number (integer)
2071 # This procedure is called when the user selects a Query type. The current
2072 # query type information given by the globals $queryButtonsFind and
2073 # $queryInfoFind are affected by this operation.
2074 proc query-select {i} {
2075     global queryButtonsFind queryInfoFind queryButtons queryInfo
2076     set queryInfoFind [lindex $queryInfo $i]
2077     set queryButtonsFind [lindex $queryButtons $i]
2078     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
2079 }
2080
2081 # Procedure query-new-action
2082 # Commits a new query type definition by extending the globals
2083 # $queryTypes, $queryButtons and $queryInfo.
2084 proc query-new-action {} {
2085     global queryTypes queryButtons queryInfo settingsChanged
2086
2087     set settingsChanged 1
2088     lappend queryTypes [.query-new.top.index.entry get]
2089     lappend queryButtons {}
2090     lappend queryInfo {}
2091
2092     destroy .query-new
2093     cascade-query-list
2094 }
2095
2096 # Procedure query-new
2097 # Makes a dialog in which the user is requested to enter the name of a
2098 # new query type.
2099 proc query-new {} {
2100     set w .query-new
2101
2102     toplevel $w
2103     set oldFocus [focus]
2104     place-force $w .
2105     top-down-window $w
2106     frame $w.top.index
2107     pack $w.top.index -side top -anchor e -pady 2
2108     entry-fields $w.top index {{Query Name:}} \
2109             query-new-action {destroy .query-new}
2110     top-down-ok-cancel $w query-new-action 1
2111     focus $oldFocus
2112 }
2113
2114 # Procedure query-delete-action {queryNo}
2115 #  queryNo     query type number (integer)
2116 # Procedure that deletes the query type specified by $queryNo.
2117 proc query-delete-action {queryNo} {
2118     global queryTypes queryButtons queryInfo settingsChanged
2119
2120     set settingsChanged 1
2121
2122     set queryTypes [lreplace $queryTypes $queryNo $queryNo]
2123     set queryButtons [lreplace $queryButtons $queryNo $queryNo]
2124     set queryInfo [lreplace $queryInfo $queryNo $queryNo]
2125     destroy .query-delete
2126     cascade-query-list
2127 }
2128
2129 # Procedure query-delete {queryNo}
2130 #  queryNo     query type number (integer)
2131 # Asks if the user really want to delete a given query type; calls
2132 # query-delete-action if 'yes'.
2133 proc query-delete {queryNo} {
2134     global queryTypes
2135
2136     set w .query-delete
2137
2138     toplevel $w
2139     place-force $w .
2140     top-down-window $w
2141     set n [lindex $queryTypes $queryNo]
2142
2143     label $w.top.warning -bitmap warning
2144     message $w.top.quest -text "Are you sure you want to delete the \
2145                 query type $n ?"  -aspect 300
2146     pack $w.top.warning $w.top.quest -side left -expand yes -padx 10 -pady 5
2147     bottom-buttons $w [list {Ok} [list query-delete-action $queryNo] \
2148                 {Cancel} [list destroy $w]] 1
2149 }
2150
2151 # Procedure cascade-query-list
2152 # Updates the entries below Options|Query to list all query types.
2153 proc cascade-query-list {} {
2154     global queryTypes hostid queryAuto
2155     set w .top.options.m.query
2156     set i 0
2157     $w.clist delete 0 last
2158     foreach n $queryTypes {
2159         if {$n == "Auto"} {
2160                 $w.clist add check -label $n -variable queryAuto
2161         } else {
2162                 $w.clist add command -label $n -command [list query-select $i]
2163         }
2164         incr i
2165     }
2166     set i 0
2167     $w.slist delete 0 last
2168     foreach n $queryTypes {
2169         if {$n == "Auto"} {
2170                 if {$hostid == "Default"} {
2171                         $w.slist add command -label $n -state disabled -command [list query-setup $i]
2172                 } else {
2173                         $w.slist add command -label $n -command [list query-setup $i]
2174                 }
2175         } else {
2176                 $w.slist add command -label $n -command [list query-setup $i]
2177         }
2178         incr i
2179     }
2180     set i 0
2181     $w.dlist delete 0 last
2182     foreach n $queryTypes {
2183         $w.dlist add command -label $n -command [list query-delete $i]
2184         incr i
2185     }
2186 }
2187
2188 # Procedure save-geometry
2189 # This procedure saves the per-user related settings in ~/.clientrc.tcl.
2190 # The geometry information stored in the global array $windowGeometry is
2191 # saved. Also a few other user settings, such as current display format, are
2192 # saved.
2193 proc save-geometry {} {
2194     global windowGeometry hotTargets textWrap displayFormat popupMarcdf \
2195                 recordSyntax elementSetNames hostid
2196
2197     set windowGeometry(.) [wm geometry .]
2198
2199     if {[catch {set f [open ~/.clientrc.tcl w]}]} {
2200         return
2201     }
2202     if {$hostid != "Default"} {
2203         puts $f "set hostid [list $hostid]"
2204         set b [z39 databaseNames]
2205         puts $f "set hostbase [list $b]"
2206     }
2207     puts $f "set hotTargets [list $hotTargets]"
2208     puts $f "set textWrap $textWrap"
2209     puts $f "set displayFormat $displayFormat"
2210     puts $f "set popupMarcdf $popupMarcdf"
2211     puts $f "set recordSyntax $recordSyntax"
2212     puts $f "set elementSetNames $elementSetNames"
2213     foreach n [array names windowGeometry] {
2214         puts -nonewline $f "set [list windowGeometry($n)] "
2215         puts $f [list $windowGeometry($n)]
2216     }
2217     close $f
2218 }
2219
2220 # Procedure save-settings
2221 # This procedure saves the per-host related settings irtdb.tcl which
2222 # is normally kept in the directory /usr/local/lib/irtcl.
2223 # All query types and target defintion profiles are saved.
2224 proc save-settings {} {
2225     global profile libdir settingsChanged queryTypes queryButtons queryInfo queryAuto
2226
2227     if {[file writable "${libdir}/irtdb.tcl"]} {
2228         set f [open "${libdir}/irtdb.tcl" w]
2229     } else {
2230         set f [open "irtdb.tcl" w]
2231     }
2232     puts $f "# Setup file"
2233     foreach n [lsort [array names profile]] {
2234         puts $f "set [list profile($n)] [list $profile($n)]"
2235     }
2236     puts $f "set queryTypes [list $queryTypes]"
2237     puts $f "set queryButtons [list $queryButtons]"
2238     puts $f "set queryInfo [list $queryInfo]"
2239     puts $f "set queryAuto [list $queryAuto]"
2240     close $f
2241     set settingsChanged 0
2242 }
2243
2244 # Procedure alert {ask}
2245 #  ask    prompt string
2246 # Makes a grabbed dialog in which the user is requested to answer
2247 # "Ok" or "Cancel". This procedure returns 1 if the user hits "Ok"; 0
2248 # otherwise.
2249 proc alert {ask} {
2250     set w .alert
2251
2252     global alertAnswer font
2253
2254     toplevel $w
2255     set oldFocus [focus]
2256     place-force $w .
2257     top-down-window $w
2258
2259     label $w.top.warning -bitmap warning
2260     message $w.top.message -text $ask -aspect 300 -font $font(b,normal)
2261     pack $w.top.warning $w.top.message -side left -pady 5 -padx 10 -expand yes
2262
2263     set alertAnswer 0
2264     top-down-ok-cancel $w {alert-action} 1
2265     focus $oldFocus
2266     return $alertAnswer
2267 }
2268
2269 # Procedure alert-action
2270 # Called when the user hits "Ok" in the .alert-window.
2271 proc alert-action {} {
2272     global alertAnswer
2273     set alertAnswer 1
2274     destroy .alert
2275 }
2276
2277 # Procedure exit-action
2278 # This procedure is called if the user exists the application
2279 proc exit-action {} {
2280     global settingsChanged
2281
2282     if {$settingsChanged} {
2283         save-settings
2284     }
2285     save-geometry
2286     exit 0
2287 }
2288
2289 # Procedure listbuttonaction {w name h user i}
2290 #  w       menubutton widget
2291 #  name    name information
2292 #  h       handler to be invoked
2293 #  user    user information to be passed to handler $h
2294 #  i       index passed as second argument to handler $h
2295 # Utility function to emulate a listbutton. Called when the user
2296 # Modifies the listbutton. See procedure listbuttonx.
2297 proc listbuttonaction {w name h user i} {
2298     $w configure -text [lindex $name 0]
2299     $h [lindex $name 1] $user $i
2300 }
2301
2302 # Procedure listbuttonx {button no names handle user}
2303 #  button  menubutton widget
2304 #  no      initial value index (integer)
2305 #  names   list of name entries. The first entry in each name
2306 #          entry is the actual name
2307 #  handle  user function to be called when the listbutton changes
2308 #          its value
2309 #  user    user argument to the $handle function
2310 # Makes an extended listbutton.
2311 proc listbuttonx {button no names handle user} {
2312     if {[winfo exists $button]} {
2313         $button configure -text [lindex [lindex $names $no] 0]
2314         ${button}.m delete 0 last
2315     } else {
2316         menubutton $button -text [lindex [lindex $names $no] 0] \
2317                         -width 10 -menu ${button}.m -relief raised -border 1
2318         irmenu ${button}.m
2319         ${button}.m configure -tearoff off
2320     }
2321     set i 0
2322     foreach name $names {
2323         ${button}.m add command -label [lindex $name 0] \
2324                         -command [list listbuttonaction ${button} $name $handle $user $i]
2325         incr i
2326     }
2327 }
2328
2329 # Procedure listbutton {button no names}
2330 #  button  menubutton widget
2331 #  no      initial value index (integer)
2332 #  names   list of possible values.
2333 # Makes a listbutton. The functionality is emulated by the use menubutton-
2334 # and menu widgets.
2335 proc listbutton {button no names} {
2336     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
2337             -relief raised -border 1
2338     irmenu ${button}.m
2339     ${button}.m configure -tearoff off
2340     foreach name $names {
2341         ${button}.m add command -label $name \
2342                 -command [list ${button} configure -text $name]
2343     }
2344 }
2345
2346 # Procedure listbuttonv-action {button var names i}
2347 #  button   menubutton widget
2348 #  var      global variable to be affected
2349 #  names    list of possible names and values
2350 # This procedure is called when the user alters a menu created by the
2351 # listbuttonv procedure. The global variable $var is updated.
2352 proc listbuttonv-action {button var names i} {
2353     global $var
2354
2355     set $var [lindex $names [expr $i+1]]
2356     $button configure -text [lindex $names $i]
2357 }
2358
2359 # Procedure listbuttonv {button var names}
2360 #  button   menubutton widget
2361 #  var      global variable to be affected
2362 #  names    List of name/value pairs, i.e. {n1 v1 n2 v2 ...}.
2363 # This procedure emulates a listbutton by means of menu/menubutton widgets.
2364 # The global variable $var is automatically updated and set to one of the
2365 # values v1, v2, ...
2366 proc listbuttonv {button var names} {
2367     global $var
2368
2369     set n "-"
2370     eval "set val $$var"
2371     set l [llength $names]
2372     for {set i 1} {$i < $l} {incr i 2} {
2373         if {$val == [lindex $names $i]} {
2374             incr i -1
2375             set n [lindex $names $i]
2376             break
2377         }
2378     }
2379     if {[winfo exists $button]} {
2380         $button configure -text $n
2381         return
2382     }
2383     menubutton $button -text $n -menu ${button}.m -relief raised -border 1
2384     irmenu ${button}.m
2385     ${button}.m configure -tearoff off
2386     for {set i 0} {$i < $l} {incr i 2} {
2387         ${button}.m add command -label [lindex $names $i] \
2388                 -command [list listbuttonv-action $button $var $names $i]
2389     }
2390 }
2391
2392 # Procedure query-add-index-action {queryNo}
2393 #  queryNo       query type number (integer)
2394 # Handler that makes a new query index.
2395 proc query-add-index-action {queryNo} {
2396     set w .query-setup
2397
2398     global queryInfoTmp queryButtonsTmp
2399
2400     set newI [.query-add-index.top.index.entry get]
2401     lappend queryInfoTmp [list $newI {}]
2402     $w.top.index.list insert end $newI
2403     destroy .query-add-index
2404     #destroy $w.top.lines
2405     #frame $w.top.lines -relief ridge -border 2
2406     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2407     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2408 }
2409
2410 # Procedure query-add-line
2411 #  queryNo      query type number (integer)
2412 # Handler that adds new query line.
2413 proc query-add-line {queryNo} {
2414     set w .query-setup
2415
2416     global queryInfoTmp queryButtonsTmp
2417
2418     lappend queryButtonsTmp {I 0}
2419
2420     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2421 }
2422
2423 # Procedure query-del-line
2424 #  queryNo      query type number (integer)
2425 # Handler that removes query line.
2426 proc query-del-line {queryNo} {
2427     set w .query-setup
2428
2429     global queryInfoTmp queryButtonsTmp
2430
2431     set l [llength $queryButtonsTmp]
2432     if {$l <= 0} {
2433         return
2434     }
2435     incr l -1
2436     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
2437     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2438 }
2439
2440 # Procedure query-add-index
2441 #  queryNo      query type number (integer)
2442 # Handler that adds new query index.
2443 proc query-add-index {queryNo} {
2444     set w .query-add-index
2445
2446     toplevel $w
2447     set oldFocus [focus]
2448     place-force $w .query-setup
2449     top-down-window $w
2450     frame $w.top.index
2451     pack $w.top.index -side top -anchor e -pady 2
2452     entry-fields $w.top {index} {{Index Name:}} \
2453             [list query-add-index-action $queryNo] [list destroy $w]
2454     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
2455     focus $oldFocus
2456 }
2457
2458 # Procedure query-setup-action
2459 #  queryNo      query type number (integer)
2460 # Handler that updates the query information database stored in the
2461 # globals $queryInfo and $queryButtons. This procedure is executed when
2462 # the user commits the query setup changes by pressing button "Ok".
2463 proc query-setup-action {queryNo} {
2464     global queryButtons queryInfo queryButtonsTmp queryInfoTmp queryButtonsFind \
2465                 queryInfoFind settingsChanged hostid currentDb profile
2466     set settingsChanged 1
2467     set queryInfo [lreplace $queryInfo $queryNo $queryNo $queryInfoTmp]
2468     set queryButtons [lreplace $queryButtons $queryNo $queryNo $queryButtonsTmp]
2469     if {[info exists profile($hostid,AttributeDetails,$currentDb,Bib1Use)]} {
2470         set profile($hostid,queryButtons,$currentDb) $queryButtonsTmp
2471     }
2472     set queryInfoFind $queryInfoTmp
2473     set queryButtonsFind $queryButtonsTmp
2474     destroy .query-setup
2475     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
2476 }
2477
2478 #proc changeQueryButtons {target base}
2479 #target         target name
2480 #base           database name
2481 #Substitutes the third element (the Auto element) in queryButtons with
2482 #profile(target,queryButtons,base). The third element in queryInfo is also substituted with
2483 #profile(target,AttributeDetails,base,Bib1Use)
2484 proc changeQueryButtons {target base} {
2485         source bib-1.tcl
2486         global profile queryButtons queryInfo
2487         if {[info exists profile($target,queryButtons,$base)]} {
2488                 set queryButtons [lreplace $queryButtons 2 2 $profile($target,queryButtons,$base)]
2489                 foreach tag $profile($target,AttributeDetails,$base,Bib1Use) {
2490                         if {$tag < 1037} {
2491                                 lappend tempList [list $bib1($tag) 1=$tag]
2492                         }
2493                 }
2494                 set queryInfo [lreplace $queryInfo 2 2 $tempList]
2495         }
2496 }
2497
2498 # Procedure activate-e-index {value no i}
2499 #   value   menu name
2500 #   no      query index number
2501 #   i       menu index (integer)
2502 # Procedure called when listbutton is activated in the query type edit
2503 # window. The global $queryButtonsTmp is updated in this operation.
2504 proc activate-e-index {value no i} {
2505     global queryButtonsTmp queryIndexTmp
2506     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
2507     dputs $queryButtonsTmp
2508     set queryIndexTmp $i
2509 }
2510
2511 # Procedure activate-index {value no i}
2512 #   value   menu name
2513 #   no      query index number
2514 #   i       menu index (integer)
2515 # Procedure called when listbutton is activated in the main query
2516 # window. The global $queryButtonsFind is updated in this operation.
2517 proc activate-index {value no i} {
2518     global queryButtonsFind
2519
2520     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
2521     dputs "queryButtonsFind $queryButtonsFind"
2522 }
2523
2524 # Procedure update-attr
2525 # This procedure creates listbuttons for all bib-1 attributes except
2526 # the use-attribute in the .index-setup window.
2527 # The globals $relationTmpValue, $positionTmpValue, $structureTmpValue,
2528 # $truncationTmpValue and $completenessTmpValue are maintainted by the
2529 # listbuttons.
2530 proc update-attr {} {
2531     set w .index-setup
2532     listbuttonv $w.top.relation.b relationTmpValue\
2533             {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
2534             {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
2535             {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
2536     listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
2537             {First in field} 1 {First in subfield} 2 {Any position in field} 3}
2538     listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
2539             {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list}  6 \
2540             {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
2541             {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
2542             {local-number} 107 {string} 108 {numeric string} 109}
2543     listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
2544             {Left} 2 {Left and right} 3 {No truncation} 100 \
2545             {Process #} 101 {Re-1} 102 {Re-2} 103}
2546     listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
2547             {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
2548 }
2549
2550 # Procedure use-attr {init}
2551 #  init      init flag
2552 # This procedure creates a listbox with several Bib-1 use attributes.
2553 # If $init is 1 the listbox is created with the attributes. If $init
2554 # is 0 the current selection of the listbox is read and the global
2555 # $useTmpValue is set to the current use-value.
2556 proc use-attr {init} {
2557     set attr {
2558         {None}                           0
2559         {Personal name}                  1
2560         {Corporate name}                 2
2561         {Conference name}                3
2562         {Title}                          4
2563         {Title-series}                   5
2564         {Title-uniform}                  6
2565         {ISBN}                           7
2566         {ISSN}                           8
2567         {LC card number}                 9
2568         {BNB card number}                10
2569         {BGF(sic) number}                11
2570         {Local number}                   12
2571         {Dewey classification}           13
2572         {UDC classification}             14
2573         {Bliss classification}           15
2574         {LC call number}                 16
2575         {NLM call number}                17
2576         {NAL call number}                18
2577         {MOS call number}                19
2578         {Local classification}           20
2579         {Subject heading}                21
2580         {Subject-RAMEAU}                 22
2581         {BDI-index-subject}              23
2582         {INSPEC-subject}                 24
2583         {MESH-subject}                   25
2584         {PA-subject}                     26
2585         {LC-subject-heading}             27
2586         {RVM-subject-heading}            28
2587         {Local subject index}            29
2588         {Date}                           30
2589         {Date of publication}            31
2590         {Date of acquisition}            32
2591         {Title-key}                      33
2592         {Title-collective}               34
2593         {Title-parallel}                 35
2594         {Title-cover}                    36
2595         {Title-added-title-page}         37
2596         {Title-caption}                  38
2597         {Title-running}                  39
2598         {Title-spine}                    40
2599         {Title-other-variant}            41
2600         {Title-former}                   42
2601         {Title-abbreviated}              43
2602         {Title-expanded}                 44
2603         {Subject-PRECIS}                 45
2604         {Subject-RSWK}                   46
2605         {Subject-subdivision}            47
2606         {Number-natl-bibliography}       48
2607         {Number-legal-deposit}           49
2608         {Number-govt-publication}        50
2609         {Number-publisher-for-music}     51
2610         {Number-DB}                      52
2611         {Number-local-call}              53
2612         {Code-language}                  54
2613         {Code-geographic-area}           55
2614         {Code-institution}               56
2615         {Name and title}                 57
2616         {Name-geographic}                58
2617         {Place-publication}              59
2618         {CODEN}                          60
2619         {Microform-generation}           61
2620         {Abstract}                       62
2621         {Note}                           63
2622         {Author-title}                 1000
2623         {Record type}                  1001
2624         {Name}                         1002
2625         {Author}                       1003
2626         {Author-name-personal}         1004
2627         {Author-name-corporate}        1005
2628         {Author-name-conference}       1006
2629         {Identifier-standard}          1007
2630         {Subject-LC-children's}        1008
2631         {Subject-name-personal}        1009
2632         {Body of text}                 1010
2633         {Date/time added to database}  1011
2634         {Date/time last modified}      1012
2635         {Authority/format identifier}  1013
2636         {Concept-text}                 1014
2637         {Concept-reference}            1015
2638         {Any}                          1016
2639         {Server choice}                1017
2640         {Publisher}                    1018
2641         {Record source}                1019
2642         {Editor}                       1020
2643         {Bib-level}                    1021
2644         {Geographic class}             1022
2645         {Indexed by}                   1023
2646         {Map scale}                    1024
2647         {Music key}                    1025
2648         {Related periodical}           1026
2649         {Report number}                1027
2650         {Stock number}                 1028
2651         {Thematic number}              1030
2652         {Material type}                1031
2653         {Doc ID}                       1032
2654         {Host item}                    1033
2655         {Content type}                 1034
2656         {Anywhere}                     1035
2657     }
2658     set w .index-setup
2659     global useTmpValue
2660     set l [llength $attr]
2661
2662     if {$init} {
2663         set s 0
2664         set lno 0
2665         for {set i 0} {$i < $l} {incr i} {
2666             $w.top.use.list insert end [lindex $attr $i]
2667             incr i
2668             if {$useTmpValue == [lindex $attr $i]} {
2669                 set s $lno
2670             }
2671             incr lno
2672         }
2673         $w.top.use.list selection clear 0 end
2674         $w.top.use.list selection set $s $s
2675         incr s -3
2676         if {$s < 0} {
2677             set s 0
2678         }
2679         $w.top.use.list yview $s
2680     } else {
2681         set lno [lindex [$w.top.use.list curselection] 0]
2682         set i [expr $lno+$lno+1]
2683         set useTmpValue [lindex $attr $i]
2684         dputs "useTmpValue=$useTmpValue"
2685     }
2686 }
2687
2688 # Procedure index-setup-action {oldAttr queryNo indexNo}
2689 #  oldAttr     original attributes (?)
2690 #  queryNo     query number
2691 #  indexNo     index number
2692 # Commits setup of a query index. The mapping from the index to
2693 # the Bib-1 attributes are handled by this function.
2694 proc index-setup-action {oldAttr queryNo indexNo} {
2695     set attr [lindex $oldAttr 0]
2696
2697     global useTmpValue relationTmpValue structureTmpValue truncationTmpValue \
2698         completenessTmpValue positionTmpValue queryInfoTmp
2699
2700     use-attr 0
2701
2702     dputs "index-setup-action"
2703     dputs "queryNo $queryNo"
2704     dputs "indexNo $indexNo"
2705     if {$useTmpValue > 0} {
2706         lappend attr "1=$useTmpValue"
2707     }
2708     if {$relationTmpValue > 0} {
2709         lappend attr "2=$relationTmpValue"
2710     }
2711     if {$positionTmpValue > 0} {
2712         lappend attr "3=$positionTmpValue"
2713     }
2714     if {$structureTmpValue > 0} {
2715         lappend attr "4=$structureTmpValue"
2716     }
2717     if {$truncationTmpValue > 0} {
2718         lappend attr "5=$truncationTmpValue"
2719     }
2720     if {$completenessTmpValue > 0} {
2721         lappend attr "6=$completenessTmpValue"
2722     }
2723     dputs "new attr $attr"
2724     set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
2725     destroy .index-setup
2726 }
2727
2728 # Procedure index-setup {attr queryNo indexNo}
2729 #  attr        original attributes
2730 #  queryNo     query number
2731 #  indexNo     index number
2732 # Makes a window with settings of a given query index which the user
2733 # may inspect/modify.
2734 proc index-setup {attr queryNo indexNo} {
2735     set w .index-setup
2736
2737     global relationTmpValue structureTmpValue truncationTmpValue \
2738                 completenessTmpValue positionTmpValue useTmpValue
2739     set relationTmpValue 0
2740     set truncationTmpValue 0
2741     set structureTmpValue 0
2742     set positionTmpValue 0
2743     set completenessTmpValue 0
2744     set useTmpValue 0
2745
2746     catch {destroy $w}
2747     toplevelG $w
2748
2749     set n [lindex $attr 0]
2750     wm title $w "Index setup $n"
2751
2752     top-down-window $w
2753
2754     set len [llength $attr]
2755     for {set i 1} {$i < $len} {incr i} {
2756         set q [lindex $attr $i]
2757         set l [string first = $q]
2758         if {$l > 0} {
2759             set t [string range $q 0 [expr $l - 1]]
2760             set v [string range $q [expr $l + 1] end]
2761             switch $t {
2762                 1
2763                 { set useTmpValue $v }
2764                 2
2765                 { set relationTmpValue $v }
2766                 3
2767                 { set positionTmpValue $v }
2768                 4
2769                 { set structureTmpValue $v }
2770                 5
2771                 { set truncationTmpValue $v }
2772                 6
2773                 { set completenessTmpValue $v }
2774             }
2775         }
2776     }
2777
2778     frame $w.top.use -relief ridge -border 2
2779     frame $w.top.relation -relief ridge -border 2
2780     frame $w.top.position -relief ridge -border 2
2781     frame $w.top.structure -relief ridge -border 2
2782     frame $w.top.truncation -relief ridge -border 2
2783     frame $w.top.completeness -relief ridge -border 2
2784
2785     update-attr
2786
2787     # Use Attributes
2788
2789     pack $w.top.use -side left -pady 6 -padx 6 -fill y
2790
2791     label $w.top.use.label -text "Use"
2792         listbox $w.top.use.list -width 26 -yscrollcommand "$w.top.use.scroll set"
2793     scrollbar $w.top.use.scroll -orient vertical -border 1
2794     pack $w.top.use.label -side top -fill x -padx 2 -pady 2
2795     pack $w.top.use.list -side left -fill both -expand yes -padx 2 -pady 2
2796     pack $w.top.use.scroll -side right -fill y -padx 2 -pady 2
2797     $w.top.use.scroll config -command "$w.top.use.list yview"
2798
2799     use-attr 1
2800
2801     # Relation Attributes
2802
2803     pack $w.top.relation -pady 6 -padx 6 -side top
2804     label $w.top.relation.label -text "Relation" -width 18
2805
2806     pack $w.top.relation.label $w.top.relation.b -fill x
2807
2808     # Position Attributes
2809
2810     pack $w.top.position -pady 6 -padx 6 -side top
2811     label $w.top.position.label -text "Position" -width 18
2812
2813     pack $w.top.position.label $w.top.position.b -fill x
2814
2815     # Structure Attributes
2816
2817     pack $w.top.structure -pady 6 -padx 6 -side top
2818     label $w.top.structure.label -text "Structure" -width 18
2819
2820     pack $w.top.structure.label $w.top.structure.b -fill x
2821
2822     # Truncation Attributes
2823
2824     pack $w.top.truncation -pady 6 -padx 6 -side top
2825     label $w.top.truncation.label -text "Truncation" -width 18
2826
2827     pack $w.top.truncation.label $w.top.truncation.b -fill x
2828
2829     # Completeness Attributes
2830
2831     pack $w.top.completeness -pady 6 -padx 6 -side top
2832     label $w.top.completeness.label -text "Completeness" -width 18
2833
2834     pack $w.top.completeness.label $w.top.completeness.b -fill x
2835
2836     # Ok-cancel
2837     bottom-buttons $w [list \
2838             {Ok} [list index-setup-action $attr $queryNo $indexNo] \
2839             {Cancel} [list destroy $w]] 0
2840
2841 }
2842
2843 # Procedure query-edit-index {queryNo}
2844 #  queryNo     query number
2845 # Determines if a selection of an index is active. If one is selected
2846 # the index-setup dialog is started.
2847 proc query-edit-index {queryNo} {
2848     global queryInfoTmp
2849     set w .query-setup
2850
2851     set i [lindex [$w.top.index.list curselection] 0]
2852     if {![string length $i]} {
2853         return
2854     }
2855     set attr [lindex $queryInfoTmp $i]
2856     dputs "Editing no $i $attr"
2857     index-setup $attr $queryNo $i
2858 }
2859
2860 # Procedure query-delete-index {queryNo}
2861 #  queryNo     query number
2862 # Determines if a selection of an index is active. If one is selected
2863 # the index is deleted.
2864 proc query-delete-index {queryNo} {
2865     global queryInfoTmp queryButtonsTmp
2866     set w .query-setup
2867
2868     set i [lindex [$w.top.index.list curselection] 0]
2869     if {![string length $i]} {
2870         return
2871     }
2872     set queryInfoTmp [lreplace $queryInfoTmp $i $i]
2873     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2874     $w.top.index.list delete $i
2875 }
2876
2877 # Procedure query-setup {queryNo}
2878 #  queryNo     query number
2879 # Makes a dialog in which a query type an be customized.
2880 proc query-setup {queryNo} {
2881     set w .query-setup
2882
2883     global queryTypes queryButtons queryInfo queryButtonsTmp queryInfoTmp queryIndexTmp
2884
2885     set queryIndexTmp 0
2886     set queryName [lindex $queryTypes $queryNo]
2887     set queryInfoTmp [lindex $queryInfo $queryNo]
2888     set queryButtonsTmp [lindex $queryButtons $queryNo]
2889
2890     toplevelG $w
2891
2892     wm minsize $w 0 0
2893     wm title $w "Query setup $queryName"
2894
2895     top-down-window $w
2896
2897     frame $w.top.lines -relief ridge -border 2
2898     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2899
2900     # Index Lines
2901
2902     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2903
2904     button $w.top.lines.add -text "Add" -command [list query-add-line $queryNo]
2905     button $w.top.lines.del -text "Remove" -command [list query-del-line $queryNo]
2906     pack $w.top.lines.del -fill x -side bottom
2907     pack $w.top.lines.add -fill x -pady 10 -side bottom
2908
2909     # Indexes
2910
2911     frame $w.top.index -relief ridge -border 2
2912     pack $w.top.index -pady 6 -padx 6 -side right -fill y
2913
2914     listbox $w.top.index.list -yscrollcommand [list $w.top.index.scroll set]
2915     scrollbar $w.top.index.scroll -orient vertical -border 1 \
2916         -command [list $w.top.index.list yview]
2917     bind $w.top.index.list <Double-1> [list query-edit-index $queryNo]
2918
2919     pack $w.top.index.list -side left -fill both -expand yes -padx 2 -pady 2
2920     pack $w.top.index.scroll -side right -fill y -padx 2 -pady 2
2921
2922     $w.top.index.list selection clear 0 end
2923     $w.top.index.list selection set 0 0
2924     foreach x $queryInfoTmp {
2925     $w.top.index.list insert end [lindex $x 0]
2926     }
2927
2928     # Bottom
2929     bottom-buttons $w [list \
2930             Ok [list query-setup-action $queryNo] \
2931             Add [list query-add-index $queryNo] \
2932             Edit [list query-edit-index $queryNo] \
2933             Delete [list query-delete-index $queryNo] \
2934             Cancel [list destroy $w]] 0
2935 }
2936
2937 # Procedure index-clear
2938 # Handler that clears the search entry fields.
2939 proc index-clear {} {
2940     global queryButtonsFind
2941
2942     set i 0
2943     foreach b $queryButtonsFind {
2944         .lines.$i.e delete 0 end
2945         incr i
2946     }
2947 }
2948
2949 # Procedure index-query
2950 # The purpose of this function is to read the user's query and convert
2951 # it to the prefix query that IrTcl/YAZ uses to represent an RPN query.
2952 # Each entry in a search fields takes the form
2953 #    [relOp][?]term[?]
2954 #  Here, relOp is an optional relational operator and one of:
2955 #      >  < >= <=  <>
2956 #    which sets the Bib-1 relation to greater-than, less-than, etc.
2957 #  The ? (question-mark) is also optional. A (?) on left-side indicates
2958 #    left truncation; (?) on right-side indicates right-truncation; (?)
2959 #    on both sides indicates both-left-and-right truncation.
2960 proc index-query {} {
2961     global queryButtonsFind queryInfoFind
2962
2963     set i 0
2964     set qs {}
2965
2966     foreach b $queryButtonsFind {
2967         set term [string trim [.lines.$i.e get]]
2968         if {$term != ""} {
2969             set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
2970
2971             set relation ""
2972             set len [string length $term]
2973             incr len -1
2974
2975             if {$len > 1} {
2976                 if {[string index $term 0] == ">"} {
2977                     if {[string index $term 1] == "=" } {
2978                         set term [string trim [string range $term 2 $len]]
2979                         set relation 4
2980                     } else {
2981                         set term [string trim [string range $term 1 $len]]
2982                         set relation 5
2983                     }
2984                 } elseif {[string index $term 0] == "<"} {
2985                     if {[string index $term 1] == "=" } {
2986                         set term [string trim [string range $term 2 $len]]
2987                         set relation 2
2988                     } elseif {[string index $term 1] == ">"} {
2989                         set term [string trim [string range $term 2 $len]]
2990                         set relation 6
2991                     } else {
2992                         set term [string trim [string range $term 1 $len]]
2993                         set relation 1
2994                     }
2995                 }
2996             }
2997             set len [string length $term]
2998             incr len -1
2999             set left 0
3000             set right 0
3001             if {[string index $term $len] == "?"} {
3002                 set right 1
3003                 set term [string range $term 0 [expr $len - 1]]
3004             }
3005             if {[string index $term 0] == "?"} {
3006                 set left 1
3007                 set term [string range $term 1 end]
3008             }
3009             set term "\{${term}\}"
3010             if {$right && $left} {
3011                 set term "@attr 5=3 ${term}"
3012             } elseif {$right} {
3013                 set term "@attr 5=1 ${term}"
3014             } elseif {$left} {
3015                 set term "@attr 5=2 ${term}"
3016             }
3017             if {$relation != ""} {
3018                 set term "@attr 2=${relation} ${term}"
3019             }
3020             foreach a $attr {
3021                 set term "@attr $a ${term}"
3022             }
3023             if {$qs != ""} {
3024                 set qs "@and ${qs} ${term}"
3025             } else {
3026                 set qs $term
3027             }
3028         }
3029         incr i
3030     }
3031     dputs "qs=  $qs"
3032     return $qs
3033 }
3034
3035 # Procedure index-focus-in {w i}
3036 #  w    index frame
3037 #  i    index number
3038 # This procedure handles <FocusIn> events. A red border is drawed
3039 # around the active search entry field when tk3.6 is used (tk4.X
3040 # makes a black focus border itself).
3041 proc index-focus-in {w i} {
3042     global curIndexEntry
3043     $w.$i configure -background red
3044     set curIndexEntry $i
3045 }
3046
3047 # Procedure index-lines {w readOp buttonInfo queryInfo handle}
3048 #  w          search fields entry frame
3049 #  realOp     if true, search-request bindings are bound to the entries.
3050 #  buttonInfo query type button information
3051 #  queryInfo  query type field information
3052 #  handle     handler called a when a 'listbutton' changes its value
3053 # Makes one or more search areas - with listbuttons on the left
3054 # and entries on the right.
3055 proc index-lines {w realOp buttonInfo queryInfo handle} {
3056     set i 0
3057     foreach b $buttonInfo {
3058         if {! [winfo exists $w.$i]} {
3059             frame $w.$i -border 0
3060         }
3061         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
3062
3063         if {$realOp} {
3064             if {! [winfo exists $w.$i.e]} {
3065                 entry $w.$i.e -width 32 -relief sunken -border 1
3066                 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
3067                                 bind $w.$i.e <FocusOut> [list $w.$i configure -background white]
3068                 pack $w.$i.l -side left
3069                 pack $w.$i.e -side left -fill x -expand yes
3070                 pack $w.$i -side top -fill x -padx 2 -pady 2
3071                 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
3072                 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
3073                 bind $w.$i.e <Return> {search-request 0}
3074             }
3075         } else {
3076             pack $w.$i.l -side left
3077             pack $w.$i -side top -fill x -padx 2 -pady 2
3078         }
3079         incr i
3080     }
3081     set j $i
3082     while {[winfo exists $w.$j]} {
3083         destroy $w.$j
3084         incr j
3085     }
3086     if {! $realOp} {
3087         return
3088     }
3089     set j 0
3090     incr i -1
3091     while {$j < $i} {
3092         set k [expr $j+1]
3093         bind $w.$j.e <Tab> "focus $w.$k.e"
3094         set j $k
3095     }
3096     if {$i >= 0} {
3097                 bind $w.$i.e <Tab> "focus $w.0.e"
3098         focus $w.0.e
3099     }
3100 }
3101
3102 # Procedure search-fields {w buttondefs}
3103 #  w           search fields entry frame
3104 #  buttondefs  button definitions
3105 # Makes search entry fields and listbuttons.
3106 # Note: This procedure is not used elsewhere. The index-lines
3107 #       procedure is used instead.
3108 proc search-fields {w buttondefs} {
3109     set i 0
3110     foreach buttondef $buttondefs {
3111         frame $w.$i -background white
3112
3113         listbutton $w.$i.l 0 $buttondef
3114         entry $w.$i.e -width 32 -relief sunken
3115
3116         pack $w.$i.l -side left
3117         pack $w.$i.e -side left -fill x -expand yes
3118         pack $w.$i -side top -fill x -padx 2 -pady 2
3119
3120         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
3121         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
3122
3123         incr i
3124     }
3125     set j 0
3126     incr i -1
3127     while {$j < $i} {
3128         set k [expr $j+1]
3129         bind $w.$j.e <Tab> "focus $w.$k.e \n
3130         $w.$k configure -background red \n
3131         $w.$j configure -background white"
3132         set j $k
3133     }
3134     bind $w.$i.e <Tab> "focus $w.0.e \n
3135         $w.0 configure -background red \n
3136         $w.$i configure -background white"
3137     focus $w.0.e
3138     $w.0 configure -background red
3139 }
3140
3141 #Procedure configureOptionsSyntax {target base}
3142 #target         target name
3143 #base           database name
3144 #Changes the Options|Syntax menu acording to the information obtained via explain.
3145 proc configureOptionsSyntax {target base} {
3146         if {[info exists profile{$target,syntax,$base}]} {
3147         #Dette kan ikke laves færdigt da Zebra ikke leverer nogle record syntax oplysninger endnu.
3148
3149         } else {
3150                 initOptionsSyntax
3151         }
3152 }
3153
3154 # Init: The geometry information for the main window is set - either
3155 # to a default value or to the value in windowGeometry(.)
3156 if {[catch {set g $windowGeometry(.)}]} {
3157     wm geometry . 420x340
3158 } else {
3159     wm geometry . $g
3160 }
3161
3162 # Init: Presentation formats are read.
3163 read-formats
3164
3165 # Init: The main window is defined.
3166 frame .top  -border 1 -relief raised
3167 frame .lines  -border 1 -relief raised
3168 frame .mid  -border 1 -relief raised
3169 frame .data -border 1 -relief raised
3170 frame .bot  -border 1 -relief raised
3171 pack .top .lines .mid -side top -fill x
3172 pack .data -side top -fill both -expand yes
3173 pack .bot -fill x
3174
3175 # Init: Definition of File menu.
3176 menubutton .top.file -text File -menu .top.file.m
3177 irmenu .top.file.m
3178 .top.file.m add command -label {Save settings} -command {save-settings}
3179 .top.file.m add separator
3180 .top.file.m add command -label Exit -command {exit-action}
3181
3182 # Init: Definition of Target menu.
3183 menubutton .top.target -text Target -menu .top.target.m
3184 irmenu .top.target.m
3185 .top.target.m add cascade -label Connect -menu .top.target.m.clist
3186 .top.target.m add command -label Disconnect -command {close-target}
3187 .top.target.m add command -label About -command {about-target}
3188 .top.target.m add cascade -label Setup -menu .top.target.m.slist
3189 .top.target.m add command -label {Setup new} -command {define-target-dialog}
3190 .top.target.m add separator
3191 set-target-hotlist 0
3192
3193 configure-disable-e .top.target.m 1
3194 configure-disable-e .top.target.m 2
3195
3196 irmenu .top.target.m.clist
3197 irmenu .top.target.m.slist
3198 cascade-target-list
3199
3200 # Init: Definition of Service menu.
3201 menubutton .top.service -text Service -menu .top.service.m
3202 irmenu .top.service.m
3203 .top.service.m add cascade -label Database -menu .top.service.m.dblist
3204 .top.service.m add cascade -label Present -menu .top.service.m.present
3205 irmenu .top.service.m.present
3206 .top.service.m.present add command -label {10 More} -command [list present-more 10]
3207 .top.service.m.present add command -label All -command [list present-more {}]
3208 .top.service.m add command -label Search -command {search-request 0}
3209 .top.service.m add command -label Scan -command {scan-request}
3210 .top.service.m add command -label Explain -command \
3211     {explain-refresh $hostid {ready-response {}} }
3212
3213 .top.service configure -state disabled
3214
3215 irmenu .top.service.m.dblist
3216
3217 # Init: Definition of Set menu.
3218 menubutton .top.rset -text Set -menu .top.rset.m
3219 irmenu .top.rset.m
3220 .top.rset.m add command -label Load -command {load-set}
3221 .top.rset.m add separator
3222
3223 # Init: Definition of the Options menu.
3224 menubutton .top.options -text Options -menu .top.options.m
3225 irmenu .top.options.m
3226 .top.options.m add cascade -label Query -menu .top.options.m.query
3227 .top.options.m add cascade -label Format -menu .top.options.m.formats
3228 .top.options.m add cascade -label Wrap -menu .top.options.m.wrap
3229 .top.options.m add cascade -label Syntax -menu .top.options.m.syntax
3230 .top.options.m add cascade -label Elements -menu .top.options.m.elements
3231 .top.options.m add radiobutton -label Debug -variable debugMode -value 1
3232
3233 # Init: Definition of the Options|Query menu.
3234 irmenu .top.options.m.query
3235 .top.options.m.query add cascade -label Select -menu .top.options.m.query.clist
3236 .top.options.m.query add cascade -label Edit -menu .top.options.m.query.slist
3237 .top.options.m.query add command -label New -command {query-new}
3238 .top.options.m.query add cascade -label Delete -menu .top.options.m.query.dlist
3239
3240 irmenu .top.options.m.query.slist
3241 irmenu .top.options.m.query.clist
3242 irmenu .top.options.m.query.dlist
3243 cascade-query-list
3244
3245 # Init: Definition of the Options|Formats menu.
3246 irmenu .top.options.m.formats
3247 set i 0
3248 foreach f $displayFormats {
3249     .top.options.m.formats add radiobutton -label $f -value $i \
3250             -command [list set-display-format $i] -variable displayFormat
3251     incr i
3252 }
3253
3254 # Init: Definition of the Options|Wrap menu.
3255 irmenu .top.options.m.wrap
3256 .top.options.m.wrap add radiobutton -label Character \
3257         -value char -variable textWrap -command {set-wrap char}
3258 .top.options.m.wrap add radiobutton -label Word \
3259         -value word -variable textWrap -command {set-wrap word}
3260 .top.options.m.wrap add radiobutton -label None \
3261         -value none -variable textWrap -command {set-wrap none}
3262
3263 # Init: Definition of the Options|Syntax menu.
3264 proc initOptionsSyntax {} {
3265         irmenu .top.options.m.syntax
3266         .top.options.m.syntax add radiobutton -label None -value None -variable recordSyntax
3267         .top.options.m.syntax add separator
3268         .top.options.m.syntax add radiobutton -label USMARC \
3269                 -value USMARC -variable recordSyntax
3270         .top.options.m.syntax add radiobutton -label UNIMARC \
3271                 -value UNIMARC -variable recordSyntax
3272         .top.options.m.syntax add radiobutton -label UKMARC \
3273                 -value UKMARC -variable recordSyntax
3274         .top.options.m.syntax add radiobutton -label DANMARC \
3275                 -value DANMARC -variable recordSyntax
3276         .top.options.m.syntax add radiobutton -label FINMARC \
3277                 -value FINMARC -variable recordSyntax
3278         .top.options.m.syntax add radiobutton -label NORMARC \
3279                 -value NORMARC -variable recordSyntax
3280         .top.options.m.syntax add radiobutton -label PICAMARC -value PICAMARC -variable recordSyntax
3281         .top.options.m.syntax add separator
3282         .top.options.m.syntax add radiobutton -label SUTRS -value SUTRS -variable recordSyntax
3283         .top.options.m.syntax add separator
3284         .top.options.m.syntax add radiobutton -label GRS1 -value GRS1 -variable recordSyntax
3285 }
3286 initOptionsSyntax
3287
3288 # Init: Definition of the Options|Elements menu.
3289 irmenu .top.options.m.elements
3290 .top.options.m.elements add radiobutton -label Unspecified \
3291         -value None -variable elementSetNames
3292 .top.options.m.elements add radiobutton -label Full \
3293         -value F -variable elementSetNames
3294 .top.options.m.elements add radiobutton -label Brief -value B -variable elementSetNames
3295
3296 # Init: Definition of Help menu.
3297 menubutton .top.help -text "Help" -menu .top.help.m
3298 irmenu .top.help.m
3299
3300 .top.help.m add command -label "Help on help" \
3301         -command {tkerror "Help on help not available. Sorry"}
3302 .top.help.m add command -label "About" -command {about-origin}
3303
3304 # Init: Pack menu bar items.
3305 pack .top.file .top.target .top.service .top.rset .top.options -side left
3306 pack .top.help -side right
3307
3308 # Init: Define query area.
3309 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
3310 image create photo scan -file ${libdir}/bitmaps/a-z.gif
3311 image create photo clear -file ${libdir}/bitmaps/trash.gif
3312 image create photo present -file ${libdir}/bitmaps/page.gif
3313 image create photo search -file ${libdir}/bitmaps/search.gif
3314 button .mid.search -image search -command {search-request 0} -state disabled -relief flat
3315 button .mid.scan -image scan -command scan-request -state disabled -relief flat
3316 button .mid.present -image present -command [list present-more 10] -state disabled -relief flat
3317 button .mid.clear -image clear -command index-clear -relief flat
3318 pack .mid.search .mid.scan .mid.present .mid.clear -side left -fill y -pady 1
3319
3320 # Init: Define record area in main window.
3321 text .data.record -font fixed -height 2 -width 20 -wrap none -borderwidth 0 \
3322         -relief flat -yscrollcommand [list .data.scroll set] -wrap $textWrap
3323 scrollbar .data.scroll -command [list .data.record yview]
3324 .data.record configure -takefocus 0
3325 .data.scroll configure -takefocus 0
3326
3327 pack .data.scroll -side right -fill y
3328 pack .data.record -expand yes -fill both
3329 initBindings
3330
3331 # Init: Define standards tags. These are used in the display
3332 # format procedures.
3333
3334 .data.record tag configure marc-tag -foreground blue
3335 .data.record tag configure marc-id -foreground red
3336 .data.record tag configure marc-data -foreground black
3337 .data.record tag configure marc-head -font $font(n,normal) \
3338         -foreground brown -relief raised -borderwidth 1
3339 .data.record tag configure marc-small-head -foreground brown
3340 .data.record tag configure marc-pref -font $font(n,normal) -foreground blue
3341 .data.record tag configure marc-text -font $font(n,normal) -foreground black
3342 .data.record tag configure marc-it -font $font(n,normal) -foreground black
3343
3344 # Init: Define logo.
3345 button .bot.logo -bitmap @${libdir}/bitmaps/book1 -command cancel-operation
3346 .bot.logo configure -takefocus 0
3347
3348 # Init: Define status information fields at the bottom.
3349 frame .bot.a
3350 pack .bot.a -side left -fill x
3351 pack .bot.logo -side right -padx 2 -pady 2 -ipadx 1
3352
3353 message .bot.a.target -text {} -aspect 2000 -border 1
3354
3355 label .bot.a.status -text "Not connected" -width 15 -relief sunken -anchor w -border 1
3356 label .bot.a.set -text "" -width 5 -relief sunken -anchor w -border 1
3357 label .bot.a.message -text "" -width 15 -relief sunken -anchor w -border 1
3358
3359 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
3360 pack .bot.a.status .bot.a.set .bot.a.message -side left -padx 2 -pady 2 -ipadx 1 -ipady 1
3361
3362 # Init: Determine if the IrTcl extension is already there. If
3363 #  not, then dynamically load the IrTcl extension.
3364 if {[catch {ir z39}]} {
3365     set e [info sharedlibextension]
3366     puts -nonewline "Loading irtcl$e ..."
3367     load ${libdir}/irtcl$e irtcl
3368     ir z39
3369     puts "ok"
3370 }
3371
3372 if {[file exists ${libdir}/explain.tcl]} {
3373     source ${libdir}/explain.tcl
3374 }
3375
3376 #if {[file exists ${libdir}/setup.tcl]}
3377     source ${libdir}/setup.tcl
3378
3379
3380 # Init: Uncomment this line if you wan't to enable logging.
3381 ir-log-init all irtcl irtcl.log
3382
3383 # Init: If hostid is a valid target, a new connection will be established
3384 # immediately.
3385 if {[string compare $hostid Default]} {
3386     catch {open-target $hostid $hostbase}
3387 }
3388
3389 # Init: Enable the logo.
3390 show-logo 1
3391