#!/depot/path/wish -f

# Name: tkbiff
#
# Description: Execute an arbitrary action when mail is received.
#
# To use: Simply run tkbiff.  It will create a sample .tkbiff file which
# you can edit to customize tkbiff further.  The sample file demonstrates
# how to provide a slick GUI with sounds for different users.
#
# Author: Don Libes, NIST, created February 1, 1995
set tkbiff_version 1.6b ;# last updated September 17, 1996
#
# Note: The code in tkbiff itself may look a little non-intuitive in
# places.  This was an intentional tradeoff against three things:
#
# 1) I wanted the section of the code that provides the GUI to be as
# simple and intuitive as possible since that is all that most people
# will ever look at.
#
# 2) I wanted this to be more portable than the C-based biffs.
#
# 3) I wanted this to be fast enough that people wouldn't feel that it
# needed to be rewritten in C.

##################
# defaults that can be overridden via a configuration file
##################

set sleep		10
set rcfile		.tkbiff

proc announce_new_msgs {} {
    global new_list msg

    foreach id $new_list {
	puts "you have new mail from $msg($id,from)"
    }
}

proc renounce_msgs {ids} {}

# Mail addresses can be pretty long what with text, <>, and other stuff.
# This routine selects a short hunk of the address this is the best looking
# of all of the junk.  Good for icons and other places with limited space.
proc short_from {from} {
	if ![regexp (.)(.*) $from dummy c list] return

	set list [split $list ""]

	#
	# separate into quoted, unquoted, <>'d and parened pieces
	# Code assumes delimiters are balanced, but I think mail enforces
	# this so we're safe.
	#

	while 1 {
		if {$c == "<"} {
			set i [lsearch $list ">"]
			set angle [join [lrange $list 0 [expr $i-1]] ""]
			set list [lrange $list [expr $i+2] end]
		} elseif {$c == "\""} {
			set i [lsearch $list "\""]
			set quote [join [lrange $list 0 [expr $i-1]] ""]
			set list [lrange $list [expr $i+2] end]
		} elseif {$c == "("} {
			set i [lsearch $list ")"]
			set paren [join [lrange $list 0 [expr $i-1]] ""]
			set list [lrange $list [expr $i+2] end]
		} else {
			append raw $c
		}
		if {[llength $list] == 0} break
		set c [lindex $list 0]
		set list [lrange $list 1 end]
	}

	if [info exists paren] {
		return [string range $paren 0 15]
	}
	if [info exists quote] {
		return [string range $quote 0 15]
	}
	if [info exists raw] {
		return [string range $raw 0 15]
	}
	string range $angle 0 15
}

# do "busy" whenever we are about to start something time-consuming
proc busy {} {}

# do "idle" whenever we are idle
proc idle {} {}

# print out a usage message
proc usage {} {
    puts {usage: tkbiff [-cf configfile] [-mbox file] [-user username]}
}

###################
# end of defaults
###################

###################
# public variables
#
### Read-write variables
#
# mbox		     name of mail box or folder
# rcfile	     name of configuration file
# sleep		     # of seconds to sleep before each check
#
### Read-only variables
#
# tkbiff_version     version string of tkbiff
# all_ids	     array of all message-ids in use
# all_list           list of all message-ids in use
# new_list           list of the new message-ids read this cycle
# recently_seen_ids  array of m-ids recently seen but not currently in use
#
# msg($id,type) where type is one of {
#   from
#   sender
#   to
#   cc
#   subject
#   replyto
#   date
#   body
# }
#
###################

catch {set mbox $env(MAIL)}

while {[llength $argv]} {
    set flag [lindex $argv 0]
    switch -- $flag \
	    "-cf" {
	set rcfile [lindex $argv 1]
	set argv [lrange $argv 2 end]
    } "-mbox" {
	set mbox [lindex $argv 1]
	set argv [lrange $argv 2 end]
    } "-user" {
	set whoami [lindex $argv 1]
	set argv [lrange $argv 2 end]
    } default {
	usage
	exit 1
    }
}

if ![file exists $rcfile] {
    if [info exists env(DOTDIR)] {
	set rcfile $env(DOTDIR)/$rcfile
    } else {
	set rcfile $env(HOME)/$rcfile
    }
}

if ![info exists mbox] {
    if [info exists whoami] {
    } elseif {![catch {set whoami $env(USER)}]} {
    } elseif {![catch {set whoami $env(LOGNAME)}]} {
    } else {
	puts "who are you?
	exit 1
    }

    if {[file isdirectory [set dir /usr/var/mail]]} {
    } elseif {[file isdirectory [set dir /var/spool/mail]]} {
    } elseif {[file isdirectory [set dir /usr/spool/mail]]} {
    } elseif {[file isdirectory [set dir /var/mail]]} {
    } elseif {[file isdirectory [set dir /usr/mail]]} {
    } else {
	puts "where is your mail file?"
	exit 1
    }

    set mbox $dir/$whoami
}

proc _read_rcfile {} {
    global rcfile

    if ![file exists $rcfile] {
	if {[catch {set new [open $rcfile w]}]} {
	    puts "unable to create $rcfile"
	    puts "msg"
	    exit
	}
	puts "Creating $rcfile file for you.  Customize as you like."
	puts "Press ? in tkbiff window for more information."
	set proto [open [info script] r]
	while {-1 != [gets $proto buf]} {
	    if [regexp "^tkwait" $buf] break
	}
	puts -nonewline $new [read $proto]
	close $proto
	close $new
    }

    if [file readable $rcfile] {
	uplevel #0 source $rcfile
    }
}

proc _read_new_msg {f vars} {
	upvar $vars v

	;# force optional things to be set
	set v(Resent-From:) ""
	set v(Sender:) ""
	set v(Cc:) ""
	set v(Subject:) ""
	set v(Reply-To:) ""
	set v(Date:) ""
	set v(body) ""
	set v(Status:) NEW

	# The following loop extracts headers.  It is the hotspot in the
	# code so this is the place where I've given up some clarity and
	# simplicity for speed (and obscurity).  Actually, this runs just
	# fine on reasonable size mailboxes.  But some people actually leave
	# thousands of mail messages in their incoming mail spool file!
	#
	# Each header line is parsed into a head and tail (if possible).
	# - Notice that the head may be empty.  If it is, then the line is a
	# continuation of the previous header and it just needs appending.
	# - If the head is not empty, then it is used as the element name in
	# an array.  It is also saved just in case continuation lines arrive
	# later.
	# - If the line cannot be parsed into a head and tail, then we have
	# reached the end of the header section and we go on to pick up the
	# message body.

	while {-1 != [gets $f buf]} {
		if {[regexp "(\[^ \t]*)\[ \t]+(.*)" $buf dummy head tail] == 0} break
		if {$head != ""} {
			set [set var v($head)] $tail
		} else {
			append $var " " $tail
		}
	}

	if [info exists v(Content-Length:)] {
		set v(body) [read $f $v(Content-Length:)]
	}

	# consume body (if any remaining) and 1st line of next msg's header
	while {-1 != [gets $f buf]} {
		if [regexp "^From " $buf dummy] break
		append v(body) $buf\n
	}

	# trim whitespace from front and newlines from rear
	# equivalent to:
	# set v(body) [string trimright $v(body) "\n\t "]
	# set v(body) [string trimleft $v(body) "\n"]	
	#
	# The following (rather interesting) regexp does this in about 40%
	# of the time as the two commands above.
	regexp "^\n*(.*\[^\n\t ])?" $v(body) junk v(body)
}

# File times are inconsistent (sometimes even going backwards) because of
# buggy mail software or fs skew, so generate and maintain an artificial
# but reliable count by which we can track whether messages are old or new
set _cycle 0

# return 1 if new messages, 0 otherwise
proc _read_all_msgs {} {
    global mbox new_list msg all_ids _cycle all_list

    set new_list {}
    set all_list {}
    incr _cycle

    if [catch {set f [open $mbox]}] return

    while 1 {
	_read_new_msg $f tmpmsg

	if [catch {set id $tmpmsg(Message-Id:)}] {
	    # skip corrupt msgs (missing id)
	    if [eof $f] break
	    continue
	}

	if ![info exist all_ids($id)] {
	    lappend new_list $id
	    set msg($id,from)		$tmpmsg(From:)
	    set msg($id,resentfrom)	$tmpmsg(Resent-From:)
	    set msg($id,sender)		$tmpmsg(Sender:)
	    set msg($id,cc)		$tmpmsg(Cc:)
	    set msg($id,subject)	$tmpmsg(Subject:)
	    set msg($id,replyto)	$tmpmsg(Reply-To:)
	    set msg($id,date)		$tmpmsg(Date:)
	    set msg($id,body)		$tmpmsg(body)
	    set msg($id,status)		$tmpmsg(Status:)
	    set msg($id,from,short)	[short_from $tmpmsg(From:)]
	    if [catch {set msg($id,to) $tmpmsg(To:)}] {
		if [catch {set msg($id,to) $tmpmsg(Apparently-To:)}] {
		    set msg($id,to) ""
		}
	    }
	}

	# Ignore multiple messages exist with same message-id.
	# Caused by broken MUAs, typically from forwarding mail
	# and reusing the old message id.
	if ![info exists new_ids($id)] {
	    set new_ids($id) $_cycle
	    set all_ids($id) $_cycle
	    lappend all_list $id
	}

	if [eof $f] break
    }
    close $f
}

proc _discard_old_msgs {} {
    global msg _cycle all_ids recently_seen_ids sleep

    # forget about "recent but no longer used" ids that have aged enough
    set recently [expr $_cycle - 3]
    foreach id [array names recently_seen_ids] {
	if {$recently_seen_ids($id) < $recently} {
	    unset recently_seen_ids($id)
	}
    }

    set dead_ids {}
    foreach id [array names all_ids] {
	if {$all_ids($id) != $_cycle} {
	    lappend dead_ids $id
	    # briefly remember old ids - they may show up again shortly if
	    # the MUA or MTA is temporarily truncating the file before
	    # rewriting it
	    set recently_seen_ids($id) $all_ids($id)
	}
    }

    renounce_msgs $dead_ids

    # It's possible to do this much more efficiently in Tcl 7.4 but since
    # this isn't a CPU bottleneck, I'm just going to leave it this way.
    foreach id $dead_ids {
	unset all_ids($id)
	unset msg($id,from)
	unset msg($id,resentfrom)
	unset msg($id,sender)
	unset msg($id,to)
	unset msg($id,cc)
	unset msg($id,subject)
	unset msg($id,replyto)
	unset msg($id,date)
	unset msg($id,body)
	unset msg($id,from,short)
	unset msg($id,status)
    }
}

# start off mtime with a time that can't possibly match
# so that we are forced to check the mail file
set _mtime -1
# from now on, 0 will mean "no file"

set _mboxsize 0		;# size of mailbox

set all_ids(x) x           ;unset all_ids(x)
set recently_seen_ids(x) x ;unset recently_seen_ids(x)

proc _mail_file_changed {} {
    global _mtime mbox _mboxsize suppress_nfs_caching

    # mailboxes should not be stored on partitions with NFS-caching enabled
    # but provide a workaround for people who are temporarily misconfigured
    if ![info exists suppress_nfs_caching] {
	catch {
	    # This effectively flushes the NFS cache containing the mbox stats.
	    set tmpfile $mbox.$$
	    close [open $tmpfile w]
	    exec /bin/rm -f $tmpfile
	}
    }

    if [catch {file mtime $mbox} newtime] {
	# mail file does not exist
	set _mboxsize 0
	if {$_mtime} {
	    # but did exist before
	    set _mtime 0
	    return 1
	} else {
	    # and did not exist before either
	    return 0
	}
    } else {
	# mail exists

	set newsize [file size $mbox]
	if {$newtime == $_mtime} {
	    # Some MUAs (e.g., elm) don't update the date after
	    # modifying the mbox (yes, really!) so check the size
	    # as well.  The fear that we might miss new mail if
	    # the size is exactly the same is unfounded since all
	    # MTAs *do* update the date.

	    if {$_mboxsize == $newsize} {
		return 0
	    }
	}
	set _mtime $newtime
	set _mboxsize $newsize
	return 1
    }
}

proc check_for_new_mail {} {
    _read_rcfile

    if ![_mail_file_changed] return

    busy
    _read_all_msgs
    _discard_old_msgs
    announce_new_msgs
    idle
}

# This code can run under either tcl or tk, except that the form of
# sleeping is different between the two.  So handle both forms here.

if [info exists tk_version] {
    proc _tkmain {} {
	global sleep

	check_for_new_mail
	if [catch {
	    after [expr $sleep*1000] _tkmain
	}] exit
    }
    _tkmain
} else {
    while 1 {
	check_for_new_mail
	exec /bin/sleep $sleep
    }
}

# This is the end of the tkbiff program.  Below here is a prototype
# .tkbiff file.  If a user does not have one, the remainder of this file
# is used as a prototype and installed.

tkwait variable forever;  DO NOT CHANGE THIS LINE
# .tkbiff file for customizing Don Libes' tkbiff
#
# You may not need to, but feel free to change ANYTHING in this file.
# The GUI is entirely in this configuration file, thus you can change
# any part of the GUI.  Indeed, that's the nice thing about tkbiff.
# The GUI is configurable in every way.
#
# Note: the default look-and-feel are set to what I like.  To get more
# information on the defaults, just run tkbiff and press ? in the window
# that pops up.  It is self-explanatory.
#######################################################################

#######################################################################
# Action to execute upon receipt of new mail.
proc announce_new_msg {id} {
	global msg

	puts "you have new mail from $msg($id,from)"

	# For convenience, extract msg attributes, lowercase to simplify tests,
	# and put pieces into simple variables for easy access.

	set from	[string tolower $msg($id,from)]
	set to		[string tolower $msg($id,to)]
	set cc		[string tolower $msg($id,cc)]
	set subject	[string tolower $msg($id,subject)]
	# Other fields that can be examined are: sender, replyto, and body.

	# Now the tests are simple.  The long "if" may look dumb, but
	# there's little point in making it table-driven.  By leaving
	# the tests explicit, we get the flexibility to do much more
	# creative or complex decision making.
	# Plus it's very easy to read!

	if {[string match "*expect*" $subject]} {
		play "Yeah"
	} elseif {[string match "*ora.com*" $from]} {
		play Sledge-Flute
	} elseif {[string match "*mailer-daemon*" $from]} {
		play bogus
	} elseif {[string match "*bark*" $from]} {
		play bark
	} elseif {[string match "*bodarky*" $from]} {
		play doh
	} elseif {[string match "*bloom*" $from]} {
		play BT-Royal-Ugly-Dudes
	} elseif {[string match "*clark*" $from]} {
		play Back-Off-Man
	} elseif {[string match "*debtron*" $from]} {
		play AL-Lets-Rock
	} elseif {[string match "*densock*" $from]} {
		play bringout
	} elseif {[string match "*fowler*" $from]} {
		play hes-dead-jim
	} elseif {[string match "*shoffman*" $from]} {
		play chirp
	} elseif {[string match "*ken manheimer*" $from]} {
		play Aludium-Q36
	} elseif {[string match "*don libes*" $from]} {
		play What-would-you-do-with-a-brain
	} elseif {[string match "*luce*" $from]} {
		play PB-Swords
	} elseif {[string match "*mulroney*" $from]} {
		play stupid-for-nothing
	} elseif {[string match "*kc*" $from]} {
		play clint_eastwood
	} elseif {[string match "*paisley*" $from]} {
		play Look-Up-in-the-Sky
	} elseif {[string match "*potts*" $from]} {
		play space-madness
	} elseif {[string match "*steve ray*" $from]} {
		play STTNG-redalert
	} elseif {[string match "*ressler*" $from]} {
		play crash
	} elseif {[string match "*sauder*" $from]} {
		play justwhat
	} elseif {[string match "*selden*" $from]} {
		play Darth-Dont-be-too-proud
	} elseif {[string match "*susan libes*" $from]} {
		play Be-nice
	} elseif {[string match "*sol libes*" $from]} {
		play Where-humor
	} elseif {[string match "*express-users*" $to$cc]} {
		play horse-poop
	} else {
		play TNG-beep2
	}
}

# prepare messages for display and announcement
# currently just used to suppress messages from display and announcement
proc prep_new_msg {id} {
	global msg

	set from	[string tolower $msg($id,from)]
	set to		[string tolower $msg($id,to)]
	set subject	[string tolower $msg($id,subject)]

	# I want to be alerted about anything personally addressed to me.  
	if [string match "*libes*" $to] return

	if {[string match *library* $from]} {
		# Skip all messages from our library server (except
		# my own).
		suppress_msg $id
	} elseif {[string match "*mailer-daemon*" $from]} {
		# As postmaster, I see all bounced headers.
		# Suppress them except for my own.
		suppress_msg $id
	} elseif {[string match "*majordomo*" $from]} {
		# Skip complaints from majordomo.
		suppress_msg $id
	} elseif {[string match "*postmaster*" $from] &&
	          [string match "*postmaster*" $to]} {
		# Shouldn't normally be needed except that I'm getting
		# deluged by these from epfl.ch.
		suppress_msg $id
	} elseif {[string match "*seds report*" $subject]} {
		suppress_msg $id
	}
}

######################################################################
# initializations that should only be done once - when program is started
######################################################################
proc init {} {
    uplevel #0 {

	# Sleep this many seconds before checking again.  Leave this short
	# for good response.  Don't worry about it taking a lot of time -
	# the checking is inexpensive.
	set sleep 		4

	# parameters for main window which displays sender-subject pairs
	set width		50	;# after this, truncate
	set maxheight		5	;# after this, add a scrollbar
	set main_font		5x8
	set main_font_alt	*-Courier-Bold-R-Normal-*-120-*

	# parameters for body windows
	set body_font		*-Courier-Medium-R-Normal-*-120-*
	set body_height_max	40	;# after this, add a scrollbar
	set body_width		80	;# after this, wrap

	# parameters for help window
	set help_font	*-Helvetica-Bold-R-Normal--*-120-*

	# if you don't want message body windows to go away when you hide
	# them in the main window, set to 0.
	set destroy_body_when_hiding	1

	# if you don't want message body windows to go away when the mail
	# is no longer in your spool file, set to 0.
	set destroy_body_when_gone	1

	# scroll new message into main window automatically
	# (assuming you aren't looking elsewhere).
	set autoscroll		1

	# raise main window when new mail arrives
	set autoraise		1
	# deiconify main window when new mail arrives
	set autodeiconify	1

	# if you don't want to display certain messages, change any of
	# the following values to 0.
	set showing(unread) 0	;# for people who write back to the spool file
	set showing(read)   0	;# for people who write back to the spool file
	set showing(new)    1

	# define directories to search for sounds.  This can also
	# be overridden at run time with the SOUNDPATH environment variable.
	set sounddirs "~/sounds /depot/sundry/lib/sounds"
	catch {set sounddirs [split $env(SOUNDPATH) ": "]}

	set do_sounds 1		;# set to 0 to suppress sounds

	# my machine at home has no sound, sigh
	if {[string first "isdn055" $env(DISPLAY)]!=-1} {
		set do_sounds 0
	}

	# Define local and remote sound programs.  Remote version is used if
	# tkbiff runs on one host (i.e., where mail spool file is) but
	# displays on another.
	catch {
		set default_volume 50		;# range is 0-100 for play or
						;#          0-128 for rplay.
		set localplaycmd [which play]	;# rplay works, too.
		set remoteplaycmd $localplaycmd
	}
	# Guess likely paths for sound players.
	# Either hardcode the path or use "which" to verify existence of player
	# because we need the full path anyway for remoteplaycmd because rsh
	# has such a primitive path.
	#
	# If your audio player is called something else, either hardcode it
	# in the play procedure elsewhere in this script - or make a shell
	# script called "play" which calls your real audio player.  The script
	# should accept a -v flag which takes a numeric arg for the volume.
	# See default_volume (above).

	# I like bisque (a peach-like color).  Comment this out and
	# you will get Motif-standard gray.
	# Or just choose your own colors.
	if {[winfo depth .] > 1} {
		tk_bisque
	}

	# If you like seeing cute 3D borders around everything, set the
	# following to a non-zero value.  2 looks fine to me, but I simply
	# don't want to waste the space.  (Actually, I like borders around
	# scrollbars - so that is forced later despite this setting.)
	set borders 0

	# And if you like space *around* the borders as well (bleah!!!),
	# set the following to a non-zero value.
	option add *highlightThickness 0

	# initialize widgets and other things that are probably
	# not of interest to most people
	_init			

	#############################################################
	# define keystroke and mouse button actions
	#############################################################

        #         destroy widget if it exists----------\
        #         show headers-----------------------\  |
        #                                             V V
	bind .main <1>			{show_body %y 0 1}
	bind .main <2>			{show_body %y 0 0}
	bind .main <Shift-1>		{show_body %y 1 1}
	bind .main <Shift-2>		{show_body %y 1 0}

	bind .main <ButtonRelease-2>	{catch {destroy $w}}
	bind .main <3>			{hide_msg  %y}

	bind all <Return>		{check_for_new_mail}

	bind all <u>			{toggle_status unread}
	bind all <r>	 		{toggle_status read}
	bind all <n>			{toggle_status new}

	bind all <f>			{alt_font %K}

	bind all <h>			{help}
	bind all <question>		{help}

	bind all <s>			{toggle_sound}
	bind all <a>			{toggle_autoscroll}
	bind all <t>			{toggle_autoraise}
	bind all <i>			{toggle_autodeiconify}

	# support "more"-like scrolling
	bind all <space> 		{scroll %W 1}
	bind all <Delete> 		{scroll %W -1}
	bind all <BackSpace> 		{scroll %W -1}
    }
}

# procedure to play an audio clip
#    arg 1: sound name
#    arg 2: volume level (optional)
proc play {args} {
	global do_sounds sounddirs default_volume
	global speaker_location speakerhost remoteplaycmd localplaycmd

	if {!$do_sounds} return

	set sound [lindex $args 0]
	if {[llength $args] > 1} {
		set volume [lindex $args 1]
	} else {
		set volume $default_volume
	}

	if {[string first / $sound] == -1} {
		# if no slash in name, look for it in the sound directories
		foreach dir $sounddirs {
			if [file readable $dir/$sound.au] {
				set sound $dir/$sound.au
				break
			} elseif [file readable $dir/$sound] {
				set sound $dir/$sound
				break
			}
		}
	}

	# expand in case it starts with a tilde
	catch {set sound [glob $sound]}

	# if not found, try and play it anyway - perhaps a sound server
	# is being used.

	# if running remotely (i.e., on host where mail spool file lives)
	# play through local speaker (i.e.. on speakerhost).  Assumption made
	# here about finding sound files in same place on both machines, but
	# that will be valid for most people.  If not, you'll have to write
	# more sophisticated code.

	# This test could be moved to init but is left here for readability.
	if {[info exists speakerhost]} {
		set play "rsh -n $speakerhost $remoteplaycmd"
	} else {
		set play $localplaycmd
	}

	if [catch "exec $play -v $volume $sound" msg] {
		puts "couldn't play $sound using $play"
		puts "$msg"
	}
}

########################################################################
#
#  Most people will not be interested in changing things below here.
#
########################################################################

proc _init {} {
    uplevel #0 {
	set gui_version 1.6i; # last updated October 8, 1996

	wm minsize . 1 1
	wm maxsize . 999 999
	wm iconname . tkbiff
	wm title . "tkbiff - Press ? for help"

	option add *elementBorderWidth 2
	option add *borderWidth $borders
	option add *relief sunken

	if !$borders {
		# force borders around scrollbars
		option add *Scrollbar.borderWidth 2
	}

	set position 10

	set expected_height 1
	listbox .main -width $width -height 1		

	.main config -font $main_font -yscroll ".sb set" -setgrid 1 \
			-selectborderwidth 1
	scrollbar .sb -command ".main yview"

	set scrollbar_visible 0
	pack .main -expand yes -fill both -side right

	update
	# actual height of window
	set height 0			

	bind .main <Configure> {
		# record new width
		scan [wm geometry .] "%%dx%%d" width height
		#puts "Configure event: height = $height"

		set old_maxheight $maxheight
		if {$height != $expected_height} {
			set maxheight $height
			#puts "setting new maxheight $height"
		}

		if {$maxheight != $old_maxheight} update_help_text
		update_display
	}

	# skip Tk 4.0b4 defaults, omit class bindings
	bindtags .main {.main . all}

	# focus .
	bind .main <FocusIn>		{focus .}

	# generate pretty things for help window
	if {-1 == [string first / $rcfile]} {
		set display_rcfile ~/$rcfile
	} else {
		set display_rcfile $rcfile
	}
	if [info exists whoami] {
		set display_whoami $whoami
	} else {
		set display_whoami "not used"
	}

	# is speaker on separate system from mail spool?
	regexp "(.*):" [winfo screen .] dummy speakerhost
	if {[catch {exec /bin/hostname} hostname]} {
	} elseif {[catch {exec /usr/ucb/hostname} hostname]} {
	} elseif {[catch {exec hostname}]} {
	} else {
	    puts "where is your hostname command?"
	}
	if {[lindex [split $speakerhost .] 0] == $hostname
	 || $speakerhost == $hostname
	 || $speakerhost == "unix"
	 || $speakerhost == ""} {
		# same system
		unset speakerhost

		if ![info exists localplaycmd] {
			if $do_sounds {
				puts "tkbiff: could not locate sound player"
				puts "tkbiff: disabling sound generation"
				set do_sounds 0
			}
		}
	} else {
		# different system
		if ![info exists remoteplaycmd] {
			if $do_sounds {
				puts "tkbiff: could not locate sound player on $speakerhost"
				puts "tkbiff: disabling sound generation"
				set do_sounds 0
			}
			;# just in case do_sounds is later reenabled
			unset speakerhost
		}
	}
    }
}

proc hide_msg {y} {
	global msg show_list destroy_body_when_hiding

	if {![info exists show_list]} {
		wm iconify .
		return
	}

	# translate from y position to message id
	set id [lindex $show_list [.main nearest $y]]

	if {$destroy_body_when_hiding} {
		set w [id_to_widget $id]
		catch {destroy $w}
	}

	set msg($id,status) HIDE
	update_display
}

proc suppress_msg {id} {
	global msg
	set msg($id,status) HIDE
}

proc toggle_status {type} {
	global showing

	set showing($type) [expr !$showing($type)]
	update_help_text
	update_display
}

proc toggle_sound {} {
	global do_sounds

	set do_sounds [expr !$do_sounds]
	update_help_text
}

proc toggle_autoscroll {} {
	global autoscroll

	set autoscroll [expr !$autoscroll]
	update_help_text
}

proc toggle_autoraise {} {
	global autoraise

	set autoraise [expr !$autoraise]
	update_help_text
}

proc toggle_autodeiconify {} {
	global autodeiconify

	set autodeiconify [expr !$autodeiconify]
	update_help_text
}

proc normal_font {keysym} {
	global main_font

	.main configure -font $main_font
	bind all $keysym {alt_font %K}
}

proc alt_font {keysym} {
	global main_font_alt

	.main configure -font $main_font_alt
	bind all $keysym {normal_font %K}
}

proc position_window {w} {
	global position

	# some people have interactive placement which really loses
	# so force placement somewhere
	set position [expr ($position+20)%300]
	wm geometry $w +$position+$position
}

# translate an id to a widget name
proc id_to_widget {id} {
	# strip punctuation from id so it is usable as a widget name
	regsub -all {[][<>.@ :$-]} $id "" w
	# Tk does not permit uppercase widget names
	return .[string tolower $w]
}

# Compute physical number of lines required to display a string.
# String must NOT include terminating newline. 
proc count_lines {s} {
	global body_width body_height_max

	set lines 0
	# long lines will wrap, so compute physical lines required.
	# no handling is made for special characters (in particular, control
	# chars can consume up to 4 chars and tabs can consume up to 8)
	# however the likelihood of them actually causing problems is low
	# enough that its not worth worrying about.  And even in the worst
	# case, the user can scroll the window up using the pan bindings.
	# Can't fit more than 75 lines on any screen, so don't bother counting
	# lines after that.
	set max_lines 75
	foreach line [split $s \n] {
		# treat empty lines as if they had one char to simplify
		# subsequent linecount computation
		if 0==[set chars [string length $line]] {
			set chars 1
		}
		incr lines [expr 1+($chars-1)/$body_width]
		
		if {$lines > $max_lines} break
	}
	return $lines

	# Below here is an old version, no longer used.  It's dead-on
	# but too slow and I'm willing to give up some accuracy.

	# if long enough, don't even bother being accurate
	if {[string length $s]>$body_width*$body_height_max} {
		return $body_height_max
	}

	set row 1
	set col 0

	foreach char [split $s ""] {
		scan $char %c c
		if {$c >= 040 && $c <= 0176} {
			incr col
		} elseif {$c == 012} {
			set col 0
			incr row
			continue
		} elseif {$c == 011} {
			incr col [expr 8 - $col%8]
		} elseif {$c >= 07 && $c <= 015} {
			incr col 2
		} else {
			incr col 4
		}
		if {$col > $body_width} {
			incr row
			set col [expr $col-$body_width]
		}
		if {$row > $body_height_max} break
	}
	return $row
}

# when messages go away, delete all the gui-related bookkeeping
proc destroy_guimsg {id} {
	# if message was suppressed, this will fail immediately - that's normal
	catch {
		unset guimsg($id,headers)
		unset guimsg($id,headers,lines)
		unset guimsg($id,subject)
		unset guimsg($id,subject,lines)
		unset guimsg($id,body,lines)
		unset guimsg($id,min,lines)
		unset guimsg([id_to_widget $id],id)
	}
}

# Create preformatted message for display purposes.
# This is done once per message so that the act of popping it up is quick.
# The bottleneck here is computing the number of lines in the message.
# The original size that comes with the message is logical lines, but we need
# physical lines, specific to the width of the text widget.  When lines wrap,
# logical lines can take multiple physical lines.  So this procedure also
# computes how many lines will be required.  We want to show that many lines
# if we have the space to do so.
proc create_guimsg {id} {
	global msg guimsg

	if {[string match $msg($id,status) HIDE]} return

	set w [id_to_widget $id]

	if [string compare "" $msg($id,resentfrom)] {
	    append headers "Resent-From: $msg($id,resentfrom)\n"
	}
	if [string compare "" $msg($id,to)] {
	    append headers "To: $msg($id,to)\n"
	}
	if [string compare "" $msg($id,cc)] {
	    append headers "Cc: $msg($id,cc)\n"
	}
	if [string compare "" $msg($id,date)] {
	    append headers "Date: $msg($id,date)\n"
	}
	set guimsg($id,headers) [string trim $headers \n]
	set guimsg($id,headers,lines) [count_lines $guimsg($id,headers)]
	if {$guimsg($id,headers,lines)} {
		append guimsg($id,headers) "\n"
	}

	set guimsg($id,subject) "Subject: $msg($id,subject)"
	set guimsg($id,subject,lines) [count_lines $guimsg($id,subject)]
	set guimsg($id,body,lines) [count_lines $msg($id,body)]
}

proc show_body {y show_headers destroy_if_exists} {
	global bodies w msg guimsg body_width body_height_max
	global body_font show_list

	if {![info exists show_list]} return

	# translate from y position to message id
	set id [lindex $show_list [.main nearest $y]]

	set w [id_to_widget $id]

	if [winfo exists $w] {
		if $destroy_if_exists {
			destroy $w
		} else {
			raise $w
		}
		return
	}

	toplevel $w
	position_window $w
	wm title $w "From: $msg($id,from)"
	wm iconname $w $msg($id,from,short)

	set lines [expr $guimsg($id,body,lines) + $guimsg($id,subject,lines)]

	set body {}
	if $show_headers {
		append body $guimsg($id,headers)
		incr lines $guimsg($id,headers,lines)
	}

	# number of lines in header+message is at least this and may be more
	set guimsg($id,min,lines) $lines
	# remember id so that we can get it from events using only widget name
	set guimsg($w,id) $id

	append body "$guimsg($id,subject)\n$msg($id,body)"

	if {$lines > $body_height_max} {
		set winheight $body_height_max
	} else {
		set winheight $lines
	}

	# Constrain width because we don't handle varying widths.
	wm minsize $w $body_width 1
	wm maxsize $w $body_width 999
	text $w.text -width $body_width -height $winheight -font $body_font \
		-setgrid 1

	scrollbar $w.sb -command "$w.text yview"
	if {[winfo depth .] > 1} {
		$w.sb config -activebackground #ffaeb9
	}
	$w.text config -yscroll "$w.sb set"

	# scrollbar would normally be packed during configure event
	# but it looks so funny (seeing the window move over) that we
	# pack it here initially
	if {$winheight < $lines} {
		pack $w.sb -expand yes -fill y -side left
	}

	pack $w.text -fill both -expand yes -side right

	$w.text insert end $body
	$w.text configure -state disabled	;# avoid giving focus
	bind $w <Destroy> {catch {destroy %W}}

	# puts "message rows >= [msg_line_count $msg($id,body)]"

	# Do raise last to avoid early flush.
	# Do update before raise, otherwise raise causes brief display
	# of a vanilla top-level.  Have no idea why this is.
	# (Wasn't necessary with Tk7.4.  Needed only by 7.5.)
	# Alas, the update means that a 2nd show_body can be triggered
	# at this time, destroying the window so that when we come back
	# it is gone.  Thus, we must check the raise.  Sigh.
	update
	if [catch {raise $w}] return

	bind $w.text <Configure> {
		set w [file rootname %W]

		# record new width
		scan [wm geometry $w] "%%dx%%d" winwidth winheight

		set id $guimsg($w,id)

		# if new height is big enough, add scrollbar if not already
		# if new height is small enough, remove sb if not already

		if {$guimsg($id,min,lines) > $winheight} {
			if ![winfo ismapped $w.sb] {
				pack $w.sb -expand yes -fill y -side left
			}
		} else {
			if [winfo ismapped $w.sb] {
				pack unpack $w.sb
			}
		}
	}
}

proc update_display {} {
	global msg all_list maxheight scrollbar_visible width autoscroll
	global height expected_height showing show_list

	# remember how window is scrolled
	set goaltop [.main nearest 0]		;# first visible line

	set bottom_was_showing [expr [.main size] - $goaltop <= $height]

	.main delete 0 end
	set show_count 0		;# number of showable messages
					;# after any filtering
	catch {unset show_list}

	foreach id $all_list {
		if {$msg($id,status) == "O"   && $showing(unread) ||
		    $msg($id,status) == "RO"  && $showing(read) ||
		    $msg($id,status) == "NEW" && $showing(new)} {
			incr show_count
			lappend show_list $id
			.main insert end [format "%-16s %s" \
				$msg($id,from,short) $msg($id,subject)]
		}
	}

	if {$show_count > 0} {
		if {$show_count <= $maxheight} {
			set height $show_count
		} else {
			set height $maxheight
		}

		.main configure -width $width -height $height
		# wm geometry . ${width}x$height
		wm geometry . ""
		set expected_height $height
	} else {
		.main insert end "no mail"
		.main configure -width $width -height 1
		# wm geometry . ${width}x1
		wm geometry . ""
		set expected_height 1
	}

	if {$show_count > $maxheight} {
		if !$scrollbar_visible {
			pack .sb -expand yes -fill y
			set scrollbar_visible 1
		}
	} else {
		if $scrollbar_visible {
			pack forget .sb
			set scrollbar_visible 0
		}
	}

	if {$autoscroll && $bottom_was_showing} {
		.main yview [expr $show_count - $height]
	} else {
		.main yview $goaltop
	}

	update
}

proc announce_new_msgs {} {
	global new_list msg first_time autoraise autodeiconify
	global recently_seen_ids

	if ![info exists first_time] {
		set first_time 1
		init
	}

	foreach id $new_list {
		prep_new_msg $id
		create_guimsg $id
	}

	update_display

	# at startup, do not announce messages already waiting
	if $first_time {
		set first_time 0
		return
	}

	set first_announce 1

	foreach id $new_list {
		if {[string match $msg($id,status) HIDE]} continue

		# if message was last seen just a short time ago
		# mailer probably temporarily rewrote file so don't
		# reannounce
		if {[info exists recently_seen_ids($id)]} continue

		# raise/deiconify before audios.  Since audios are slow
		# relatively-speaking, this lets the updated main window
		# be visible immediately.

		if {$first_announce} {
			set first_announce 0
			if {$autoraise} {raise .}
			if {$autodeiconify} {wm deiconify .}
			update
		}

		announce_new_msg $id
	}
}

proc renounce_msg {id} {
	global destroy_body_when_gone

	if {$destroy_body_when_gone} {
		set w [id_to_widget $id]
		catch {destroy $w}
	}

	destroy_guimsg $id
}

proc renounce_msgs {ids} {
	foreach id $ids {
		renounce_msg $id
	}
}

proc scroll {w dir} {
	# use catch to ignore calls to objects without scrollbars
	catch {tkScrollByPages $w.sb v $dir}
}

proc which {prog} {
	global env

	foreach dir [split $env(PATH) :] {
		if [file executable $dir/$prog] {
			return $dir/$prog
		}
	}
	error "$prog: not found"
}

proc busy {} {
	# change to busy cursor
	catch {
		.main config -cursor watch
		update
	}
}

proc idle {} {
	# restore to idle cursor
	.main config -cursor ""
	update
}

proc display_or_suppress {s} {
	global showing

	regexp "." $s key
	return "'$key' toggles display of $s messages (currently being\
		 [expr $showing($s)?"displayed":"suppressed"])"
}

proc help {} {
	global help_font

	if [winfo exists .help] {
		destroy .help
		return
	}

	toplevel .help
	wm title .help "tkbiff help"
	wm iconname .help "tkbiff help"

	catch {wm resizable .help 0 0}

	position_window .help

	message .help.text -relief flat -font $help_font
	update_help_text

	button .help.ok -text "ok" -command {destroy .help} -bd 5 -relief raised
	pack .help.text
	pack .help.ok -fill x -padx 2 -pady 2
}

proc update_help_text {} {
	global maxheight showing do_sounds autoscroll autoraise autodeiconify
	global mbox display_rcfile display_whoami sleep speakerhost
	global tkbiff_version gui_version

	# catch if help is not displayed
	catch {
		.help.text configure -text \
"tkbiff - by Don Libes, NIST, 2/1/95 - Version $tkbiff_version - GUI Version $gui_version.

tkbiff is yet another program to report new mail. \
Its claim to fame is a high degree of configurability. \
You can configure it to display messages, show pictures, play sounds,\
or order pizza.  Everything associated with the user interface can be changed\
- colors, key bindings, this message, everything! \
The configuration is usually stored in ~/.tkbiff. \
The remainder of this message describes the default configuration.

The default configuration is intended to allow very fast message\
browsing while taking very little screen real estate.

Fast browsing is provided by the following bindings:
Mouse button 1 pops up a message until button 1 is pressed again (or button 2 is released).
Mouse button 2 pops up a message until button 2 is released.
Mouse button 3 deletes a message from the display (or iconifies the window if no messages are shown).
By default, To:, Cc:, Resent-From:, and Date: are not displayed. \
Display these by holding down <Shift> while popping up the message.

'f' toggles between fonts. \
To conserve screen space, a small font is used initially.

Additional space is saved by using a scrollbar if enough messages\
arrive (currently $maxheight).  Change this by resizing the window -\
the new size\
will be used as the new limit. \
If autoscrolling is on and the last message header is already visible,\
the display will automatically scroll so that new messages become visible.
'a' toggles autoscroll (currently [expr $autoscroll?"on":"off"]).

'i' toggles autodeiconify (currently [expr $autodeiconify?"on":"off"]). \
If autodeiconify is on when new mail arrives, the main window is deiconified.
't' toggles autoraise (currently [expr $autoraise?"on":"off"]). \
If autoraise is on when new mail arrives, the main window is raised.

Some mail clients use the \"Status:\" line in mail messages.  The\
following bindings make use of that:
'u' toggles display of unread messages (currently being\
		[expr $showing(unread)?"displayed":"suppressed"]).
'r' toggles display of read messages (currently being\
		[expr $showing(read)?"displayed":"suppressed"]).
'n' toggles display of new messages (currently being\
		[expr $showing(new)?"displayed":"suppressed"]).

Sounds are nice when you're not looking at the screen but not\
so nice when you're having a meeting in your office.
's' toggles sound generation (currently [
  expr $do_sounds?"on, sound directed to [
    expr {[info exists speakerhost]?"remote host $speakerhost":"local host"}
  ]":"off"
]).

<Return> rereads your configuration file and checks for new mail - \
useful for testing new configurations rapidly.

'?' or 'h' toggles display of this help window. \
The status of any non-obvious toggles can be viewed in this help window. \
The toggles or any other parameters may be changed permanently by editing\
the configuration file.

Command-line options include the usual X and Tk things such as -display and\
-geometry. \
Also supported are -cf, -mbox, and -user to explicitly identify\
a different configuration file (currently $display_rcfile),\
mail file (currently $mbox),\
or user name (currently $display_whoami)."
	}
}
