#!/usr/bin/wish
# -*-tcl-*-
# This grossness allows wish to be anywhere in PATH: \
exec wishx -f "$0" ${1+"$@"}

#
# Bugs: 
#   Any spool name with a non [a-z] first character or containing a '.' 
#     will break things badly.
#


option add *update     60000         startupFile
option add *retryDelay  5000         startupFile
option add *spoolPattern $env(USER)  startupFile
option add *spoolDir /var/spool/mail startupFile
option add *list         $env(USER)  startupFile
option add *spools*anchor      w     startupFile
option add *spools*borderWidth 0     startupFile
option add *spools.borderWidth 2     startupFile
option add *wmGeometry         +0+0  startupFile
option add *showEmpty          true  startupFile
option add *summaryCmd            frm   startupFile
option add *bind1              refresh_now startupFile
option add *bind2              "" startupFile
option add *bind3              {make_summary_frame [spoolname %W]}  startupFile

# Tkspools*bind2: exec gnudoit -q "(vm-visit-folder \"[spoolname %W]\")"
#
# I have this in my .Xresources file.  It's useful enough to tell
# everyone about, but not common enough to make the default.


# list of spools which, when changed, set off the bell
set beep             [option get . beep Beep]

# time between checks in miliseconds
set update_time      [option get . update Update]

# time a check is postponed (in miliseconds) if a lockfile is found
set retry_time       [option get . retryDelay RetryDelay]

# directory in which to look for spool files
set spooldir         [option get . spoolDir SpoolDir]

# glob pattern which matches your spool files in spoolDir
set spoolpattern     [option get . spoolPattern SpoolPattern]

# list of spools to list messages from
set listsummary         [option get . list List]

# list empty spools
set showempty [regexp "^true|yes|1$" [option get . showEmpty ShowEmpty]]

# Command to run that yields one line per message of specified file
set summarycmd          [option get . summaryCmd SummaryCmd]

# Lame fake geometry option
wm geometry . [option get . wmGeometry WmGeometry]


proc make_bindings {widget} {
    bind $widget <ButtonRelease-1> [option get $widget bind1 Bind1]
    bind $widget <ButtonRelease-2> [option get $widget bind2 Bind2]
    bind $widget <ButtonRelease-3> [option get $widget bind3 Bind3]

    # We don't really want more resources for all the modifiers, do we?
    # This command is only for flushing the cache in case of timing errors
    bind $widget <Shift-ButtonRelease-1> refresh_all
}

proc refresh_spool_data {} {
    global spooldir spoolpattern sizes lastchanges beep showempty \
            summarytext summarycmd changedspools nonemptyspools
    set nonemptyspools ""
    set beep_now 0
    set changedspools ""
    if {[catch {glob $spoolpattern} files]} {
        set files ""
    } else {
        set files [lsort $files]
    }
    foreach name $files {
        if {[string match "*.lock" $name]} continue
        regexp {([0-9]+) ([A-Z][a-z][a-z] +[0-9]+ +[0-9:]+)} \
                [exec ls -l $name] \
                matchvar size lastchange
        if {$size > 0 || $showempty} {
            lappend nonemptyspools $name
        }

        if {[catch {string compare $lastchange $lastchanges($name)} \
                has_changed] || $has_changed} {
            lappend changedspools $name
            # Get rid of possible err msg
            set has_changed 1
        }
        set lastchanges($name) $lastchange

        if {$size > 0} {
            if {$has_changed} {
                set summarytext($name) [exec $summarycmd $name]
                set sizes($name) [llength [split $summarytext($name) "\n"]]
                if {[lsearch -exact $beep $name] > -1} {
                    set beep_now 1
                }
            }
        } { 
            set sizes($name) 0
            set summarytext($name) ""
        }
    }
    if $beep_now bell
    return $nonemptyspools
}

proc refresh_summary {} {
    global sizes listsummary shownsummary summarytext spools
    set was_showing [llength $shownsummary]
    foreach name $shownsummary {
        destroy .summary.$name
    }
    set shownsummary ""
    foreach name $listsummary {
        if {([lsearch -exact $spools $name] > -1) && $sizes($name)} {
            lappend shownsummary $name
            label .summary.$name -textvariable summarytext($name) -anchor w -justify left
            pack .summary.$name -in .summary -fill x 
            make_bindings .summary.$name
        }
    }
    # This block is a hack
    if {$was_showing && ![llength $shownsummary]} {
        # The .summary frame doesn't shrink down when nothing is in it.
        # As a workaround, stick in a small label, then destroy it.
        label .summary.not_a_real_spool -width 1
        pack .summary.not_a_real_spool -in .summary
        update
        destroy .summary.not_a_real_spool
    }
}

proc refresh_spools {} {
    global sizes spools nonemptyspools

    foreach name $spools {
        destroy .spools.$name
    }
    set spools $nonemptyspools
    foreach name $spools {
        label .spools.$name -text [format "%3d %s" $sizes($name) $name]
        pack .spools.$name -in .spools -fill both
        make_bindings .spools.$name
    }    
}

proc spoolname {spoolwidget} {
    if {![regexp {([^\.]+)$} $spoolwidget matchvar name]} {
        error "Failed to extract spool name from widget: $spoolwidget"
    }
    return $name
}

proc make_summary_frame {name} {
    global summarytext
    toplevel .summary_$name -class Tkspools
    wm iconname .summary_$name "Summary: $name"
    wm title    .summary_$name "Summary: $name"

    # This crap is just so we can specify resources more naturally.
    frame .summary_$name.frame
    pack .summary_$name.frame -in .summary_$name

    label .summary_$name.frame.$name -textvariable summarytext($name) -justify left
    pack .summary_$name.frame.$name -in .summary_$name.frame
    bind .summary_$name.frame.$name <ButtonPress> {destroy [winfo toplevel %W]}
    
}

label .summary -relief raised
frame .spools -relief raised
if {$listsummary != ""} {
    pack .summary -side top -fill both
}
pack .spools -side top -fill both

make_bindings .summary
make_bindings .spools

# Only works in extended Tcl
#signal trap SIGHUP refresh_now 

proc refresh_now {} {
    after cancel refresh
    refresh
}

proc refresh_all {} {
    global lastchanges spoolpattern
    foreach name [lsort [glob $spoolpattern]] {
        set lastchanges($name) 0
    }
    refresh_now
}

proc refresh {} {
    global update_time retry_time changedspools
    if {![catch {glob "*.lock"}]} {
        after $retry_time refresh
        return
    }
    after $update_time refresh
    refresh_spool_data
    if {[llength $changedspools]} {
        refresh_spools
        refresh_summary
        update
    }
}

cd $spooldir
set spools ""
set shownsummary ""
wm resizable . false false
refresh