File: tkpgp

package info (click to toggle)
tkpgp 1.11.1.5-3
links: PTS
area: contrib
in suites: woody
size: 260 kB
ctags: 193
sloc: tcl: 3,125; makefile: 241; sh: 8
file content (4557 lines) | stat: -rwxr-xr-x 140,198 bytes
parent folder | download | duplicates (2)
#!/usr/bin/wish

########################################################################
# TkPGP - Tcl/Tk GUI shell for PGP and GnuPG.
# Copyright (C) 1998,99 tftp@yahoo.com
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA. You also can find a copy of the GNU General Public
# License on GNU Web site(s) such as http://www.gnu.org and its mirrors.
########################################################################

# Here is the RCS ID.
set RCSID {$Revision: 1.11.1.5 $}

# These define geometry of the keys window
set opt(w_objType)  7
set opt(w_uid)     43
set opt(w_length)  7
set opt(w_hex)     13
set opt(w_created) 13
set opt(w_expires) 13
set opt(w_algorithm) 6
set opt(w_use)       17
set opt(columns) { objType algorithm length hex expires created use }
set opt(lastConfig) {}

#
# Crypto Engines:
# 0 = GPG
# 1 = PGP (any version, see $opt(pgpVersion)
#
# PGP versions:
# 2 = PGP v2.6.x (very similar to v6)
# 5 = PGP v5
# 6 = PGP v6
#

# This group of options is visible on main switch panel
set opt(auto_add_keys)    1
set opt(ascii_armor)      1
set opt(text_mode)        1
set opt(conventional)     0
set opt(sign_with_defkey) 1
set opt(disable_edit)     1
set opt(alt_font)         0
set opt(cryptoEngine)     0
set opt(pgpVersion)       2
set opt(uses_motif)       0
set opt(icon_xpm)         /usr/X11R6/include/X11/bitmaps/PGP-lock.icon
set opt(icon_settings)    /usr/X11R6/include/X11/bitmaps/PGP-lock.icon
set opt(icon_keyselect)   /usr/X11R6/include/X11/bitmaps/PGP-lock.icon
set opt(icon_pass)        /usr/X11R6/include/X11/bitmaps/PGP-lock.icon

set opt(encrypt_to_self)  1
set opt(def_key_id)       {}
set opt(confirm_exit)     0

# Preprocessing feature
set opt(ask_save)         1
set opt(wrap_margin)      80
set opt(wrap_active)      0
set opt(wrap_warn)        1
set opt(wrap_advice)      1
set opt(wrap_trim)        0
set opt(warn_i18n)        1
set opt(cite_extras)      1
set opt(cite_prefix)      {> }

# Fonts
set opt(key_font)       fixed
set opt(data1_font)     fixed
set opt(data2_font)     -*-*-medium-r-*-*-8-*-*-*-*-*-koi8-*

set opt(bin_echo)               "echo"

# These are PGP v5 binaries. You may add fixed options here or paths.
set opt(bin_pgp5_keys)          "pgpk"
set opt(bin_pgp5_decrypt)       "pgpv"
set opt(bin_pgp5_encrypt)       "pgpe"
set opt(bin_pgp5_sign)          "pgps"
set opt(bin_pgp5_sign+encrypt)  "pgpe -s"

# This is PGP v6 binary. Options are discouraged (TkPGP adds them on its own).
set opt(bin_pgp2_or_6)          "pgp"

# This is GPG binary. Options are discouraged (TkPGP adds them on its own).
set opt(bin_gpg)                "gpg"

set opt(verbose)                1
set opt(debug)                  0
set opt(cfgwrite)               1
set opt(gpg_with_colons)        1

# Geometry management
set opt(manages_geometry)       1
set opt(encGeom)                {}
set opt(sigGeom)                {}
set opt(setGeom)                {}
set opt(emailGeom)              {}

# Shell use for various needs
set opt(shell) {/usr/X11R6/bin/xterm -e bash -c "$*;echo 'Press ENTER';read"}
set opt(shell_decrypt)        1
set opt(shell_encrypt)        1
set opt(shell_sign)           1
set opt(shell_sign+encrypt)   1
set opt(shell_keys)           0
set opt(shell_password)       0

set opt(file_cached_keys)     {pgpCache.dat}
set opt(tmpdir)               {}
set opt(tmp_prefix)           {tmptkpgp}
set opt(uses_cached_keys)     1
set opt(uses_sorted_lists)    1
set opt(uses_visible_item)    0
set opt(keep_pass)            30

set infoStack   {}
set data_buffer {}
set mess_buffer {}
set undo_buffer {}
set undo_button {}
set pgppass     {}
set passBG      {}
set passFG      {}
set mess_button 0
set show_passphr 0
set force_hid_pass 1

set cfg_list    {}
set cfg_handler {}
set cbk_disedt  {}
set hexKeys     {}
set signKey     {}
set pkeyArray(0)  {}
set pkeyArray_len 0
set ks_win_mode {}
set dataWnd     {}
set keyWndList  {}
set statusWnd   {}
set fksw_lastCall {}
set wordwrap_rv 0
set var_getciteaswho {}

# Work area for GPG key parser
set gpg_tempKey(length)     {}
set gpg_tempKey(algoCode)   {}
set gpg_tempKey(hex)        {}
set gpg_tempKey(created)    {}
set gpg_tempKey(expires)    {}

##################################################
# CONFIGURATION SETUP/LOAD/SAVE
##################################################

#
# DebugLog
#
# This procedure logs the parameter into the message buffer and
# the standard output.
#
proc DebugLog msg {
    global mess_buffer opt
    if $opt(debug) {
        puts $msg
        lappend mess_buffer $msg
    }
}

proc Configure { } {
    global cfgFile opt tcl_platform tk_version

    # OS-dependent configuration.
    set opt(exportsel)      1
    set opt(uses_primary)   1
    set opt(uses_motif)     1

    # Apparently tk_popup doesn't work any more in Tk 8.0...
    # It is replaced with "$pathName post $x $y" construct.
    set opt(use_tk_popup)   1
    if {$tk_version >= 8} {
        set opt(use_tk_popup) 0
    }

    set opt(is_UNIX) [expr ![string compare $tcl_platform(platform) unix]]
    if $opt(is_UNIX) {
        # UNIX:
        # X Window System has PRIMARY selection buffer and we want to use it.
        set cfgFile           {~/.tkpgp}
        set opt(uses_primary) 1
        set opt(exportsel)    1
        # Set reasonable X Window system fonts (may be overridden)
        set opt(key_font)     fixed
        set opt(data1_font)   fixed
        set opt(data2_font)   -*-*-medium-r-*-*-8-*-*-*-*-*-koi8-*
        set opt(uses_motif)   0
        set opt(xfontsel)     /usr/X11R6/bin/xfontsel
        set opt(gfontsel)     gfontsel
        set opt(exec)         sh
        set opt(exec_opt)     -c
    } else {
        # Non-UNIX OS:
        # Only X Window System has PRIMARY selection buffer
        set cfgFile           tkpgp.ini
        set opt(uses_primary) 0
        # Set reasonable X Window system fonts (may be overridden)
        set opt(key_font)     {Courier 14}
        set opt(data1_font)   {Courier 14}
        set opt(data2_font)   {Times 16}
        set opt(exportsel)    0
        set opt(exec)         {cmd}
        set opt(exec_opt)     {/c}
    }
    ConfigLoad

    # These aren't options at all but placed into
    # options array for convenience.
    # We reset them each time the program starts (ignore saved values).
    set opt(show_objectsA)  { pub ret sec sig SIG sub }
    set opt(show_objects)   { pub sec }
    set opt(proc_keys_step) 25
    set opt(title_str)      {}

    # These settings are accessible only via menu (don't have one)
    set opt(show_buttons)     1
    set opt(show_switches)    1

    # This is a safeguard against accidental enabling of debugging.
    # User must re-enable debugging each time TkPGP starts.
    set opt(debug)            0
}

proc ConfigLoad { } {
    global opt cfgFile
    set cfgExp [ExpandEnvironmentVariables $cfgFile]
    if [catch { set fp [open $cfgExp r] }] {
        InfoDialog "New configuration file\n'$cfgExp'\nwill be created."
        return
    }
    foreach line [split [read $fp] \n] {
        set len [llength $line]
        if {$len <= 0} {
            break
        } elseif {$len == 2} {
            set index [lindex $line 0]
            set value [lindex $line 1]
            set opt($index) $value
        } else {
            puts "Bad init line '$line'"
        }
    }
    close $fp
}

#
# ConfigSave
#
# This procedure saves current configuration.
#
# History:
# 22-Jan-99 New file was not created; now fixed.
#
proc ConfigSave { } {
    global opt cfgFile
    set cfgExp [ExpandEnvironmentVariables $cfgFile]

    # If file exists it must be writable.
    if [file exists $cfgExp] {
        if {![file writable $cfgExp]} {
            # Whine only if sysadmin haven't disabled it
            # (may be OK if this is a system-wide R/O file)
            if $opt(cfgwrite) {
                ErrorDialog "File '$cfgFile'\nis not writable!"
            }
            return
        }
    }
    if [catch { set fp [open $cfgExp w] }] {
        ErrorDialog "Failed to save configuration\ndata to '$cfgExp'"
        return
    }
    foreach i [array names opt] {
        puts $fp [list $i $opt($i)]
    }
    close $fp
}

#
# ExpandEnvironmentVariables
#
# This procedure scans the source string for expressions like
# $HOME and replaces them with their values. I use preconfigured
# shell to do the job for us; this will allow to use any shell and
# any syntax as long as shell understands it. As an added benefit,
# I don't need to write the expansion code :)
#
# History:
# 20-Feb-99 Debug now goes into message buffer too.
#
proc ExpandEnvironmentVariables {src} {
    global opt
    set cmds "$opt(bin_echo) $src"
    #                        ___bash___ _____-c_______ "echo foo $bar ..."
    if [catch {set res [exec $opt(exec) $opt(exec_opt) $cmds] } err] {
        ErrorDialog "Failed to expand '$src':\n$err"
        set res $src
    }
    DebugLog "'$src' => '$res'"
    return $res
}

#
# ButtonActivate
#
# Procedure raises all slaves (buttons presumably) in the master,
# then reconfigures specified slave as sunken (depressed). This
# slave is also stored in opt(lastConfig) to be used when Settings
# window is opened again (to open last viewed page).
#
# History:
# 15-Apr-99 Created.
#
proc ButtonActivate {master slave} {
    global opt
    set opt(lastConfig) $slave
    foreach b [winfo children $master] {
        if [string compare $b $master.$slave] {
            set relief raised
        } else {
            set relief sunken
        }
        $b configure -relief $relief
    }
}

#
# Settings
#
# History:
# 15-Apr-99 Added button locking code, restore of last viewed page.
#
proc Settings {} {
    global opt
    set w .setw
    if [winfo exists $w] {
        raise $w
        return
    }
    toplevel $w
    DecorateWindow $w "TkPGP Settings" "TkPGP Settings" $opt(icon_settings)
    GeometryRestore $w setGeom

    set b $w.buttons
    set p $w.pages

    pack [frame $b -relief sunken] -side left -anchor nw -padx .5 -expand 0
    pack [frame $p -relief sunken] -side right -anchor ne -padx .5 \
        -expand yes -fill both

    pack [button $b.g -text Binaries \
        -command "ButtonActivate $b g ; Settings_Bin $p"] -fill x
    pack [button $b.l -text Columns \
        -command "ButtonActivate $b l ; Settings_Col $p"] -fill x
    pack [button $b.f -text Fonts \
        -command "ButtonActivate $b f ; Settings_Fonts $p"] -fill x
    pack [button $b.k -text Keys \
        -command "ButtonActivate $b k ; Settings_Keys $p"] -fill x
    pack [button $b.s -text Shell \
        -command "ButtonActivate $b s ; Settings_Shell $p"] -fill x
    pack [button $b.y -text System \
        -command "ButtonActivate $b y ; Settings_Sys $p"] -fill x
    pack [button $b.t -text "Text" \
        -command "ButtonActivate $b t ; Settings_Text $p"] -fill x

    pack [frame  $b.filler] -fill x -pady 2m

    pack [button $b.apply -text Apply -command "Settings_Apply $p 0"] -fill x
    pack [button $b.c -text Close -command "Settings_Close $p $w"] -fill x

    # Open last viewed page or just the first one.

    set lastConfig [string trim $opt(lastConfig)]
    if {[string length $lastConfig] && [winfo exists $b.$lastConfig]} {
        $b.$lastConfig invoke
    } else {
        Settings_Bin $p
    }
}

#
# Procedure unmaps and destroys all slaves of given master.
#
# History:
# 27-Oct-98 Added auto-apply.
#
proc Cleanup_Master {w} {
    set slaves [pack slaves $w]
    if [llength $slaves] {
        # Ask confirmation on changes (second parameter)
        Settings_Apply $w 1
    }
    foreach i $slaves { destroy $i }
}

proc Entry_String {frame_name prompt widl widv init} {
    pack [frame $frame_name] -expand no -fill x
    pack [label $frame_name.label -justify left -anchor e \
        -text $prompt -width $widl] -side left \
        -anchor nw -expand no
    pack [entry $frame_name.value -width $widv] -side top \
        -anchor nw -expand no -fill x
    $frame_name.value insert 0 $init
}

proc Entry_Interleaved {w prompt widv init} {
    set s 1
    pack [label $w$s -justify left \
        -text $prompt] -side top -anchor nw -expand no
    pack [entry $w -width $widv] -side top -anchor nw -expand no -fill x
    $w insert 0 $init
}

proc ConfirmApply {} {
    # tk_dialog window title text bitmap default string string
    return [tk_dialog .cfmDlg {Changes are not saved yet} \
        {Apply changes?} question 0 Yes No]
}

#
# Return the global variable 'varName'
#
proc GetGlobal {varName} {
    upvar #0 $varName vl
    return $vl
}

proc SetGlobal {varName value} {
    # Refer to global variable 'varName'
    upvar #0 $varName v
    set v $value
}

proc RetrieveCurrentValues {} {
    global cfg_list
    set v {}
    foreach e $cfg_list {
        set varName [lindex $e 1]
        set winName [lindex $e 2]
        if [regexp ^w_ $varName] {
            # We are getting data from a text control.
            # However the name may refer to frame. Check here.
            set alt_winName $winName.value
            if [winfo exists $alt_winName] {
                set winName $alt_winName
            }
            # puts $winName
            if [catch { set val [$winName get]}] {
                ErrorDialog "get isn't applicable:\n'$winName'"
            } else {
                lappend v $val
            }
        } else {
            lappend v [GetGlobal $varName]
        }
    }
    return $v
}

proc CompareCurrentAndSavedValues {curv} {
    global opt cfg_list
    set has_changed 0
    set n 0
    foreach e $cfg_list {
        set optName [lindex $e 0]
        if [string length $optName] {
            set curVal [lindex $curv $n]
            if [string compare $opt($optName) $curVal] {
                incr has_changed
            }
        }
        incr n
    }
    return $has_changed
}

proc SetSavedValues {curv} {
    global opt cfg_list
    set n 0
    foreach e $cfg_list {
        set optName [lindex $e 0]
        if [string length $optName] {
            set curVal [lindex $curv $n]
            set opt($optName) $curVal
        }
        incr n
    }
}

#
# Settings_Apply
#
# History:
# 14-Oct-98 Removed .value left after switch to Entry_Interleaved
# 27-Oct-98 Generalized.
# 30-Oct-98 Removed removal of cfg_handler after use (prevents reapply)
#
proc Settings_Apply {w {ask 1}} {
    set curv [RetrieveCurrentValues]
    if [CompareCurrentAndSavedValues $curv] {
        # Something changed!
        if $ask {
            if [ConfirmApply] {
                return
            }
        }
        SetSavedValues $curv

        # We changed settings. Now we must execute the
        # section-specific handler to possibly update
        # existing windows or do something else like that.

        global cfg_handler
        if [string length $cfg_handler] {
            $cfg_handler $w
        }
    }
}

#
# Here section-specific windows are constructed.
#

# Settings_Bin
#
# History:
# 08-Apr-99 Added GnuPG support.
# 29-May-99 Frame for checkbuttons does not expand any more. Removed 'gpgm'.
# 28-Oct-99 Added PGP v2 and v6 support.
#
proc Settings_Bin {w} {
    global opt c_vrb c_dbg c_pgpver cfg_list cfg_handler

    Cleanup_Master $w

    set cfg_handler {}
    set cfg_list [ list \
            [list bin_pgp5_keys w_fk $w.fk] \
            [list bin_pgp5_decrypt w_fd $w.fd] \
            [list bin_pgp5_encrypt w_fe $w.fe] \
            [list bin_pgp5_sign w_fs $w.fs] \
            [list bin_pgp5_sign+encrypt w_fi $w.fi] \
            [list bin_pgp2_or_6 w_pgp6 $w.pgp6 ] \
            [list bin_gpg w_gpg $w.gpg] \
            [list pgpVersion c_pgpver {}] \
            [list verbose c_vrb $w.ck.c_vrb] \
            [list debug c_dbg $w.ck.c_dbg]]

    Entry_Interleaved $w.fk "PGP v5 Keys" 40 $opt(bin_pgp5_keys)
    Entry_Interleaved $w.fd "PGP v5 Decrypt" 40 $opt(bin_pgp5_decrypt)
    Entry_Interleaved $w.fe "PGP v5 Encrypt" 40 $opt(bin_pgp5_encrypt)
    Entry_Interleaved $w.fs "PGP v5 Sign" 40 $opt(bin_pgp5_sign)
    Entry_Interleaved $w.fi "PGP v5 Sign+Encrypt" 40 \
            $opt(bin_pgp5_sign+encrypt)
    Entry_Interleaved $w.pgp6 "PGP v2 or v6" 40 $opt(bin_pgp2_or_6)
    Entry_Interleaved $w.gpg "Gnu Privacy Guard" 40 $opt(bin_gpg)

    pack [frame $w.ck] -anchor nw
    grid  [checkbutton $w.ck.c_vrb -text {Verbose output} -variable c_vrb]\
            -sticky nw -row 0 -column 0
    grid  [checkbutton $w.ck.c_dbg -text Debugging -variable c_dbg]\
            -sticky w -row 1 -column 0
    grid [radiobutton $w.ck.use_pgp2 \
        -text "PGP v2.6.x" -variable c_pgpver -value 2] \
        -sticky w -row 0 -column 1
    grid [radiobutton $w.ck.use_pgp5 \
        -text "PGP v5" -variable c_pgpver -value 5] \
        -sticky w -row 1 -column 1
    grid [radiobutton $w.ck.use_pgp6 \
        -text "PGP v6" -variable c_pgpver -value 6] \
        -sticky w -row 2 -column 1

    set c_vrb $opt(verbose)
    set c_dbg $opt(debug)
    set c_pgpver $opt(pgpVersion)
}

proc Settings_Col {w} {
    global opt cfg_handler cfg_list

    Cleanup_Master $w

    set cfg_handler Settings_Col_Apply
    set cfg_list [ list \
            [list w_objType   w_objType $w.objType] \
            [list w_uid       w_uid     $w.uid] \
            [list w_length    w_length  $w.length] \
            [list w_hex       w_hex     $w.hex] \
            [list w_created   w_created $w.created] \
            [list w_expires   w_expires $w.expires] \
            [list w_algorithm w_algorithm $w.alg] \
            [list w_use       w_use     $w.use]]

    Entry_String $w.objType "Object Type:" 14 5 $opt(w_objType)
    Entry_String $w.uid     "UID:"         14 5 $opt(w_uid)
    Entry_String $w.length  "Key Size:"    14 5 $opt(w_length)
    Entry_String $w.hex     "Key ID:"      14 5 $opt(w_hex)
    Entry_String $w.created "Created:"     14 5 $opt(w_created)
    Entry_String $w.expires "Expires:"     14 5 $opt(w_expires)
    Entry_String $w.alg     "Algorithm:"   14 5 $opt(w_algorithm)
    Entry_String $w.use     "Usage:"       14 5 $opt(w_use)
#set opt(columns) { objType algorithm length hex expires created use }
}

#
# Handler for columns. Resizes the key window if it is on screen.
#
proc Settings_Col_Apply {w} {
    global fksw_lastCall
    if {[llength $fksw_lastCall] == 3} {
        if [winfo exists [lindex $fksw_lastCall 0]] {
            FillKeySelectWindowWithPublicKeys \
                [lindex $fksw_lastCall 0] \
                [lindex $fksw_lastCall 1] \
                [lindex $fksw_lastCall 2] 1
        }
    }
}

#
# Settings_Fonts
#
# Settings page to configure fonts.
#
# History:
# 16-Apr-99 Added GNOME font selection utility.
#
proc Settings_Fonts {w} {
    global opt cfg_handler cfg_list

    Cleanup_Master $w

    set cfg_handler ApplyFonts
    set cfg_list [ list \
            [list key_font   w_objType $w.f1] \
            [list data1_font w_data1   $w.f2] \
            [list data2_font w_data2   $w.f3]]

    Entry_Interleaved $w.f1 "Key window font" 50 $opt(key_font)
    Entry_Interleaved $w.f2 "Data font #1"    50 $opt(data1_font)
    Entry_Interleaved $w.f3 "Data font #2"    50 $opt(data2_font)
    if $opt(is_UNIX) {
        Entry_Interleaved $w.f4 "GNOME font selection utility" \
                50 $opt(gfontsel)
        lappend cfg_list [list gfontsel w_gfontsel $w.f4]
        Entry_Interleaved $w.f5 "Xfree86 font selection utility" \
                50 $opt(xfontsel)
        lappend cfg_list [list xfontsel w_xfontsel $w.f5]
    }
    # <--- Add other interleaved stuff here --->
    if $opt(is_UNIX) {
        pack [button $w.xfs -text "Run xfontsel" -command \
            "Run_fontsel $w x" ] -side right -anchor ne -padx 1m -pady 3m
        pack [button $w.gfs -text "Run gfontsel" -command \
            "Run_fontsel $w g" ] -side right -anchor ne -padx 1m -pady 3m
    }
}

#
# Run_fontsel
#
# Procedure runs a font selection utility. Parameter 'what'
# is 'x' for xfontsel (X11, XFree86) or 'g' for gfontsel (GNOME).
#
# History:
# 16-Apr-99 Added parameter 'what', renamed.
#
proc Run_fontsel {w what} {
    switch $what {
        g { set executable [$w.f4 get] }
        x { set executable [$w.f5 get] }
        default { return }
    }
    if [catch { exec $executable & } err] {
        ErrorDialog $err $w
    }
}

proc GetDataFont {} {
    global opt
    if $opt(alt_font) {
        return $opt(data2_font)
    } else {
        return $opt(data1_font)
    }
}

#
# History:
# 30-Oct-98 Provided default value for the parameter (it's not used anyway)
#
proc ApplyFonts {{w ""}} {
    global opt dataWnd keyWndList
    if [winfo exists $dataWnd] {
        set fnt [GetDataFont]
        # puts "$dataWnd configure -font $fnt"
        if [catch {$dataWnd configure -font $fnt} err] {
            ErrorDialog $err $w
        }
    }
    foreach keyWnd $keyWndList {
        if [winfo exists $keyWnd] {
            if [catch {$keyWnd configure -font $opt(key_font)} err] {
                ErrorDialog $err $w
                break
            }
        }
    }
}

proc Settings_SelectDefKey {wed} {
    global tmp_defKey
    set tmp_defKey {}
    if {[string length $tmp_defKey] == 0} {
        SelectSigningKey .defKey tmp_defKey
    }
    if [string length $tmp_defKey] {
        $wed delete 0 end
        $wed insert 0 $tmp_defKey
    } else {
        ErrorDialog "Default key not changed" $wed
    }
}

#
# History:
# 27-Oct-98 Added "Choose" button to select the default key.
#
proc Settings_Keys {w} {
    global opt cfg_handler cfg_list c_edk

    Cleanup_Master $w

    set cfg_handler {}
    set cfg_list [ list \
            [list def_key_id w_v1 $w.v1] \
            [list keep_pass  w_v2 $w.v2] \
            ]

    Entry_Interleaved $w.v2 "Passphrase expiration time (seconds):" \
        40 $opt(keep_pass)
    Entry_Interleaved $w.v1 "Default key ID:" 40 $opt(def_key_id)
    pack [button $w.b1 -text "Choose default key" \
            -command "Settings_SelectDefKey $w.v1"] \
            -side right -anchor ne -padx 1m -pady 3m
    set cfg_list

}

#
# Settings_Shell
#
# History:
# 26-Oct-98 Added "shell on keys", disabled in OFF state for now
#           because PGPK does not like -o flag...
# 08-Dec-99 Disabled "Shell on..." choices, they don't work anyway.
#
proc Settings_Shell {w} {
    global opt cfg_handler cfg_list val_d val_s val_se val_e val_k val_cp

    Cleanup_Master $w

    set cfg_handler Settings_Shell_Validate
    set cfg_list [ list \
            [list shell         w_shell  $w.shell] \
            [list shell_decrypt val_d    $w.val_d] \
            [list shell_encrypt val_e    $w.val_e] \
            [list shell_sign    val_s    $w.val_s] \
            [list shell_sign+encrypt val_se $w.val_se] \
            [list {}            val_cv   $w.val_cv] \
            [list shell_password val_cp  $w.val_cp] ]

    Entry_Interleaved $w.shell "Shell command ($* may denote PGP commands)" \
        40 $opt(shell)
    pack [checkbutton $w.val_d -text "Shell on decrypt" \
        -state disabled ] -side top -anchor nw
    pack [checkbutton $w.val_e -text "Shell on encrypt" \
        -state disabled ] -side top -anchor nw
    pack [checkbutton $w.val_s -text "Shell on sign" \
        -state disabled ] -side top -anchor nw
    pack [checkbutton $w.val_se -text "Shell on sign+encrypt"\
        -state disabled ] -side top -anchor nw
    pack [checkbutton $w.val_cv -text "Shell on conventional encryption"] \
        -side top -anchor nw
    pack [checkbutton $w.val_k -text "Shell on keys"] -side top -anchor nw
    pack [checkbutton $w.val_cp -text "Password in shell"] \
            -side top -anchor nw

    set val_d $opt(shell_decrypt)
    set val_e $opt(shell_encrypt)
    set val_s $opt(shell_sign)
    set val_se $opt(shell_sign+encrypt)
    set val_cp $opt(shell_password)

    # pgpk -o does not work; all goes to stdout anyway.
    set $opt(shell_keys) 0          ; # Disabled here!
    set val_k $opt(shell_keys)
    $w.val_k configure -state disabled

    # We always need shell on conventional encryption because
    # PGP asks for a password twice and I don't know how to pass
    # such password from outside.

    $w.val_cv select
    $w.val_cv configure -state disabled
}

#
# History:
# 30-Oct-98 Created to verify "password in shell" setting.
#
proc Settings_Shell_Validate {w} {
    global opt val_cp
    if $opt(shell_password) {
        if {!$opt(shell_sign) || !$opt(shell_sign+encrypt) || \
                !$opt(shell_decrypt)} {
            ErrorDialog "Password on shell is\nforced off because\nshell\
is not active\non all actions that\nrequire password." $w
            set opt(shell_password) [set val_cp 0]
        }
    }
}

#
# History:
# 26-Oct-98 Added "command interpreter"
#
proc Settings_Sys {w} {
    global opt cfg_handler cfg_list val_m val_d val_g val_s val_se val_e

    Cleanup_Master $w

    set cfg_handler Settings_Sys_Apply
    set cfg_list [ list \
            [list tmpdir            w_tmp  $w.tmp]      \
            [list file_cached_keys  w_ch   $w.ch]       \
            [list tmp_prefix        w_pf   $w.pf]       \
            [list exec              w_sh   $w.sh]       \
            [list exec_opt          w_sho  $w.sho]      \
            [list manages_geometry  val_g  $w.bt.val_g] \
            [list uses_motif        val_m  $w.bt.val_m] \
            [list uses_cached_keys  val_d  $w.bt.val_d] \
            [list uses_sorted_lists val_e  $w.bt.val_e] \
            [list uses_visible_item val_s  $w.bt.val_s] \
            [list confirm_exit      val_se $w.bt.val_se]\
    ]

    Entry_Interleaved $w.tmp "Temporary directory:" 40 $opt(tmpdir)
    Entry_Interleaved $w.ch  "File for cached keys:" 40 $opt(file_cached_keys)
    Entry_Interleaved $w.pf  "Base name of temporary files:" \
            40 $opt(tmp_prefix)
    Entry_Interleaved $w.sh "Command Interpreter:" 40 $opt(exec)
    Entry_Interleaved $w.sho "Interpreter options:" 40 $opt(exec_opt)

    pack [frame $w.bt] -anchor nw
    grid [checkbutton $w.bt.val_g -text "Restore geometry"] \
            -sticky nw -row 0 -column 0
    grid [checkbutton $w.bt.val_m -text "Motif-style dialogs"] \
            -sticky w -row 1 -column 0
    grid [checkbutton $w.bt.val_d -text "Use cached keys"] \
            -sticky nw -row 2 -column 0

    grid [checkbutton $w.bt.val_e -text "Lists are sorted"] \
            -sticky nw -row 0 -column 1
    grid [checkbutton $w.bt.val_s -text "Scroll to current item"] \
        -sticky nw -row 1 -column 1
    grid [checkbutton $w.bt.val_se -text "Confirm exit"] \
            -sticky nw -row 2 -column 1

    set val_d $opt(uses_cached_keys)
    set val_e $opt(uses_sorted_lists)
    set val_g $opt(manages_geometry)
    set val_m $opt(uses_motif)
    set val_s $opt(uses_visible_item)
    set val_se $opt(confirm_exit)

    if { ! $opt(is_UNIX)} {
        $w.bt.val_m configure -state disabled
    }
}

#
# History:
# 14-Oct-98 Added validation of temporary directory.
#
proc Settings_Sys_Apply {w} {
    global opt val_d val_m val_s val_se val_e

    # Verify that tmpdir exists
    set tmp_dir [ExpandEnvironmentVariables $opt(tmpdir)]
    if [string length $tmp_dir] {
        if {![file isdirectory $tmp_dir]} {
            ErrorDialog "'$tmp_dir' is not a directory!" $w
            set opt(tmpdir) {}
            return
        }
    }
}

#
# Settings_Text_Handler
#
# Procedure enables/disables certain widgets based on
# the state of "Wrap Active" checkbutton.
#
# History:
# 30-May-99 Created.
#
proc Settings_Text_Handler {w} {
    global val_wa
    set newstate1 [MakeStateKeyword $val_wa zero-disabled]
    set newstate2 [MakeStateKeyword $val_wa zero-normal]
    $w.v1.value configure -state $newstate1
    $w.bt.val_ww configure -state $newstate1
    $w.bt.val_wt configure -state $newstate1
    $w.bt.val_wn configure -state $newstate2
}

#
# Settings_Text
#
# History:
# 29-May-99 Created.
# 10-Nov-99 Added option to control "save file" confirmation.
#
proc Settings_Text {w} {
    global opt cfg_list cfg_handler
    global val_wa val_ww val_wn val_wt val_we val_sw

    Cleanup_Master $w

    set cfg_handler {}
    set cfg_list [list \
            [list wrap_margin w_v1    $w.v1.value] \
            [list cite_prefix w_v2    $w.v2.value] \
            [list cite_extras w_v3    $w.v3.value] \
            [list wrap_active val_wa  $w.bt.val_wa] \
            [list wrap_warn   val_ww  $w.bt.val_ww] \
            [list wrap_advice val_wn  $w.bt.val_wn] \
            [list wrap_trim   val_wt  $w.bt.val_wt] \
            [list warn_i18n   val_we  $w.bt.val_we] \
            [list ask_save    val_sw  $w.bt.val_sw] \
            ]

    Entry_String $w.v2 "Citation prefix"  20 15 $opt(cite_prefix)
    Entry_String $w.v3 "Citation gap"  20 15 $opt(cite_extras)
    Entry_String $w.v1 "Word wrap margin" 20 15 $opt(wrap_margin)
    pack [frame $w.bt] -anchor nw
    grid [checkbutton $w.bt.val_wa -text "Word wrap enabled" \
            -command "Settings_Text_Handler $w"] \
            -sticky nw -row 0 -column 0
    grid [checkbutton $w.bt.val_ww -text "Warn if wrap occurs"] \
            -sticky w -row 1 -column 0
    grid [checkbutton $w.bt.val_wt -text "Trim spaces around wrap"] \
            -sticky w -row 2 -column 0
    grid [checkbutton $w.bt.val_wn -text "Recommend wrap"] \
            -sticky w -row 3 -column 0
    grid [checkbutton $w.bt.val_we -text \
            "Warn about international characters"] \
            -sticky w -row 4 -column 0
    grid [checkbutton $w.bt.val_sw -text "Confirm on save of preloaded file"]\
             -sticky w -row 5 -column 0

    # Set initial values to checkbuttons
    set val_wa $opt(wrap_active)
    set val_ww $opt(wrap_warn)
    set val_wn $opt(wrap_advice)
    set val_wt $opt(wrap_trim)
    set val_we $opt(warn_i18n)
    set val_sw $opt(ask_save)

    # Set initial states of checkbuttons (normal/disabled)
    Settings_Text_Handler $w
}

#
# The "Close" button handler. Saves unsaved changes, closes window.
#
proc Settings_Close {w top} {
    GeometrySave $top setGeom
    Cleanup_Master $w
    destroy $top
}

#
# ======== GEOMETRY MANAGEMENT CODE ========
#
proc GeometryRestore {window nick} {
    global opt
    if $opt(manages_geometry) {
        if [string length $opt($nick)] {
            DebugLog "GeometryRestore: $window $opt($nick)"
            wm geometry $window $opt($nick)
        }
    }
}

proc GeometrySave {window nick} {
    global opt
    set opt($nick) [wm geometry $window]
    DebugLog "GeometrySave: $window $opt($nick)"
}

proc CenterWindow w {
    if { "$w" == "" } {
        set w .
    }
    set x [winfo reqwidth $w]
    set y [winfo reqheight $w]
    set wx [winfo screenwidth $w]
    set wy [winfo screenheight $w]
    # puts "Window '$w': +$x+$y Screen: wx=$wx wy=$wy"
    set ox [expr ($wx-$x)/2]
    set oy [expr ($wy-$y)/2]
    wm geometry $w +$ox+$oy
}

#
# DecorateWindow
#
# Procedure applies title bar text, icon name and icon bitmap
# to the specified window.
#
# History:
# 17-Apr-99 Created.
#
proc DecorateWindow {topName title iconname iconbitmapfile} {
    wm title $topName $title
    wm iconname $topName $iconname

    # Try to locate our icon bitmap file, create bitmap if successful.
    if [string length $iconbitmapfile] {
        if [file exists $iconbitmapfile] {
            if [catch "wm iconbitmap $topName @$iconbitmapfile" ] {
                puts "Corrupted bitmap $iconbitmapfile"
            }
        }
    }
}

proc FlashAndInvokeButton {buttonName} {
    if [winfo exists $buttonName] {
        $buttonName flash
        $buttonName invoke
    }
}

proc CreateKeyFrame {frame_name frame_height} {
    global opt keyWndList
    set border 0.2m

    frame $frame_name
    scrollbar $frame_name.scroll -command "$frame_name.uid yview"
    listbox $frame_name.title -borderwidth $border \
        -setgrid 1 -height 1 -font $opt(key_font) -takefocus 0
    listbox $frame_name.uid -borderwidth $border \
        -yscroll "$frame_name.scroll set" \
        -setgrid 1 -height $frame_height -font $opt(key_font) \
        -selectmode extended
    lappend keyWndList $frame_name.title
    lappend keyWndList $frame_name.uid

    # Now pack components of the frame
    pack $frame_name.title -side top -fill x
    pack $frame_name.scroll -side right -fill y
    pack $frame_name.uid -side left -expand 1 -fill both -padx 0.5m
}

proc CreateButtonsFrame {top frame_name retvar hasMini} {
    frame $frame_name
    if $hasMini {
        pack [button $frame_name.add -text Add \
            -command "Do_PK_MoveKey $top 1"] -side left
        pack [button $frame_name.remove -text Remove \
            -command "Do_PK_MoveKey $top 0"] -side left
    } else {
    }
#   pack [button $frame_name.prop -text Properties \
#       -command "Do_PK_Properties $top"] -side left
    pack [button $frame_name.refresh -text Refresh \
        -command "Do_PK_Refresh $top"] -side left
    #
    # Following buttons are right-aligned
    #
    pack [button $frame_name.cancel -text Cancel \
        -command "Do_PK_Close $top $hasMini"] -side right
    pack [button $frame_name.done -text Done \
        -command "Do_PK_Done $top $retvar $hasMini"] -side right
}

proc CreateKeySelectWindow {top retvar hasMini title} {
    global keyWndList opt

    set bigheight 15
    set miniheight 3
    if [string length $top] {
        if [winfo exists $top] {
            destroy $top
        }
        toplevel $top
        DecorateWindow $top $title $title $opt(icon_keyselect)
        if $hasMini {
            GeometryRestore $top encGeom
        } else {
            GeometryRestore $top sigGeom
        }
    }
    set keyWndList {}
    CreateButtonsFrame $top $top.buttons $retvar $hasMini
    CreateKeyFrame $top.biglist $bigheight
    if $hasMini {
        CreateKeyFrame $top.minilist $miniheight
    }

    # Pack the main window
    pack $top.biglist -fill both -side top -expand 1 -padx 0.5m
    pack $top.buttons -fill x -side top -padx 1m
    if $hasMini {
        pack $top.minilist -fill both -expand 1 -padx 0.5m
    }
}

# ErrorDialog
#
# This procedure displays an error dialog with text 'text'.
#
proc ErrorDialog {text {parent ""}} {
    # tk_dialog window title text bitmap default string string
    tk_dialog $parent.errorDlg Error $text warning 0 Close
}

# InfoDialog
#
# This procedure displays an info dialog with text 'text'.
#
proc InfoDialog {text {parent ""}} {
    # tk_dialog window title text bitmap default string string
    tk_dialog $parent.infoDlg Information $text info 0 Close
}

# InfoWindow
#
# This procedure manages the stack of info messages,
# We use the title string of the lower list.
# 'op' may be:
#    clear    - Leaves the info window blank, 'text' ignored
#    push     - Pushes older messages into stack, shows new 'text'
#    replace  - Replaces the currently displayed message with 'text'
#    pop      - Restores previously displayed message, 'text' ignored
#
# History:
# 12-Oct-98 Got rid of opt(iwStack), use infoStack instead.
# 27-Oct-98 Added version number retrieved from RCS ID field.
#
proc InfoWindow {op {text {}} } {
    global statusWnd infoStack
    # puts "op=$op text='$text'"
    if {![winfo exists $statusWnd]} {
        return
    }
    set sLen [llength $infoStack]
    switch $op {
        clear {
            global RCSID
            set infoStack {}
            set m1 "Ready"
            # Will ignore full match (goes to tmp_fmatch)
            if [regexp -nocase {: ([0-9.]+) } $RCSID tmp_fmatch ver] {
                set m1 "TkPGP $ver: $m1"
            }
            lappend infoStack $m1
            set sLen 0
        }
        push {
            lappend infoStack $text
            # $sLen became an index of last element of the list
        }
        pop {
            # Have string(s) in stack -- pop one.
            # Point index to last element of the list.
            incr sLen -1
            if { $sLen >= 0} {
                # Replace that last element with nothing
                set infoStack [lreplace $infoStack $sLen end]
                # Move index back because we just deleted an element
                incr sLen -1
            }
            # At this point we may have $sLen < 0 which
            # means that stack is empty and we must paint default string.
        }
        replace {
            # Point index to last element of the list.
            incr sLen -1
            set infoStack [lreplace $infoStack $sLen end $text]
        }
        default {
            ErrorDialog "InfoWindow($op): Illegal parameter." $statusWnd
            return
        }
    }
    # puts "stack='$infoStack' sLen=$sLen"
    if {$sLen >= 0} {
        $statusWnd configure -text [lindex $infoStack $sLen]
    }
    update idletasks
}

proc GetKeyComponent {keystring what} {
    switch $what {
        object    { return [string range $keystring 0 2]}
        flag      { return [string range $keystring 3 3]}
        objType   { return [string range $keystring 0 3]}
        length    { return [string range $keystring 5 8]}
        hex       { return [string range $keystring 10 19]}
        created   { return [string range $keystring 21 30]}
        expires   { return [string range $keystring 32 41]}
        algorithm { return [string range $keystring 43 57]}
        use       { return [string range $keystring 59 75]}
    }
    return {}
}

proc GetKeyObject {ky object} {
    set len [llength $ky]
    for {set i 0} {$i < $len} {incr i} {
        set line [lindex $ky $i]
        set comp [GetKeyComponent $line object]
        if {[string compare $comp $object] == 0} {
            return $line
        }
    }
    return {}
}

proc FormatKeyOptions {s fmt} {
    global opt
    set ret {}
    # Now get wanted components in wanted order
    foreach n $fmt {
        set widTotal $opt(w_$n)
        if $widTotal {
            set widStr [expr $widTotal - 3]
            set comp [GetKeyComponent $s $n]
            append ret [format "%-*.*s | " $widStr $widStr $comp]
        }
    }
    return $ret
}

#
# Returns UID (user name, email...) trimmed and padded to fit
# the 'w_uid' wide field, appends delimiter and returns the result.
#
proc FormatUID uid {
    global opt
    set n [expr $opt(w_uid)-3]
    return [format "%-*.*s | " $n $n [string range $uid 5 end]]
}

proc FormatTitleString fmt {
    global opt
    set ret [FormatUID "User ID"]
    append ret [FormatKeyOptions \
        {Type Bits KeyID      Created    Expires    Algorithm       Use} \
        $fmt ]
    return $ret
}

proc FormatPublicKey {ky uid keyType fmt} {
    if [string length $uid] {
        # Format key string
        set s [GetKeyObject $ky $keyType]
        if [string length $s] {
            set s [FormatKeyOptions $s $fmt]
            if [string length $s] {
                set ret [FormatUID $uid]
                return [append ret $s]
            }
        }
        return "no $keyType key"
    }
    return "oops! uid=''"
}

#
# A small wrapper to use one or another method of pulling keys from GPG.
#
proc FormatPublicKey_GnuPG {keystring} {
    global opt
    if $opt(gpg_with_colons) {
        return [FormatPublicKey_GnuPG_withColons $keystring]
    } else {
        return [FormatPublicKey_GnuPG_withoutColons $keystring]
    }
}

#
# pub  1024R/514C5279 1998-12-16 Linux Kernel Archives <ftpadmin@kernel.org>
# |         |         |         |         |
# 0         10        20        30        40
#
proc FormatPublicKey_GnuPG_withoutColons {keystring} {
    set object     [string range $keystring 0 2]
    set flag       [string range $keystring 3 3]
    set objType    [string range $keystring 0 3]
    set length     [string range $keystring 5 8]
    set algoChar   [string range $keystring 9 9]
    set hex        [string range $keystring 11 18]
    if [string length [string trim $hex]] {
        set hex "0x$hex"
    } else {
        append hex "  "
    }
    set created    [string range $keystring 20 29]
    set expires    "          "
    switch $algoChar {
        D { set algorithm DSS }
        R { set algorithm RSA }
        default { set algorithm {   } }
    }
    set use "Encrypt/Verify"
    set uid [string range $keystring 31 end]

# James Bond <jmbond@whatever.net>         | pub  | RSA |  768 |
# 0x00700700 | ---------- | 1995-00-00 | Sign & Encrypt |

    set ls [FormatUID "     $uid"]
    append ls "$objType | $algorithm | $length | $hex | $expires | $created | $use |"
    return $ls
}

#
# pub:q:1024:17:68B7AB8957548DCD:1998-07-07:2002-12-29:59:-:Werner Koch (gnupg sig) <dd9jn@gnu.org>:
# pub:q:1024:17:6C7EE1B8621CC013:1998-07-07:2002-11-19:66:-:Werner Koch <werner.koch@guug.de>:
#
#  1. Field:  Type of record
#             pub = public key
#             sub = subkey (secondary key)
#             sec = secret key
#             ssb = secret subkey (secondary key)
#             uid = user id (only field 10 is used).
#             fpr = fingerprint: (fingerprint is in field 10)
#             pkd = public key data (special field format, see below)
# 
#  2. Field:  A letter describing the calculated trust. This is a single
#             letter, but be prepared that additional information may follow
#             in some future versions. (not used for secret keys)
#                 o = Unknown (this key is new to the system)
#                 d = The key has been disabled
#                 r = The key has been revoked
#                 e = The key has expired
#                 q = Undefined (no value assigned)
#                 n = Don't trust this key at all
#                 m = There is marginal trust in this key
#                 f = The key is full trusted.
#                 u = The key is ultimately trusted; this is only used for
#                     keys for which the secret key is also available.
#  3. Field:  length of key in bits.
#  4. Field:  Algorithm:  1 = RSA
#                        16 = ElGamal (encrypt only)
#                        17 = DSA (sometimes called DH, sign only)
#                        20 = ElGamal (sign and encrypt)
#             (for other id's see include/cipher.h)
#  5. Field:  KeyID
#  6. Field:  Creation Date (in UTC)
#  7. Field:  Key expiration date or empty if none.
#  8. Field:  Local ID: record number of the dir record in the trustdb.
#             This value is only valid as long as the trustdb is not
#             deleted. You can use "#<local-id> as the user id when
#             specifying a key. This is needed because keyids may not be
#             unique - a program may use this number to access keys later.
#  9. Field:  Ownertrust (primary public keys only)
#             This is a single letter, but be prepared that additional
#             information may follow in some future versions.
# 10. Field:  User-ID.  The value is quoted like a C string to avoid
#             control characters (the colon is quoted "\x3a").
#
proc FormatPublicKey_GnuPG_withColons {keystring} {
    global gpg_tempKey

    set elem [split $keystring :]
    set object     [lindex $elem 0]
    set length     [lindex $elem 2]
    set algoCode   [lindex $elem 3]
    set hex        [string range [lindex $elem 4] 8 end]
    set created    [lindex $elem 5]
    set expires    [lindex $elem 6]
    set uid        [lindex $elem 9]

    # If this is NOT an uid record then we take snapshot
    if [string compare $object uid] {
        set gpg_tempKey(length)   $length
        set gpg_tempKey(algoCode) $algoCode
        set gpg_tempKey(hex)      $hex
        set gpg_tempKey(created)  $created
        set gpg_tempKey(expires)  $expires
    } else {
        # This is an uid record and we have to recall data from snapshot.
        # object and uid fields are valid, all other have to be updated.
        set length   $gpg_tempKey(length)
        set algoCode $gpg_tempKey(algoCode)
        set hex      $gpg_tempKey(hex)
        set created  $gpg_tempKey(created)
        set expires  $gpg_tempKey(expires)
    }

    # Pad length with spaces if needed
    while {[string length $length] < 4} { set length " $length" }

    # Add 0x to the key ID if it is not empty (uid)
    if [string length $hex] { set hex "0x$hex" }
    while {[string length $hex] < 10} { append hex " " }

    # We need to know secret keys so we can correctly explain usage.
    set secretKey 0
    if {[string compare $object sec] == 0} {
        set secretKey 1
    }

    # Translate numeric algorithm into character representation
    set algorithm {   }
    set use "              "
    switch $algoCode {
        1 {
            set algorithm RSA
            if $secretKey {
                set use "Sign,Encrypt  "
            } else {
                set use "Encrypt       "
            }
        }
        16 {
            set algorithm ElG
            set use "Encrypt       "
        }
        17 {
            set algorithm DSA
            if $secretKey {
                set use "Sign,Encrypt  "
            } else {
                set use "Encrypt       "
            }
        }
        20 {
            set algorithm ElG
            if $secretKey {
                set use "Sign,Encrypt  "
            } else {
                set use "Encrypt       "
            }
        }
    }

    # Enlarge creation, expiration date strings if need to be
    while {[string length $created] < 10} { append created " " }
    while {[string length $expires] < 10} { append expires " " }

    # Correct possibly quoted ':' in UID
    while [regsub -nocase {\\x3a} $uid : var_unused] { }

    set ls [FormatUID "     $uid"]
    append ls "$object  | $algorithm | $length | $hex | $expires | $created | $use |"
    return $ls
}

#
# FormatPublicKey_PGPv2
#
# Key ring: '/home/dmitri/.pgp/pubring.pgp'
# Type Bits/KeyID    Date       User ID
# pub@ 1024/6CE12BF1 1995/06/27 John E. Walker <jwalker@revenge.net>
#                               John E. Walker II <jwalker@revenge.com>
# pub@  768/5AB7ACE1 1999/10/28 John Q. Smith <12345.6789@compuserve.com>
# |         |         |         |         |
# 0         10        20        30        40
# 2 matching keys found.
#
# History:
# 28-Oct-99 Created for PGP v2 support.
#
proc FormatPublicKey_PGPv2 {keystring} {
    set algorithm  "RSA"
    set object     [string range $keystring 0 2]
    set flag       [string range $keystring 3 3]
    set length     [string range $keystring 5 8]
    set hex        [string range $keystring 10 17]
    set created    [string range $keystring 19 28]
    set expires    "   -n/a-  "
    set uid        [string range $keystring 30 end]

    set ls [FormatUID "     $uid"]
    append ls "$object$flag | $algorithm | $length | 0x$hex | $expires | $created | Encrypt/Verify |"
    return $ls
}

#
# FormatPublicKey_PGPv6
#
# RSA  1024      0x514C5279 1998/12/16 Linux Kernel Archives <ftpadmin@kern...
# DSS@ 768/768   0xB670E1D0 1997/10/22 Little Brother <snoop@localhost>
# |         |         |         |         |
# 0         10        20        30        40
#
# History:
# 27-Oct-99 Created for PGP v6 support.
#
proc FormatPublicKey_PGPv6 {keystring} {
    set algorithm  [string range $keystring 0 2]
    set object     "pub"
    set flag       [string range $keystring 3 3]
    set length     [string range $keystring 5 11]
    if [regexp {^([0-9]+)/} $length len1] {
        set length $len1
    }
    if {[string length $length] > 4} {
        set length [string range $length 0 3]
    }
    set hex        [string range $keystring 15 24]
    set created    [string range $keystring 26 35]
    set expires    "          "
    set uid        [string range $keystring 37 end]

    set ls [FormatUID "     $uid"]
    append ls "$object$flag | $algorithm | $length | $hex | $expires | $created | Encrypt/Verify |"
    return $ls
}

#
# This procedure runs GPG/pgpk on specified key ID (or all of them).
# It was designed to work in shell or hidden; however if it runs
# in shell all output goes into X window, not to stdout. I wanted
# to direct output to a file, but option -o does not work.
#
# History:
# 08-Apr-99 Added GnuPG support.
# 27-Oct-99 Added PGP v6 support.
#
proc ReadKeyList {{hex ""}} {
    global opt

    set msg {}
    set maxError 0
    if [string length $hex] { set msg " on key $hex" }
    #
    # Choose and run current crypto engine to obtain list of keys
    #
    switch $opt(cryptoEngine) {
        0 {
            set gpgbin $opt(bin_gpg)
            InfoWindow push "Running $gpgbin$msg ..."
            set cmds "$gpgbin --list-keys "
            if $opt(gpg_with_colons) { append cmds "--with-colons " }
            set maxError 1
        }
        1 {
            switch $opt(pgpVersion) {
                5 {
                    InfoWindow push "Running $opt(bin_pgp5_keys)$msg ..."
                    set cmds "$opt(bin_pgp5_keys) -ll "
                }
                2 -
                6 {
                    InfoWindow push "Running $opt(bin_pgp2_or_6)$msg ..."
                    set cmds "$opt(bin_pgp2_or_6) -kv "
                    set maxError 1
                }
            }
        }
    }
    if $opt(shell_keys) {
        set tmpFile [TempFile "tkpgp_ky.tmp"]
        set cmds "$cmds -o $tmpFile"
    }
    set cmds "$cmds $hex"
    if $opt(shell_keys) {
        set cmds [ApplyShell $cmds]
    }
    set rv [ExecuteScript $cmds "" $maxError]
    # puts $rv
    InfoWindow pop
    if $opt(shell_keys) {
        set tmpExp [ExpandEnvironmentVariables $tmpFile]
        InfoWindow push "Reading temporary file '$tmpExp' ..."
        set res [catch { set fi [open $tmpExp r] } err]
        if $res {
            ErrorDialog $err
        } else {
            set rv [read $fi]
            close $fi
        }
        InfoWindow pop
    }
    # puts $rv
    return $rv
}

proc ReadKeys {top reget_keys {hex {}} } {
    global opt
    set cacheFile [TempFile $opt(file_cached_keys)]
    if {[string length $hex] && $reget_keys} {
        return [ReadKeyList $hex]
    }
    set cacheExp [ExpandEnvironmentVariables $cacheFile]
    if {$opt(uses_cached_keys) && !$reget_keys && [file exists $cacheExp]} {
        InfoWindow push "Reading cache '$cacheExp' ..."
        set res [catch { set fi [open $cacheExp r] }]
        InfoWindow pop
        if {$res == 0} {
            set v [read $fi]
            close $fi
            return $v
        }
    }
    set v [ReadKeyList]

    if $opt(uses_cached_keys) {
        InfoWindow push "Recreating cache '$cacheExp'"
        set res [catch { set fo [open $cacheExp w] }]
        if $res {
            ErrorDialog "Can't open '$cacheExp', no caching."
        } else {
            puts $fo $v
            close $fo
        }
        InfoWindow pop
    }
    return $v
}

#
# PrepareKeyData_PGPv5
#
# Rebuild pkeyArray() array, set its length to pkeyArray_len
#
proc PrepareKeyData_PGPv5 {top v fmt show} {
    global opt pkeyArray pkeyArray_len
    set ky {}
    set pkeyArray_len 0
    set pkeyArray_show 0
    set info_push push
    foreach s [split $v \n] {
        if [string length $s] {
            if {[string first "uid" $s] != 0} {
                # Any non-uid line shall be saved into the list
                # Make sure user wants to see this
                # type of objects!
                set obj [GetKeyComponent $s object]
                if {[lsearch -exact $show $obj] >= 0} {
                    lappend ky $s
                }
            } else {
                # This is uid.
                # Process all objects found so far.
                foreach keyline $ky {
                    set obj [GetKeyComponent $keyline object]
                    set ls [FormatPublicKey $ky $s $obj $fmt]
                    if [string length $ls] {
                        # Display message every several keys
                        if {[incr pkeyArray_show -1] <= 0} {
                            InfoWindow $info_push \
                                "Processing keys ($pkeyArray_len) ..."
                            set info_push replace
                            set pkeyArray_show $opt(proc_keys_step)
                        }
                        set pkeyArray($pkeyArray_len) $ls
                        incr pkeyArray_len
                    }
                }
            }
        } else {
            set ky {}
        }
    }
    # Remove info message if it was ever pushed
    if [string compare $info_push push] {
        InfoWindow pop
    }
}

#
# PrepareKeyData_PGPv6
#
# Rebuild pkeyArray() array, set its length to pkeyArray_len
#
proc PrepareKeyData_PGPv6 {top v fmt show} {
    global opt pkeyArray pkeyArray_len
    set pkeyArray_len 0
    set pkeyArray_show 0
    set info_push push
    set val_s {}
    foreach s [split $v \n] {
        set s [string trimright $s]
        # puts "{$s}"
        if {[string length $s] > 0} {
            if [regexp {^(RSA|DSS)} $s] {
                set val_s $s
            } elseif [string length $val_s] {
                #
                # This string probably contains an additional ID.
                # We should merge this ID into previous line.
                #
                set v1 [string range $val_s 0 36]
                set v2 [string trim [string range $s 37 end]]
                if [string length $v2] {
                    set s "$v1$v2"
                } else {
                    set s {}
                    set val_s {}
                    continue
                }
            } else {
                set s {}
                set val_s {}
                continue
            }

            set ls [FormatPublicKey_PGPv6 $s]

            # If we produced output from this source line...
            if [string length $ls] {
                # Display message every several keys
                if {[incr pkeyArray_show -1] <= 0} {
                    InfoWindow $info_push \
                            "Processing keys ($pkeyArray_len) ..."
                    set info_push replace
                    set pkeyArray_show $opt(proc_keys_step)
                }
                set pkeyArray($pkeyArray_len) $ls
                incr pkeyArray_len
            }
        }
    }
    # Remove info message if it was ever pushed
    if [string compare $info_push push] {
        InfoWindow pop
    }
}

#
# PrepareKeyData_PGPv2
#
# Rebuild pkeyArray() array, set its length to pkeyArray_len
#
# pub   768/5AB7ACE1 1999/10/28 John Q. Smith <12345.6789@compuserve.com>
#                               John Q. Smith <foo@bar.net>
#
proc PrepareKeyData_PGPv2 {top v fmt show} {
    global opt pkeyArray pkeyArray_len
    set pkeyArray_len 0
    set pkeyArray_show 0
    set info_push push
    set val_s {}
    foreach s [split $v \n] {
        set s [string trimright $s]
        # puts "{$s}"
        if {[string length $s] > 0} {
            # Catch primary kines with key info
            if [regexp "^pub" $s] {
                set val_s $s
            } elseif {[string length $val_s] && [regexp "^ " $s]} {
                #
                # This string probably contains an additional ID.
                # We should merge this ID into previous line.
                #
                set v1 [string range $val_s 0 29]
                set v2 [string trim [string range $s 30 end]]
                if [string length $v2] {
                    set s "$v1$v2"
                } else {
                    set s {}
                    set val_s {}
                    continue
                }
            } else {
                set s {}
                set val_s {}
                continue
            }

            set ls [FormatPublicKey_PGPv2 $s]

            # If we produced output from this source line...
            if [string length $ls] {
                # Display message every several keys
                if {[incr pkeyArray_show -1] <= 0} {
                    InfoWindow $info_push \
                            "Processing keys ($pkeyArray_len) ..."
                    set info_push replace
                    set pkeyArray_show $opt(proc_keys_step)
                }
                set pkeyArray($pkeyArray_len) $ls
                incr pkeyArray_len
            }
        }
    }
    # Remove info message if it was ever pushed
    if [string compare $info_push push] {
        InfoWindow pop
    }
}

#
# PrepareKeyData_GnuPG
#
# Rebuild pkeyArray() array, set its length to pkeyArray_len
#
proc PrepareKeyData_GnuPG {top v fmt show} {
    global opt pkeyArray pkeyArray_len
    set pkeyArray_len 0
    set pkeyArray_show 0
    set info_push push
    foreach s [split $v \n] {
        if {[string length $s] <= 0} { continue }
        set ls {}
        if {[string first "pub" $s] == 0} {
            set ls [FormatPublicKey_GnuPG $s]
        } elseif {[string first "uid" $s] == 0} {
            set ls [FormatPublicKey_GnuPG $s]
        } else {
            continue
        }

        # If we produced output from this source line...
        if [string length $ls] {
            # Display message every several keys
            if {[incr pkeyArray_show -1] <= 0} {
                InfoWindow $info_push "Processing keys ($pkeyArray_len) ..."
                set info_push replace
                set pkeyArray_show $opt(proc_keys_step)
            }
            set pkeyArray($pkeyArray_len) $ls
            incr pkeyArray_len
        }
    }
    # Remove info message if it was ever pushed
    if [string compare $info_push push] {
        InfoWindow pop
    }
}

#
# This procedure is part of QuickSort algorithm.
# Shamelessly borrowed from URL:
# http://www.science.gmu.edu/~egodard/prgasm1/quicksor.html
# (and one bug fixed).
#
# First parameter is the name of the global array to be sorted.
# Remaining parameters are used according to original code.
#
proc partition {an_array part_low_ind part_high_ind} {
    upvar #0 $an_array arr

    # swap median value an first value of array
    set comp1 [expr ($part_low_ind + $part_high_ind) / 2]         
    set transit $arr($part_low_ind)
    set arr($part_low_ind) $arr($comp1)
    set arr($comp1) $transit

    set median_val $arr($part_low_ind)
    set lastsmall $part_low_ind
    for {set i [expr $part_low_ind+1]} {$i <= $part_high_ind} {incr i} {
        # Here is the only place where we compare elements:
        if { [string compare $arr($i) $median_val] < 0 } {
            incr lastsmall
            # swap lastsmall and i
            set transit $arr($lastsmall)
            set arr($lastsmall) $arr($i)
            set arr($i) $transit
        }
    }

    # swap part_low_ind and lastsmall
    set transit $arr($part_low_ind)
    set arr($part_low_ind) $arr($lastsmall)
    set arr($lastsmall) $transit

    set median $lastsmall
    return $median
}

#
# This is the main QuickSort procedure.
#
# First parameter is the name of the global array to be sorted.
# Remaining parameters are used according to original code.
# They are bounding indices; this means that this code does not
# attempt to determine the boundaries and, therefore, can
# sort segments of an array (if anyone knows what for :)
#
proc quicksort {an_array qk_low_ind qk_high_ind} {
    if {$qk_low_ind < $qk_high_ind} {
        set median [partition $an_array $qk_low_ind $qk_high_ind]
        quicksort $an_array $qk_low_ind $median
        quicksort $an_array [expr $median+1] $qk_high_ind
    }
}

#
# This procedure is used to sort an array of strings.
# The parameter is the name of the global array to be sorted.
#
proc SortPkeyArray {top} {
    global pkeyArray pkeyArray_len

    InfoWindow push "Sorting keys..."
    #
    # Here you can switch between QuickSort and Bubble sort.
    # Don't know why you'd want, though :)
    #
    if 0 {
        set i_one [expr $pkeyArray_len-1]
        for {set i 0} {$i < $i_one} {incr i} {
            for {set j [expr $i+1]} {$j < $pkeyArray_len} {incr j} {
                if {[string compare $pkeyArray($i) $pkeyArray($j)] > 0} {
                    set tmp $pkeyArray($i)
                    set pkeyArray($i) $pkeyArray($j)
                    set pkeyArray($j) $tmp
                }
            }
        }
    } else {
        quicksort pkeyArray 0 [expr $pkeyArray_len-1]
    }
    InfoWindow pop
}

#
# ProcessKeyData
#
# History:
# 28-Oct-99 Added PGP v2 and v6 support.
#
proc ProcessKeyData {top lb v fmt show rebuild} {
    global opt pkeyArray pkeyArray_len

    # Rebuild array of keys only on first access or if rebuild req'd
    # TODO: Don't force rebuild if we just want different keys!
    if {$rebuild || ($pkeyArray_len <= 0)} {
        switch $opt(cryptoEngine) {
            0 { PrepareKeyData_GnuPG $top $v $fmt $show }
            1 {
                switch $opt(pgpVersion) {
                    2 { PrepareKeyData_PGPv2 $top $v $fmt $show }
                    5 { PrepareKeyData_PGPv5 $top $v $fmt $show }
                    6 { PrepareKeyData_PGPv6 $top $v $fmt $show }
                    default {
                        ErrorDialog "ProcessKeyData: Invalid PGP version"
                        return
                    }
                }
            }
            default {
                ErrorDialog "ProcessKeyData: Invalid crypto engine"
                return
            }
        }
        if $opt(uses_sorted_lists) {
            SortPkeyArray $top
        }
    }

    # Delete "Loading..." message if it was in listbox.
    $lb delete 0 end

    # Now transfer the array of strings into the listbox
    #
    # Note that we do not use InsertIntoListbox_Lexicographically 
    # because it would be too slow. Instead we load pre-sorted
    # array of strings "as is".

    for {set i 0} {$i < $pkeyArray_len} {incr i} {
        $lb insert end $pkeyArray($i)
    }
}

#
# History:
# 14-Oct-98 Added title string for mini list (selected keys)
#
proc FillKeySelectWindowWithPublicKeys { top fmt objects {reget_keys 0}} {
    global opt ks_win_mode fksw_lastCall

    set fksw_lastCall [list $top $fmt $objects]
    set need_reload 0
    if [string compare $ks_win_mode $objects] {
        incr need_reload
    }
    set ks_win_mode $objects
    set opt(title_str) [FormatTitleString $fmt]
    $top.biglist.title delete 0 end
    $top.biglist.title insert 0 $opt(title_str)
    if [winfo exists $top.minilist.title] {
        $top.minilist.title delete 0 end
        $top.minilist.title insert 0 $opt(title_str)
    }
    InfoWindow clear

    # Clear the listbox in case of Refresh
    $top.biglist.uid delete 0 end
    $top.biglist.uid insert 0 "Loading keys, please wait..."

    set v [ReadKeys $top $reget_keys]

    ProcessKeyData $top $top.biglist.uid $v $fmt $objects $need_reload
}

proc InsertIntoListbox_Lexicographically {lb str} {
    global opt
    if $opt(uses_sorted_lists) {
        set num [$lb size]
        set where end
        for {set i 0} {$i < $num} {incr i} {
            set s [$lb get $i]
            if {[string compare $str $s] <= 0} {
                set where $i
                break
            }
        }
    } else {
        set where end
    }
    $lb insert $where $str
    # Optionally scroll the listbox to show added element
    if $opt(uses_visible_item) {
        $lb see $where
    }
}

proc GetHexKey { lb k } {
    global opt
    set s [$lb get $k]
    set n_del $opt(w_uid)
    foreach obj $opt(columns) {
        if {[string compare $obj hex] == 0} {
            return [string range $s $n_del [expr $n_del+$opt(w_hex)-3-1]]
        } else {
            incr n_del $opt(w_$obj)
        }
    }
    return {}
}

#
# History:
# 30-Oct-98 Created to sort item numbers (quicksort works on strings).
#
proc SortListOfNumbers {l {order "up"}} {
    set j_max [llength $l]
    set i_max [expr $j_max - 1]
    for {set i 0} {$i < $i_max} {incr i} {
        for {set j [expr $i + 1]} {$j < $j_max} {incr j} {
            set i_val [lindex $l $i]
            set j_val [lindex $l $j]
            if {$order == "up" } {
                set xcg [expr $i_val - $j_val]
            } else {
                set xcg [expr $j_val - $i_val]
            }
            if {$xcg > 0} {
                set l [lreplace $l $i $i $j_val]
                set l [lreplace $l $j $j $i_val]
            }
        }
    }
    return $l
}

#
# Do_PK_MoveKey
#
# This procedure moves key objects between windows (panes). The
# parameter 'move_down' specifies direction (1=down, 0=up).
# Procedure gets list of selected items in source listbox and
# moves them into destination listbox.
#
# History:
# 30-Oct-98 Added pre-sorting of numbers of selected items, otherwise
#           wrong keys would be moved between listboxes.
#
proc Do_PK_MoveKey {top move_down} {
    if $move_down {
        set lb_from $top.biglist.uid
        set lb_to $top.minilist.uid
    } else {
        set lb_from $top.minilist.uid
        set lb_to $top.biglist.uid
    }

    # Get list of selected items (0-based numbers)
    # To safely move items from source listbox we must
    # sort items, and then work our way from last to first.
    # Otherwise numbers would be totally screwed up.

    set csel [SortListOfNumbers [$lb_from curselection] down]
    # puts $csel

    # Deselect whatever items were selected.
    $lb_from selection clear 0 end

    foreach i $csel {
        set j [$lb_from get $i]
        InsertIntoListbox_Lexicographically $lb_to $j
        $lb_from delete $i
    }
}

#
# Do_PK_Refresh
#
# This code runs when user clicks "Refresh" button. It clears
# listbox(es) and reloads the top listbox with new data.
#
# History:
# 23-Dec-98 Restore the previously selected items if we have some.
#
proc Do_PK_Refresh top {
    global opt pkeyArray_len ks_win_mode

    # When called from Recipient window we don't have selection window.
    set cursel {}
    set lt $top.biglist.uid
    set lb $top.minilist.uid
    if [winfo exists $lb] {

        # Do we have some items already selected?
        set cursel [$lb get 0 end]

        # Clear all selected entries since we reread top box...
        $lb delete 0 end
    }

    # Force rebuild of the listbox content
    set pkeyArray_len 0
    FillKeySelectWindowWithPublicKeys $top $opt(columns) $ks_win_mode 1

    # Restore the lower listbox if it previously had some contents.
    # We do it by locating matching items in the [new] top listbox,
    # then selecting them and (after all are selected) moving them down.

    if [llength $cursel] {

        # Since list of selected items is much smaller than number of
        # keys on a keyring, it will be faster to do outer loop on
        # all keys and inner loop on keys to be selected.

        $lt selection clear 0 end
        set n [$lt size]
        for {set i 0} {$i < $n} {incr i} {

            # Compare i-th element of top listbox to all of
            # previously memorized elements from lower listbox.

            set topElem [$lt get $i]
            set m [llength $cursel]
            for {set j 0} {$j < $m} {incr j} {
                if {[string compare $topElem [lindex $cursel $j]] == 0} {

                    # Mark this element
                    $lt selection set $i

                    # Remove found element from $cursel
                    set cursel [lreplace $cursel $j $j]
                    break
                }
            }
        }

        # Hopefully we found all previously selected elements!
        if {[llength $cursel] > 0} { ErrorDialog "Failed to find keys:\n$cursel" $top }
        if [llength [$lt curselection]] { Do_PK_MoveKey $top 1 }
    }
}

proc Do_PK_Close {top hasMini} {
    if $hasMini {
        GeometrySave $top encGeom
    } else {
        GeometrySave $top sigGeom
    }
    catch "destroy $top"
    update
}

proc Do_PK_Done {top retvar hasMini} {
    # Create a reference 'rv' to global variable '$retvar'
    upvar #0 $retvar rv
    set rv {}
    if $hasMini {
        set lbox $top.minilist.uid
        set ll [$lbox size]
        if {$ll <= 0} {
            ErrorDialog "Please add one or more keys to lower window." $top
            return
        }
        # Convert all selections to hex keys, return list
        for {set i 0} {$i < $ll} {incr i} {
            lappend rv [GetHexKey $lbox $i]
        }
    } else {
        set lbox $top.biglist.uid
        set csel [$lbox curselection]
        if {[llength $csel] != 1} {
            ErrorDialog "Please select exactly one key." $top
            return
        }
        set index [lindex $csel 0]
        set rv [GetHexKey $lbox $index]
    }
    Do_PK_Close $top $hasMini
}

#
# Procedure scans big key list, returns index [0..whatever] of
# record that has specified UID. May return -1 if record not found.
#
proc GetIndexByUID {top uid} {
    set ll [$top.biglist.uid size]
    for {set i 0} {$i < $ll} {incr i} {
        if { $uid == [GetHexKey $top.biglist.uid $i]} {
            return $i
        }
    }
    return -1
}

proc RecipientsKeyRButtonMenu {big w x y b} {
    global opt

    set state_add [MakeStateKeyword $big zero-disabled]
    set state_rem [MakeStateKeyword $big zero-normal]
    catch "destroy $w.mnu"
    menu $w.mnu -tearoff 0
    $w.mnu add command -label Add \
        -command "FlashAndInvokeButton $b.add" \
        -state $state_add
    $w.mnu add command -label Remove \
        -command "FlashAndInvokeButton $b.remove"\
        -state $state_rem
    $w.mnu add command -label Done -command "FlashAndInvokeButton $b.done"
    $w.mnu add separator
    $w.mnu add command -label Properties -command \
        "FlashAndInvokeButton $b.prop" -state disabled
    $w.mnu add separator
    $w.mnu add command -label Refresh \
        -command "FlashAndInvokeButton $b.refresh"
    $w.mnu add command -label Cancel \
        -command "FlashAndInvokeButton $b.cancel"

    if $opt(use_tk_popup) {
        tk_popup $w.mnu $x $y
    } else {
        $w.mnu post $x $y
    }
}

proc SelectRecipientKeys { top retvar } {
    global opt
    upvar #0 $retvar rv
    if [winfo exists $top] {
        raise $top
        return
    }
    CreateKeySelectWindow $top $retvar 1 {Select recipients}
    update
    FillKeySelectWindowWithPublicKeys $top $opt(columns) $opt(show_objects) 0
    #
    # Add automatically currently defined keys to the lower box.
    #
    foreach dki $rv {
        set i [GetIndexByUID $top $dki]
        if {$i >= 0} {
            $top.minilist.uid insert 0 [$top.biglist.uid get $i]
        } else {
            ErrorDialog "Key ID $dki not found on your keyring." $top
        }
    }
    bind $top.biglist.uid <Double-Button-1> \
        "FlashAndInvokeButton $top.buttons.add"
    bind $top.biglist.uid <Button-3> \
        "RecipientsKeyRButtonMenu 1 $top.biglist.uid %X %Y $top.buttons"
    bind $top.minilist.uid <Double-Button-1> \
        "FlashAndInvokeButton $top.buttons.remove"
    bind $top.minilist.uid <Button-3> \
        "RecipientsKeyRButtonMenu 0 $top.biglist.uid %X %Y $top.buttons"
    set rv {}
    tkwait window $top
}

proc SigningKeyRButtonMenu {w x y b} {
    global opt

    catch "destroy $w.mnu"
    menu $w.mnu -tearoff 0
    $w.mnu add command -label Done -command "FlashAndInvokeButton $b.done"
    $w.mnu add separator
    $w.mnu add command -label Properties -command \
        "FlashAndInvokeButton $b.prop" -state disabled
    $w.mnu add command -label "Make default" -command \
        "FlashAndInvokeButton $b.prop" -state disabled
    $w.mnu add separator
    $w.mnu add command -label Refresh -command "FlashAndInvokeButton $b.refresh"
    $w.mnu add command -label Cancel -command "FlashAndInvokeButton $b.cancel"
    if $opt(use_tk_popup) {
        tk_popup $w.mnu $x $y
    } else {
        $w.mnu post $x $y
    }
}

proc SelectSigningKey { top retvar } {
    global opt
    upvar #0 $retvar rv
    CreateKeySelectWindow $top $retvar 0 {Select signing key}
    update
    FillKeySelectWindowWithPublicKeys $top $opt(columns) [list sec] 0
    #
    # FIXME add rv
    #
    bind $top.biglist.uid <Double-Button-1> \
        "FlashAndInvokeButton $top.buttons.done"
    bind $top.biglist.uid <Button-3> \
        "SigningKeyRButtonMenu $top.biglist.uid %X %Y $top.buttons"
    set rv {}
    tkwait window $top
}

############# PROPERTIES WINDOW ################

proc CreatePropButtonsFrame {top frame_name} {
    frame $frame_name
    button $frame_name.add -text Add -command "DoMoveKey 1"
    button $frame_name.remove -text Remove -command "DoMoveKey 0"
    button $frame_name.prop -text Properties -command DoProperties
    button $frame_name.refresh -text Refresh -command DoRefresh
    button $frame_name.execute -text Execute -command DoExecute
    button $frame_name.cancel -text Cancel -command "destroy $top"
    pack $frame_name.add $frame_name.remove $frame_name.prop \
        $frame_name.refresh $frame_name.execute $frame_name.cancel \
        -side left -expand 1
}

proc CreateKeyPropertiesWindow {top hex} {
    set bigheight 15
    catch { destroy $top }
    toplevel $top
    wm title $top "Key $hex"
    CreatePropButtonsFrame $top $top.buttons
    CreateKeyFrame $top.biglist $bigheight

    # Pack the main window
    pack $top.biglist -fill both -side top -expand 1 -padx 0.5m
    pack $top.buttons -fill x -side top
}

proc FillKeyPropWindowWithKeys {top hex fmt} {
    global opt
    set ls [FormatTitleString $fmt]
    $top.biglist.title delete 0 end
    $top.biglist.title insert 0 $ls

    # Clear the listbox in case of Refresh
    $top.biglist.uid delete 0 end

    set v [ReadKeys 1 $hex]
    # FIXME: Reload parameter is incorrect below
    ProcessKeyData $top.biglist.uid $v $fmt $opt(show_objectsA) 0
}

#
# SetUndoBuffer
#
# Procedure sets the undo buffer to specified value 'buf'.
# Previous contents of the undo buffer is discarded. Here
# you may add multilevel undo. If buffer is empty then
# undo buffer is not altered.
#
# History:
# 31-May-99 Changed to use MakeStateKeyword procedure.
#
proc SetUndoBuffer { {buf ""} } {
    global undo_buffer undo_button

    # Never zero undo buffer (would be silly!), disable Undo
    # before testing (assume that buffer _is_ empty).
    set us 0
    if [string length $buf] {
        set us 1
        set undo_buffer $buf
    }
    # Shall be careful if window already passed away...
    if [winfo exists $undo_button] {
        $undo_button configure -state [MakeStateKeyword $us zero-disabled]
    }
}

proc CreateExecuteButtons {w wfrm wedit} {
    global opt undo_button
    frame $wfrm

    # Get buttons
    set wfrg $wfrm.get
    frame $wfrg
    pack [button $wfrg.getclip -text "Get clipboard" \
        -command "DoGetClipboard $wedit CLIPBOARD"] -fill x
    if $opt(uses_primary) {
        pack [button $wfrg.getprim -text "Get primary" \
            -command "DoGetClipboard $wedit PRIMARY"] -fill x
    }
    pack [button $wfrg.getfile -text "Read file" \
        -command "DoGetClipboard $wedit FILE"] -fill x

    # Set buttons
    set wfrs $wfrm.set
    frame $wfrs
    pack [button $wfrs.setclip -text "Set clipboard" \
        -command "DoSetClipboard $wedit CLIPBOARD"] -fill x
    if $opt(uses_primary) {
        pack [button $wfrs.setprim -text "Set primary" \
            -command "DoSetClipboard $wedit PRIMARY"] -fill x
    }
    pack [button $wfrs.setfile -text "Write file" \
        -command "DoSetClipboard $wedit FILE"] -fill x

    # PGP buttons
    set wfrp $wfrm.pgp
    frame $wfrp
    pack [button $wfrp.sign -text Sign \
        -command "DoCryptography sign $wedit"] -fill x
    pack [button $wfrp.encr -text Encrypt \
        -command "DoCryptography encrypt $wedit"] -fill x
    pack [button $wfrp.s_en -text Sign+Encrypt \
        -command "DoCryptography sign+encrypt $wedit"] -fill x
    pack [button $wfrp.decr -text Decrypt \
        -command "DoCryptography decrypt $wedit"] -fill x
    pack [button $wfrp.undo -text Undo \
        -command "DoCryptography undo $wedit"] -fill x
    set undo_button $wfrp.undo
    SetUndoBuffer

    # Other buttons
    set wfro $wfrm.oth
    frame $wfro
    pack [button $wfro.setup -text Settings -command Settings] -fill x
    pack [button $wfro.close -text Close -command "QuitPGS \"$w\""] -fill x

    # Pack these frames
    pack $wfrg $wfrs $wfrp $wfro -pady 2m -fill x
}

proc CreateOptionsFrame {w frm wedit} {
    global cbk_disedt

    frame $frm
    grid [checkbutton $frm.ascii -text {ASCII armor} \
        -variable opt(ascii_armor) -state disabled] \
        -column 0 -row 0 -sticky w
    grid [checkbutton $frm.aadd -text {Auto add keys} \
        -variable opt(auto_add_keys) -state disabled] \
        -column 0 -row 1 -sticky w
    grid [checkbutton $frm.txt -text {Text mode} \
        -variable opt(text_mode)  -justify left] \
        -column 0 -row 2 -sticky w

    grid [checkbutton $frm.asci1 -text "Conventional encryption" \
        -variable opt(conventional)] \
        -sticky w -row 0 -column 1
    grid [checkbutton $frm.c_edk -text "Encrypt to default key"  \
        -variable opt(encrypt_to_self)] \
        -sticky w -row 1 -column 1
    grid [checkbutton $frm.sdefkey -text "Sign with default key" \
        -variable opt(sign_with_defkey)] \
        -sticky w -row 2 -column 1

    grid [checkbutton [set cbk_disedt $frm.altfont] \
        -text {Alternative font} \
        -variable opt(alt_font) \
        -command "ApplyFonts"] \
        -sticky w -row 0 -column 2
    grid [checkbutton [set cbk_disedt $frm.disedt] \
        -text {Disable editor} \
        -variable opt(disable_edit) \
        -command "SetEditorDisabledState $wedit"] \
        -sticky w -row 1 -column 2
    grid [checkbutton $frm.showmsg -text {Show messages} \
        -variable mess_button \
        -command "ShowMessages $wedit"] \
        -sticky w -row 2 -column 2

    grid [radiobutton $frm.cryptoEngine \
        -text GnuPG -variable opt(cryptoEngine) -value 0] \
        -sticky w -row 0 -column 3
    grid [radiobutton $frm.use_pgp5 \
        -text PGP -variable opt(cryptoEngine) -value 1] \
        -sticky w -row 1 -column 3
}

#
# SetEditorDisabledState
#
# This procedure sets the editor state. It can be either disabled
# (to prevent accidental changes) or enabled if you want to edit
# some text there. Editor also must be enabled at least for a moment
# to insert text into it.
#
# History:
# 31-May-99 Changed to use MakeStateKeyword procedure.
#
proc SetEditorDisabledState {wedit {state {}} } {
    if { $state == {}} {
        global opt
        set state $opt(disable_edit)
    }
    $wedit configure -state [MakeStateKeyword $state zero-normal]
}

#
# This procedure creates or destroys the frame with action buttons.
# What to do is defined by $opt(show_buttons) setting.
#
proc ManageButtons {w wedit} {
    global opt
    set w_rbuts $w.rbuts
    set has_buttons [winfo exists $w_rbuts]
    if { $opt(show_buttons) && !$has_buttons} {
        CreateExecuteButtons $w $w_rbuts $wedit
        pack $w_rbuts -side right -anchor ne -padx .5m -pady .5m
    } elseif { !$opt(show_buttons) && $has_buttons} {
        destroy $w_rbuts
    }
}

#
# This procedure creates or destroys the frame with switches.
# What to do is defined by $opt(show_switches) setting.
#
proc ManageSwitches {w wedit} {
    global opt
    set w_left $w.fl
    set w_fsw $w_left.opt
    set has_switches [winfo exists $w_fsw]
    if { $opt(show_switches) && !$has_switches} {
        CreateOptionsFrame $w $w_fsw $wedit
        pack $w_left.opt -anchor nw -side bottom -padx .5m -pady .5m
    } elseif { !$opt(show_switches) && $has_switches} {
        destroy $w_fsw
    }
}

#
# History:
# 30-Oct-98 Changed to use procedure SchedulePassphraseBurning
#
proc CreateStatusBar {statusFrame} {
    global statusWnd clockWnd passWnd
    pack [frame $statusFrame] -fill x -anchor sw -side bottom
    set statusWnd $statusFrame.status
    set clockWnd $statusFrame.clock
    set passWnd $statusFrame.pass
    pack [label $clockWnd -text "00:00" -width 10 -relief sunken] -side right
    pack [label $passWnd -width 10 -relief sunken] -side right
    pack [label $statusWnd -anchor w -relief sunken] \
        -anchor w -side left -expand yes -fill x
    bind $statusFrame.pass <Button-1> { SchedulePassphraseBurning 0 }
}

#
# This is a main window procedure.
# An optional parameter may specify the name of the
# window we are creating. If we are reusing root window {} then
# this parameter shall be left blank. However if you call this
# window from other Tcl application then it would be a great idea
# to specify some other name - or else it will replace one of your
# windows!
#
# History:
# 27-Oct-98 Added right-mouse-button action menu to text editor.
# 17-Apr-99 Added icon title and optional bitmap (1bpp for now).
# 10-Nov-99 Added loading of a file on startup.
#
proc Execute { {w {}} } {
    global opt dataWnd argv
    set wName "Data Processing window"
    # Prevent loss of data if user already works in Execute window!
    if [winfo exists $w] {
        ErrorDialog "The $wName is already in use" $w
        return
    }
    if [string length $w] {
        if [winfo exists $w] {
            raise $w
            return
        }
        toplevel $w
        set topName $w
    } else {
        set topName .
    }
    DecorateWindow $topName $wName TkPGP $opt(icon_xpm)

    set w_left $w.fl
    set w_left_e $w_left.e
    set dataWnd $w_left_e.edit
    set wscroll $w_left_e.scr

    # Create left frame; top of it is editor frame, bottom - options.
    frame $w_left

    # Create left-top frame for edit box.
    pack [frame $w_left_e] -anchor nw -expand yes -fill both

    # Set up a status window
    CreateStatusBar $w_left.f

    # Create the scrollbar to scroll the data box.
    scrollbar $wscroll -command "$dataWnd yview"

    # Create edit control for data.
    text $dataWnd -exportselection $opt(exportsel) -yscroll "$wscroll set"
    if [catch {$dataWnd configure -font [GetDataFont]} err] {
        # Whine and forget the font setting
        ErrorDialog $err $w
    }
    bind $dataWnd <Button-3> "DataWindowRButtonMenu $dataWnd %X %Y"
    SetEditorDisabledState $dataWnd

    pack $dataWnd -expand yes -fill both -side left -padx .5m -pady .5m
    pack $wscroll -fill y -side right -padx .5m -pady .5m

    # Insert switches
    ManageSwitches $w $dataWnd

    pack $w_left -fill both -expand yes -side left -padx .5m -pady .5m
    ManageButtons $w $dataWnd

    # CenterWindow $w - doesn't work yet
    InfoWindow clear

    # Load file
    if [llength $argv] {
        set fname [lindex $argv 0]
        if [catch {set fp [open $fname r]}] {
            ErrorDialog "Failed to open file $fname" $dataWnd
        } else {
            set ret [catch { set s [read $fp] }]
            close $fp
            if $ret {
                ErrorDialog "Failed to read from file $fname" $dataWnd
            } else {
                # Trim all trailing newlines, add one our own
                SetEditor $dataWnd "[string trimright $s]\n"
            }
        }
    }
}

proc EmailData { wedit } {
    global opt
    set w .emailw
    if [winfo exists $w] {
        raise $w
        return
    }
    toplevel $w
    DecorateWindow $w "TkPGP Email window" \
            "TkPGP Email window" $opt(icon_settings)

    GeometryRestore $w emailGeom

    grid [label $w.lto -text To: ] -sticky nw -row 0 -column 0
    grid [entry $w.eto -width 40 ] -sticky nw -row 0 -column 1

    grid [label $w.lcc -text CC: ] -sticky nw -row 1 -column 0
    grid [entry $w.ecc -width 40 ] -sticky nw -row 1 -column 1

    grid [label $w.lbcc -text BCC: ] -sticky nw -row 2 -column 0
    grid [entry $w.ebcc -width 40 ] -sticky nw -row 2 -column 1

    grid [label $w.lsj -text Subject: ] -sticky nw -row 3 -column 0
    grid [entry $w.esj -width 40 ] -sticky nw -row 3 -column 1

    grid [button $w.send -text Send -state normal \
            -command "EmailHandler $w $wedit send"] \
            -sticky nw -row 5 -column 0
    grid [button $w.cancel -text Cancel \
            -command "EmailHandler $w $wedit cancel"] \
            -sticky nw -row 5 -column 1
}

proc EmailHandler {w wedit action} {
    global mess_buffer dataWnd
    switch $action {
        send {
            # Obtain the data and make sure we have something to send!
            # If not, disable Send button because we can't send now.
            set data [GetEditor $wedit]
            if {[string length $data] <= 1} {
                $w.send configure -state disabled
                ErrorDialog "No data to send" $wedit
                return
            }

            set to [string trim [$w.eto get]]
            if {[string length $to] <= 0} {
                ErrorDialog "No recipient (To: field)" $wedit
                return
            }

            set cc [string trim [$w.ecc get]]
            if [string length $cc] {
                set cc "-c $cc"
            }

            set bcc [string trim [$w.ebcc get]]
            if [string length $bcc] {
                set bcc "-b $bcc"
            }

            set sj [string trim [$w.esj get]]
            if [string length $sj] {
                set sj "-s $sj"
            }
            # puts "$to $cc $bcc $sj"

            # Document the call that we are about to make.
            lappend mess_buffer "mail $sj $cc $bcc $to << (data)\n"

            # Invoke the mail application
            set rv [catch [exec mail $sj $cc $bcc $to << $data] msg]
            if {$rv == 0} {
                # Optional success message here
            } else {
                ErrorDialog "Sending probably failed:\n$msg"
            }

        }
    }
    GeometrySave $w emailGeom
    destroy $w
}

#
# GetEditor
#
# Procedure returns the editor buffer "as is".
#
# History:
#
proc GetEditor {wedit} {
    set s [$wedit get 0.0 end]
    # Trim all trailing newlines, add one our own
    set s [string trimright $s]
    append s "\n"
    return $s
}

#
# GetEditorWithSelection
#
# Procedure returns the editor buffer split into three
# components:
# - before selected portion
# - the selected portion
# - after selected portion
#
# These components are returned as list with three elements,
# indexed as 0, 1, 2 correspondingly. If there is no selection
# in the editor widget then error dialog is shown and empty
# list is returned.
#
# History:
# 31-May-99 Created.
#
proc GetEditorWithSelection {wedit} {
    global opt
    if {$opt(disable_edit) || ![winfo exists $wedit]} {
        ErrorDialog "Editor is disabled!"
        return {}
    }

    if {![IsTextWidgetHasSelection $wedit]} {
        ErrorDialog "Nothing is selected!"
        return {}
    }

    # Now we are sure that 'sel' tag exists. We now can
    # extract data referring to the tag.
    set v0 [$wedit get 0.0 sel.first]
    set v1 [$wedit get sel.first sel.last]
    set v2 [$wedit get sel.last end]
    return [list $v0 $v1 $v2]
}

#
# SetEditor
#
# Procedure replaces the current editor buffer with new content
# specified by parameter 's'. Old buffer is discarded.
#
# History:
# 31-May-99 Added trimming of superfluous trailing newlines, spaces.
#
proc SetEditor {wedit s} {
    # Trim all trailing newlines, add one our own
    set s [string trimright $s]
    append s "\n"

    # Editor window may be read-only (disabled). Unlock for a moment.
    SetEditorDisabledState $wedit 0
    $wedit delete 0.0 "end - 1 chars"
    $wedit insert 0.0 $s
    SetEditorDisabledState $wedit
}

#
# ModifyEditorBuffer
#
# Procedure performs 'action' on content of the buffer.
# If editor is read-only then nothing is done.
#
# History:
# 31-May-99 Created.
# 11-Nov-99 Added Email capability.
# 02-Dec-99 Added 'lalign-selection' mode.
#
proc ModifyEditorBuffer {wedit action} {
    global opt
    if {$opt(disable_edit) || ![winfo exists $wedit]} {
        ErrorDialog "Editor is read-only!"
        return
    }
    set buf {}
    set buf_changed 0
    set mark_insert [$wedit index insert]
    switch $action {
        cite-selection -
        cite-selection-as -
        lalign-selection -
        uncite-selection {
            set buflist [GetEditorWithSelection $wedit]
            if [llength $buflist] {
                set buf [ModifySelection $buflist $action]
                incr buf_changed
            }
        }
        ellipsis-selection {
            set buflist [GetEditorWithSelection $wedit]
            if [llength $buflist] {
                set buf [lindex $buflist 0]
                append buf {[...]}
                append buf [lindex $buflist 2]
                incr buf_changed
            }
        }
        clear-selection {
            set buflist [GetEditorWithSelection $wedit]
            if [llength $buflist] {
                set buf "[lindex $buflist 0][lindex $buflist 2]"
                incr buf_changed
            }
        }
        clear-all {
            incr buf_changed
        }
        email-all {
            EmailData $wedit
        }
        default {
            ErrorDialog "ModifyEditorBuffer: Illegal action '$action'"
        }
    }
    if $buf_changed {
        SetUndoBuffer [GetEditor $wedit]
        SetEditor $wedit $buf
        if [string length $mark_insert] {
            $wedit mark set insert $mark_insert
            $wedit see $mark_insert
        }
    }
}

#
# ModifyListOfStrings
#
# This procedure performs various operations on list of strings
# (which are usually stripped of \n characters, but this is not
# important). Procedure receives the source list, action keyword
# and optional data (type of which depends on action). Procedure
# returns the modified list. If called with unsupported action
# keyword the procedure simply returns the source list unchanged.
#
# History:
# 31-May-99 Created.
# 02-Dec-99 Added 'lalign' mode.
#
proc ModifyListOfStrings {llist action {data ""}} {
    set out {}
    foreach i $llist {
        switch $action {
            cite {
                if {[string length $data] == 0} {
                    set data "> "
                }
                lappend out "$data$i"
            }
            uncite {
                # Remove optional as-who, '>' and optional space:
                if [regsub {[^>]*> ?} $i {} i_out] {
                    # We have already done unciting!
                } else {
                    # Failed to uncite, keep original.
                    set i_out $i
                }
                lappend out $i_out
            }
            lalign {
                # Remove leading spaces, tabs
                if [regsub {^[ \t]+} $i {} i_out] {
                    # We have already done unciting!
                } else {
                    # Failed to uncite, keep original.
                    set i_out $i
                }
                lappend out $i_out
            }
            default {
                ErrorDialog "ModifyListOfStrings: Illegal action '$action'"
                return $llist
            }
        }
    }
    return $out
}

proc GetCiteAsWhoHandler {wtop w button varname} {
    if [winfo exists $wtop] {
        if [winfo exists $w] {
            upvar #0 $varname var
            switch $button {
                ok { set var [$w get] }
                cancel { set var {} }
            }
        }
        destroy $wtop
    }
}

proc GetCiteAsWho { } {
    global opt var_getciteaswho
    set w .getaswho
    set ll "Citation prefix"
    if [winfo exists $w] { destroy $w }
    toplevel $w
    DecorateWindow $w $ll $ll $opt(icon_settings)

    pack [frame $w.f1] -fill x
    pack [label $w.f1.icon -bitmap question] -side left -padx 3m
    pack [label $w.f1.msg -justify left -text \
"Please enter the citation prefix, such as
name of the person. For example, if you enter
'Mary' the text will be prefixed with 'Mary> '"] \
        -padx 3m -pady 3m -fill x
    pack [entry $w.f1.cp] -fill x
    pack [frame $w.f3] -padx 3m -pady 3m
    pack [button $w.f3.okbutton -text Ok -width 10 -command \
        "GetCiteAsWhoHandler $w $w.f1.cp ok var_getciteaswho"] \
        -side left -padx 2m
    pack [button $w.f3.cancbutton -text Cancel -width 10 -command \
        "GetCiteAsWhoHandler $w $w.f1.cp cancel var_getciteaswho"] \
        -side left -padx 2m

    # Preserve user's previous entry
    $w.f1.cp insert 0 $var_getciteaswho
    tkwait window $w
    return [string trim $var_getciteaswho]
}

proc TerminateStringWithEOL {str {cr_extra 1}} {
    set len [string length $str]
    if {$len > 0} {
        set plast [string range $str [expr $len-1] end]
        if [string compare $plast "\n"] {
            for {set i 0} {$i < $cr_extra} {incr i} {
                append str "\n"
            }
        }
    }
    return $str
}

proc BeautifyCitation {llist} {
    global opt
    set extras $opt(cite_extras)
    if {([llength $llist] == 3) && $extras} {
        # Make sure that text prior to citation ends with '\n'
        # Make sure that citation itself ends with '\n'
        for {set i 0} {$i < 2} {incr i} {
            set str [lindex $llist $i]
            set str [TerminateStringWithEOL $str $extras]
            set llist [lreplace $llist $i $i $str]
        }
    } else {
        ErrorDialog "BeautifyCitation: Bad llist\n$llist"
    }
    return $llist
}

#
# ModifySelection
#
# Procedure performs 'action' on data. The data consists of three
# components - "before selection", "selection" and "after selection".
# Procedure returns a text string which is, presumably, made of these
# three components after the 'action' has been performed on them.
#
# History:
# 01-Jun-99 Created.
# 02-Dec-99 Added 'lalign-selection' mode.
#
proc ModifySelection {buflist action} {
    global opt
    switch $action {
        cite-selection {
            set llist [MessageToList [lindex $buflist 1] good-and-slow]
            set llist [ModifyListOfStrings $llist cite $opt(cite_prefix)]
            set buflist [lreplace $buflist 1 1 [join $llist "\n"]]
            set buflist [BeautifyCitation $buflist]
        }
        cite-selection-as {
            set as_name [GetCiteAsWho]
            if [string length $as_name] {
                set llist [MessageToList [lindex $buflist 1] good-and-slow]
                set as_who "$as_name$opt(cite_prefix)"
                set llist [ModifyListOfStrings $llist cite $as_who]
                set buflist [lreplace $buflist 1 1 [join $llist "\n"]]
                set buflist [BeautifyCitation $buflist]
            }
        }
        lalign-selection {
            set llist [MessageToList [lindex $buflist 1] good-and-slow]
            set llist [ModifyListOfStrings $llist lalign]
            set buflist [lreplace $buflist 1 1 [join $llist "\n"]]
        }
        uncite-selection {
            set llist [MessageToList [lindex $buflist 1] good-and-slow]
            set llist [ModifyListOfStrings $llist uncite]
            set buflist [lreplace $buflist 1 1 [join $llist "\n"]]
        }
        default {
            ErrorDialog "ModifySelection: Illegal action '$action'"
        }
    }
    return "[lindex $buflist 0][lindex $buflist 1][lindex $buflist 2]"
}

#
# MakeStateKeyword
#
# Procedure returns either "normal" or "disabled"
# depending on 'value' and 'polarity'. Value must
# be a number - zero or non-zero. Polarity takes
# two values (character strings):
#
# zero-normal       Value=0 Keyword="normal"
# zero-disabled     Value=0 Keyword="disabled"
#
# History:
# 31-May-99 Created.
#
proc MakeStateKeyword {value polarity} {
    set rvn "normal"
    set rvd "disabled"
    set rv $rvn
    switch $polarity {
        zero-normal {
            if $value {
                set rv $rvd
            }
        }
        zero-disabled {
            if {!$value} {
                set rv $rvd
            }
        }
        default {
            ErrorDialog "MakeStateKeyword: Illegal polarity '$polarity'"
        }
    }
    return $rv
}

#
# IsTextWidgetHasSelection
#
# Procedure checks if the text widget has selection (tag 'sel')
# and returns 1 if it does, 0 if it doesn't.
#
# History:
# 01-Jun-99 Created.
#
proc IsTextWidgetHasSelection {w} {
    if [winfo exists $w] {
        if {[llength [$w tag ranges "sel"]] > 0} {
            return 1
        }
    }
    return 0
}

#
# DataWindowRButtonMenu
#
# This is the handler of RButton click in data window.
# We construct right-click menu here.
#
# History:
# 31-May-99 Added "Cite selection", "Uncite selection". Now menu is
#           created regardless of editor buffer enabled state, but
#           menu items are disabled if no action is allowed.
# 02-Dec-99 Added "Email All" and "Left-align selection"
#
proc DataWindowRButtonMenu {w x y} {
    global opt

    set state [MakeStateKeyword $opt(disable_edit) zero-normal]

    # Some items also require selection
    set has_selection [IsTextWidgetHasSelection $w]
    set state2 $state
    if {!$has_selection} {
        set state2 [MakeStateKeyword 0 zero-disabled]
    }

    catch "destroy $w.mnu"
    menu $w.mnu -tearoff 0
    $w.mnu add command -label "Cite selection" \
        -state $state2 -command "ModifyEditorBuffer $w cite-selection"
    $w.mnu add command -label "Cite selection as..." \
        -state $state2 -command "ModifyEditorBuffer $w cite-selection-as"
    $w.mnu add command -label "Uncite selection" \
        -state $state2 -command "ModifyEditorBuffer $w uncite-selection"
    $w.mnu add command -label "Ellipsis selection" \
        -state $state2 -command "ModifyEditorBuffer $w ellipsis-selection"
    $w.mnu add command -label "Left-align selection" \
        -state $state2 -command "ModifyEditorBuffer $w lalign-selection"
    $w.mnu add separator
    $w.mnu add command -label "Clear Selection" \
        -state $state2 -command "ModifyEditorBuffer $w clear-selection"
    $w.mnu add command -label "Clear All" \
        -state $state -command "ModifyEditorBuffer $w clear-all"
    $w.mnu add separator
    $w.mnu add command -label "Email All" \
        -state $state -command "ModifyEditorBuffer $w email-all"
    if $opt(use_tk_popup) {
        tk_popup $w.mnu $x $y
    } else {
        $w.mnu post $x $y
    }
}

proc ShowMessages {wedit} {
    global data_buffer mess_buffer mess_button cbk_disedt
    if $mess_button {
        set data_buffer [GetEditor $wedit]
        set mess_text {}
        set mess_len [llength $mess_buffer]
        for {set i 0} {$i < $mess_len} {incr i} {
            set mess_el [lindex $mess_buffer $i]
            if {$i == 0} {
                append mess_text "Return code: $mess_el\n"
            } else {
                append mess_text "$mess_el\n"
            }
        }
        SetEditor $wedit $mess_text
        SetEditorDisabledState $wedit 1
        if [winfo exists $cbk_disedt] {
            $cbk_disedt configure -state [MakeStateKeyword 0 zero-disabled]
        }
    } else {
        SetEditor $wedit $data_buffer
        SetEditorDisabledState $wedit
        if [winfo exists $cbk_disedt] {
            $cbk_disedt configure -state [MakeStateKeyword 0 zero-normal]
        }
    }
}

proc DoGetClipboard {wedit seltype} {
    set s {}
    switch $seltype {
        FILE {
            set fname [FileDialog $wedit open]
            if [string length $fname] {
                set openExp [ExpandEnvironmentVariables $fname]
                if [catch {set fp [open $openExp r]}] {
                    ErrorDialog "Failed to open file $openExp" $wedit
                    return
                } else {
                    set ret [catch { set s [read $fp] }]
                    close $fp
                    if $ret {
                        ErrorDialog "Failed to read from file $openExp" $wedit
                        return
                    }
                }
            } else {
                return
            }
        }
        default {
            set ret [catch { set s [selection get -selection $seltype] } ]
            if $ret {
                ErrorDialog "No data on $seltype" $wedit
                return
            }
        }
    }

    # Trim all trailing newlines, add one our own
    set s [string trimright $s]
    append s "\n"
    SetEditor $wedit $s
}

proc DoSetClipboard {wedit seltype} {
    set s [GetEditor $wedit]
#   puts "Set clipboard:'$s'"
    switch $seltype {
        CLIPBOARD {
            clipboard clear
            clipboard append $s
        }
        FILE {
            set fname [FileDialog $wedit save]
            if [string length $fname] {
                set saveExp [ExpandEnvironmentVariables $fname]
                if [catch { set fp [open $saveExp w] } ] {
                    ErrorDialog "Failed to open file $saveExp" $wedit
                    return
                } else {
                    set ret [catch { puts -nonewline $fp $s } ]
                    close $fp
                    if $ret {
                        ErrorDialog "Failed to write into file $saveExp" $wedit
                        return
                    }
                }
            } else {
                return
            }
        }
        PRIMARY {
            $wedit tag add sel 0.0 "end - 1 char"
        }
    }
}

proc FileDialog {w operation {defext .pgp}} {
    global opt tk_strictMotif
    set tk_strictMotif $opt(uses_motif)
    #
    #   Type names        Extension(s)    Mac File Type(s)
    #
    #---------------------------------------------------------
    set types {
        {"All files"            *                       }
        {"PGP data files"       {.asc .pgp}     TEXT    }
        {"Text files"           {.txt .doc}             }
    }
    switch $operation {
        open {
            set file [tk_getOpenFile -filetypes $types -parent $w]
        }
        save {
            set file [tk_getSaveFile -filetypes $types -parent $w \
                -initialfile Untitled -defaultextension $defext]
        }
    }
    return $file
}

proc ReadFileAndDeleteAfterwards {fname} {
    global opt
    set v {}
    set tmpExp [ExpandEnvironmentVariables $fname]
    set rv [catch {set fp [open $tmpExp r]} ]
    DebugLog "Opened '$tmpExp', status=$rv, will delete."
    if { $rv == 0 } {
        set v [read $fp]
        close $fp
    }
    catch { file delete $tmpExp }
    return [list $rv $v]
}

#
# WriteStringIntoFile
#
# This procedure opens file named 'fname' for writing, saves given
# string 'str' into it and then closes the file. The file name will
# be expanded if it has shell variables. The procedure returns
# actual (expanded) file name or empty string if an error occurs.
#
# History:
# 11-Nov-99 Added returned value and code to catch errors.
#
proc WriteStringIntoFile {fname str} {
    set tmpExp [ExpandEnvironmentVariables $fname]
    set rv [catch {set fp [open $tmpExp w] } ]
    DebugLog "Opened for writing '$tmpExp', status=$rv"
    if { $rv == 0 } {
        puts -nonewline $fp $str
        close $fp
    } else {
        global dataWnd
        ErrorDialog "Failed to write into file '$tmpExp'" $dataWnd
        set tmpExp {}
    }
    return $tmpExp
}

#
# QuitPGS
#
# History:
# 14-Oct-98 Implemented confirmation dialog
# 10-Nov-99 Added saving of autoloaded file.
#
proc QuitPGS w {
    global opt argv dataWnd
    if $opt(confirm_exit) {
        # tk_dialog window title text bitmap default string string
        set rv [tk_dialog .quitDlg "Quitting TkPGP" \
           "Close TkPGP ?" \
            question 0 Yes No]
        if $rv { return }
    }
    if [llength $argv] {
        set fname [lindex $argv 0]
        set wantsave 1
        if $opt(ask_save) {
            set rv [tk_dialog .quitDlg "Need to save file" \
                    "Save work to $fname ?" question 0 Yes No Cancel]
            switch $rv {
                0 { set wantsave 1 }
                1 { set wantsave 0 }
                2 { return }
            }
        }
        if $wantsave {
            if [catch {set fp [open $fname w]}] {
                ErrorDialog "Failed to open file $fname" $dataWnd
            } else {
                set s [GetEditor $dataWnd]
                set ret [catch { puts -nonewline $fp $s } ]
                if $ret {
                    ErrorDialog "Failed to read from file $fname" $dataWnd
                }
                close $fp
            }
        }
    }
    ConfigSave
    if {"$w" == ""} { set w . }
    destroy $w
}

# === Procedures that create PGP command line(s) ===

proc AddAsciiArmorOption {} {
    global opt
    if $opt(ascii_armor) {
        return " -a"
    } else {
        return {}
    }
}

proc AddAutoAddKeys { } {
    global opt
    if { $opt(auto_add_keys) == 0 } {
        return " -K"
    } else {
        return {}
    }
}

proc AddInOutFiles {infile outfile} {
    return " -o$outfile $infile"
}

#
# History:
# 30-Oct-98 Created to facilitate scheduled burning of the passphrase
#           and manage the associated clock update.
#
proc SchedulePassphraseBurning {delay} {
    global clockWnd spb_id
    # Cancel possibly pending 'after'
    if [info exists spb_id] {
        after cancel $spb_id
        set spb_id 0
    }

    # Update the clock
    set hr [expr ($delay / 3600)]
    set mn [expr ($delay % 3600) / 60]
    set sc [expr ($delay % 60)]
    if $hr {
        set s [format "%d:%02d:%02d" $hr $mn $sc]
    } else {
        set s [format "%02d:%02d" $mn $sc]
    }
    $clockWnd configure -text $s

    if {$delay > 0} {
        set spb_id [after [expr 1000] \
                "SchedulePassphraseBurning [expr $delay-1]"]
    } else {
        # Burn Passphrase
        UpdatePassphrase {}
    }
}

proc UpdatePassphrase {pass} {
    global pgppass passWnd passBG passFG
    set pgppass $pass
    if [string length $pgppass] {
        set passBG [$passWnd cget -bg]
        set passFG [$passWnd cget -fg]
        $passWnd configure -text PASS -bg red -fg yellow
    } else {
        $passWnd configure -text {}
        if [string length $passBG] { $passWnd configure -bg $passBG }
        if [string length $passFG] { $passWnd configure -fg $passFG }
    }
}

proc SetPassphraseHandler {w we} {
    UpdatePassphrase [$we get]
    ClosePassphraseBox $w
}

proc ClosePassphraseBox w {
    catch { destroy $w }
    update
}

proc GenerateShowPassMode { } {
    global show_passphr
    if $show_passphr {
        set x ""
    } else {
        set x +
    }
    return $x
}

proc ShowPassphrase we {
    $we configure -show [GenerateShowPassMode]
}

#
# The procedure associates given script with any of two ENTER
# keys on the PC keyboard (Return and ENTER on numeric keypad).
#
proc BindEnterKeys {window script} {
    bind $window <Key-KP_Enter> $script
    bind $window <Key-Return> $script
}

#
# AddPassphrase_PGP
#
# The passphrase has to be passed via shell (bash most likely).
# We use double quotes for passphrase because singly-quoted
# string can not contain a single quote (see below). Therefore
# we use double quotes for both entire command line (as passed
# woth option -c of bash) and passphrase (which is part of said
# command line). Inner quotes must be protected with '\'
# characters, and the _contents_ of the passphrase must be
# scanned for special characters (", $, ` and \ - see below),
# and if found, these characters must be quoted.
#
# From bash(1):
# ------------
# Enclosing  characters  in single quotes preserves the lit-
# eral value of each character within the quotes.  A  single
# quote  may not occur between single quotes, even when pre-
# ceded by a backslash.
#
# Enclosing characters in double quotes preserves  the  lit-
# eral  value  of all characters within the quotes, with the
# exception of $, `, and \.  The characters $ and  `  retain
# their special meaning within double quotes.  The backslash
# retains its special meaning only when followed by  one  of
# the  following  characters:  $,  `, ", \, or <newline>.  A
# double quote may be quoted within double quotes by preced-
# ing it with a backslash.
# ------------
#
# This is a testing passphrase used (with test key, of course :)
# `~!@#$%^&*()_+ -=|\[];:'"<,>.?/
#
# This how it usually gets quoted (see "Show Messages" buffer):
# bash -c "(export PGPPASS=\"\\\`~!@#\\\$%^&*()_+ -=|\\[];:'\\\"<,>.?/\"; ...
#
# History:
# 05-Dec-99 Added quoting of special characters.
# 06-Dec-99 Added '--' to allow passphrases with dashes
# 07-Dec-99 Added more comments, saved quoted passphrase to be later
#           replaced with "***" in "Save Messages" buffer.
#
proc AddPassphrase_PGP {cmd copyPass} {
    global opt

    if [string length $copyPass] {
        # Scan raw passphrase, do quoting as explained above.
        set l_src [split $copyPass {}]
        set l_out {}
        foreach ch $l_src {
            switch -exact -- $ch {
                $   -
                `   -
                \"  { lappend l_out \\\\\\ $ch }
                \\  { lappend l_out \\\\ }
                default
                    { lappend l_out $ch }
            }
        }
        set quotedPass [join $l_out {}]
        # Add printing of the passphrase in debug mode. This is
        # potentially dangerous, so you would need to change 0
        # to 1 below to enable the feature!
        if {0 && $opt(debug)} {
            set cmd "echo passphrase={\\\$PGPPASS};$cmd"
        }
        set cmd "(export PGPPASS=\\\"$quotedPass\\\";$cmd;unset PGPPASS)"
    }
    return $cmd
}

#
# This code seems to be not used. I still don't know how to open pipe
# from Tcl code. Even if I do, I would be better off opening status-fd.
#
proc AddPassphrase_GnuPG {cmd copyPass} {
    if [string length $copyPass] {
        append cmd " --passphrase-fd 0"
    }
    return $cmd
}

#
# AddPassphrase
#
# Procedure returns the updated command line (with all necessary
# passphrase settings etc.) or empty string if passphrase is not
# available (cancelled, for example).
#
# History:
# 14-Oct-98 Added raising of get-pass window if one already exists.
# 30-Oct-98 Replaced raising with removal of old window because
#           we need this procedure to return data syncronously.
# 30-Oct-98 Changed to use procedure SchedulePassphraseBurning
# 12-Jan-99 Changed to treat empty password input as "password in shell"
# 08-Apr-99 Disabled "burning" of empty passphrase.
# 07-Dec-99 Added forced hiding of passphrase ($force_hid_pass)
#
proc AddPassPhrase {cmd} {
    global opt pgppass show_passphr force_hid_pass

    # If user indicated that s/he wants to enter password in
    # the shell (xterm) window each time when PGP needs it
    # then we don't need to manage the passphrase in TkPGP.
    # However user loses the ability to cache the passphrase.

    if $opt(shell_password) { return $cmd }

    # TODO: Be able to add passphrase to GnuPG. For now we can't.
    if { $opt(cryptoEngine) == 0} { return $cmd }

    # Reset "Show Passphrase" checkbox, we want to keep passphrase
    # obscured; to show user must enable it each time explicitly.
    # This might be configurable.
    if $force_hid_pass {
        # puts "--- $force_hid_pass ---"
        set show_passphr 0
    }

    set copyPass $pgppass
    if {[string length $copyPass] == 0} {
        set w .getpass
        # Make sure we don't have two passphrase dialogs on screen!
        catch "destroy $w"
        toplevel $w
        DecorateWindow $w "Enter passphrase" "TkPGP Passphrase" $opt(icon_pass)
        pack [entry $w.entry -width 40 -show [GenerateShowPassMode]] \
            -expand 1 -fill x -padx 1m -pady 1m
        frame $w.f
        pack [checkbutton $w.f.hid -text "Show passphrase" -command \
            "ShowPassphrase $w.entry" -variable show_passphr] \
            -side left
        frame $w.f.f
        pack [button $w.f.f.ok -text Ok \
            -command "SetPassphraseHandler $w $w.entry"] -side left
        pack [button $w.f.f.cancel -text Cancel \
            -command "ClosePassphraseBox $w" ] -side left
        pack $w.f.f -side right
        pack $w.f -expand 1 -fill x -padx 1m -pady 1m

        # Add ENTER key bindings
        BindEnterKeys $w.entry "FlashAndInvokeButton $w.f.f.ok"
        CenterWindow $w
        focus $w.entry
        tkwait window $w
        set copyPass $pgppass

        # If we have a passphrase then schedule destruction of
        # the passphrase after specified delay (in seconds).

        if [string length $copyPass] {
            SchedulePassphraseBurning $opt(keep_pass)
        }
    }
    # Add passphrase to the command as appropriate. GnuPG does not come here.
    # 0 { set cmd [AddPassphrase_GnuPG $cmd $copyPass] }
    switch $opt(pgpVersion) {
        2 { append cmd " -z$copyPass" }
        5 -
        6 { set cmd [AddPassphrase_PGP $cmd $copyPass] }
    }
    return $cmd
}

proc AddRecipients {recip} {
    global opt
    if $opt(conventional) {
        return " -c"
    }
    set s {}
    set n [llength $recip]
    for {set i 0} {$i < $n} {incr i} {
        set rp [lindex $recip $i]
        if {($opt(pgpVersion) == 5) || ($opt(cryptoEngine) == 0)} {
            # PGP v5 and GnuPG require option -r before each recipient
            append s " -r $rp"
        } else {
            # PGP v2 and v6 do not need no -r's
            append s " $rp"
        }
    }
    return $s
}

proc AddSigningKeyId { } {
    global opt signKey
    set s {}
    if $opt(sign_with_defkey) {
        if [string length $opt(def_key_id)] {
            set s $opt(def_key_id)
        } else {
            ErrorDialog "No default key ID."
            return {}
        }
    } else {
        if [string length $signKey] {
            set s $signKey
        } else {
            ErrorDialog "No signing key ID."
            return {}
        }
    }
    return " -u $s"
}

proc AddTextOption {} {
    global opt
    if $opt(text_mode) {
        return " -t"
    } else {
        return {}
    }
}

proc AddTextOption_GnuPG {} {
    global opt
    if $opt(text_mode) {
        return " --textmode"
    } else {
        return {}
    }
}

#
# AddVerboseOption
#
# This procedure adds "verbose" option which, quite expectedly,
# should increase verbosity of the crypto engine.
#
# History:
# 09-Nov-99 Added GPG options that were missed previously.
#
proc AddVerboseOption {} {
    global opt
    if $opt(verbose) {
        if {$opt(cryptoEngine) == 0} {
            # GnuPG
            return " -v"
        } else {
            # PGP v6 does not like -v, but PGP v2 and
            # v5 love them, differently...
            switch $opt(pgpVersion) {
                2 { return " +VERBOSE=2" }
                5 { return " -v" }
                6 { return "" }
            }
        }
    }
    return {}
}

#
# Make_PGP_CommandLine()
#
# Procedure creates and returns the command line to be executed.
# If it returns empty string then something went wrong and caller
# should not try to execute this.
#
# History:
# 30-Oct-98 Added code to check if PGP procedure was cancelled.
# 12-Jan-99 Added need_pass argument.
#
proc Make_PGP_CommandLine {op recip infile outfile need_pass} {
    global opt
    # The PGP binary (executable) name is always a good starting point!
    switch $opt(pgpVersion) {
        5 {
            # PGP v5
            set cmds $opt(bin_pgp5_$op)
        }
        6 -
        2 {
            # PGP v2 or v6
            set cmds $opt(bin_pgp2_or_6)
            switch $op {
                encrypt { append cmds " -e" }
                sign { append cmds " -s"}
                sign+encrypt { append cmds " -es" }
            }
        }
    }
    append cmds [AddVerboseOption]
    switch $op {
        decrypt {
            append cmds [AddAutoAddKeys]
            append cmds [AddInOutFiles $infile $outfile]
        }
        encrypt {
            append cmds [AddAsciiArmorOption]
            append cmds [AddTextOption]
            if {$opt(pgpVersion) == 5} {
                # PGP v5
                append cmds [AddRecipients $recip]
                append cmds [AddInOutFiles $infile $outfile]
            } else {
                append cmds [AddInOutFiles $infile $outfile]
                append cmds [AddRecipients $recip]
            }
            # FIXME add conventional enc. here
        }
        sign {
            append cmds [AddAsciiArmorOption]
            append cmds [AddTextOption]
            set sig_opt [AddSigningKeyId]
            if { [string length $sig_opt] == 0 } {
                return {}
            } else {
                append cmds $sig_opt
            }
            append cmds [AddInOutFiles $infile $outfile]
        }
        sign+encrypt {
            append cmds [AddAsciiArmorOption]
            # FIXME add conventional enc. here
            append cmds [AddTextOption]
            set sig_opt [AddSigningKeyId]
            if { [string length $sig_opt] == 0 } { return "" }
            append cmds $sig_opt
            if {$opt(pgpVersion) == 5} {
                # PGP v5
                append cmds [AddRecipients $recip]
                append cmds [AddInOutFiles $infile $outfile]
            } else {
                # PGP v6
                append cmds [AddInOutFiles $infile $outfile]
                append cmds [AddRecipients $recip]
            }
        }
        default {
            ErrorDialog "Make_PGP_CommandLine($op ...): Illegal call"
            return {}
        }
    }
    # Add passphrase if we need it.
    if $need_pass {
        set cmds [AddPassPhrase $cmds]
    }

    # If command string is empty (no passphrase) we return empty string.
    if {![string length $cmds]} {
        return {}
    }

    # Execute in shell only if needed (specified explicitly or
    # by choice of conventional encryption.
    if {$opt(shell_$op) || ($opt(conventional) && ($op == "encrypt")) } {
        set cmds [ApplyShell $cmds]
    }
    # puts "cmds='$cmds'"
    return $cmds
}

proc AddSigningOption_GnuPG {} {
    global opt
    if $opt(text_mode) {
        return " --clearsign"
    } else {
        return " --sign"
    }
}

#
# Make_GnuPG_CommandLine()
#
# Procedure creates and returns the command line to be executed.
# If it returns empty string then something went wrong and caller
# should not try to execute this.
#
# History:
# 08-Apr-99 Created.
# 29-Oct-99 Moved -r <recipient> ... before --encrypt.
#
proc Make_GnuPG_CommandLine {op recip infile outfile need_pass} {
    global opt
    # The GnuPG binary (executable) name is always a good starting point!
    set cmds $opt(bin_gpg)
    append cmds [AddVerboseOption]
    switch $op {
        decrypt {
            append cmds [AddInOutFiles $infile $outfile]
        }
        encrypt {
            append cmds [AddAsciiArmorOption]
            append cmds [AddTextOption_GnuPG]
            append cmds [AddRecipients $recip]
            append cmds " --encrypt"
            append cmds [AddInOutFiles $infile $outfile]
            # FIXME add conventional enc. here
        }
        sign {
            append cmds [AddAsciiArmorOption]
            append cmds [AddTextOption_GnuPG]
            append cmds [AddSigningOption_GnuPG]
            set sig_opt [AddSigningKeyId]
            if { [string length $sig_opt] == 0 } {
                return {}
            } else {
                append cmds $sig_opt
            }
            append cmds [AddInOutFiles $infile $outfile]
        }
        sign+encrypt {
            append cmds [AddAsciiArmorOption]
            # FIXME add conventional enc. here
            append cmds [AddTextOption_GnuPG]
            append cmds " --encrypt --sign"
            set sig_opt [AddSigningKeyId]
            if { [string length $sig_opt] == 0 } { return "" }
            append cmds $sig_opt
            append cmds [AddRecipients $recip]
            append cmds [AddInOutFiles $infile $outfile]
        }
        default {
            ErrorDialog "Make_GnuPG_CommandLine($op ...): Illegal call"
            return {}
        }
    }
    # Add passphrase if we need it.
    if $need_pass {
        set cmds [AddPassPhrase $cmds]
    }

    # If command string is empty (no passphrase) we return empty string.
    if {![string length $cmds]} {
        return {}
    }

    # Execute in shell only if needed (specified explicitly or
    # by choice of conventional encryption.
    if {$opt(shell_$op) || ($opt(conventional) && ($op == "encrypt")) } {
        set cmds [ApplyShell $cmds]
    }
    # puts "cmds='$cmds'"
    return $cmds
}

#
# The shell command may contain $* which we replace with our commands.
# If it is not there, then we simply append.
#
proc ApplyShell {cmds} {
    global opt
    set arg [string first {$*} $opt(shell)]
    if {$arg < 0} {
        set cmds "$opt(shell) $cmds"
    } else {
        set cmds "[string range $opt(shell) 0 [expr $arg-1]]$cmds\
[string range $opt(shell) [expr $arg+2] end]"
    }
    # puts "cmds='$cmds'"
    return $cmds
}

#
# Generate fully-qualified temporary file name
#
# History:
# 16-Sep-98 Trimmed generated name to allow spaces here, there.
# 14-Oct-98 Added / to separate directory and file (merged before)
#
proc TempFile f {
    global opt
    set d [string trim $opt(tmpdir)]
    set f [string trim $f]
    if [string length $d] { set f "$d/$f" }
    return [ExpandEnvironmentVariables $f]
}

#
# SecureCommandLine
#
# This procedure removes passphrase from command line (replaces it
# with '*') because the command line may be visible in message window
# (for debugging)
#
# History:
# 14-Oct-98 Created.
# 28-Oct-99 Added check for -zPASSPHRASE of PGP 2.6.x
# 07-Dec-99 Corrected to conform to latest version of quoted passphrase.
#
proc SecureCommandLine {s} {
    set have_pass 0
    if [regexp -nocase -indices {PGPPASS=([^;]+);} $s mv smv] {
        incr have_pass
    } else {
        global opt
        if {($opt(cryptoEngine) == 1) && ($opt(pgpVersion) == 2)} {
            if [regexp -nocase -indices { -z([^']*)} $s mv smv] {
                incr have_pass
            }
        }
    }
    if $have_pass {
        set v1 [lindex $smv 0]
        set v2 [lindex $smv 1]
        if {($v1 >= 0) && ($v2 >= $v1)} {
            set s1 [string range $s 0 [expr $v1 - 1]]
            set s3 [string range $s [expr $v2 + 1] end]
            set s2 {}
            for {set i [expr $v2 - $v1 + 1]} {$i > 0} {incr i -1} {
                set s2 "$s2*"
            }
            set s "$s1$s2$s3"
        }
    }
    return $s
}

#
# MakeSureFileDoesntExist
#
# History:
# 30-Oct-98 Created to ensure that temporary files that TkPGP
#           is going to use do not already exist. If they do
#           user either chooses to delete them or TkPGP stops
#           the PGP procedure.
#
proc MakeSureFileDoesntExist fname {
    set rv 0
    if [file exists $fname] {
        set rv [tk_dialog .existsDlg "File exists" \
                "Temporary file\n$fname\nexists. Delete?" \
                question 1 Yes No]
        update idletasks
        if {$rv == 0} {
            if [catch "file delete $fname" msg] {
                ErrorDialog $msg
                set rv 1
            }
        }
    }
    return $rv
}

#
# Procedure analyzes the message to be decrypted and returns TRUE
# if there is a tag indicating an encrypted messages. Otherwise
# the message may contain signatures, key blocks etc. which do not
# require our private key and, therefore, passphrase.
#
proc CheckIfPassphraseNeeded {src} {
    # If we have a PGP message then definitely we need a passphrase
    if {[string first "-----BEGIN PGP MESSAGE-----" $src] >= 0} {
        return 1
    }
    # Otherwise we apparently have a signed message(s) or key block(s)...
    # If we are wrong about that, PGP will ask for passphrase in a shell.
    return 0
}

#
# MessageToList
#
# This procedure splits the source buffer 'src' into list of
# lines (originally separated in 'src' with <CR> or <CR><LF>).
# If last line was *not* terminated with <CR> such <CR> will
# be assumed (i.e. we do not store the flag if any given line
# was properly terminated).
#
# History:
# 30-May-99 Created.
#
proc MessageToList {src method} {
    switch $method {
        quick-and-dirty {
            return [split $src "\n"]
        }
        good-and-slow {
            set slen [string length $src]
            set out {}
            set accum {}
            for {set i 0} {$i < $slen} {incr i} {
                set ch [string range $src $i $i]
                set cmp_LF [string compare $ch "\n"]
                if {$cmp_LF == 0} {
                    lappend out $accum
                    set accum {}
                } else {
                    append accum $ch
                }
            }
            #
            # Last line may be incomplete (no terminator)
            #
            if [string length $accum] {
                lappend out $accum
            }
            return $out
        }
        default {
            ErrorDialog "MessageToList: Invalid method '$method'"
        }
    }
}

#
# WordWrapHandler
#
# Procedure serves as a callback for the dialog box set up
# in procedure WordWrapAdvice. Numeric code 'action' defines
# what button user clicked. We set the return value (to be
# passed back to the caller of WordWrapAdvice) and destroy
# the dialog window.
#
# History:
# 29-May-99 Created.
#
proc WordWrapHandler {w action} {
    global opt wordwrap_rv
    set wordwrap_rv $action
    destroy $w
}

#
# WordWrapAdvice
#
# Procedure analyzes the buffer 'src', tests individual strings
# for maximum length (as configured) and reports if at least
# one violation is encountered. Returns TRUE if user chose to
# activate word wrap for this message. It may also permanently
# activate the global word wrapping, or it can deactivate the
# advisory facility (this very procedure) for future runs.
#
# History:
# 29-May-99 Created.
#
proc WordWrapAdvice {src} {
    global opt wordwrap_rv

    # If called when advisory turned off, don't wrap but proceed.
    if {!$opt(wrap_advice)} {
        return 1
    }
    set list_of_lines [MessageToList $src quick-and-dirty]
    foreach one_line $list_of_lines {
        # puts $one_line
        set len [string length $one_line]
        if {$len > $opt(wrap_margin)} {
            set w .wrapad
            set ll "Long line detected"
            if [winfo exists $w] { destroy $w }
            toplevel $w
            DecorateWindow $w $ll $ll $opt(icon_settings)
            pack [frame $w.f1] -fill x
            pack [label $w.f1.icon -bitmap question] -side left -padx 3m
            pack [label $w.f1.msg -justify left -text \
"One or more of lines in your message are longer
than recommended ($opt(wrap_margin)). This may cause problems
because on its way to recipient the message may become
word-wrapped and digital signature will not match
the changed text of your message.\n
This is an advisory only. If you wish you can enable
word-wrapping facility of TkPGP for this message only,
or for all other messages, or you may elect to disable
this dialog from now on."]
            pack [frame $w.f2] -fill x -pady 2m
            pack [checkbutton $w.f2.wordwrap_nomore \
                -text "Don't show this message any more" \
                -command "DontShowHandler wordwrap_nomore wrap_advice"]\
                -side left
            pack [frame $w.f3] -fill x -padx 2m -pady 2m
            set wordwrap_rv 0
            grid [button $w.f3.wrap_yesnow -text "Wrap now" \
                -command "WordWrapHandler $w 3"] -padx 1m -column 0 -row 0
            grid [button $w.f3.wrap_yesall -text "Wrap always" \
                -command "WordWrapHandler $w 2"] -padx 1m -column 1 -row 0
            grid [button $w.f3.wrap_no -text "Don't wrap" \
                -command "WordWrapHandler $w 1"] -padx 1m -column 2 -row 0
            grid [button $w.f3.wrap_stop -text "Cancel" \
                -command "WordWrapHandler $w 0"] -padx 1m -column 3 -row 0
            tkwait window $w
            return $wordwrap_rv
        }
    }
    return 1
}

proc WordWrapReport {num_soft num_hard} {
    global opt
    set m $opt(wrap_margin)
    set w .wrapinfo
    set ll "Word wrap report"
    if [winfo exists $w] { destroy $w }
    toplevel $w
    DecorateWindow $w $ll $ll $opt(icon_settings)
    pack [frame $w.f1] -fill x
    pack [label $w.f1.icon -bitmap info] -side left -padx 3m
    pack [label $w.f1.msg -justify left -text \
"One or more lines in your message were longer
than recommended ($m) and were word-wrapped
to prevent the message from inadvertent changes
on its way to recipient via Internet."] -pady 1m
    pack [label $w.f1.soft -justify left \
        -text "Soft line breaks: $num_soft"] -side left
    pack [label $w.f1.hard -justify left \
        -text "Hard line breaks: $num_hard"] -side left
    pack [frame $w.f2] -fill x -pady 2m
    pack [button $w.f2.okbutton -text Ok -command "destroy $w"]
    tkwait window $w
    update idletasks
}

proc WordWrapPerform {src} {
    global opt
    set out {}
    set nchanges 0
    set nchanges_hard 0
    set mrg [expr $opt(wrap_margin) - 1]
    set list_of_lines [MessageToList $src good-and-slow]
    foreach one_line $list_of_lines {
        # puts "one_line='$one_line'"
        set p $one_line
        set len [string length $p]
        if {$len <= $mrg} {
            if $opt(wrap_trim) {
                set p [string trimright $p]
            }
            append out "$p\n"
        } else {
            while {[string length $p] > 0} {
                # Find a space at $mrg or before.
                set ispace 0
                for {set i $mrg} {$i > 0} {incr i -1} {
                    set ch [string index $p $i]
                    if {[string compare $ch { }] == 0} {
                        set ispace $i
                        break
                    }
                }
                # If we found a space it will be soft break.
                # Otherwise - hard break.
                if {$ispace <= 0} {
                    if {$mrg <= [string length $p]} {
                        incr nchanges_hard
                    } else {
                        incr nchanges
                    }
                    set ispace $mrg
                } else {
                    incr nchanges
                }
                # Now we are ready to wrap.
                set p1 [string range $p 0 $ispace]
                set p2 [string range $p [expr $ispace+1] end]
                if $opt(wrap_trim) {
                    set p1 [string trimright $p1]
                    set p2 [string trimleft $p2]
                }
                append out "$p1\n"
                # puts "p1='$p1'"
                # puts "p2='$p2'"
                set p $p2
            }
        }
    }
    if $opt(wrap_warn) {
        if {$nchanges > 0 || $nchanges_hard > 0} {
            WordWrapReport $nchanges $nchanges_hard
        }
    }
    return $out
}

proc DontShowHandler {varName option} {
    global opt
    upvar #0 $varName var

    if $var {
        set opt($option) 0
    } else {
        set opt($option) 1
    }
}

proc CheckForInternationalSymbols {src} {
    global opt

    set len [string length $src]
    set matches ""
    set fmt [format {[%s%c]} "^\n\r\t\f -" 127 ]
    append fmt {]}
    for {set i 0} {$i < $len} {incr i} {
        if [regexp $fmt [string range $src $i $i]] {
            lappend matches $i
        }            
    }
    if {[llength $matches] <= 0} {
        return
    }
    set match [lindex $matches 0]

    set w .warni18n
    set ll "International characters found"
    if [winfo exists $w] { destroy $w }
    toplevel $w
    DecorateWindow $w $ll $ll $opt(icon_settings)

    pack [frame $w.f1] -fill x
    pack [label $w.f1.icon -bitmap info] -side left -padx 3m
    pack [label $w.f1.msg -justify left -text \
"Your message contains one or more international
characters (with codes from 128 to 255). First code
is in position $match. Such message may be ASCII-
armored despite of your intent to clear-sign it
as a readable text."] -pady 3m
    pack [frame $w.f2] -fill x -pady 2m
    pack [checkbutton $w.f2.warni18n_nomore \
        -text "Don't show this message any more" \
        -command "DontShowHandler warni18n_nomore warn_i18n"] -side left
    pack [frame $w.f3] -fill x -pady 2m
    pack [button $w.f3.okbutton -text Ok -command "destroy $w"]
    tkwait window $w
}

#
# DoCryptography
#
# This procedure carries on the specified action 'op'.
# The window name 'wedit' is provided to be used as a source/destination
# of data, and also as a parent window for other windows.
#
# History:
# 14-Oct-98 Cancel signing if default key is needed but not set.
# 30-Oct-98 Simplified code to check if PGP procedure was cancelled.
# 12-Jan-99 Now temporary files are always deleted after PGP finishes.
# 20-Feb-98 Append to, do not clean message buffer.
# 08-Apr-99 Added GnuPG support.
# 29-May-99 Added word wrapping routine.
#
proc DoCryptography {op wedit} {
    global hexKeys opt signKey mess_buffer
    set wantRecip 0
    set wantSign  0
    set s [GetEditor $wedit]
    if {[string length $s] <= 0} {
        ErrorDialog "Editor buffer is empty, nothing to do!"
        return
    }
    set s_original $s
    set errfile [TempFile $opt(tmp_prefix).err]
    set need_pass 1
    set need_wrap 0
    set need_i18n_check 0
    switch $op {
        decrypt {
            set infile [TempFile $opt(tmp_prefix).asc]
            set outfile [TempFile $opt(tmp_prefix).txt]

            # Eliminate unneeded passphrase if there is no
            # PGP message to decrypt
            set need_pass [CheckIfPassphraseNeeded $s]
        }
        encrypt {
            set infile [TempFile $opt(tmp_prefix).txt]
            set outfile [TempFile $opt(tmp_prefix).asc]
            incr wantRecip
            set need_pass 0
            incr need_wrap
        }
        sign {
            set infile [TempFile $opt(tmp_prefix).txt]
            set outfile [TempFile $opt(tmp_prefix).asc]
            incr wantSign
            incr need_wrap
            incr need_i18n_check
        }
        sign+encrypt {
            set infile [TempFile $opt(tmp_prefix).txt]
            set outfile [TempFile $opt(tmp_prefix).asc]
            incr wantRecip
            incr wantSign
            incr need_wrap
        }
        undo {
            global undo_buffer
            SetEditor $wedit $undo_buffer
            SetUndoBuffer $s
            return
        }
        default {
            ErrorDialog "DoCryptography($op,$wedit): Illegal call"
            return
        }
    }

    #
    # If we may need word wrapping, do it now.
    #
    if $need_wrap {
        set do_wrap $opt(wrap_active)
        if {!$do_wrap && $opt(wrap_advice)} {
            set n [WordWrapAdvice $s]
            switch $n {
                3 { incr do_wrap }
                2 { incr do_wrap; incr opt(wrap_active) }
                1 { }
                0 { ErrorDialog "Cancelled."; return }
            }
        }
        if $do_wrap {
            set s [WordWrapPerform $s]
        }
        #
        # Clear signatures may be impossible if PGP
        # is configured to ASCII-armor international
        # texts (because it thinks they are binaries).
        #
        if {$opt(warn_i18n) && $need_i18n_check && $opt(text_mode)} {
            CheckForInternationalSymbols $s
        }
    }

    #
    # If we need recipients ask for them...
    #
    set winName .smk
    if {$wantRecip && !$opt(conventional)} {
        set hexKeys {}
        #
        # Auto-add our own key to encrypt to self
        #
        if $opt(encrypt_to_self) {
            set dki $opt(def_key_id)
            if [string length $dki] {
                lappend hexKeys $dki
            } else {
                ErrorDialog "No default key.\nWill not encrypt to self." $wedit
            }
        }
        SelectRecipientKeys $winName hexKeys
        if {[string length $hexKeys] == 0} {
            ErrorDialog "No recipients!" $wedit
            return
        }
    }
    #
    # If we are going to make signatures ask what key to use...
    #
    if $wantSign {
        # We can't sign when doing conventional encryption!
        if $opt(conventional) {
            ErrorDialog "Signing is incompatible with\nconventional\
encryption.\nSigning cancelled." $wedit
            return
        }
        # Possibly we want to use default key.
        set signKey {}
        if $opt(sign_with_defkey) {
            if [string length $opt(def_key_id)] {
                set signKey $opt(def_key_id)
            } else {
                ErrorDialog "Default key not set.\nSigning cancelled." $wedit
                return
            }
        }
        if {[string length $signKey] == 0} {
            SelectSigningKey $winName signKey
        }
        if {[string length $signKey] == 0} {
            ErrorDialog "Signing key not selected.\nSigning cancelled." $wedit
            return
        }
    }
    set someFileExists 0
    if [MakeSureFileDoesntExist $infile] {
        incr someFileExists
    } elseif [MakeSureFileDoesntExist $outfile] {
        incr someFileExists
    } elseif [MakeSureFileDoesntExist $errfile] {
        incr someFileExists
    }
    if $someFileExists {
        InfoDialog "Procedure cancelled\nbecause some\ntemporary\
files\nremain in the\ntemporary directory" $wedit
        return
    }

    # At this point none of temporary files exist.

    switch $opt(cryptoEngine) {
        0 {
            set cmds [Make_GnuPG_CommandLine $op \
                    $hexKeys $infile $outfile $need_pass]
        }
        1 { set cmds [Make_PGP_CommandLine $op \
                $hexKeys $infile $outfile $need_pass] }
    }
    if [string length $cmds] {
        set sec_cmds [SecureCommandLine $cmds]
        set extra_msg "$sec_cmds\n"
    } else {
        InfoDialog "Did nothing!" $wedit
        return
    }

    # Now we dump our data into a temporary file.
    WriteStringIntoFile $infile $s

    # Here we run PGP...
    append extra_msg [ExecuteScript $cmds $errfile]

    # Delete the temporary files ASAP, they contain plaintext!

    catch { file delete $infile }
    set vl [ReadFileAndDeleteAfterwards $outfile]
    lappend mess_buffer [ReadFileAndDeleteAfterwards $errfile]

    # Files deleted. Add whatever 'exec' returned to the message buffer.
    if [string length $extra_msg] { lappend mess_buffer $extra_msg }

    set rv [lindex $vl 0]
    set v  [lindex $vl 1]
    if $rv {
        ErrorDialog "No output file $outfile" $wedit
        return
    }
    SetUndoBuffer $s_original
    SetEditor $wedit $v
}

#
# ExecuteScript
#
# This procedure executes given commands with currently defined
# command interpreter (sh, bash, command.com, cmd.exe - whatever)
#
# Procedure returns whatever 'exec' returns. It will be empty string
# if an error occurs.
#
# History:
# 12-Jan-99 Added 'catch' to handle 'exec' errors gracefully.
# 20-Feb-99 Fixed horrible bug with variable expansion. Also
#           debug goes now into message buffer too.
# 12-Apr-99 Added 'maxError' to allow minor warnings.
# 29-May-99 Shortened strings, added 'n' and 'n2' variables.
#
proc ExecuteScript {cmds {errFile ""} {maxError 0} } {
    global opt mess_buffer
    set n "ExecuteScript"
    set n2 "$n will execute:"
    if {[string length $errFile] > 0} {
        # puts "$n2\n'$opt(exec) $opt(exec_opt) $cmds' >&$errFile"
        DebugLog "$n2\n'$opt(exec) $opt(exec_opt) $cmds' >&$errFile"
        set rv [catch {exec $opt(exec) $opt(exec_opt) $cmds >&$errFile} rs]
    } else {
        # puts "$n2\n'$opt(exec) $opt(exec_opt) $cmds'"
        DebugLog "$n2\n'$opt(exec) $opt(exec_opt) $cmds'"
        set rv [catch {exec $opt(exec) $opt(exec_opt) $cmds } rs]
    }
    # puts "$rv $maxError"
    DebugLog "$n done, status=$rv, results follow:\n$rs"
    if {$rv > $maxError} {
        ErrorDialog "$n failed:\n$rs\nSelect \"Show Messages\"\nfor details."
        DebugLog "$n failed."
        set rs {}
    }
    # puts "\$rs={$rs}"
    return $rs
}

#
# ****************  MAIN PROGRAM ****************
#
Configure
Execute