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
Variables
Special 1 byte characters
Arithmetic Operators
Boolean Operators
Character Operations
Statements
Arithmetic Expressions
Control Structures
I/O Statements
Some Examples
TCL script "cvvideos" to convert all .avi files to .qt in a directory
TCL script "ideskicon" to create desktop entries for idesk
TCL script "scrotate" to rotate screen resolution
TCL script "xfapsel" to simulate "Open with" and "Execute" for the file windows of xfm
TCL script "doslin"" to strip files of CRs (from DOS/Windows)
TCL script "fifix " to replace unprintable characters from a text file by "? "
TCL script "strca" to strip records containing a certain string from a text file
TCL script "renfd" to rename files in a directory
TCL script "csvslk" to convert .csv files to .slk format
TK Appointment Calendar
TK based xedit from xedit-0.3.9-1.i386.rpm converted to English and bug-fixed


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