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