pfm 2.0.8-1 / usr / share / pfm / misc.tcl

# misc.tcl

# proc appendToPath
# This procedure joins 2 widget paths taking into account that
# the exception that {.} joined with "xxx" yields .xxx and not ..xxx

proc appendToPath {path tail} {

    if {$path eq {.}} then {
        set result "${path}${tail}"
    } else {
        set result "${path}.${tail}"
    }
    return $result
}

# proc addMenuItem {menuName itemLabel itemType argument}
#
#   - menuName: the pathname of the menu to which the item is to be added
#
#   - itemLabel: the untranslated label see files in subdir 'msgs' for
#                translated labels
#   - itemType: one of 'command', 'cascade'
#
#   - argument: if command, it is the command to bind to the menuitem
#               if cascade, it is the pathname of the menu to open
#
# This procedure adds a menu item to menu $menuName. It translates the
# $itemLabel using the files in subdir 'msgs' and looks for "&" in the
# translated label. If "&" is found, it is removed and a "-underline"
# clause is added to underline the character following the "&".
#
# This procedure returns an empty string

proc addMenuItem {menuName itemLabel itemType argument} {
    if {$itemType eq {cascade}} then {
        set thirdClause {-menu}
    } else {
        set thirdClause {-command}
    }
    set translated [mcunderline $itemLabel]
    if {[llength $translated] > 1} then {
        $menuName add $itemType \
            -label [lindex $translated 0] -underline [lindex $translated 1] \
            $thirdClause $argument
    } else {
        $menuName add $itemType \
            -label [lindex $translated 0] $thirdClause $argument
    }
    return
}

# proc defineButton {btnName bindTag btnLabel btnCommand}
#
#  - btnName: the pathname of the button to define
#
#  - bindTag: the tag to use in the bind command for the shortcut
#
#  - btnLabel: the untranslated string to display on the button
#
#  - btnCommand: the command to bind to the button.
#
# This procedure defines a button with pathname $btnName and returns
# $btnName. It translates the $btnLabel using the files in subdir 'msgs'
# and looks for "&" in the translated label. If "&" is found, it is
# removed, a "-underline" clause is added to underline the character
# following the "&" and $btnCommand is also bound to <Alt-KeyPress-x>
# where 'x' is the underlined character.
#
# Nasty problem: The binding for the keyboard shortcut with AltUnderlined
# is difficult to get right:
#
#   - without 'after 200' it works on Windows, but on Linux when
#     the button command destroys the 'text' widget that received the
#     KeyPress event, Tk raises on error because it tries to do something
#     with the text widget that has already been destroyed.
#
#   - with 'after idle' it works well on Linux but on Windows,
#     Tk derails completely when the command creates a new toplevel.
#     It goes into an endless loop with high CPU load.
#
#   - with 'after 200' it seems to work well on both Windows and Linux,
#     but I can only hope that 200 ms will always be sufficient to
#     avoid the problem.
#
#   - I have also tried to generate a virtual event <<ALtUnderlined>>,
#     but that path leads to the same troubles.

proc defineButton {btnName bindTag btnLabel btnCommand} {
    set translation [mcunderline $btnLabel]
    if {[llength $translation] > 1} then {
        set widget [ttk::button $btnName -takefocus 0 -command $btnCommand \
            -text [lindex $translation 0] -underline [lindex $translation 1]]
        bind $bindTag <Alt-KeyPress-[lindex $translation 2]> \
            [list after 200 [list $btnName instate {!disabled} [list $btnName invoke]]]
    } else {
        set widget [ttk::button $btnName -takefocus 0 -command $btnCommand \
            -text [lindex $translation 0]]
    }
    return $widget
}

# Same as define button, but for a checkbutton

proc defineCheckbutton {btnName bindTag btnLabel btnCommand btnVariable OnValue OffValue} {
    set translation [mcunderline $btnLabel]
    if {[llength $translation] > 1} then {
        set widget [ttk::checkbutton $btnName -takefocus 0 -command $btnCommand \
            -text [lindex $translation 0] -underline [lindex $translation 1] \
            -variable $btnVariable -onvalue $OnValue -offvalue $OffValue]
        bind $bindTag <Alt-KeyPress-[lindex $translation 2]> \
            [list after 200 [list $btnName instate {!disabled} [list $btnName invoke]]]
    } else {
        set widget [ttk::checkbutton $btnName -command $btnCommand \
            -text [lindex $translation 0] \
            -variable $btnVariable -onvalue $OnValue -offvalue $OffValue]
    }
    return $widget
}

# Same as define button, but for a radiobutton

proc defineRadiobutton {btnName bindTag btnLabel btnCommand btnVariable value} {
    set translation [mcunderline $btnLabel]
    if {[llength $translation] > 1} then {
        set widget [ttk::radiobutton $btnName -takefocus 0 -command $btnCommand \
            -text [lindex $translation 0] -underline [lindex $translation 1] \
            -variable $btnVariable -value $value]
        bind $bindTag <Alt-KeyPress-[lindex $translation 2]> \
            [list after 200 [list $btnName instate {!disabled} [list $btnName invoke]]]
    } else {
        set widget [ttk::radiobutton $btnName -command $btnCommand \
            -text [lindex $translation 0] \
            -variable $btnVariable -value $value]
    }
    return $widget
}

# Append newTag to a widget's bindtags

proc appendBindTag {widget newTag} {
    set tags [bindtags $widget]
    lappend tags $newTag
    bindtags $widget $tags
    return
}

# bindToplevelOnly $topPath $event $script
#
# This procedure generates a new unique bindtag of the form
# "tpOnly$counter" where counter is incremented at every invocation
# of the procedure. Then it appends this bindtag to the toplevel
# identified by $topPath and binds $event and $script to this new bindtag.
#
# Normally a toplevel receives the events from all its children.
# Sometimes that is not what you want. E.g. to catch the <Destroy> event
# from a toplevel, it is not a good idea to bind a script to the toplevel
# because it will be called for every child of the toplevel that is
# destroyed.

namespace eval TpOnlyTags {variable counter 0}

proc bindToplevelOnly {topPath event script} {
    variable TpOnlyTags::counter
    set newTag "tpOnly$counter"
    incr counter
    appendBindTag $topPath $newTag
    bind $newTag $event $script
    return $newTag
}

# Append a bindtag $tag to all descendants of $widget
proc recursiveAppendTag {widget tag} {
    foreach child [winfo children $widget] {
        appendBindTag $child $tag
        recursiveAppendTag $child $tag
    }
    return
}

# proc mcunderline {untranslated}
#
#    - untranslated: is the untranslated string
#
# This procedure translates the untranslated string using the files
# in subdir msgs. It also looks for "&" in the translated string.
#
# If "&" is found:
#    the procedure returns a list in which:
#        - the 1st item is the translated string without "&"
#        - the index where the "&" was located
#        - the lower case character that was following the "&" (i.e.
#          the character that will be displayed underlined)
# else:
#     the procedure returns a list in which the translated string
#     is the only element.

proc mcunderline {untranslated} {
    set translated [mc $untranslated]
    set underline [string first {&} $translated]
    if {$underline >= 0} then {
        set translated [string replace $translated $underline $underline]
        set shortcut [string tolower [string index $translated $underline]]
        set result [list $translated $underline $shortcut]
    } else {
        set result [list $translated]
    }
    return $result
}

# proc addNotebookTab {nbName window tabLabel}
#
#   - nbName: the name of the notebook to which a tab will be added
#   - window: the the name of the window that will be added as tab
#   - tabLabel: the untranslated label to display on the tab
#
# This procedure translates the tabLabel using the files in the msgs
# subdirectory. It also looks for & to take care of underlining the
# next character. Then it calls the normal notebook add command.

proc addNotebookTab {nbName window tabLabel} {
    set translated [mcunderline $tabLabel]
    if {[llength $translated] > 1} then {
        $nbName add $window \
            -text [lindex $translated 0] -underline [lindex $translated 1]
    } else {
        $nbName add $window -text [lindex $translated 0]
    }
    return
}
# proc pfm_message {msg parent}
# This procedure reports an error message 'msg'. 'msg' must be a
# translated string.

proc pfm_message {msg parent} {
    if {[info command winfo] eq {winfo}} then {
        dict append arg parent $parent
        dict append arg title [mc pfm_message]
        dict append arg message $msg
        dict append arg msgWidth 500
        dict append arg defaultButton btnOK
        dict append arg buttonList btnOK
        set dlg [GenDialog "#auto" $arg]
        $dlg wait
    } else {
        puts $msg
    }
    return
}

# A GenDialog object displays a toplevel window containing a message
# and a number of buttons. The "wait" method waits for the user to press
# one of the buttons and returns the label of the pressed button.
#
# A GenDialog object is created as follows:
#
# GenDialog "#auto" $arg
# where $arg is a dictionary with the folling keys:
#    - parent: the toplevel parent window
#    - title: the title to give to the toplevel window that is created
#    - message: the text to display on the window. This is the translated
#            text.
#    - msgWidth: the width in pixels of the message
#    - defaultButton: the untranslated label of the default button, i.e.
#            the button that initially gets the focus
#    - buttonList: the list of untranslated labels for the buttons that
#            will be displayed.
#
# After creating a GenDialog object you can call the wait method to
# get the result. It returns the label of the pressed button.
#
# You don't have to worry about deleting the object. It is automatically
# deleted after returning from wait.

class GenDialog {
    protected variable window
    protected variable buttonPressed
    protected variable waitCalled 0

    constructor {arg} {
        set window [toplevel \
            [appendToPath [dict get $arg parent] [namespace tail $this]]]
        set buttonPressed [dict get $arg defaultButton]
        wm title $window [dict get $arg title]
        set parent [dict get $arg parent]
        wm transient $window $parent
        set x [expr [winfo rootx $parent] + 100]
        set y [expr [winfo rooty $parent] + 50]
        wm geometry $window "+${x}+${y}"
        set msg [message ${window}.msg \
            -width [dict get $arg msgWidth] \
            -justify left \
            -text [dict get $arg message]]
        set frm [ttk::frame ${window}.frm]
        set row 0
        foreach btnLabel [dict get $arg buttonList] {
            set btn [defineButton $frm.$btnLabel $window $btnLabel \
                [list $this onButton $btnLabel]]
            grid $btn -row 0 -column $row
            incr row
        }
        pack $msg -side top -expand 1 -fill both -padx {10 10} -pady {10 10}
        pack $frm -side top -pady {0 10}
        if {[dict get $arg defaultButton] in [dict get $arg buttonList]} then {
            focus $frm.[dict get $arg defaultButton]
        }
        bindToplevelOnly $window <Destroy> [list $this onDestroy]
        bind $window <KeyPress-Escape> [list destroy $window]
    }

    destructor {
        return
    }

    public method onDestroy {} {
        if {!$waitCalled} then {
            after idle [list delete object $this]
        }
        return
    }

    public method onButton {btnLabel} {
        set buttonPressed $btnLabel
        destroy $window
        return
    }

    public method wait {} {
        set waitCalled 1
        tkwait window $window
        after idle [list delete object $this]
        return $buttonPressed
    }
}

# Class GenForm

# A GenForm object displays a toplevel window which enables the user to
# see and modify a number of data.
#
# A GenForm object is created as follows:
#
#      GenForm $id $parent $title $dataList
#
#      where: $id: is the new object's name. If "#auto" is used
#                 for this parameter, a new name is created automatically
#
#             $parent: is the parent's window path
#
#             $title: title for window
#
#             $dataList is a list containing an item for each data item
#                 that is displayed on the window, and where each item
#                 is a dict with the folling keys:
#                     -name: data item's name which must be unique
#                            within this dialog
#                     -type: the data item's type, which must be one of
#                            string, bool, password
#                     -value: the data item's initial value
#                     -valuelist: a list of allowed values. If this
#                            list is not empty, a combox is used, else
#                            a normal text entry is used.
#
# After creating the object, call the object's wait method to get the
# result:
#
#  genFormObject wait resultName
#
# This method returns 1 or 0 depending on whether OK or cancel was
# pressed. The results become available in the array with name
# resultName.
#
# You don't have to worry about deleting the object. If the user presses
# OK or Cancel, or if he destroys the window. The object is deleted
# as well.

class GenForm {
    protected variable data
    protected variable window
    protected variable pressedOK 0
    protected variable waitCalled 0
    protected variable frm1

    constructor {parent title dataList} {
        set pressedOK 0
        set window [toplevel \
            [appendToPath $parent [namespace tail $this]]]
        wm transient $window $parent
        set x [expr [winfo rootx $parent] + 100]
        set y [expr [winfo rooty $parent] + 50]
        wm geometry $window "+${x}+${y}"
        wm title $window $title
        set frm1 [ttk::frame ${window}.frm1]
        set idx 0
        foreach item $dataList {
            set name [dict get $item name]
            set type [dict get $item type]
            set value [dict get $item value]
            set valuelist [dict get $item valuelist]
            set data($name) $value
            set label [ttk::label $frm1.lb$idx -text $name]
            switch $type {
                bool {
                    set control [ttk::checkbutton $frm1.cont$idx \
                        -variable [scope data($name)] \
                        -onvalue 1 -offvalue 0]
                    set sticky w
                }
                password {
                    set control [entry $frm1.cont$idx \
                        -textvariable [scope data($name)] \
                        -show "*"]
                    set sticky we
                }
                default {
                    if {[llength $valuelist] > 0} then {
                        set control [ttk::combobox $frm1.cont$idx \
                            -textvariable [scope data($name)] \
                            -values $valuelist]
                        set sticky we
                    } else {
                        set control [entry $frm1.cont$idx \
                            -textvariable [scope data($name)]]
                        set sticky we
                    }
                }
            }
            if {$idx == 0} then {
                focus $control
            }
            grid $label -column 0 -row $idx -sticky $sticky
            grid $control -column 1 -row $idx -sticky $sticky
            incr idx
        }
        grid columnconfigure $frm1 1 -weight 1
        pack $frm1 -side top -padx {10 10} -pady {10 10}
        set frm2 [ttk::frame ${window}.frm2]
        set btnOK [defineButton $frm2.ok $window btnOK [list $this onOK]]
        set btnCancel [defineButton $frm2.cancel $window btnCancel \
            [list $this onCancel]]
        $btnOK configure -takefocus 1
        $btnCancel configure -takefocus 1
        pack $btnCancel -side right
        pack $btnOK -side right
        pack $frm2 -side top -fill x -padx {10 10} -pady {0 10}
        bindToplevelOnly $window <Destroy> [list $this onDestroy]
        bind $window <KeyPress-Escape> [list destroy $window]
        bind $window <KeyPress-Down> {focus [tk_focusNext [focus]]}
        bind $window <KeyPress-Up> {focus [tk_focusPrev [focus]]}
        bind $window <KeyPress-Return> [list $this onOK]
    }

    destructor {
    }

    public method onDestroy {} {
        if {!$waitCalled} then {
            after idle [list delete object $this]
        }
        return
    }

    public method wait {resultVar} {
        upvar $resultVar result
        set waitCalled 1
        tkwait window $window
        array set result [array get data]
        after idle [list delete object $this]
        return $pressedOK
    }

    public method onOK {} {
        set pressedOK 1
        destroy $window
        return
    }

    public method onCancel {} {
        set pressedOK 0
        destroy $window
        return
    }

    public method displayHelpText {helpText} {
        set lbHelp [ttk::label ${window}.lbHelp -text $helpText \
            -padding {10 10 10 10}]
        pack $lbHelp -side top -before $frm1
        return
    }
}

# A TextEdit object displays a window in which the user can see
# and possibly edit a text. To create a TextEdit object use:
#
#     TextEdit #auto $parent $title $initialText $readOnly
#
# where: - $parent is the widget pathname of the parent window
#        - $title is the window title
#        - $initialText: is the text that will be displayed initially
#        - $readOnly: 0 or 1, indicating whether the user is allowed
#                     to edit the text.
#
# After creating the object, there are 3 possible modes of use.
#
# 1. Normal mode:  In this mode, the initial text is displayed, but
#                  it is not possible to get any result. You don't
#                  have to worry about deleting the object. It is
#                  deleted automatically when the user pressed OK or
#                  Cancel, or when he destroys the window. This mode
#                  is only usefull for readOnly text.
#
# 2. Wait mode:    In this mode, after creating the object, you call
#                  the object's "wait" method. This method does not
#                  return before the user has pressed OK or Cancel, or
#                  has destroyed the window. The wait method should be
#                  called as follows:
#
#                  textEditObject wait textVarName
#
#                  It returns 1 or 0 edpending on wheter OK or Cancel
#                  was pressed, and it stores the result in the variable
#                  with the name textVarName. You don't have to worry
#                  about deleting the object. It is automatically deleted
#                  after returning from the wait method.
#
# 3. CallBack mode: In this mode, after creating the object, you call
#                  the object's "defineCallBack" method. This method is
#                  called as follows:
#
#                  textEditObject defineCallBack callBackScript
#
#                  This callBackScript must call the object's getText
#                  method as follows:
#
#                  textEditObject getText textVarName
#
#                  It returns 1 or 0 depending on whether OK or Cancel
#                  was pressed, and it stores the result in the variable
#                  with the name textVarName. After returning from this
#                  method, the textEditObject no longer exists. So, you
#                  can call this method only once.
#
# You can also add custom menus to the this widget using the method
# addMenuItem
#
#  textEditObject addMenuItem $btnLabel $type $arg
#
# where $type is either command or cascade
#
# $arg is then either a script to be called when the menuitem is invoked,
# or the name of a menu in case of cascade.
#
# In case of command, you can use %T to represent the text widget's pathname.
#
# If you want to destroy the object, do not call delete object, but
# call the destroyWindow method instead.


class TextEdit {
    public variable window
    protected variable menubar
    protected variable readOnly
    protected variable txtWidget
    protected variable actualText {}
    protected variable wrap {none}
    protected variable btnFrame
    protected variable entSearch
    protected variable pressedOK 0
    protected variable mode normal
    protected variable callback

    constructor {parent title initialText c_readOnly} {
        set readOnly $c_readOnly
        setupWindow $parent $title $initialText
    }

    destructor {
    }

    protected method setupWindow {parent title initialText} {
        set window [toplevel [appendToPath $parent [namespace tail $this]]]
        wm title $window $title
        wm geometry $window [join $::geometry::text {x}]
        set menubar [setupMenus]
        $window configure -menu $menubar
        set txtWidget [text $window.txt -width 1 -height 1 -wrap $wrap]
        $txtWidget tag configure blue -foreground {medium blue}
        $txtWidget tag configure red -foreground {red3}
        $txtWidget tag configure green -foreground {green4}
        if {$readOnly} then {
            $txtWidget configure -background $::readonlyBackground
        }
        set vsb [ttk::scrollbar $window.vsb -orient vertical \
            -command [list $txtWidget yview]]
        set hsb [ttk::scrollbar $window.hsb -orient horizontal \
            -command [list $txtWidget xview]]
        $txtWidget configure \
            -yscrollcommand [list $vsb set] \
            -xscrollcommand [list $hsb set]
        $txtWidget insert end $initialText
        $txtWidget mark set insert 1.0
        $txtWidget yview 0
        set btnFrame [ttk::frame $window.btnFrame]
        if {!$readOnly} then {
            set btnOK [defineButton $btnFrame.btnOK $window btnOK \
                [list $this onOK]]
            $btnOK configure -style SButton
        } else {
            set lbReadOnly [ttk::label $btnFrame.rdonly \
                -text [mc lbReadOnly] -foreground {medium blue}]
            $txtWidget configure -state disabled
        }
        set btnCancel [defineButton $btnFrame.btnCancel $window btnCancel \
            [list $this onCancel]]
        $btnCancel configure -style SButton
        set btnWrap [defineCheckbutton $btnFrame.btnWrap $window btnWrap \
            [list $this onWrap] [scope wrap] word none]
        set searchFrm [ttk::frame $btnFrame.search]
        set btnSearch [defineButton $searchFrm.btn $window btnSearch \
            [list $this onSearch]]
        $btnSearch configure -style SButton
        set entSearch [entry $searchFrm.ent]
        bind $entSearch <KeyPress-Return> [list $this onSearch]
        pack $btnSearch -side right
        pack $entSearch -side right -expand 1 -fill both
        grid $txtWidget -column 0 -row 0 -sticky wens
        grid $vsb -column 1 -row 0 -sticky ns
        grid $hsb -column 0 -row 1 -sticky we
        grid $btnFrame -column 0 -columnspan 2 -row 2 -sticky we \
            -pady {10 10} -padx {10 10}
        grid [ttk::sizegrip ${window}.sg] -column 0 -columnspan 2 \
            -row 3 -sticky e
        grid columnconfigure $window 0 -weight 1
        grid rowconfigure $window 0 -weight 1
        pack $btnCancel -side right
        if {!$readOnly} then {
            pack $btnOK -side right
        } else {
            pack $lbReadOnly -side right
        }
        pack $searchFrm -side right -expand 1 -fill x
        pack $btnWrap -side right
        set tpOnly [bindToplevelOnly $window <Destroy> [list $this onDestroy]]
        bind $tpOnly <Configure> {set ::geometry::text {%w %h}}
        bind $window <KeyPress-Escape> [list destroy $window]
        focus $txtWidget
        return
    }

    protected method setupMenus {} {
        set menu [menu ${window}.menubar -tearoff 0]
        set mnuText [menu ${menu}.text -tearoff 0]
        ::addMenuItem $mnuText mnuTxtSave command [list $this onSave]
        ::addMenuItem $mnuText mnuTxtPrint command [list $this onPrint]
        $mnuText add separator
        ::addMenuItem $mnuText mnuTxtClose command [list destroy $window]
        $mnuText entryconfigure 3 -accelerator {Esc}
        ::addMenuItem $menu mnuText cascade $mnuText
        return $menu
    }

    public method onDestroy {} {
        switch $mode {
            normal {
                after idle [list delete object $this]
            }
            callback {
                eval $callback
            }
        }
        return
    }

    public method onPrint {} {
        printTextWidget $txtWidget $window
        return
    }

    public method onSave {} {
        saveTxtFromWidget $txtWidget $window
        return
    }

    public method onWrap {} {
        $txtWidget configure -wrap $wrap
        return
    }

    public method gotoBegin {} {
        $txtWidget mark set insert 1.0
        $txtWidget yview 0
        return
    }

    public method onSearch {} {
        focus $entSearch
        set pattern [$entSearch get]
        if {[string length $pattern]} then {
            set searchPosition [$txtWidget index insert]
            $txtWidget tag delete match
            set searchPosition [$txtWidget search -nocase \
                $pattern $searchPosition end]
            if {$searchPosition ne {}} then {
                set endmatch [$txtWidget index \
                    "$searchPosition +[string length $pattern] chars"]
                $txtWidget tag add match $searchPosition $endmatch
                $txtWidget tag configure match -background yellow
                $txtWidget mark set insert $endmatch
                $txtWidget see insert
            } else {
                pfm_message [mc searchEOT] $window
                $txtWidget mark set insert 1.0
                $txtWidget see insert
            }
        }
        return
    }

    public method onOK {} {
        set pressedOK 1
        set actualText [$txtWidget get 1.0 "end - 1 chars"]
        destroy $window
        return
    }

    public method onCancel {} {
        set pressedOK 0
        set actualText {}
        destroy $window
        return
    }

    public method addMenuItem {itemLabel itemType argument} {
        set argument [string map [list %T $txtWidget] $argument]
        ::addMenuItem $menubar $itemLabel $itemType $argument
        return
    }

    public method getText {textVar} {
        upvar $textVar result
        if {$pressedOK} then {
            set result $actualText
        }
        after idle [list delete object $this]
        return $pressedOK
    }

    public method setText {textVar} {
        upvar $textVar text
        if {$readOnly} then {
            $txtWidget configure -state normal
        }
        $txtWidget delete 1.0 end
        $txtWidget insert end $text
        if {$readOnly} then {
            $txtWidget configure -state disabled
        }
        return
    }

    public method appendText {text colour} {
        if {$readOnly} then {
            $txtWidget configure -state normal
        }
        if {$colour in {red green blue}} then {
            $txtWidget insert end $text $colour
        } else {
            $txtWidget insert end $text
        }
        if {$readOnly} then {
            $txtWidget configure -state disabled
        }
        return
    }

    public method wait {textVar} {
        upvar $textVar result
        set mode wait
        tkwait window $window
        set result $actualText
        after idle [list delete object $this]
        return $pressedOK
    }

    public method defineCallBack {callBackScript} {
        set callback $callBackScript
        set mode callback
        return
    }

    public method destroyWindow {} {
        destroy $window
        return
    }
}

# A ListBox object creates a toplevel window with a multicolumn listbox
# (ttk::treeview control) to allow the user to select a value from
# a list of values. Additionally, it has an entry and a button which
# allows the user to search for a particular string in the listbox
# values.
#
# To create a ListBox object call
#
# ListBox "#auto" $parent $title $headerlist $valuelist $selected
#
# where: -parent is the pathname of the parent toplevel window.
#        -title: the toplevel's title
#        -headerlist: the list of column headers. The length of
#         this list determines the number of columns
#        -valuelist: the list of values for the listbox where each item
#         is a list containing a value for each column
#        -selected: the index of the initially selected listbox item
#
# ListBox tries to estimate an optimum columnwidth and window size.
#
# After creating the ListBox object, call the wait method to
# get the uer's choice:
#
# listBoxObject wait result
#
# where result is the name of the variable that will receive the
# selected value(s). The return value of the wait method is 1 or 0
# depending on whether the user has really selected a value or
# just destroyed the window.
#
# If you want to destroy the object, do not call delete object, but
# call the destroyWindow method instead.

class ListBox {
    protected variable window
    protected variable valuelist {}
    protected variable lsb
    protected variable entSearch
    protected variable waitCalled 0
    protected variable itemSelected 0
    protected variable selectedValues {}
    protected variable statusfield
    protected variable stringFound 0

    constructor {parent title headerlist c_valuelist selected} {
        set valuelist $c_valuelist
        set window [toplevel [appendToPath $parent [namespace tail $this]]]
        wm transient $window $parent
        set x [expr [winfo rootx $parent] + 100]
        set y [expr [winfo rooty $parent] + 50]
        wm geometry $window "+${x}+${y}"
        wm title $window $title
        set frmSearch [ttk::frame $window.frmSearch]
        set entSearch [entry $frmSearch.ent]
        set btnSearch [defineButton $frmSearch.btn $window btnSearch \
            [list $this onSearch]]
        $btnSearch configure -style SButton
        bind $entSearch <KeyPress-Return> [list $this onSearch]
        pack $btnSearch -side right
        pack $entSearch -side right -expand 1 -fill both
        set frmLsb [ttk::frame $window.frmlsb]
        set columnlist {}
        for {set idx 0} {$idx < [llength $headerlist]} {incr idx} {
            lappend columnlist col$idx
        }
        set lsb [ttk::treeview $frmLsb.lsb -columns $columnlist \
            -selectmode browse -show headings]
        set idx 0
        foreach heading $headerlist {
            $lsb heading col$idx -text $heading
            $lsb column col$idx -width [estimateColumnWidth $idx]
            incr idx
        }
        set idx 0
        set selItem "I0"
        foreach tuple $valuelist {
            set item [$lsb insert {} end -id "I$idx" -values $tuple]
            if {$idx == $selected} then {
                set selItem $item
            }
            incr idx
        }
        set vsb [ttk::scrollbar $frmLsb.vsb -orient vertical \
            -command [list $lsb yview]]
        $lsb configure -yscrollcommand [list $vsb set]
        grid $lsb -column 0 -row 0 -sticky wens
        grid $vsb -column 1 -row 0 -sticky ns
        grid columnconfigure $frmLsb 0 -weight 1
        grid rowconfigure $frmLsb 0 -weight 1
        set btnBar [ttk::frame $window.btnBar]
        set btnOK [defineButton $btnBar.btnOK $window btnOK \
            [list $this onSelection]]
        $btnOK configure -style TButton
        set btnCancel [defineButton $btnBar.btnCancel $window btnCancel \
            [list destroy $window]]
        $btnCancel configure -style TButton
        grid $btnOK -column 0 -row 0
        grid $btnCancel -column 1 -row 0
        grid anchor $btnBar center
        set statusbar [ttk::frame $window.sb]
        set statusfield [ttk::label $statusbar.sf]
        set grip [ttk::sizegrip $statusbar.sg]
        grid $statusfield -column 0 -row 0
        grid $grip -column 1 -row 0 -sticky e
        grid columnconfigure $statusbar 0 -weight 1
        pack $frmSearch -side top -fill x -pady 10 -padx 10
        pack $frmLsb -side top -expand 1 -fill both
        pack $btnBar -side top -fill x -ipady 10 -ipadx 10
        pack $statusbar -side top -fill x
        bindToplevelOnly $window <Destroy> [list $this onDestroy]
        # bind $lsb <1> [list after idle [list $this onSelection]]
        # Note: The above binding has the annoying side effect that
        # the user cannot adjust the column widths without destroying
        # the window. That is why it has been commented out.
        bind $lsb <KeyPress-Return> [list after idle [list $this onSelection]]
        bind $window <KeyPress-Escape> [list destroy $window]
        update
        focus $window
        focus $lsb
        # next "if" statement has been added for bug 1073
        if {[llength $valuelist] > 0} then {
            $lsb see $selItem
            $lsb selection set $selItem
            $lsb focus $selItem
        }
        return
    }

    destructor {
        return
    }

    protected method estimateColumnWidth {column} {
        set nrOfChars 0
        set text {}
        foreach tuple $valuelist {
            set stringLength [string length [lindex $tuple $column]]
            if {$stringLength > $nrOfChars} then {
                set nrOfChars $stringLength
                set text [lindex $tuple $column]
            }
        }
        set width [font measure TkTextFont -displayof $window " $text "]
        return $width
    }

    public method onDestroy {} {
        if {!$waitCalled} then {
            after idle [list delete object $this]
        }
        return
    }

    public method destroyWindow {} {
        destroy $window
        return
    }

    public method onSelection {} {
        set itemSelected 1
        set selectedValues [$lsb item [$lsb selection] -values]
        destroy $window
        return
    }

    public method wait {resultName} {
        upvar $resultName result
        set waitCalled 1
        tkwait window $window
        set result $selectedValues
        after idle [list delete object $this]
        return $itemSelected
    }

    public method onSearch {} {
        focus $entSearch
        set searchString [$entSearch get]
        if {[string length $searchString]} then {
            set currentValues [$lsb item [$lsb selection] -values]
            set startIndex [lsearch -exact $valuelist $currentValues]
            if {$stringFound} then {
                set startIndex [expr $startIndex + 1]
            }
            set newIndex [lsearch -nocase -glob -start $startIndex \
                $valuelist "*${searchString}*"]
            if {$newIndex >= 0} then {
                set stringFound 1
                $lsb selection set "I${newIndex}"
                $lsb focus "I${newIndex}"
                $lsb see "I${newIndex}"
                $statusfield configure -text [mc lsbSearchFound $searchString]
            } else {
                set stringFound 0
                $lsb selection set "I0"
                $lsb focus "I0"
                $lsb see "I0"
                $statusfield configure -text [mc lsbSearchNotFound]
            }
        }
        return
    }
}

proc convertToUTF-8 {fileName fromEncoding parent} {
    # This procedures converts $fileName from $fromEncoding to UTF-8.
    # It writes the converted file in pfmOptions(tmpdir) and returns
    # the name of the converted file.
    #
    # Even if the $fromEncoding = utf-8, we execute this conversion.
    # Tcl seems to be rather clever to recognise encodings such that
    # even if the user has specifed utf-8 when that is not correct,
    # Tcl converts it to utf-8.

    set outFileName {}
    set tmpdir [$::pfmOptions getOption general tmpdir]
    if {![file exists $tmpdir]} then {
        if {[catch {file mkdir $tmpdir} errMsg]} then {
            pfm_message $errMsg $parent
        }
    }
    if {[catch {open $fileName r} inFile]} then {
        pfm_message $inFile $parent
    } else {
        chan configure $inFile -encoding $fromEncoding
        set tail [file tail $fileName]
        set tmpName "pfm[pid]_${tail}"
        set outFileName [file join $tmpdir $tmpName]
        lappend ::tmpFiles $outFileName
        if {[catch {open $outFileName w} outFile]} then {
            pfm_message $outFile $parent
            set outFileName {}
        } else {
            # bug 1057 "-translation lf" added in version 1.5.2
            # Without this modification, tcl would use CR LF
            # as line ending on the Windows platform. psql would
            # interpret LF as line ending and it would consider CR
            # as an extra character.
            chan configure $outFile -encoding utf-8 -translation lf
            while {![eof $inFile]} {
                chan puts $outFile [chan gets $inFile]
            }
        chan close $inFile
        chan close $outFile
        }
    }
    return $outFileName
}

proc versionCompare {v1 v2} {
    # This procedures compares 2 version numbers of the form x.y.z
    # It returns:
    #      +1 if v1 > v2
    #       0 if v1 = v2
    #      -1 if v1 < v2

    set v1List [split $v1 "."]
    set v2List [split $v2 "."]
    set result 0
    for {set i 0} {($i <= 2) && ($result == 0)} {incr i} {
        if {[lindex $v1List $i] < [lindex $v2List $i]} then {
            set result -1
        } else {
            if {[lindex $v1List $i] > [lindex $v2List $i]} then {
                set result 1
            }
        }
    }
    return $result
}

# ContextMenu defines a popup menu with the menu items:
# 0: Copy
# 1: Cut
# 2: Paste

namespace eval ContextMenu {
    variable menu

    proc setup {} {
        variable menu
        set menu [menu .mnEdit -tearoff 0]
        addMenuItem $menu mnuCopy command ::ContextMenu::onCopy
        addMenuItem $menu mnuCut command ::ContextMenu::onCut
        addMenuItem $menu mnuPaste command {}
        $menu entryconfigure 0 -accelerator {Cntrl-c}
        $menu entryconfigure 1 -accelerator {Cntrl-x}
        $menu entryconfigure 2 -accelerator {Cntrl-v}

        bind all <ButtonPress-3> [list ::ContextMenu::popUpMenu %W %X %Y]
        bind all <Control-KeyPress-c> ::ContextMenu::onCopy
        bind all <Control-KeyPress-x> ::ContextMenu::onCut
        # bind all <Control-KeyPress-v> [list ::ContextMenu::onPaste %W]
        # This is already a deafult Tk binding. If above line is
        # uncommented, text is pasted twice.
        return
    }

    proc popUpMenu {clickedWidget x y} {
        variable menu
        set owner [selectionOwner]
        if {$owner eq {}} then {
            $menu entryconfigure 0 -state disabled
            $menu entryconfigure 1 -state disabled
        } else {
            $menu entryconfigure 0 -state normal
            if {[getState $owner] eq {normal}} then {
                $menu entryconfigure 1 -state normal
            } else {
                $menu entryconfigure 1 -state disabled
            }
        }
        if {([getState $clickedWidget] eq {normal}) && [getClipboardText textToPaste]} then {
            $menu entryconfigure 2 \
                -command [list ::ContextMenu::onPaste $clickedWidget] \
                -state normal
        } else {
            $menu entryconfigure 2 -command {} -state disabled
        }
        tk_popup $menu $x $y
        return
    }

    proc onCopy {} {
        if {([selectionOwner] ne {}) && [getSelectedText selectedText]} then {
            clipboard clear -displayof .
            clipboard append -displayof . -format STRING -type STRING -- \
                $selectedText
            selection clear -displayof . -selection PRIMARY
        }
        return
    }

    proc onCut {} {
        set owner [selectionOwner]
        if {($owner ne {}) && [getSelectedText selectedText]} then {
            clipboard clear -displayof .
            clipboard append -displayof . -format STRING -type STRING -- \
                $selectedText
            if {[getState $owner] eq {normal}} then {
                $owner delete sel.first sel.last
            }
            selection clear -displayof . -selection PRIMARY
        }
        return
    }

    proc onPaste {widget} {
        set state [getState $widget]
        if {($state eq {normal}) && [getClipboardText textToPaste]} then {
            $widget insert insert $textToPaste
        }
        return
    }

    proc getState {widget} {
        if {[winfo exists $widget]} then {
            set class [winfo class $widget]
        } else {
            set class {}
        }
        switch -- $class {
            Entry -
            Text {
                set state [$widget cget -state]
                # state is one of {normal, disabled, readonly}
            }
            TEntry -
            TCombobox {
                if {[$widget instate {disabled}]} then {
                    set state disabled
                } else {
                    if {[$widget instate {readonly}]} then {
                        set state readonly
                    } else {
                        set state normal
                    }
                }
            }
            default {
                set state disabled
            }
        }
        return $state
    }

    proc getSelectedText {textName} {
        upvar $textName text
        if {[catch {selection get -displayof . -selection PRIMARY \
                -type STRING} text]} then {
            set result 0
            set text {}
        } else {
            set result 1
        }
        return $result
    }

    proc selectionOwner {} {
        return [selection own -displayof . -selection PRIMARY]
    }

    proc getClipboardText {textName} {
        upvar $textName text
        if {[catch {clipboard get -displayof . -type STRING} text]} then {
            set result 0
            set text {}
        } else {
            set result 1
        }
        return $result
    }
}

proc printTextWidget {txtWidget parent} {

    proc longestLine {txtWidget} {

        set longest 0
        set lastIndex [$txtWidget index end]
        set index [$txtWidget index 1.0]
        while { $index < $lastIndex } {
            set thisLineLength [string length [$txtWidget get $index "$index lineend"]]
            if { $longest < $thisLineLength } then {
                set longest $thisLineLength
            }
            set index [$txtWidget index "$index +1 lines"]
        }
        return $longest
    }

    proc getParms {cmd} {
        set parmList {}
        set moreParms 1
        set startSearch 0
        while {$moreParms} {
            set startOfParm [string first {$(} $cmd $startSearch]
            if {$startOfParm >= 0} then {
                set endOfParm [string first {)} $cmd $startOfParm]
                if {$endOfParm < 0} then {
                    pfm_message [mc sqlErrCmd $cmd] $window
                    set moreParms 0
                } else {
                    set startSearch $endOfParm
                    set parm [string range $cmd $startOfParm $endOfParm]
                    set equalSign [string first {=} $parm]
                    if {$equalSign >= 0} then {
                        set name [string range $parm 2 [expr $equalSign - 1]]
                        set value [string range $parm [expr $equalSign + 1] end-1]
                    } else {
                        set name [string range $parm 2 end-1]
                        set value {}
                    }
                    set parmDef [dict create \
                        full $parm \
                        name $name \
                        type string \
                        value $value \
                        valuelist {}]
                    lappend parmList $parmDef
                }
            } else {
                set moreParms 0
            }
        }
        return $parmList
    }

    set tmpdir [$::pfmOptions getOption general tmpdir]
    set tmptxt [file join $tmpdir pfm_print[pid].txt]
    lappend ::tmpFiles $tmptxt
    set tmpchan [open $tmptxt w]
    chan configure $tmpchan \
        -encoding [$::pfmOptions getOption general printencoding]
    chan puts $tmpchan [$txtWidget get 1.0 "end -1 chars"]
    chan close $tmpchan
    set tmpps [file join $tmpdir pfm_print[pid].ps]
    set tmppdf [file join $tmpdir pfm_print[pid].pdf]
    lappend ::tmpFiles $tmpps
    lappend ::tmpFiles $tmppdf
    foreach cmd [$::pfmOptions getOption general printcmd] {
        set parmList [getParms $cmd]
        if {[llength $parmList] > 0} then {
            set dlg [GenForm "#auto" $parent [mc sqlPrintOptions] $parmList]
            $dlg displayHelpText [mc sqlPrintHelp [longestLine $txtWidget]]
            if {[$dlg wait result]} then {
                foreach parm $parmList {
                    set full [dict get $parm full]
                    set name [dict get $parm name]
                    set value $result($name)
                    set cmdList {}
                    foreach cmdarg $cmd {
                        lappend cmdList [string map [list $full $value] $cmdarg]
                    }
                    set cmd $cmdList
                }
            } else {
                break
            }
        }
        set cmd [string map [list %txt [list $tmptxt] %ps \
            [list $tmpps] %pdf [list $tmppdf]] $cmd]
        catch [linsert $cmd 0 exec] execOut
        set message "${cmd}:\n${execOut}"
        pfm_message $message $parent
    }
    return
}

proc saveTxtFromWidget {txtWidget parent} {
    set fileTypes {
        {{Text} {.txt} }
        {{All files} *}
    }
    set defaultExt ".txt"
    set filename [tk_getSaveFile -title [mc miscSelectSaveText] \
        -filetypes $fileTypes \
        -defaultextension $defaultExt -parent $parent \
        -initialdir [file normalize ~]]
    if {$filename ne {}} then {
        if {[catch {open $filename w} saveChan]} then {
            pfm_message $saveChan $parent
        } else {
            chan puts $saveChan [$txtWidget get 1.0 end]
            chan close $saveChan
        }
    }
    return
}