1# history.tcl --
2#
3#       Provides a history mechanism for entry widgets
4#
5# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
6#
7# See the file "license.terms" for information on usage and redistribution
8# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9#
10# RCS: @(#) $Id: history.tcl,v 1.4 2005/08/25 03:36:58 andreas_kupries Exp $
11
12package require Tk
13package provide history 0.1
14
15namespace eval history {
16    bind History <Up>   {::history::up %W}
17    bind History <Down> {::history::down %W}
18}
19
20proc ::history::init {w {len 30}} {
21    variable history
22    variable prefs
23    set bt [bindtags $w]
24    if {[lsearch $bt History] > -1} { error "$w already has a history" }
25    if {[set i [lsearch $bt $w]] < 0} { error "cant find $w in bindtags" }
26    bindtags $w [linsert $bt [expr {$i + 1}] History]
27    array set history [list $w,list {} $w,cur -1]
28    set prefs(maxlen,$w) $len
29    return $w
30}
31
32proc ::history::remove {w} {
33    variable history
34    variable prefs
35    set bt [bindtags $w]
36    if {[set i [lsearch $bt History]] < 0} { error "$w has no history" }
37    bindtags $w [lreplace $bt $i $i]
38    unset prefs(maxlen,$w) history($w,list) history($w,cur)
39}
40
41proc ::history::add {w line} {
42    variable history
43    variable prefs
44    if {$history($w,cur) > -1 && [lindex $history($w,list) $history($w,cur)] == $line} {
45        set history($w,list) [lreplace $history($w,list) $history($w,cur) $history($w,cur)]
46    }
47    set history($w,list) [linsert $history($w,list) 0 $line]
48    set history($w,list) [lrange $history($w,list) 0 $prefs(maxlen,$w)]
49    set history($w,cur) -1
50}
51
52proc ::history::up {w} {
53    variable history
54    if {[lindex $history($w,list) [expr {$history($w,cur) + 1}]] != ""} {
55        if {$history($w,cur) == -1} {
56            set history($w,tmp) [$w get]
57        }
58        $w delete 0 end
59        incr history($w,cur)
60        $w insert end [lindex $history($w,list) $history($w,cur)]
61    } else {
62        alert $w
63    }
64}
65
66proc ::history::down {w} {
67    variable history
68    if {$history($w,cur) != -1} {
69        $w delete 0 end
70        if {$history($w,cur) == 0} {
71            $w insert end $history($w,tmp)
72            set history($w,cur) -1
73        } else {
74            incr history($w,cur) -1
75            $w insert end [lindex $history($w,list) $history($w,cur)]
76        }
77    } else {
78        alert $w
79    }
80}
81
82proc ::history::get {w} {
83    variable history
84    return $history($w,list)
85}
86
87proc ::history::clear {w} {
88    variable history
89    set history($w,cur) -1
90    set history($w,list) {}
91    unset -nocomplain history($w,tmp)
92}
93
94proc ::history::configure {w option {value {}}} {
95    variable history
96    variable prefs
97    switch -exact -- $option {
98        length {
99            if {$value == ""} { return $prefs(maxlen,$w) }
100            if {![string is integer -strict $value]} { error "length must be an integer" }
101            set prefs(maxlen,$w) $value
102        }
103        alert {
104            if {$value == ""} { return [info body ::history::alert] }
105            proc ::history::alert w $value
106        }
107        default {
108            error "unknown option $option"
109        }
110    }
111}
112
113proc ::history::alert {w} {bell}
114