TCL/TK Basics And Examples
This is REALLY only
the very basics!
For a much more
complete documentation see: The Tcler's Wiki.
A detailed command description is in The
TCL Commands Manual
The usual disclaimer applies: Don't blame me, if you, your data, or your PC get hurt!
Latest Update: 30th May 2015.
Contents
General:
TCL adheres to structured programming concepts, similar to Pascal.
It is a very unforgiving rigid format
language. Spaces are often mandatory when in other languages like Basic or PL/I they were
completely optional. Error messages are often cryptic and imprecise.
You have been warned!
Variables:
Their names can contain alphabetic and numeric characters
as well as the undersquore _
They are implicitly
defined by their first use. There is a difference
between variable_name and variable_value. When referring to
the value of a variable the variable_name must be preceded
by a $ sign.
There are numeric and string variables, arrays and associative arrays (where the index is an arbitrary string), all defined implicitly.
Examples:
Integer literals: 1
or 123 Real literals: 1.234 or 0.456
Character literal:
"This String"
Variable: x14
Array element: y12(6)
Associative array
element: popul(Sydney)
A special type of
variable is a list. It is defined as
follows (example):
set rgbcolours {red
green blue}
Special 1 byte characters:
These can be used as
strings:
\n New Line
\r Carriage return
\f Form feed
\t Tab
\" Doublequote
\[ Opening square bracket
\] Closing square bracket
\$ Dollar sign
\xhh Hexadecimal byte contents denoted by hh
Arithmetic Operators:
The usual suspects: + - * /
Boolean Operators:
Not: !
Greater: > Less:
<
Equal: == Unequal: !=
Character Operations:
You can use the append
command to concatinate
strings:
Example:
append line $xval
";Y" $yval ";K" "\""
You can use the string
command to manipulate strings:
Examples:
Length of a character variable:
set lefina [string length $filenam]
Or set fnefil to the substring of filenam starting at the first character (which is zero) and ending at the END of the character number in variable beforavi:
set fnefil [string range $filenam 0 $beforavi]
For a myriad other string operations the string function can be used. It is described in
The TCL Commands Manual
Statements:
Separated by semicolon or line-feed. Can be nested with the [ ] brackets.
Assignment:
set variablename value
Examples:
set line "C;X"
set xval 1
Arithmetics:
incr variablename increment_value
Examples:
incr xval 1
incr yval 10
Arithmetic Expressions:
Must be evaluated by the function-like statement expr...
Example:
set num [expr (25 * 2) - $xval]
Control Structures:
Note: There must be always
at least ONE space between any closing } and a following {
while {condition} {
statement1
....
statement n
}
for {initialisation}
{end-test}
{loop-increment} {
statement1
....
statement
n
}
Example:
for {set k 1} {$k
<= 8} {incr k 1} {
puts [expr ($k * $k)]
}
if {condition}
{
statement1
....
statement
n
}
if {condition}
{
statement1
....
statement
n
} else {
statement
1
....
statemente
n
}
if {condition}
{
....
} elseif {condition}
{
....
} elseif {condition}
{
....
} ......... {condition}
{
} else {
....
}
switch string
{
pattern1
{
...statements...
}
pattern2
{
...statements...
}
pattern3
{
........
}
default
{
...statements...
}
}
I/O Statements:
Output to screen: puts
variable_value
Example: puts
$outrec2
Input from keyboard:
gets stdin variablename
Example: gets
stdin linfil
Open file:
set file_reference_variable
[open file_name_value
r|w]
r is for read and w for write.
Example: set
fout [open $dofil w]
End_Of_File
Condition:
eof file_reference_variable_value
Example of use: while { ![eof $finp]} {
statements
}
Close file:
close file_reference_variable_value
Example: close $fout
Read binary:
set variable [read
file_reference_variable_value
number_of-bytes_to_be_read]
Example: set baite [read $finp 1]
Read record:
gets file_reference_variable_value
variable
Example: gets $fint linrec
Write binary:
puts -nonewline file_reference_variable_value
variable_value
Example:
puts -nonewline $fout $baite
Write record terminated with a
line_feed:
puts file_reference_variable_value
variable_value
puts $fout $outrec
Some Examples
TCL script "cvvideos"
to convert .avi files in a directory to .qt ones:
#!/usr/bin/tclsh
# Converts all avi files in the current directory to .qt
puts "Enter directory name"
gets stdin dirnam
cd $dirnam
set tempnam "temp.txt"
exec ls -1 > $tempnam
# Writes 1 name per line
set infil [open $tempnam r]
while { ![eof $infil]} {
gets $infil filenam
set lefina [string length $filenam]
if { $lefina > 4 } {
set starpo [expr ($lefina -4)]
# should be position of the . if filename is *.avi
set schwanz [string range $filenam $starpo [expr ($lefina - 1)]]
if { $schwanz == ".avi" } {
puts "Now processing ";puts $filenam
set nefil [string range $filenam 0 [expr ($lefina - 4)]]
append nefil "qt"
exec mencoder $filenam -ovc lavc -oac copy -o $nefil > /dev/null 2> /dev/null
exec rm -f $filenam
}
}
}
close $infil
exec rm -f $tempnam
exit
TCL script "ideskicon"
to create desktop entries for idesk:
THIS SCRIPT HAS BEEN SUPERSEDED BY A
SERIES OF BASH SCRIPTS - SEE HERE
#!/usr/bin/tclsh
cd ~/.idesktop
set filex 1
while { $filex == 1 } {
puts "Creating new IDESK item"
puts "Name in directory, suffix .lnk will be appended :"
gets stdin nenam
append nenam ".lnk"
if { [file exists $nenam] } {
puts "This file DOES ALREADY EXIST. Try again."
} else {
set filex 0
}
}
set fout [open "##$$" w]
set texten "table Icon"
puts $fout $texten
puts "Enter Caption (displayed on desktop):"
gets stdin caname
set texten " Caption: "
append texten $caname
puts $fout $texten
puts "Enter Caption-Tip (further explanation):"
gets stdin catip
set texten " ToolTip.Caption: "
append texten $catip
puts $fout $texten
set filex 0
while { $filex == 0 } {
puts "Enter Icon-filename (fully qualified):"
gets stdin icofi
if { [file exists $icofi] } {
set filex 1
} else {
puts "This file does NOT exist. Try again."
}
}
set texten " Icon: "
append texten $icofi
puts $fout $texten
puts "Width of icon in pixels (32):"
gets stdin wpic
set interim [string length $wpic]
if { $interim == 0 } {
set wpic "32"
}
set texten " Width: "
append texten $wpic
puts $fout $texten
puts "Heigth of icon in pixels (32):"
gets stdin hpic
set interim [string length $hpic]
if { $interim == 0 } {
set hpic "32"
}
set texten " Heigth: "
append texten $hpic
puts $fout $texten
puts "Initial X-location of icon (500):"
gets stdin xloc
set interim [string length $xloc]
if { $interim == 0 } {
set xloc "500"
}
set texten " X: "
append texten $xloc
puts $fout $texten
puts "Initial Y-location of icon (500):"
gets stdin yloc
set interim [string length $yloc]
if { $interim == 0 } {
set yloc "500"
}
set texten " Y: "
append texten $yloc
puts $fout $texten
puts "Command to execute as primary:"
gets stdin comma
set texten " Command\[0\]: "
append texten $comma
puts $fout $texten
set texten " Command\[1\]: "
append texten "xedit
~/.idesktop/##$$
"
puts $fout $texten
puts $fout "end"
close $fout
set infil "\#\#\$\$"
set oufil "\#\#\#\$\$"
exec whoami > $oufil
set eing [open $infil r]
set ausg [open $oufil w]
while {![eof $eing]} {
gets $eing adirec
set teco [string first "\#\#\$\$" $adirec]
if {$teco !=-1} {
set adirec [string range $adirec 0 31]
append adirec $nenam
}
puts $ausg $adirec
}
close $eing
close $ausg
exec rm -f \#\#\$\$
exec mv \#\#\#\$\$ $nenam
puts "Your chance to edit the entries follows. Save the file after any
change"
exec nedit $nenam
exit
TCL script "scrotate"
to
rotate screen resolution:
#!/usr/bin/tclsh
set stfil scrstat
set finp [open $stfil r]
set baite [read $finp 1]
incr baite 1
if { $baite == "5" } {
set baite "0"
}
close $finp
set foup [open $stfil w]
puts $foup $baite
close $foup
exec xrandr -s $baite
exit
Note: This
requires a file in your home directory named scrstat, that contains a 1
byte numeric value (between 0 and 5). Execution of the script will
circle
the screen resolution - and this numeric value - between 0 and 5
(numbers taken from xrandr -q)
TCL
script "xfapsel" to simulate "Open with" and "Execute" for the file windows of xfm:
#!/usr/bin/tclsh
puts "Enter program name to open file with:"
gets stdin proname
set pwd [ exec pwd ]
append pwd "/" $argv
if { $proname == "x" } {
exec xterm -e $pwd
exit
}
exec $proname $pwd
exit
TCL script "doslin" to strip files of CRs (from DOS/Windows):
#!/usr/bin/tclsh
puts "DOS file to LINUX conversion. Enter DOS-filename:"
gets stdin dofil
puts "LINUX filename:"
gets stdin linfil
exec whoami > $linfil
set finp [open $dofil r]
set fout [open $linfil w]
while { ![eof $finp]} {
set baite [read $finp 1]
if { $baite != "\r" } { puts -nonewline $fout $baite }
}
close $finp
close $fout
puts "All converted"
exit
TCL script
"fifix" to replace unprintable characters from a text file by "?":
#!/usr/bin/tclsh
puts "Fix unprintable chars in file. Enter Input-filename:"
gets stdin impfil
set oufil $impfil
append oufil "f"
exec touch $oufil
set fout [open $oufil w]
set finp [open $impfil r]
while { ![eof $finp]} {
set baite [read $finp 1]
if { $baite == "\n" } {
puts -nonewline $fout $baite
} elseif { $baite < "\x7e" } {
if { $baite > "\x1f" } {
puts -nonewline $fout $baite
}
} else {
puts -nonewline $fout "?"
}
}
close $finp
close $fout
puts "Unprintables removed"
exit
TCL script "strca" to
strip records containing a certain string from a text file:
#!/usr/bin/tclsh
if { $argc != 3 } {
puts "Usage: strca infil outfil call"
exit }
set infil [ lindex $argv 0 ]
set oufil [ lindex $argv 1 ]
set calls [ lindex $argv 2 ]
exec whoami > $oufil
set eing [open $infil r]
set ausg [open $oufil w]
while {![eof $eing]} {
gets $eing adirec
set teco [string first $calls $adirec]
puts $teco
if {$teco !=-1} {
puts "ignored"
} else {
puts $ausg $adirec}
}
close $eing
close $ausg
puts "All Done!"
exit
TCL
script "renfd" to rename all *.jpg files in a directory to prefxxx.jpg where xxx runs from 1 to the number
of .jpg files in the directory:
#!/usr/bin/tclsh
set jay ".jpg"
puts "Change all *.jpg filenames in directory to prefxxx.jpg"
puts "Enter prefix"
gets stdin prfx
set suff 0
exec rm -f tmp##tmp
exec ls > tmp##tmp
set infil "tmp##tmp"
set finp [open $infil r]
while { ![eof $finp]} {
gets $finp fina
set teco [string first $jay $fina]
if {$teco !=-1} {
incr suff 1
set prfxw $prfx
if {$suff < 10} {
append prfxw
"00"
} else {
if {$suff < 100} {
append prfxw "0"
}
}
append prfxw $suff
append prfxw ".jpg"
exec mv $fina $prfxw
}
}
exec rm -f tmp##tmp
close $finp
exit 0
TCL script "csvslk" to convert .csv files to .slk format:
#!/usr/bin/tclsh
puts "Converts .csv files to .slk ones - enter .csv name (full):"
gets stdin csvfilputs "Enter .slk name (full):"
gets stdin slkfilexec whoami > $slkfil
set finp [open $csvfil r]
set fout [open $slkfil w]
set xval 1set yval 1
set head "ID;PSCALC3"
puts $fout $head
set line "C;X"
append line $xval ";Y" $yval ";K" "\""
while { ![eof $finp] } {
set baite [read $finp 1]
if { $baite == "\r" } { set baite [read $finp 1] }
if { $baite != "\n" } { if { $baite !="," } {
append line $baite
} else {
append line "\""
puts $fout $line
incr xval 1
puts $xval
set line "C;X"
append line $xval ";Y" $yval ";K" "\""
} } else {
append line "\""
puts $fout $line
incr yval 1
puts $yval
set xval 1
set line "C;X"
append line $xval ";Y" $yval ";K" "\""
}
}
if { $xval != 1 } { append line "\""
puts -newline $fout $line }
puts $fout "E"close $finp
close $fout
puts "All converted"
exit
Careful! This doesn't work 100% in all cases, but it is no
longer necessary
since kspread and gnumeric both can read .csv files.
TK Appointment
Calendar:
Note: This uses
an appointment text
file called appoint.txt with the
following
format (example). After displaying the missed, current, and next 10
coming up appointments, you are given the chance to edit this file. For the edit process I use "xedit".
Previously I had "nedit" as editor, which can lead to deadlock
situations when nedit sees that appoint.txt has been modified (by
mouse-over on the appointk window); xedit has no such problems.
You need not insert the appointments in ascending
date
sort order, since the file is sorted before evaluation. The date format
is YYYY-MM-DD:
9999999999 April 2008 (the 9s denote a comment - this record is ignored)
2008-04-17 Single line appointment_1 text in free format
2008-04-19 Single line appointment_2 text in free format
2008-04-30 ...
9999999999 May 2008
2008-05-13 ...
2008-05-22 Single line appointment_n text in free format
Now the program itself:
#!/usr/bin/wish -f
proc crewin { } {
cd
listbox .msgs -foreground red -background green -width 80 -height 18
label .inq -text "Would you like to edit the appointment file? (n)"
button .bye -text "No" -command exit
button .edit -text "Yes" -command "exec xedit appoint.txt &"
wriwin
return
}
proc refre { } {
destroy all
wriwin
return
}
# End crewin
proc wriwin { } {
exec sort -d --key=1,10 appoint.txt > wjtmp##
exec mv wjtmp## appoint.txt
set afi [open "appoint.txt" r]
set datstr [exec date -I]
set pstr ""
append pstr "Todays Date is: " $datstr
.msgs delete 0 end
.msgs insert end $pstr
.msgs itemconfigure end -foreground blue
set reco "1"
set apind "0"
set tod "0"
set mis "0"
set com 0
while {![eof $afi]} {
gets $afi reco
set apdat [string range $reco 0 9]
if {$apdat > $datstr} {
if {$apdat != "9999999999"} {
set mis "1"
if {$com == 0 } {
.msgs insert end " "
.msgs insert end "Next 10 appointments coming up:"
.msgs itemconfigure end -foreground blue
}
incr com 1
if {$com < 11 } {
set pstr $reco
.msgs insert end $pstr
}
}
}
if {$apdat < $datstr} {
if {$mis == "0"} {
.msgs insert end " "
.msgs insert end "Missed appointment(s):"
.msgs itemconfigure end -foreground blue
set mis "1"
}
set pstr $reco
.msgs insert end $pstr
set apind "1"
}
if {$apdat == $datstr} {
set mis "1"
if {$tod == "0"} {
.msgs insert end " "
.msgs insert end "Todays appointment(s):"
.msgs itemconfigure end -foreground blue
set tod "1"
}
set pstr $reco
.msgs insert end $pstr
set apind "1"
}
}
close $afi
pack .msgs .inq
pack .bye .edit -side right
return
}
# end wriwin
crewin
bind all <Control-c> {destroy .}
bind all <Return> {destroy .}
bind all <n> {destroy .}
bind all <N> {destroy .}
bind all <y> {exec xedit appoint.txt &;}
bind all <Y> {exec xedit appoint.txt &;}
bind all <Enter> {refre;}
TK based xedit from
xedit-0.3.9-1.i386.rpm converted to English and bug-fixed:
Note: This version runs on Mandriva, Mageia, OpenSuse and probaby on many others...
#!/bin/sh
# the next line restarts using wish \
exec `which wish` "$0" "$@"
# Xedit by xento figal based on josep acosta script
# Reversed to English by Waldis Jirgens
# Also fixed tkTextSetCursor bug in "Find".
# default global values
global .
set fileName " "
set saveTextMsg 0
set winTitle "Xedit"
set version "Version 0.3"
set wordWrap none
set printCommand lpr
set BGCOLOR "yellow"
set FGCOLOR "black"
set BASENAME [string range $argv0 [expr [string last "/" $argv0] + 1]
end]
set MODIFIED "Modified..."
# main window settings
eval destroy [winfo child .]
wm title . $winTitle
wm iconname . $winTitle
wm geometry . 80x25
wm minsize . 25 1
#create main menu
menu .filemenu -tearoff 0
# start by setting default font sizes
if [ expr [string compare $tcl_platform(platform) "unix"] ==0] {
set textFont -Adobe-Helvetica-*-R-Normal-*-14-*
set menuFont
-adobe-helvetica-bold-r-normal--12-*-75-75-*-*-*-*
} else {
set textFont -Adobe-Courier-*-R-Normal-*-14-*
#set menuFont
-adobe-helvetica-bold-r-normal--12-*-75-75-*-*-*-*
set menuFont [.filemenu cget -font]
}
.filemenu configure -font $menuFont
# create frames for widget layout
# this is for the text widget and the y scroll bar
frame .bottomTopMenu
pack .bottomTopMenu -side top -expand 1 -fill both
# where the text widget is packed
frame .bottomleftmenu
pack .bottomleftmenu -in .bottomTopMenu -side left -expand 1
-fill both
# where the y scrollbar is packed
frame .bottomrightmenu
pack .bottomrightmenu -in .bottomTopMenu -side right
-expand 0 -fill both
# this is for the x scroll bar at the bottom of the window
frame .bottombottommenu
pack .bottombottommenu -side bottom -expand 0 -fill both
#file menu
menu .filemenu.files -tearoff 0 -font $menuFont
.filemenu add cascade -label "File" -underline 0 -menu
.filemenu.files
.filemenu.files add command -label "New" -underline 0 -command
"filesetasnew"
.filemenu.files add command -label "Open" -underline 0 -command
"filetoopen" -accelerator Ctrl+o
.filemenu.files add command -label "Save" -underline 0 -command
"filetosave" -accelerator Ctrl+s
.filemenu.files add command -label "Save as" -underline 5 -command
"filesaveas"
.filemenu.files add separator
if {"$tcl_platform(platform)" == "unix"} {
.filemenu.files add command -label "Configure
Printer" -underline 8 -command "printseupselection"
.filemenu.files add command -label "Print"
-underline 0 -command "selectprint"
.filemenu.files add separator
}
.filemenu.files add command -label "Exit" -underline 1 -command
"exitapp"
#edit menu
menu .filemenu.edit -tearoff 0 -font $menuFont
.filemenu add cascade -label "Edit" -underline 0 -menu .filemenu.edit
.filemenu.edit add command -label "Undo" -underline 0 -command "
undo_menu_proc" -accelerator Ctrl+z
.filemenu.edit add command -label "Redo" -underline 0 -command
"redo_menu_proc" -accelerator Ctrl+y
.filemenu.edit add separator
.filemenu.edit add command -label "Cut" -underline 2 -command "cuttext"
-accelerator Ctrl+x
.filemenu.edit add command -label "Copy" -underline 0 -command
"copytext" -accelerator Ctrl+c
.filemenu.edit add command -label "Paste" -underline 0 -command
"pastetext" -accelerator Ctrl+v
.filemenu.edit add command -label "Delete" -underline 2 -command
"deletetext" -accelerator Del
.filemenu.edit add separator
.filemenu.edit add command -label "Select All" -underline 7 -command
".textarea tag add sel 1.0 end" -accelerator Ctrl+/
.filemenu.edit add command -label "Print Time" -underline 5 -command
"printtime"
.filemenu.edit add separator
.filemenu.edit add check -label "Word Wrap" -underline 5 -command
"wraptext"
#search menu
menu .filemenu.search -tearoff 0 -font $menuFont
.filemenu add cascade -label "Search" -underline 0 -menu
.filemenu.search
.filemenu.search add command -label "Find" -underline 0 -command
"findtext find" -accelerator Ctrl+f
.filemenu.search add command -label "Find Next" -underline 1 -command
"findnext find" -accelerator F3
.filemenu.search add command -label "Replace" -underline 0 -command
"findtext replace" -accelerator Ctrl+r
# help menu
menu .filemenu.help -tearoff 0 -font $menuFont
.filemenu add cascade -label "Help" -underline 0 -menu .filemenu.help
.filemenu.help add command -label "Help" -underline 0 -command "helpme"
.filemenu.help add command -label "About" -underline 0 -command
"aboutme"
# now make the menu visible
. configure -menu .filemenu
#create text area
text .textarea -relief sunken -bd 2 -xscrollcommand ".xscroll set" \
-yscrollcommand ".yscroll set" -wrap $wordWrap
-width 1 -height 1 \
-fg $FGCOLOR -bg $BGCOLOR
-font $textFont -setgrid 1
scrollbar .yscroll -command ".textarea yview"
scrollbar .xscroll -command ".textarea xview" -orient horizontal
pack .textarea -in .bottomleftmenu -side left -expand 1
-fill both
pack .yscroll -in .bottomrightmenu -side right -expand 1 -fill both
pack .xscroll -in .bottombottommenu -expand 1 -fill x
focus .textarea
# this proc just sets the title to what it is passed
proc settitle {WinTitleName} {
global winTitle fileName
wm title . "$winTitle - $WinTitleName"
set fileName $WinTitleName
}
# proc to open files or read a pipe
proc openoninit {thefile} {
if [string match " " $thefile] {
fconfigure stdin -blocking 0
set incoming [read stdin 1]
if [expr [string length
$incoming] == 0] {
fconfigure stdin -blocking 1
} else {
fconfigure stdin -blocking 1
.textarea insert end $incoming
while {![eof stdin]} {
.textarea
insert
end [read -nonewline stdin]
}
}
} else {
if [ file exists $thefile ] {
set
newnamefile [open $thefile r]
} else {
set
newnamefile [open $thefile a+]
}
while {![eof $newnamefile]} {
.textarea
insert end [read -nonewline $newnamefile ]
}
close $newnamefile
settitle $thefile
}
}
# parse command line arguments
if ($argc>0) {
for {set i 0} {$i <= $argc } {incr i} {
if [ file exists [lindex
$argv $i] ] {
set nameFileToOpen [lindex $argv
$i]
openoninit $nameFileToOpen
} else {
set
initvar
[lindex $argv $i]
case
$initvar
{
-fg
{
set
FGCOLOR
[lindex $argv [expr $i+1]]
.textarea configure -fg $FGCOLOR
incr
i
}
-bg
{
set
BGCOLOR
[lindex $argv [expr $i+1]]
.textarea configure -bg $BGCOLOR
incr
i
}
-p
{
set
nameFileToOpen
" "
openoninit $nameFileToOpen }
-f
{
set
nameFileToOpen
[lindex $argv [expr $i+1]]
eval exec
$BASENAME $nameFileToOpen -fg $FGCOLOR -bg $BGCOLOR &
incr
i
}
-nf
{
set
nameFileToOpen
[lindex $argv [expr $i+1]]
openoninit $nameFileToOpen
incr
i
}
}
}
}
}
# help menu
proc helpme {} {
tk_messageBox -title "Descripcion" -type ok -message
"Xedit is a simple text editor. \
It has search, replace and basic edit functions."
}
# about menu
proc aboutme {} {
global winTitle version
tk_messageBox -title "About" -type ok -message
"$winTitle $version\n by xento figal.\n\
xento@xento.tk"
}
# generic case switcher for message box
proc switchcase {yesfn nofn} {
global saveTextMsg
if [ expr [string compare $saveTextMsg 1] ==0 ] {
set answer [tk_messageBox -message "Save before
closing?" \
-title "New Confirm?" -type yesnocancel -icon
question]
case $answer {
yes { if {[eval $yesfn] ==
1} { $nofn } }
no
{$nofn
}
}
} else {
$nofn
}
}
# new file
proc filesetasnew {} {
switchcase filetosave setTextTitleAsNew
}
proc setTextTitleAsNew {} {
.textarea delete 0.0 end
global winTitle fileName
set fileName " "
wm title . $winTitle
outccount
}
# kill main window
proc killwin {} {
destroy .
}
# exit app
proc exitapp {} {
switchcase filetosave killwin
}
# bring up open win
proc showopenwin {} {
set types {
{"All files" *}
}
set file [tk_getOpenFile -filetypes $types -parent .]
if [string compare $file ""] {
setTextTitleAsNew
openoninit $file
outccount
}
}
#open an existing file
proc filetoopen {} {
switchcase filetosave showopenwin
}
# generic save function
proc writesave {nametosave} {
set FileNameToSave [open $nametosave w+]
puts -nonewline $FileNameToSave [.textarea get 0.0
end]
close $FileNameToSave
outccount
}
#save a file
proc filetosave {} {
global fileName
#check if file exists file
if [file exists $fileName] {
writesave $fileName
return 1
} else {
return [eval filesaveas]
}
}
#save a file as
proc filesaveas {} {
set types {
{"All files" *}
}
set myfile [tk_getSaveFile -filetypes $types -parent
. -initialfile Untitled]
if { [expr [string compare $myfile ""]] != 0} {
writesave $myfile
settitle $myfile
return 1
}
return 0
}
# proc to set child window position
proc setwingeom {wintoset} {
wm resizable $wintoset 0 0
set myx [expr (([winfo screenwidth .]/2) - ([winfo
reqwidth $wintoset]))]
set myy [expr (([winfo screenheight .]/2) - ([winfo
reqheight $wintoset]/2))]
wm geometry $wintoset +$myx+$myy
set topwin [ winfo parent $wintoset ]
if { [ winfo viewable [ winfo toplevel $topwin ] ] }
{
wm transient $wintoset
$topwin
}
}
# procedure to setup the printer
proc printseupselection {} {
global printCommand
set print .print
catch {destroy $print}
toplevel $print
wm title $print "Printer Configuration:"
setwingeom $print
frame $print.top
frame $print.bottom
label $print.top.label -text "Print Command: "
entry $print.top.print -textvariable printsetupnew
-width 40
$print.top.print delete 0 end
set printvar $printCommand
$print.top.print insert 0 $printvar
button $print.bottom.ok -text "OK" -command
"addtoprint $print"
button $print.bottom.cancel -text "cancel" -command
"destroy $print"
pack $print.top -side top -expand 0
pack $print.bottom -side bottom -expand 0
pack $print.top.label $print.top.print -in
$print.top -side left -fill x -fill y
pack $print.bottom.ok $print.bottom.cancel -in
$print.bottom -side left -fill x -fill y
bind $print <Return> "addtoprint $print"
bind $print <Escape> "destroy $print"
proc addtoprint {prnt} {
global printCommand
set printCommand
[$prnt.top.print get]
destroy $prnt
}
}
# procedure to print
proc selectprint {} {
set TempPrintFile [open /tmp/tkpadtmpfile w]
puts -nonewline $TempPrintFile [.textarea get 0.0
end]
close $TempPrintFile
global printCommand
set prncmd $printCommand
eval exec $prncmd /tmp/tkpadtmpfile
eval exec rm -f /tmp/tkpadtmpfile
}
#cut text procedure
proc deletetext {} {
set cuttexts [selection own]
if {$cuttexts != "" } {
$cuttexts delete sel.first
sel.last
selection clear
}
inccount
}
#cut text procedure
proc cuttext {} {
tk_textCut .textarea
inccount
}
#copy text procedure
proc copytext {} {
tk_textCopy .textarea
inccount
}
#paste text procedure
proc pastetext {} {
global tcl_platform
if {"$tcl_platform(platform)" == "unix"} {
catch {
.textarea delete sel.first
sel.last
}
}
tk_textPaste .textarea
inccount
}
proc FindIt {w} {
global SearchString SearchPos SearchDir findcase
.textarea tag configure sel -background green
if {$SearchString!=""} {
if {$findcase=="1"} {
set
caset "-exact"
} else {
set caset
"-nocase"
}
if {$SearchDir == "forwards"} {
set limit end
} else {
set limit 1.0
}
set SearchPos [ .textarea search
-count len $caset -$SearchDir $SearchString $SearchPos $limit]
set len [string length
$SearchString]
if {$SearchPos != ""} {
.textarea see $SearchPos
tk::TextSetCursor .textarea $SearchPos
.textarea tag
add sel $SearchPos "$SearchPos + $len char"
if {$SearchDir
== "forwards"} {
set SearchPos
"$SearchPos + $len char"
}
} else {
set SearchPos "0.0"
}
}
focus .textarea
}
proc ReplaceIt {} {
global SearchString SearchDir ReplaceString
SearchPos findcase
if {$SearchString != ""} {
if {$findcase=="1"} {
set caset "-exact"
} else {
set caset "-nocase"
}
if {$SearchDir == "forwards"} {
set limit end
} else {
set limit 1.0
}
set SearchPos [ .textarea search
-count len $caset -$SearchDir $SearchString $SearchPos $limit]
set len [string length
$SearchString]
if {$SearchPos != ""} {
.textarea see $SearchPos
.textarea delete $SearchPos
"$SearchPos+$len char"
.textarea insert $SearchPos $ReplaceString
if {$SearchDir == "forwards"} {
set SearchPos "$SearchPos+$len
char"
}
} else {
set SearchPos "0.0"
}
}
inccount
}
proc ReplaceAll {} {
global SearchPos SearchString
if {$SearchString != ""} {
ReplaceIt
while {$SearchPos!="0.0"} {
ReplaceIt
}
}
}
proc CancelFind {w} {
.textarea tag delete tg1
destroy $w
}
proc ResetFind {} {
global SearchPos
set SearchPos insert
}
# procedure to find text
proc findtext {typ} {
global SearchString SearchDir ReplaceString findcase
c find
set find .find
catch {destroy $find}
toplevel $find
wm title $find "Find"
setwingeom $find
ResetFind
frame $find.l
frame $find.l.f1
label $find.l.f1.label -text "Find:" -width 11
entry $find.l.f1.entry -textvariable
SearchString -width 30
pack $find.l.f1.label $find.l.f1.entry -side left
$find.l.f1.entry selection range 0 end
if {$typ=="replace"} {
frame $find.l.f2
label $find.l.f2.label2 -text
"Replace With:" -width 11
entry $find.l.f2.entry2
-textvariable ReplaceString -width 30
pack $find.l.f2.label2
$find.l.f2.entry2 -side left
pack $find.l.f1 $find.l.f2 -side
top
} else {
pack $find.l.f1
}
frame $find.f2
button $find.f2.button1 -text "Find Next" -command
"FindIt $find" -width 10 -height 1 -underline 5
button $find.f2.button2 -text "Cancel" -command
"CancelFind $find" -width 10 -underline 0
if {$typ=="replace"} {
button $find.f2.button3 -text
"Replace" -command ReplaceIt -width 10 -height 1 -underline 0
button $find.f2.button4 -text
"Replace all" -command ReplaceAll -width 10 -height 1 -underline
8
pack $find.f2.button3
$find.f2.button4 $find.f2.button2 -pady 4
} else {
pack $find.f2.button1
$find.f2.button2 -pady 4
}
frame $find.l.f4
frame $find.l.f4.f3 -borderwidth 2 -relief groove
radiobutton $find.l.f4.f3.up -text "Backward"
-underline 0 -variable SearchDir -value "backwards"
radiobutton $find.l.f4.f3.down -text "Forward"
-underline 0 -variable SearchDir -value "forwards"
$find.l.f4.f3.down invoke
pack $find.l.f4.f3.up $find.l.f4.f3.down -side left
checkbutton $find.l.f4.cbox1 -text "Find Case_s"
-variable findcase -underline 0
pack $find.l.f4.cbox1 $find.l.f4.f3 -side left -padx
10
pack $find.l.f4 -pady 11
pack $find.l $find.f2 -side left -padx 1
bind $find <Escape> "destroy $find"
# each widget must be bound to th eevents of
the other widgets
proc bindevnt {widgetnm types find} {
if {$types=="replace"} {
bind $widgetnm <Return>
"ReplaceIt"
bind $widgetnm <Control-r>
"ReplaceIt"
bind $widgetnm <Control-a>
"ReplaceAll"
} else {
bind $widgetnm <Return>
"FindIt $find"
bind $widgetnm <Control-n>
"FindIt $find"
}
bind $widgetnm <Control-m> { $find.l.f4.cbox1
invoke }
bind $widgetnm <Control-u> { $find.l.f4.f3.up
invoke }
bind $widgetnm <Control-d> {
$find.l.f4.f3.down invoke }
}
if {$typ == "replace"} {
bindevnt
$find.f2.button3 $typ $find
bindevnt $find.f2.button4 $typ
$find
} else {
bindevnt $find.f2.button1 $typ
$find
bindevnt $find.f2.button2 $typ $find
}
bindevnt
$find.l.f4.f3.up $typ $find
bindevnt $find.l.f4.f3.down
$typ $find
bindevnt $find.l.f4.cbox1
$typ $find
bindevnt $find.l.f1.entry $typ
$find
bind $find <Control-c> "destroy $find"
focus $find.l.f1.entry
grab $find
}
# proc for find next
proc findnext {typof} {
global SearchString SearchDir ReplaceString findcase
c find
if [catch {expr [string compare $SearchString "" ]
}] {
findtext $typof
} else {
FindIt $find
}
}
#procedure to set the time change %R to %I:%M for 12 hour time display
proc printtime {} {
.textarea insert insert [clock format [clock seconds] -format "%R %p
%D"]
inccount
}
# binding for wordwrap
proc wraptext {} {
global wordWrap
if [expr [string compare $wordWrap word] == 0] {
set wordWrap none
} else {
set wordWrap word
}
.textarea configure -wrap $wordWrap
}
## NOTE modifiedstatus is declared in the linenum.pth
## so if it it not included we dont want to throw the error
## we just want to ignore, thus the catch...
# this sets saveTextMsg to 1 for message boxes
proc inccount {} {
global saveTextMsg MODIFIED
set saveTextMsg 1
catch {modifiedstatus $MODIFIED}
}
# this resets saveTextMsg to 0
proc outccount {} {
global saveTextMsg
set saveTextMsg 0
catch {modifiedstatus " "}
}
# catch the kill of the windowmanager
wm protocol . WM_DELETE_WINDOW exitapp
#bindings
bind All <Alt-F> {}
bind All <Alt-E> {}
bind All <Alt-S> {}
bind ALL <Alt-H> {}
bind . <F3> {findnext find}
bind . <Control-x> {cuttext}
bind . <Control-c> {copytext}
bind . <Control-s> {filetosave}
bind Text <Control-o> {}
bind Text <Control-f> {}
bind . <Control-o> {filetoopen}
bind . <Control-z> {undo_menu_proc}
bind . <Control-y> {redo_menu_proc}
bind . <Control-f> {findtext find}
bind . <Control-r> {findtext replace}
# because windows is 'different' and mac is unknown
if [ expr [string compare $tcl_platform(platform) "unix"] ==0] {
#events
set tk_strictMotif 0
event delete <<Cut>> <Control-x>
event delete <<Paste>> <Control-v>
event delete
<<Paste>> <Control-Key-y>
# more bindings
bind Text <Control-v> {}
bind .textarea <Control-v> {pastetext}
}
###################################################################
#set zed_dir [file dirname [info script]]
# here is where the undo stuff begins
if {![info exists classNewId]} {
# work around object creation between multiple
include of this file problem
set classNewId 0
}
proc new {className args} {
# calls the constructor for the class with optional
arguments
# and returns a unique object identifier independent
of the class name
global classNewId
# use local variable for id for new can be called
recursively
set id [incr classNewId]
if {[llength [info procs
${className}:$className]]>0} {
# avoid catch to track errors
eval ${className}:$className
$id $args
}
return $id
}
proc delete {className id} {
# calls the destructor for the class and delete all
the object data members
if {[llength [info procs
${className}:~$className]]>0} {
# avoid catch to track errors
${className}:~$className $id
}
global $className
# and delete all this object array members if any
(assume that they were stored as $className($id,memberName))
foreach name [array names $className "$id,*"] {
unset ${className}($name)
}
}
proc lifo:lifo {id {size 2147483647}} {
global lifo
set lifo($id,maximumSize) $size
lifo:empty $id
}
proc lifo:push {id data} {
global lifo
inccount
lifo:tidyUp $id
if {$lifo($id,size)>=$lifo($id,maximumSize)} {
unset
lifo($id,data,$lifo($id,first))
incr lifo($id,first)
incr lifo($id,size) -1
}
set lifo($id,data,[incr lifo($id,last)]) $data
incr lifo($id,size)
}
proc lifo:pop {id} {
global lifo
inccount
lifo:tidyUp $id
if {$lifo($id,last)<$lifo($id,first)} {
error "lifo($id) pop error,
empty"
}
# delay unsetting popped data to improve performance
by avoiding a data copy
set lifo($id,unset) $lifo($id,last)
incr lifo($id,last) -1
incr lifo($id,size) -1
return $lifo($id,data,$lifo($id,unset))
}
proc lifo:tidyUp {id} {
global lifo
if {[info exists lifo($id,unset)]} {
unset
lifo($id,data,$lifo($id,unset))
unset lifo($id,unset)
}
}
proc lifo:empty {id} {
global lifo
lifo:tidyUp $id
foreach name [array names lifo $id,data,*] {
unset lifo($name)
}
set lifo($id,size) 0
set lifo($id,first) 0
set lifo($id,last) -1
}
proc textUndoer:textUndoer {id widget {depth 2147483647}} {
global textUndoer
if {[string compare [winfo class $widget] Text]!=0} {
error "textUndoer error:
widget $widget is not a text widget"
}
set textUndoer($id,widget) $widget
set textUndoer($id,originalBindingTags) [bindtags
$widget]
bindtags $widget [concat
$textUndoer($id,originalBindingTags) UndoBindings($id)]
bind UndoBindings($id) <Control-u>
"textUndoer:undo $id"
# self destruct automatically when text widget is
gone
bind UndoBindings($id) <Destroy> "delete
textUndoer $id"
# rename widget command
rename $widget [set textUndoer($id,originalCommand)
textUndoer:original$widget]
# and intercept modifying instructions before
calling original command
proc $widget {args} "textUndoer:checkpoint $id
\$args;
global search_count;
eval
$textUndoer($id,originalCommand) \$args"
set textUndoer($id,commandStack) [new lifo $depth]
set textUndoer($id,cursorStack) [new lifo $depth]
#lee
textRedoer:textRedoer $id $widget $depth
}
proc textUndoer:~textUndoer {id} {
global textUndoer
bindtags $textUndoer($id,widget)
$textUndoer($id,originalBindingTags)
rename $textUndoer($id,widget) ""
rename $textUndoer($id,originalCommand)
$textUndoer($id,widget)
delete lifo $textUndoer($id,commandStack)
delete lifo $textUndoer($id,cursorStack)
#lee
textRedoer:~textRedoer $id
}
proc textUndoer:checkpoint {id arguments} {
global textUndoer textRedoer
# do nothing if non modifying command
if {[string compare [lindex $arguments 0]
insert]==0} {
textUndoer:processInsertion
$id [lrange $arguments 1 end]
if {$textRedoer($id,redo) ==
0} {
textRedoer:reset $id
}
}
if {[string compare [lindex $arguments 0]
delete]==0} {
textUndoer:processDeletion
$id [lrange $arguments 1 end]
if {$textRedoer($id,redo) ==
0} {
textRedoer:reset $id
}
}
}
proc textUndoer:processInsertion {id arguments} {
global textUndoer
set number [llength $arguments]
set length 0
# calculate total insertion length while skipping
tags in arguments
for {set index 1} {$index<$number} {incr index 2}
{
incr length [string length
[lindex $arguments $index]]
}
if {$length>0} {
set index
[$textUndoer($id,originalCommand) index [lindex $arguments 0]]
lifo:push
$textUndoer($id,commandStack) "delete $index $index+${length}c"
lifo:push
$textUndoer($id,cursorStack) [$textUndoer($id,originalCommand) index
insert]
}
}
proc textUndoer:processDeletion {id arguments} {
global textUndoer
set command $textUndoer($id,originalCommand)
lifo:push $textUndoer($id,cursorStack) [$command
index insert]
set start [$command index [lindex $arguments 0]]
if {[llength $arguments]>1} {
lifo:push
$textUndoer($id,commandStack) "insert $start [list [$command get $start
[lindex $arguments 1]]]"
} else {
lifo:push
$textUndoer($id,commandStack) "insert $start [list [$command get
$start]]"
}
}
proc textUndoer:undo {id} {
global textUndoer
if {[catch {set cursor [lifo:pop
$textUndoer($id,cursorStack)]}]} {
return
}
set popArgs [lifo:pop $textUndoer($id,commandStack)]
textRedoer:checkpoint $id $popArgs
eval $textUndoer($id,originalCommand) $popArgs
# now restore cursor position
$textUndoer($id,originalCommand) mark set insert
$cursor
# make sure insertion point can be seen
$textUndoer($id,originalCommand) see insert
}
proc textUndoer:reset {id} {
global textUndoer
lifo:empty $textUndoer($id,commandStack)
lifo:empty $textUndoer($id,cursorStack)
}
#########################################################################
proc textRedoer:textRedoer {id widget {depth 2147483647}} {
global textRedoer
if {[string compare [winfo class $widget] Text]!=0} {
error "textRedoer error:
widget $widget is not a text widget"
}
set textRedoer($id,commandStack) [new lifo $depth]
set textRedoer($id,cursorStack) [new lifo $depth]
set textRedoer($id,redo) 0
}
proc textRedoer:~textRedoer {id} {
global textRedoer
delete lifo $textRedoer($id,commandStack)
delete lifo $textRedoer($id,cursorStack)
}
proc textRedoer:checkpoint {id arguments} {
global textUndoer textRedoer
# do nothing if non modifying command
if {[string compare [lindex $arguments 0]
insert]==0} {
textRedoer:processInsertion
$id [lrange $arguments 1 end]
}
if {[string compare [lindex $arguments 0]
delete]==0} {
textRedoer:processDeletion
$id [lrange $arguments 1 end]
}
}
proc textRedoer:processInsertion {id arguments} {
global textUndoer textRedoer
set number [llength $arguments]
set length 0
# calculate total insertion length while skipping
tags in arguments
for {set index 1} {$index<$number} {incr index 2}
{
incr length [string length
[lindex $arguments $index]]
}
if {$length>0} {
set index
[$textUndoer($id,originalCommand) index [lindex $arguments 0]]
lifo:push
$textRedoer($id,commandStack) "delete $index $index+${length}c"
lifo:push
$textRedoer($id,cursorStack) [$textUndoer($id,originalCommand) index
insert]
}
}
proc textRedoer:processDeletion {id arguments} {
global textUndoer textRedoer
set command $textUndoer($id,originalCommand)
lifo:push $textRedoer($id,cursorStack) [$command
index insert]
set start [$command index [lindex $arguments 0]]
if {[llength $arguments]>1} {
lifo:push
$textRedoer($id,commandStack) "insert $start [list [$command get $start
[lindex $arguments 1]]]"
} else {
lifo:push
$textRedoer($id,commandStack) "insert $start [list [$command get
$start]]"
}
}
proc textRedoer:redo {id} {
global textUndoer textRedoer
if {[catch {set cursor [lifo:pop
$textRedoer($id,cursorStack)]}]} {
return
}
set textRedoer($id,redo) 1
set popArgs [lifo:pop
$textRedoer($id,commandStack)]
textUndoer:checkpoint $id $popArgs
eval $textUndoer($id,originalCommand) $popArgs
set textRedoer($id,redo) 0
# now restore cursor position
$textUndoer($id,originalCommand) mark set insert
$cursor
# make sure insertion point can be seen
$textUndoer($id,originalCommand) see insert
}
proc textRedoer:reset {id} {
global textRedoer
lifo:empty $textRedoer($id,commandStack)
lifo:empty $textRedoer($id,cursorStack)
}
# end of where youd source in undo.tcl
set undo_id [new textUndoer .textarea]
proc undo_menu_proc {} {
global undo_id
textUndoer:undo $undo_id
inccount
}
proc redo_menu_proc {} {
global undo_id
textRedoer:redo $undo_id
inccount
}
Return to my LINUX page
Return to my home page
