editor.tcl

很不错的tcl编程实例

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"

# Copyright 1996

# Authors

# Lakshmi Sastry
# Computing and Information Systems Department
# Rutherford Appleton Laboratory, Chilton, Didcot. OX11 0QX
# [e-mail]

#                         and

# Venkat VSS Sastry
# Department of Applied Mathematics and Operational Research
# Cranfield University, RMCS Shrivenham, Swindon, SN6 8LA
# [e-mail]

# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies.
  
# The authors, RAL, RMCS Shrivenham, Cranfield University and AGOCG
# make no representations about the suitability of this
# software for any purpose.  It is provided "as is" without
# express or implied warranty. Likewise they accept no responsibility
# whatsoever for any public domain software modules used (which are
# hereby acknowledged) in this software 

# 修改：mhss<[e-mail]>


global GotSelection
set GotSelection 0
frame .fr -width 10c -height 5c ;#main window
wm title .  "Simple Text Editor V 0"
pack .fr

frame .edf 
#put a text widget with scroll bars
text .ed -width 80 -height 20 -bg grey \
	-yscrollcommand ".ys set"

scrollbar .ys -command ".ed yview" 
pack .ed .ys -in .edf -side left -fill y
scrollbar .xs -orient horizontal
pack .edf .xs -in .fr  -fill x 

menu .menubar
#attach it to the main window
. config -menu .menubar
# insert some cascade menus
.menubar add cascade -label File -underline 0 -menu .menubar.file
.menubar add cascade -label Edit -underline 0 -menu .menubar.edit
.menubar add cascade -label Find -underline 0 -menu .menubar.find
.menubar add cascade -label Help -underline 0 -menu .menubar.help


menu .menubar.file
.menubar.file add command -label Open -command OpenFile
.menubar.file add command -label Save -command SaveFile 
.menubar.file add command -label "Save As" -command SaveAsFile
.menubar.file add command -label Quit -command exit

menu .menubar.edit
.menubar.edit add command -label Cut -com CutSelection
.menubar.edit add command -label Paste -com PasteSelection
.menubar.edit add command -label Copy -com CopySelection
.menubar.edit add command -label Clear -com {.ed delete 1.0 end}


menu .menubar.find
.menubar.find add cascade -label "Find Selection" \
	-menu .menubar.find.fmenu
.menubar.find add command -label "Find and Replace" -com FindValue
.menubar.find add command -label "Find Selection and Tag" \
				-com TagSelection

menu .menubar.find.fmenu
.menubar.find.fmenu add radiobutton -label Forward \
	 -com {FindSelection -forwards}
.menubar.find.fmenu add radiobutton -label Backward \
	-com {FindSelection -backwards}



#source some of the auxillary scripts we will be using
#note these can be source in appropriate procedures too

#source message.tcl
#source filesel.tcl
source popup.tcl
set fileselect(selectedfile) {}
set oldname {}
set types {
	{{Text Files}       {.txt}        }
	{{TCL Scripts}      {.tcl}        }
	{{C Source Files}   {.c}      TEXT}
	{{GIF Files}        {.gif}        }
	{{GIF Files}        {}        GIFF}
	{{All Files}        *             }
} 

proc OpenFile {} {

	global fileselect oldname types

	set fileselect(selectedfile) [tk_getOpenFile -filetypes $types]
	if {$fileselect(selectedfile) == ""} {
		set fileselect(selectedfile) $oldname
		return
	}

	set openf $fileselect(selectedfile)
	set oldname $fileselect(selectedfile)

	.ed delete 1.0 end
	set fid [open $openf r]

	while {![eof $fid]} {
		.ed insert end [read $fid 1000]
	}
	close $fid
	.ed mark set insert 1.0
	
}

proc SaveFile {} {
	global fileselect oldname

	if {$fileselect(selectedfile) == "" } {
		tk_messageBox -message "No filename given" -type ok
		set fileselect(selectedfile) $oldname
		return 
	}
	set sts [catch {set f [open $fileselect(selectedfile) w]} \
		errormessage]
	if {$sts == 0} {
		puts $f [.ed get 1.0 end]
		close $f
		set oldname $fileselect(selectedfile)
	} else {
		tk_messageBox -message "can`t open file $fileselect(selectedfile)" -type ok
	}
	
 
}

proc SaveAsFile {} {
	global fileselect types
	
	set fileselect(selectedfile) [tk_getSaveFile -filetypes $types]
	SaveFile
}

	
proc CutSelection {} {
	global seltxt
	set seltxt [selection get STRING]
	.ed delete insert "insert + [string length $seltxt] chars"
}

proc PasteSelection {} {
	global seltxt
	.ed insert insert $seltxt

}

proc CopySelection {} {
	global seltxt
	set seltxt [selection get STRING]

}

proc FindWord {swit seltxt} {
	global found
	set l1 [string length $seltxt]
	scan [.ed index end] %d nl
	scan [.ed index insert] %d cl
	if {[string compare $swit "-forwards"] == 0 } {

		set curpos [.ed index "insert + $l1 chars"]

		for {set i $cl} {$i < $nl} {incr i} {
		
			#.ed mark set first $i.0
			.ed mark set last  $i.end ;#another way "first lineend"
			set lpos [.ed index last]
			set curpos [.ed search $swit -exact $seltxt $curpos $lpos]
			if {$curpos != ""} {
				selection clear .ed 
				.ed mark set insert "$curpos + $l1 chars "
				.ed see $curpos
				set found 1
				break
			} else {
				set curpos $lpos
				set found 0
			}
		}
	} else {
		set curpos [.ed index insert]
		set i $cl
		.ed mark set first $i.0
		while  {$i >= 1} {
		
			set fpos [.ed index first]
			set i [expr $i-1]
		
			set curpos [.ed search $swit -exact $seltxt $curpos $fpos]
			if {$curpos != ""} {
				selection clear .ed
				.ed mark set insert $curpos
				.ed see $curpos
				set found 1
				break
			} else {
				.ed mark set first $i.0
				.ed mark set last "first lineend"
				set curpos [.ed index last]
				set found 0
			}
		
		}
	}
}

proc FindSelection {swit} {

	global seltxt GotSelection
	if {$GotSelection == 0} {
		set seltxt [selection get STRING]
		set GotSelection 1
	} 
	FindWord $swit $seltxt
}

proc FindValue {} {

	FindPopup
}

proc TagSelection {} {
	global seltxt GotSelection
	if {$GotSelection == 0} {
		set seltxt [selection get STRING]
		set GotSelection 1
	} 
	TagAll 
}