#
# $Id: tkpr_library.t,v 1.19 1993/07/23 23:27:14 mh Exp $
#

set TkGnats(lib) ./; ##TKGNATSLIB##
source $TkGnats(lib)/tkgnats.cf.t

# tk3.3 has a better one...
#proc tkerror {s} {
#    exec msgDialog "Tk background error in '[wm title .]'" "" "$s" &
#    schedule_reap
#}

proc Msg {a {flash 1}} {
    puts stderr $a
}

# reap any zombied exec's
set TkGnats(reap_scheduled) 0
proc do_reap {} {
    global TkGnats
    exec true
    set TkGnats(reap_scheduled) 0
}
proc schedule_reap {} {
    global TkGnats
    if {!$TkGnats(reap_scheduled)} {
	set TkGnats(reap_scheduled) 1
	after 5000 do_reap
    }
}

set f [glob -nocomplain -- ~/TkGnats/.tkgnatsrc]
if {$f != ""} {
    if {[file readable $f]} {
	source $f
    }
}

proc Exit {x} {
    #destroy .; # use if before tk3.3
    exit $x
}

proc my_pr_addr {name} {
    global TkGnats
    # strip off whitespace and then take out the first word.
    # we assume the rest is a (Full Name) type comment
    set name [string trim $name "\t\n "]
    set name [lindex [split $name "\t\n "] 0]
    set tmp [exec $TkGnats(pr-addr) $name]
    if {"$tmp" != ""} {
	set name $tmp
    }
    return $name
}

proc check_tkgnats_userdir {} {
    set user_dir [glob -nocomplain -- ~/TkGnats]
    if {$user_dir != ""} {
	if {![file isdirectory $user_dir]} {
	    mkdir $user_dir
	}
    }
}

#
# trim pr field data whitespace
#
proc ftrim {s} {
    return [string trim $s "\t\n "]
}

#
# get a list of valid gnats categories
#
proc get_categories {{pat "*"} {file ""}} {
    global TkGnats
    if {"$file" == ""} {
	set file $TkGnats(CategoriesFile)
    }
    set catlist {}
    if {[ file readable $file]} {
	foreach c [split [exec cat $file]] {
	    # ignore lines with leading hash or underscore
	    case $c "#*" {
	    } "_*" {
	    } $pat {
		lappend catlist $c
	    }
	}
    } else {
	Msg "Cannot read category file $file"
	return ""
    }
    return [lsort $catlist]
}

#
# get the users name from the passwd file given their logname
# try NIS first, then try the regular passwd file
#
proc fullname_from_logname {{lname ""}} {
    global TkGnats
    if {"$lname" == ""} {
	set lname $TkGnats(LogName)
    }
    if {
     [catch {set fullname [exec ypcat passwd | grep ^${lname}: | cut -f5 -d:]}]
    } {
	set fullname [exec cat /etc/passwd | grep ^${lname}: | cut -f5 -d:]
    }
    return $fullname
}
proc get_passwd_entry {lname} {
    # first try NIS, then try the regular passwd file..
    if {
     [catch {set fullname [exec ypcat passwd | grep ^${lname}:]}]
    } {
	catch "exec cat /etc/passwd | grep ^${lname}:" fullname
    }
    return $fullname
}

proc radiobar_frame {parent frname} {
    frame $frname
    frame $frname.labels
    frame $frname.bars
    pack append $frname $frname.labels {left} $frname.bars {right expand fillx}
    pack append $parent $frname {}
}

# text field related procs
proc textset {l t} {
    # a label
    if {[winfo exists  ._${l}.textlabel]} {
	._${l}.textlabel configure -text $t
	return
    }
    # text widget
    if {[winfo exists ._${l}_fr.text]} {
	._${l}_fr.text delete 1.0 end
	._${l}_fr.text insert 1.0 $t
	return
    }
    # entry widget
    if {[winfo exists ._${l}.text]} { 
	._${l}.text delete 0 end
	._${l}.text insert 0 $t
	return
    }
    error "no such window for $l"
}

proc textget {l} {
    if {[catch  {set x [lindex [._${l}.textlabel configure -text] 4]}  ]} {
	if {[catch {set x [._${l}_fr.text get 1.0 end]}]} {
	    return [string trim [._${l}.text get] "\n"]
	}
    }
    return "\n$x"
}
proc readonly_singletext {l {t ""}} {
    set f [frame ._${l}]
    set lw [label $f.label -anchor w -text "$l: "]
    set ew [label $f.textlabel -anchor w -text $t]
    pack append $f \
	$lw {left frame w} \
	$ew {right expand fillx frame w}
    pack append . $f {top fillx frame w pady 4}
    return $ew
}

bind Entry <KeyPress-Return> " "

proc singletext {l w {t ""}} {
    set f [frame ._${l}]
    # trim off any leading >'s for the label text
    set lw [label $f.label -anchor w -text "[string trimleft $l >]: "]
    set ew [entry $f.text -width 80 \
	-insertwidth 1	-insertofftime 400  \
	-relief sunken -borderwidth 2]
    bind $ew <Enter> "+focus $ew"
    $ew insert end $t
    pack append $f $lw {left expand fillx frame w} $ew {right frame e}
    pack append . $f {top fillx frame w pady 4}
    return $ew
}

proc bagged_singletext {l w bagname {prefix ""} {t ""}} {
    upvar #0 $bagname bag
    set f [frame ._${l}]
    set lw [label $f.label -anchor w -text "$l: "]
    set ew [entry $f.text -width 80 \
	-insertwidth 1	-insertofftime 400  \
	-relief sunken -borderwidth 2]
    bind $ew <Enter> "+focus $ew"
    $ew insert end $t
    pack append $f $lw {left expand fillx frame w} $ew {right frame e}
    pack append . $f {top fillx frame w pady 4}
    set bag($prefix$l) [format {[string trim [%s get]]} $lw]
    return $ew
}

proc multitextdeck {w blist h} {
    frame $w 
    menubutton $w.mb
    text $f.text \
	-yscrollcommand "$f.sb set" \
	-height $h -width 80 -relief sunken -padx 4 -insertwidth 1 \
	-insertofftime 400 -borderwidth 2
    foreach lbl $blist {
	set l _$lbl
    }
}

proc multitext {lbl h} {
    set l _$lbl
    set f [frame .${l}_fr]
    label $f.label -anchor w -text "[string trimleft $lbl >]: "
    text $f.text \
	-yscrollcommand "$f.sb set" \
	-height $h -width 80 -relief sunken -padx 4 -insertwidth 1 \
	-insertofftime 400 -borderwidth 2
    bind $f.text <Enter> "+focus $f.text"
    scrollbar $f.sb -command "$f.text yview" -relief sunken
    pack append $f \
	$f.label {top frame w} \
	$f.sb {left filly} \
	$f.text {right expand fill}
    pack append . \
	$f {top padx 32 pady 4 expand fill}

    return $f.text
}

proc set_text_traversal {tlist} {
    set ll [llength $tlist]
    if {$ll < 2} {
	return
    }
    for {set x 1} {$x<$ll} {incr x} {
	set w [lindex $tlist $x]
	set prevw [lindex $tlist [expr $x-1]]
	bind $prevw <Control-n> "focus $w"
    }
    bind [lindex $tlist [expr $ll-1]] <Control-n> "focus [lindex $tlist 0]"
}

proc bagged_radiobar {fr n labeltext blist offLabel dstbag } {
    radiobar $fr $n $labeltext $blist $offLabel > $dstbag
}

# make one in a list a radiobutton bar
proc radiobar {fr n labeltext blist offLabel {varprefix ""} {aname ""} } {
    if {"$aname" != ""} {
	set vname [set aname]($varprefix$labeltext)
    } else {
	set vname $varprefix$labeltext
    }
    global $vname
    set $vname ""
    label $fr.labels.$n -text "${labeltext}: "
    pack append $fr.labels $fr.labels.$n {top pady 4 frame w}
    frame $fr.bars.$n
    foreach b $blist {
	radiobutton $fr.bars.$n._$b \
		-text $b -relief flat -variable $vname
	# Buttons that say None should set variable to the empty
	# string...
	if {"$b" == "$offLabel"} {
	    $fr.bars.$n._$b configure -value ""
	} else {
	    $fr.bars.$n._$b configure -value $b
	}
	pack append $fr.bars.$n $fr.bars.$n._$b {left padx 4}
    }
    pack append $fr.bars $fr.bars.$n {top expand fillx pady 4}
}

# make one in a list a radiobutton bar
proc checkbar {fr n labeltext blist offLabel} {
    upvar #0 gbag ${labeltext}
    label $fr.labels.$n -text "${labeltext}: "
    pack append $fr.labels $fr.labels.$n {top pady 4 frame w}
    frame $fr.bars.$n
    foreach b $blist {
	checkbutton $fr.bars.$n._$b \
		-offvalue "" \
		-text $b -relief flat \
		-variable [format "%s(%s)" ${labeltext} ${b}]
	# Buttons that say None should set variable to the empty
	# string...
	if {"$b" == "$offLabel"} {
	    $fr.bars.$n._$b configure -onvalue "_ALL_" -offvalue ""
	} else {
	    $fr.bars.$n._$b configure -onvalue $b -offvalue ""
	}
	set gbag($b) ""
	pack append $fr.bars.$n $fr.bars.$n._$b {left padx 4}
    }
    # set active [lindex $blist 0]
    # $fr.bars.$n.$active select
    pack append $fr.bars $fr.bars.$n {top expand fillx pady 4}
}

#
# convert some numeric fields in a 'query-pr --sql'
# record named 'f' in the caller to mnemonic strings
#
proc convertsqlflds {f} {
    upvar 1 $f flds
    foreach a [array names flds] {
	set n $flds($a)
	case $a Severity {
	    case $n 1 { } 2 { } 3 { }
	} Priority {
	    case $n 1 { } 2 { } 3 { }
	}
    }
}

#
# split a pr stream into a tcl array named v
#
# A special array index called _prefix_ contains  all the text prior to
# to the first gnats field
#
proc parsepr {fin varname} {
    upvar 1 $varname fields
    set gnats_tag_exp {^(>[^:]+):(.*)}
    set mail_tag_exp {^([A-Z][^:]+):[ 	]+(.*)}
    set no_gnats_tags_yet 1
    set fields(_prefix_) ""
    set fldtags {_prefix_}

    set leftoverln ""
    while {1} {

	if {"$leftoverln" == ""} {
	    set x [gets $fin ln]
	    if {$x < 0} {
		break
	    }
	} else {
	    set ln $leftoverln
	    set leftoverln ""
	}

	set tag ""
	set val ""

	regexp $gnats_tag_exp $ln matched tag val
	if {"$tag" != ""} {
	    set no_gnats_tags_yet 0
	    # a gnats tag
	    # gnats tags can bu multiline so now
	    # get all the lines 'till the next gnats tag
	    lappend fldtags $tag
	    set fields($tag) "$val\n"
	    while {[gets $fin ln]>=0} {
		set tag2 ""
		regexp $gnats_tag_exp $ln matched tag2 val
		if {"$tag2" != ""} {
		    #  a new gnats tag so we have hit the end of the 
		    # current one.. leave the line we just read in
		    # leftoverln and continue on in the loop
		    set leftoverln $ln
		    break;
		}
		append fields($tag) "$ln\n"
	    }
	    continue
	}
	if {$no_gnats_tags_yet} {
	    append fields(_prefix_) "$ln\n"
	}

	# If we get here the current line is not part of a gnats tag
	# value pair
	set tag ""
	set val ""
	# Here is where we split out regular mail headers if needed.
	regexp $mail_tag_exp $ln matched tag val
	if {"$tag" != ""} {
	    lappend fldtags $tag
	    set fields($tag) "$val\n"
	}
    }

    #
    # Do a little post processing before on the fields we leave
    #
    # For the Reply-To: field make sure the (descriptive name) part of
    #	logname (descriptive name)
    # for the email adress is stripped out
    #
    if {![info exists fields(Reply-To)]} {
	set fields(Reply-To) $fields(From)
    }
    set fields(Reply-To) [lindex [string trim $fields(Reply-To) " \n\t"] 0]
    return $fldtags
}

# prompt the user for a string
proc promptDialog {msg} {
    global Helper
    if {[catch { set r [exec entryDialog $msg] } ]} {
	Msg "entry cancelled"
	return ""
    }
    return $r
}

proc write_listbox {lbname fname} {
    set fout [open $fname w]
    set sz [$lbname size]
    for {set x 0} {$x < $sz} {incr x 1} {
	puts $fout [$lbname get $x]
    }
    close $fout
}
proc foreach_listbox {lbname procname} {
    set sz [$lbname size]
    for {set x 0} {$x < $sz} {incr x 1} {
	if {[$procname [$lbname get $x]] != 0} {
	    return
	}
    }
}
