Run this Tcl code editor and tester from your Tcl console: Change to the examples directory and
enter "source ed.tcl". The file spynergy.tcl
must be in the same directory as ed.tcl.
Source code for the Ed Tcl Code Editor:
#=========================================================================== # "Ed" -- Tcl Editor and Code Tester # by Mike Doyle # Copyright (c) 1997 Eolas Technologies Inc. # Freely modifiable/redistributable under the "Standard Tcl License" # See http://www.eolas.com/tcl/license.txt for details wm iconify . #=========================================================================== # Start / Stop ED GUI Session #=========================================================================== #---------- # ed_start_gui -- initialize application, start main GUI form proc ed_start_gui {} { global _ED ed_mainf tcl_platform new open save copy cut paste search test #- TOP LEVEL ----------------------------------------- toplevel .ed_mainFrame -background lightgray wm withdraw .ed_mainFrame wm title .ed_mainFrame {Ed -- Tcl Editor} wm geometry .ed_mainFrame +[winfo screenwidth .]+0 #------------------------------------------ set Parent .ed_mainFrame #------------------------------------------ set Name $Parent.menuframe frame $Name -background white pack $Name -anchor nw -expand 0 -fill x -ipadx 0 -ipady 0 \ -padx 0 -pady 0 -side top #------------------------------------------ set Name $Parent.menuframe.file set Menu_string($Name) { {{command} {New} {-command ed_edit_clear -accelerator "ctrl+N" -underline 0}} {{command} {Open} {-command ed_file_load -accelerator "ctrl+O" -underline 0}} {{command} {Save} {-command ed_file_save -accelerator "ctrl+S" -underline 0}} {{separator} {} {}} {{command} {Exit} {-command ed_stop_gui -underline 1}} } construct_menu $Name File $Menu_string($Name) #------------------------------------------ set Name $Parent.menuframe.edit set Menu_string($Name) { {{command} {Copy} {-command ed_edit_copy -accelerator "Ctrl+C" -underline 0}} {{command} {Cut} {-command "ed_edit_cut" -accelerator "Ctrl+X" -underline 2}} {{command} {Paste} {-command "ed_edit_paste" -accelerator "Ctrl+V" -underline 0}} {{separator} {} {}} {{command} {Search} {-command "ed_edit_searchf" -accelerator "Ctrl+R" -underline 0}} {{separator} {} {}} {{command } {Test} {-command "ed_run_package" -accelerator "Ctrl+T" -underline 0}} } construct_menu $Name Edit $Menu_string($Name) #------------------------------------------ set Name $Parent.menuframe.web set Menu_string($Name) { {{command} {Get URL} {-command "ed_get_url" -accelerator "Ctrl+G" -underline 0}} {{tearoff} {no} {}} } construct_menu $Name Web $Menu_string($Name) ;########################################################################## ;# This is a test/demo of the cascading menu code. ;# It should be deleted from 'real' code. # set Name $Parent.menuframe.testcascade # set Menu_string($Name) { # {{command} {Get URL} {-command "ed_get_url" -accelerator "Ctrl+G" -underline 0}} # {{tearoff} {} {no}} # {{cascade} {Cascading Edits} { # {{command} {Copy} {-command ed_edit_copy -accelerator "Ctrl+C" -underline 0}} # {{command} {Cut} {-command "ed_edit_cut" -accelerator "Ctrl+X" -underline 2}} # {{command} {Paste} {-command "ed_edit_paste" -accelerator "Ctrl+V" -underline 0}} # {{separator} {} {}} # {{command} {Search} {-command "ed_edit_searchf" -accelerator "Ctrl+R" -underline 0}} # }} # {{cascade} {Cascading File} { # {{command} {New} {-command ed_edit_clear -accelerator "ctrl+N" -underline 0}} # {{command} {Open} {-command ed_file_load -accelerator "ctrl+O" -underline 0}} # {{command} {Save} {-command ed_file_save -accelerator "ctrl+S" -underline 0}} # {{separator} {} {}} # {{command} {Exit} {-command ed_stop_gui -underline 1}} # }} # } # construct_menu $Name menutst $Menu_string($Name) ;########################################################################### set Name $Parent.buttons frame $Name -background LightGray pack $Name -anchor nw -side top -expand 0 -fill x -ipadx 0 -ipady 0 \ -padx 0 -pady 0 #----------------------------------------- construct_button $Parent.buttons.clear $new new.ppm "ed_edit_clear" \ "Clear the screen and edit a new file" #----------------------------------------- construct_button $Parent.buttons.load $open open.ppm "ed_file_load" \ "Open an existing file" #----------------------------------------- construct_button $Parent.buttons.save $save save.ppm "ed_file_save" \ "Save current file" #----------------------------------------- set Name $Parent.buttons.l8 label $Name -background LightGray -text " " pack $Name -anchor nw -side left -expand 0 -fill x #----------------------------------------- construct_button $Parent.buttons.copy $copy copy.ppm "ed_edit_copy"\ "Copy selected object or text" #----------------------------------------- construct_button $Parent.buttons.cut $cut cut.ppm "ed_edit_cut"\ "Cut selected object or text" #----------------------------------------- construct_button $Parent.buttons.paste $paste paste.ppm "ed_edit_paste" \ "Paste selected object or text" #----------------------------------------- construct_button $Parent.buttons.search $search search.ppm "ed_edit_searchf"\ "Search for string in text" #----------------------------------------- set Name $Parent.buttons.l15 label $Name -background LightGray -text " " pack $Name -anchor nw -side left -expand 0 -fill x #----------------------------------------- construct_button $Parent.buttons.test $test test.ppm "ed_run_package" \ "Test current Tcl code" #----------------------------------------- set Name $Parent.buttons.l17 label $Name -background LightGray -text "0.0" pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.buttons.l16 label $Name -background LightGray -text " Row.Col: " pack $Name -anchor nw -side right -expand 0 -fill x #---------------------------------------- set Name $Parent.mainwin frame $Name -background white -borderwidth 2 -relief ridge pack $Name -anchor sw -side left -expand 1 -fill both #------------------------------------------ set Name $Parent.mainwin.statusframe frame $Name -background black -borderwidth 0 -relief flat pack $Name -anchor nw -side bottom -fill x -expand 0 #------------------------------------------- set Name $Parent.mainwin.statusframe.currentstatus set _ED(status_widget) $Name label $Name -background black -font $_ED(courierfont) -foreground green \ -justify left -textvariable _ED(status) -relief ridge pack $Name -anchor center #------------------------------------------ wm geometry .ed_mainFrame 640x480+30+30 if {$tcl_platform(platform) == "windows"} {set y 0} wm minsize .ed_mainFrame 320 240 ed_edit wm deiconify .ed_mainFrame update } #---------- # ed_stop_gui -- terminate ED GUI application, clean up session proc ed_stop_gui {} { ed_wait_if_blocked exit } #; ------------------------------ #; Constructs and packs a menubutton and menu set #; construct_menu {Name label cmd_list} #; Name: The name of this menubutton #; cmd_list: The list of commands defining the menu choices #: #; cmd_list Format: {menuID MenuName ExtraCmds} #; menuID: Defines the type of menu to create. Options are: #; separator - Makes a separator line #: command - Creates a command menu #; cascade - Creates a cascading menu #; MenuName: The name to put in this menu #: ExtraCmds: Extra args to define this menubutton #; If menuID is cascade, then ExtraCmds is a list of ID, Name, Cmd lists proc construct_menu {Name label cmd_list} { global _ED menubutton $Name -activebackground gray40 -activeforeground white \ -background white -foreground black -relief flat -text $label -underline 0 incr _ED(menuCount); set newmenu $Name.m$_ED(menuCount) $Name configure -menu $newmenu ;# Delete any old window that may be around from previous runs catch "destroy $newmenu" ;# Create the new menu eval "menu $newmenu" eval [list add_items_to_menu $newmenu $cmd_list] $newmenu configure -activebackground gray40 -activeforeground white \ -background white -foreground black pack $Name -anchor nw -expand 0 -ipadx 4 -ipady 0 -padx 0 \ -pady 0 -side left } #;---------- #; Add a set of menu selections to a menu from a command list #: add_items_to_menu {newmenu cmdList} #; menubutton: Name of the window to create a menu in #; cmdList: A list of commands defining menu items proc add_items_to_menu {menubutton cmdList} { global _ED ;# Evaluate each line in the cmdList foreach cmd $cmdList { switch [lindex $cmd 0] { "separator" { set doit "$menubutton add separator [lindex $cmd 2]" eval $doit } "tearoff" { if {[string match [lindex $cmd 2] "no"]} { $menubutton configure -tearoff no } } "command" { set doit "$menubutton add [lindex $cmd 0] -label {[lindex $cmd 1]} \ [lindex $cmd 2]" eval $doit } "cascade" { incr _ED(menuCount); set newmenu $menubutton.m$_ED(menuCount) set doit "$menubutton add cascade -label {[lindex $cmd 1]} \ -menu $newmenu" eval $doit menu $newmenu add_items_to_menu $newmenu [lindex $cmd 2] } } } } #; ----------------------- #; construct_button {Name data cmd helpmsg} #; Name: Name of the buttone to create #; data: Hex data defining the button image #; cmd: The command to execute when this is selected #; helpmsg: Message to display when cursor passes over button proc construct_button {Name data file cmd helpmsg} { global tcl_version if {[info exists tcl_version] == 0 || $tcl_version < 8.0} { set im [image create photo -file $file -gamma 1 -height 16 -width 16 -palette 5/5/4] } else { set im [image create photo -data $data -gamma 1 -height 16 -width 16 -palette 5/5/4] } button $Name -background LightGray -foreground black -activebackground white -image $im \ -relief raised -command "$cmd" pack $Name -anchor nw -side left -expand 0 -fill x bind $Name[list ed_status_message -help $helpmsg] bind $Name {ed_status_message -perm} } #=================================================================== # File Forms and functions #=================================================================== #---------- # ed_file_load -- load a file proc ed_file_load {} { global _ED set _ED(file) [ed_loadsave load] if {$_ED(file) == ""} {return} if {![file readable $_ED(file)]} { ed_error "File \[$_ED(file)\] is not readable." return } ed_wait_if_blocked set _ED(blockflag) 1 ed_status_message -show "loading file: \"$_ED(file)\" ..." update if {[catch "open $_ED(file) r" fd]} { ed_error "Error while opening $_ED(file): \[$fd\]" ed_status_message -perm set _ED(blockflag) 0 return } set _ED(package) "[read $fd]" close $fd set _ED(temppackage) $_ED(package) set _ED(packagekeyname) [file tail $_ED(file)] if {$_ED(packagekeyname) == ""} {set _ED(packagekeyname) $_ED(file)} if {$_ED(packagekeyname) == ""} {set _ED(packagekeyname) "UNKNOWN"} ed_edit ed_status_message -perm update set _ED(blockflag) 0 } #---------- # ed_file_save -- save package to a local file proc ed_file_save {} { global _ED ed_wait_if_blocked set _ED(blockflag) 1 set _ED(package) "[.ed_mainFrame.mainwin.textFrame.left.text get 1.0 end]" set _ED(blockflag) 0 set $_ED(file) [ed_loadsave save] if {$_ED(file) == ""} {return} if {[file exists $_ED(file)]} { if {![file writable $_ED(file)]} { ed_error "File \[$_ED(file)\] is not writable." return } } ed_wait_if_blocked set _ED(blockflag) 1 ed_status_message -show "saving file: \"$_ED(file)\" ..." update if {[catch "open $_ED(file) w" fd]} { ed_error "Error opening $_ED(file): \[$fd\]" ed_status_message -perm update set _ED(blockflag) 0 return } puts $fd "$_ED(package)" close $fd ed_status_message -perm update set _ED(blockflag) 0 } #---------- proc ed_loadsave {loadflag} { global ed_loadsave _ED if {![info exists ed_loadsave(pwd)]} { set ed_loadsave(pwd) [pwd] set ed_loadsave(filter) "*" set ed_loadsave(file) "" } set ed_loadsave(loadflag) $loadflag set ed_loadsave(path) "" set ed_loadsave(done) 0 #- TOP LEVEL ----------------------------------------- toplevel .ed_loadsave -background LightGray wm withdraw .ed_loadsave if {[string match $loadflag "load"]} { wm title .ed_loadsave "Open File" } else { wm title .ed_loadsave "Save File" } wm geometry .ed_loadsave +[expr \ ([winfo screenwidth .]/2) - 173]+[expr ([winfo screenheight .]/2) - 148] #------------------------------------------ set Parent .ed_loadsave #------------------------------------------ set Name $Parent.dir frame $Name -background lightgray pack $Name -anchor nw -side top #------------------------------------------ set Name $Parent.dir.e3 entry $Name -background aliceblue -foreground black \ -highlightbackground LightGray -width 35 \ -textvariable ed_loadsave(pwd) pack $Name -side right -anchor nw -padx 5 bind $Name {ed_loadsavegetentries} bind $Name { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } #---------- set Name $Parent.dir.l1 label $Name -background LightGray -text "Directory: " pack $Name -side right -anchor nw #------------------------------------------ set Name $Parent.type frame $Name -background lightgray pack $Name -anchor nw -side top -fill x #------------------------------------------ set Name $Parent.type.e7 entry $Name -background aliceblue -foreground black \ -highlightbackground LightGray -width 35 \ -textvariable ed_loadsave(filter) pack $Name -side right -anchor nw -padx 5 bind $Name {ed_loadsavegetentries} bind $Name { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } # #---------- set Name $Parent.type.l5 label $Name -background LightGray -text "File Type: " pack $Name -side right -anchor nw #------------------------------------------ set Name $Parent.file frame $Name -background lightgray pack $Name -anchor nw -side top -fill x #------------------------------------------ set Name $Parent.file.e11 entry $Name -background aliceblue -foreground black \ -highlightbackground LightGray -width 35 \ -textvariable ed_loadsave(file) pack $Name -side right -anchor nw -padx 5 .ed_loadsave.file.e11 delete 0 end .ed_loadsave.file.e11 insert 0 $_ED(packagekeyname) bind $Name { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } bind $Name {if {[ed_loadsavevalentry]} {set ed_loadsave(done) 1}} #------------------------------------------ set Name $Parent.file.l9 label $Name -background LightGray -text "File: " pack $Name -side right -anchor nw #------------------------------------------ set Name $Parent.list frame $Name -background LightGray -borderwidth 2 -height 50 \ -highlightbackground LightGray -relief raised -width 50 pack $Name -side top -anchor nw -expand yes -fill both #------------------------------------------ set Name $Parent.list.lb1 listbox $Name -background aliceblue -font $_ED(courierfont) \ -foreground black \ -highlightbackground LightGray -selectbackground LightBlue \ -selectforeground black \ -yscrollcommand "$Parent.list.sb2 set" -selectmode browse pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 \ -padx 2 -pady 2 -side left bind $Name {ed_loadsaveselbegin %W %y} bind $Name {ed_loadsaveselbegin2 %W} bind $Name {ed_loadsaveselbegin %W %y} bind $Name {ed_loadsaveselbegin %W %y} bind $Name {set _ED(packagekeyname) \ $seld_file; ed_loadsaveselend %W %y} bind $Name {break} bind $Name {break} bind $Name {ed_loadsaveselend %W %y} bind $Name { tkCancelRepeat tkListboxBeginSelect %W [%W index active] %W activate [%W index active] } bind $Name { tkCancelRepeat tkListboxBeginSelect %W [%W index active] %W activate [%W index active] } #------------------------------------------ set Name $Parent.list.sb2 scrollbar $Name -activebackground plum -activerelief sunken \ -background LightGray -command "$Parent.list.lb1 yview" \ -highlightbackground LightGray -troughcolor gray40 pack $Name -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 \ -padx 2 -pady 2 -side left #---------- set Name $Parent.buttons frame $Name -background lightgray pack $Name -side top -anchor nw -fill x #------------------------------------------ set Name $Parent.buttons.ok button $Name -activebackground lavender -background gray40 \ -foreground white -highlightbackground LightGray -text OK \ -command {set _ED(packagekeyname) [.ed_loadsave.file.e11 get]; if \ {[ed_loadsavevalentry]} {set ed_loadsave(done) 1}} pack $Name -side left -anchor nw -padx 3 -pady 3 #------------------------------------------ set Name $Parent.buttons.cancel button $Name -activebackground lavender -background gray40 \ -foreground white -highlightbackground LightGray -text Cancel \ -command {destroy .ed_loadsave} pack $Name -side right -anchor nw -padx 3 -pady 3 ed_loadsavegetentries wm deiconify .ed_loadsave vwait ed_loadsave(done) destroy .ed_loadsave if {[file isdirectory $ed_loadsave(path)]} {set ed_loadsave(path) ""} return $ed_loadsave(path) } proc ed_loadsaveselbegin {win ypos} { $win select anchor [$win nearest $ypos] } proc ed_loadsaveselbegin2 {win} { global seld_file set seld_file [$win get [$win curselection]] .ed_loadsave.file.e11 delete 0 end .ed_loadsave.file.e11 insert 0 $seld_file set _ED(packagekeyname) $seld_file } proc ed_loadsaveselend {win ypos} { global ed_loadsave $win select set anchor [$win nearest $ypos] set fil [.ed_loadsave.list.lb1 get [lindex [$win curselection] 0]] if {-1 == [string last "/" $fil]} { set ed_loadsave(file) $fil set ed_loadsave(path) \ [eval file join $ed_loadsave(pwd) $ed_loadsave(file)] set ed_loadsave(done) 1 return "" } set ed_loadsave(pwd) [ed_loadsavemergepaths \ $ed_loadsave(pwd) [string trimright $fil "/"]] ed_loadsavegetentries return "" } proc ed_loadsavegetentries {} { global ed_loadsave tcl_version set e 0 if {![file isdirectory $ed_loadsave(pwd)]} { gui_error "\"$ed_loadsave(pwd)\" is not a valid directory" .ed_loadsave configure -cursor {} set e 1 } .ed_loadsave configure -cursor watch update set sort_mode "-dictionary" if {[info exists tcl_version] == 0 || $tcl_version < 8.0} { set sort_mode "-ascii" } if {$ed_loadsave(filter) == ""} {set ed_loadsave(filter) "*"} set files [lsort $sort_mode "[glob -nocomplain $ed_loadsave(pwd)/.*] \ [glob -nocomplain $ed_loadsave(pwd)/*]"] .ed_loadsave.list.lb1 delete 0 end if {$e} { .ed_loadsave configure -cursor {} update return } set d "./ ../" set fils "" foreach f $files { set ff [file tail $f] if {$ff != "." && $ff != ".."} { if {[file isdirectory $f]} { lappend d "$ff/" } else { if {[string match $ed_loadsave(filter) $ff]} { lappend fils "$ff" } } } } set files "$d $fils" foreach f $files { .ed_loadsave.list.lb1 insert end $f } .ed_loadsave configure -cursor {} update } proc ed_loadsavevalentry {} { global ed_loadsave _ED if {"." != [file dirname $ed_loadsave(file)]} { set path [ed_loadsavemergepaths \ $ed_loadsave(pwd) $ed_loadsave(file)] set ed_loadsave(pwd) [file dirname $path] if {[file extension $path] != ""} { set ed_loadsave(filter) "*[file extension $path]" } else { set ed_loadsave(filter) "*" } set ed_loadsave(file) [file tail $path] ed_loadsavegetentries return 0 } set fil [ed_loadsavemergepaths $ed_loadsave(pwd) $ed_loadsave(file)] if {[string match $ed_loadsave(loadflag) "load"]} { if {(![file exists $fil]) || (![file readable $fil])} { gui_error "\"$fil\" cannot be loaded." set ed_loadsave(path) "" return 0 } else { set ed_loadsave(path) $fil set _ED(file) $fil set ed_loadsave(done) 1 return 1 } } else { set d [file dirname $fil] if {![file writable $d]} { gui_error "\"$d\" directory cannot be written to." set ed_loadsave(path) "" set _ED(file) "" return 0 } if {[file exists $fil] && (![file writable $fil])} { gui_error "\"$file\" cannot be written to." set ed_loadsave(path) "" set _ED(file) "" return 0 } set ed_loadsave(path) $fil set ed_loadsave(done) 1 set _ED(file) $fil return 1 } } proc ed_loadsavemergepaths {patha pathb} { set pa [file split $patha] set pb [file split $pathb] if {[string first ":" [lindex $pb 0]] != -1} {return [eval file join $pb]} if {[lindex $pb 0] == "/"} {return [eval file join $pb]} set i [expr [llength $pa] - 1] foreach item $pb { if {$item == ".."} { incr i -1 set pa [lrange $pa 0 $i] } elseif {$item == "."} { # -- do nothing } else { lappend pa $item } } return [eval file join $pa] } proc gui_error {message} { catch "destroy .xxx" bell tk_dialog .xxx "Error" "$message" warning 0 Close } if {[info procs bgerror] == ""} { proc bgerror {{message ""}} { global errorInfo puts stderr $errorInfo } } #==================================================================== # Edit Selected Package #==================================================================== #------------ # search form proc ed_edit_searchf {} { global _ED catch "destroy .ed_edit_searchf" #- TOP LEVEL ----------------------------------------- toplevel .ed_edit_searchf -background LightGray wm withdraw .ed_edit_searchf wm title .ed_edit_searchf {Search} #------------------------------------------ set Parent .ed_edit_searchf #------------------------------------------ set Name $Parent.f1 frame $Name -background lightgray pack $Name -anchor nw -fill x -side top -padx 5 set Name $Parent.f1.l1 label $Name -text "Search for " -background lightgray pack $Name -anchor nw -fill x -side left -padx 5 #------------------------------------------ set Name $Parent.f1.e1 entry $Name -background aliceblue -font $_ED(courierfont) \ -highlightbackground LightGray -selectbackground blue \ -selectforeground white -width 31 pack $Name -anchor nw -side left bind .ed_edit_searchf.f1.e1 { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } bind .ed_edit_searchf.f1.e1 {tk_focusNext %W} $Name delete 0 end #------------------------------------------ set Name $Parent.replace frame $Name -background lightgray pack $Name -anchor nw -side top -fill x -padx 5 -pady 5 set Name $Parent.replace.l1 label $Name -text "Replace with" -background lightgray pack $Name -anchor nw -fill x -side left -padx 5 set Name $Parent.replace.e1 entry $Name -background aliceblue -font $_ED(courierfont) \ -highlightbackground LightGray -selectbackground blue \ -selectforeground white -width 30 pack $Name -anchor nw -side left global Procs set Procs($Name) { {bind .ed_edit_searchf.replace.e1 } \ {bind .ed_edit_searchf.replace.e1 } \ {bind .ed_edit_searchf.replace.e1 } \ {bind .ed_ediy_searchf.replace.e1 }} bind .ed_edit_searchf.replace.e1 {tkEntryBackspace %W} bind .ed_edit_searchf.replace.e1 { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } bind .ed_edit_searchf.replace.e1 {tk_focusNext %W} $Name delete 0 end set Name $Parent.mainwin frame $Name -background lightgray pack $Name -anchor nw -side top -fill x -padx 5 -pady 5 #---------- set Name $Parent.mainwin.b1 button $Name -activebackground lavender -background gray40 \ -command { set _ED(srch_new) [.ed_edit_searchf.f1.e1 get] if {$_ED(srch_new) != $_ED(srch_old)} {set _ED(editcursor) 1.0} ed_edit_search .ed_mainFrame.mainwin.textFrame.left.text $_ED(srch_new) set _ED(srch_old) [.ed_edit_searchf.f1.e1 get] focus .ed_mainFrame.mainwin.textFrame.left.text raise .ed_edit_searchf } \ -foreground white -highlightbackground LightGray \ -text {Search} pack $Name -anchor nw -side left #------------------------------------------ set Name $Parent.mainwin.b2 button $Name -activebackground lavender -background gray40 \ -command { if {[.ed_mainFrame.mainwin.textFrame.left.text get sel.first sel.last] != ""} { if {[.ed_mainFrame.mainwin.textFrame.left.text tag ranges sel] == ""} { set _ED(rplc_term) [.ed_edit_searchf.replace.e1 get] .ed_mainFrame.mainwin.textFrame.left.text insert $_ED(editcursor) $_ED(rplc_term) .ed_mainFrame.mainwin.textFrame.left.text delete sel.first sel.last raise .ed_edit_searchf } } } \ -foreground white -highlightbackground LightGray \ -text {Replace} pack $Name -anchor nw -side left #------------------------------------------ set Name $Parent.mainwin.b3 button $Name -activebackground Lavender -background gray40 \ -command {destroy .ed_edit_searchf} -foreground white \ -highlightbackground LightGray -text Close pack $Name -anchor nw -side right #---------- set x [expr [winfo rootx .ed_mainFrame] + 300] set y [expr [winfo rooty .ed_mainFrame] + [winfo height .ed_mainFrame] - 300] wm geometry .ed_edit_searchf +$x+$y wm deiconify .ed_edit_searchf raise .ed_edit_searchf update wm minsize .ed_edit_searchf [winfo width .ed_edit_searchf] \ [winfo height .ed_edit_searchf] wm maxsize .ed_edit_searchf [winfo width .ed_edit_searchf] \ [winfo height .ed_edit_searchf] } #---------- # ed_edit_search -- search for entered text string proc ed_edit_search {textwin srch_string} { global _ED if {$srch_string == ""} {set _ED(editcursor) 1.0; return} set length 0; set fail [catch {\ $textwin search -regexp -count length $srch_string $_ED(editcursor) end} \ _ED(editcursor) ] if { ($length != 0) && (!$fail) } { $textwin tag add sel $_ED(editcursor) "$_ED(editcursor) + $length char" set _ED(editcursor) [$textwin index "$_ED(editcursor) + $length char"] $textwin see $_ED(editcursor) } else {set _ED(editcursor) 1.0} if {$_ED(editcursor) == 1.0} {ed_error "No match for string"; return} if {$_ED(editcursor) == $_ED(editcurold)} {ed_error "End of search"} set _ED(editcurold) $_ED(editcursor) } #---------- # ed_edit_clear -- clear the edit area proc ed_edit_clear {} { global _ED ed_wait_if_blocked set _ED(blockflag) 1 set _ED(temppackage) "" set _ED(blockflag) 0 if {[info commands .ed_mainFrame.mainwin.f1] != ""} { .ed_mainFrame.mainwin.textFrame.left.text delete 1.0 end set _ED(packagekeyname) [.ed_mainFrame.mainwin.f1.e5 get] } set _ED(package) "" set _ED(packagekeyname) "" ed_edit } #---------- # ed_edit_commit -- commit editing changes to the current package proc ed_edit_commit {} { global _ED ed_wait_if_blocked set _ED(blockflag) 1 set _ED(package) "[.ed_mainFrame.mainwin.textFrame.left.text get 1.0 end]" set _ED(blockflag) 0 update } #----------- # ed_edit_cut proc ed_edit_cut {} { tk_textCut .ed_mainFrame.mainwin.textFrame.left.text } #----------- # ed_edit_copy proc ed_edit_copy {} { tk_textCopy .ed_mainFrame.mainwin.textFrame.left.text } #----------- # ed_edit_paste proc ed_edit_paste {} { tk_textPaste .ed_mainFrame.mainwin.textFrame.left.text } #---------- # ed_edit -- bring up the edit window for the current package proc ed_edit {} { global _ED global Menu_string catch "destroy .ed_mainFrame.mainwin.mainwin" catch "destroy .ed_mainFrame.mainwin.buttons" catch "destroy .ed_mainFrame.mainwin.f1" catch "destroy .ed_mainFrame.mainwin.textFrame" #------------------------------------------ set Parent .ed_mainFrame.mainwin #----------------------------------------- set Name $Parent.mainwin frame .ed_mainFrame.mainwin.mainwin -background lightgray pack .ed_mainFrame.mainwin.mainwin -anchor nw -side bottom -fill x #------------------------------------------ set Name $Parent.textFrame frame $Name -background LightGray -borderwidth 2 \ -highlightbackground LightGray -relief raised pack $Name -anchor sw -expand 1 -fill both -side bottom #------------------------------------------ set Name $Parent.textFrame.right frame $Name -background LightGray -height 10 \ -highlightbackground LightGray -width 15 pack $Name -anchor sw -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 \ -pady 0 -side bottom #------------------------------------------ set Name $Parent.textFrame.right.vertScrollbar scrollbar $Name -activebackground plum -activerelief sunken \ -background LightGray -command "$Parent.textFrame.left.text xview" \ -highlightbackground LightGray -orient horizontal -troughcolor gray40 \ -elementborderwidth 1 pack $Name -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 \ -pady 0 -side left #------------------------------------------ set Name $Parent.textFrame.right.buttons0 frame $Name -background LightGray -height 10 \ -highlightbackground LightGray -width 15 pack $Name -anchor se -expand 0 -fill x -ipadx 0 -ipady 0 -padx 2 \ -pady 2 -side bottom #------------------------------------------ set Name $Parent.textFrame.left frame $Name -background LightGray \ -highlightbackground LightGray pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 \ -padx 0 -pady 0 -side top #------------------------------------------ set Name $Parent.textFrame.left.horizScrollbar scrollbar $Name -activebackground plum -activerelief sunken \ -background LightGray -command "$Parent.textFrame.left.text yview" \ -highlightbackground LightGray -troughcolor gray40 \ -elementborderwidth 1 pack $Name -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 \ -padx 0 -pady 0 -side right #------------------------------------------ set Name $Parent.textFrame.left.text text $Name -background AliceBlue -borderwidth 2 -foreground black \ -highlightbackground LightGray -insertbackground black \ -selectbackground lightblue -selectforeground black \ -wrap none \ -xscrollcommand "$Parent.textFrame.right.vertScrollbar set" \ -yscrollcommand "$Parent.textFrame.left.horizScrollbar set" $Name insert end { } pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 \ -padx 0 -pady 0 -side top ####----------- bind $Parent.textFrame.left.text \ {.ed_mainFrame.buttons.l17 configure -text \ [.ed_mainFrame.mainwin.textFrame.left.text index insert]} bind $Parent.textFrame.left.text \ {.ed_mainFrame.buttons.l17 configure -text \ [.ed_mainFrame.mainwin.textFrame.left.text index insert]} $Name delete 1.0 end $Name insert end $_ED(temppackage) ed_edit_commit #----------- update } #==================================================================== # Run Selected Package #==================================================================== # ed_change_button -- change the test button to stop button proc ed_stop_button {} { global _ED stop tcl_version set Name .ed_mainFrame.buttons.test if {[info exists tcl_version] == 0 || $tcl_version < 8.0} { set im [image create photo -file stop.ppm -gamma 1 -height 16 -width 16 -palette 5/5/4] } else { set im [image create photo -data $stop -gamma 1 -height 16 -width 16 -palette 5/5/4] } $Name config -image $im -command "ed_kill_apps" bind .ed_mainFrame.buttons.test {ed_status_message -help \ "Stop running code"} } proc ed_test_button {} { global _ED test tcl_version set Name .ed_mainFrame.buttons.test if {[info exists tcl_version] == 0 || $tcl_version < 8.0} { set im [image create photo -file test.ppm -gamma 1 -height 16 -width 16 -palette 5/5/4] } else { set im [image create photo -data $test -gamma 1 -height 16 -width 16 -palette 5/5/4] } $Name config -image $im -command "ed_run_package" bind .ed_mainFrame.buttons.test {ed_status_message -help \ "Test current code"} } #---------- # ed_run_package -- run the currently loaded package proc ed_run_package {} { global _ED ed_loadsave argv argv0 argc embed_args if {"$_ED(package)" == ""} { ed_status_message -alert "No code currently in run buffer." update return } ed_kill_apps ed_edit_commit .ed_mainFrame configure -cursor watch ed_status_message -show "running package: $_ED(packagekeyname)" update ed_stop_button # -- create a slave tk interpreter to run the application in set _ED(runslave) [interp create runslave] runslave eval {load {} Tk} set cmd "wm geometry . +100+100" runslave eval $cmd set cmd "wm title . [list "Main Window for $_ED(packagekeyname)"]" runslave eval $cmd runslave alias exit ed_kill_apps # runslave eval set argv0 $argv0 # runslave eval set argc $argc # if {![info exists argv]} { # runslave eval set argv {} # } else { # runslave eval set argv [list "$argv"] # } # if {[info exists embed_args]} { # runslave eval set embed_args $embed_args # } ed_wait_if_blocked if {[catch "$_ED(runslave) eval [list $_ED(package)]" result]} { ed_status_message -alert "Error occured while running $_ED(packagekeyname)" update bgerror $result } ed_status_message -perm .ed_mainFrame configure -cursor {} update set _ED(blockflag) 0 } #==================================================================== # Stop Executing Apps #==================================================================== #---------- # ed_kill_apps -- destroys Tk windows, procedures, and variables other # than those marked as saved proc ed_kill_apps {args} { global _ED ed_mainf if {$_ED(runslave) == ""} {return} .ed_mainFrame configure -cursor watch ed_status_message -show "... closing down active GUI applications ..." update ed_wait_if_blocked set _ED(blockflag) 1 catch "interp delete $_ED(runslave)" set _ED(blockflag) 0 set _ED(runslave) "" .ed_mainFrame configure -cursor {} ed_status_message -perm ed_test_button update } #============================================================================ # Utility Procedures #============================================================================ #---------- # ed_get_url proc ed_get_url {} { global _ED catch "destroy .ed_get_urlf" #- TOP LEVEL ----------------------------------------- toplevel .ed_get_urlf -background LightGray wm withdraw .ed_get_urlf wm title .ed_get_urlf {Get URL} #------------------------------------------ set Parent .ed_get_urlf #------------------------------------------ set Name $Parent.f1 frame $Name -background lightgray pack $Name -anchor nw -fill x -side top -padx 5 #------------------------------------------ set Name $Parent.f1.e1 entry $Name -background aliceblue -font $_ED(courierfont) \ -highlightbackground LightGray -selectbackground blue \ -selectforeground white -width 30 pack $Name -anchor nw -side right bind .ed_get_urlf.f1.e1 { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } bind .ed_get_urlf.f1.e1 { set url_string [.ed_get_urlf.f1.e1 get] ed_edit_clear set _ED(package) [fetchURL $url_string] .ed_mainFrame.mainwin.textFrame.left.text insert end $_ED(package) destroy .ed_get_urlf } $Name delete 0 end #------------------------------------------ set Name $Parent.mainwin frame $Name -background lightgray pack $Name -anchor nw -side top -fill x -padx 5 -pady 5 #---------- set Name $Parent.mainwin.b1 button $Name -activebackground lavender -background gray40 \ -command { set url_string [.ed_get_urlf.f1.e1 get] ed_edit_clear set _ED(package) [fetchURL $url_string] .ed_mainFrame.mainwin.textFrame.left.text insert end $_ED(package) destroy .ed_get_urlf } \ -foreground white -highlightbackground LightGray \ -text {Get URL} pack $Name -anchor nw -side left #------------------------------------------ set Name $Parent.mainwin.b2 button $Name -activebackground Lavender -background gray40 \ -command {destroy .ed_get_urlf} -foreground white \ -highlightbackground LightGray -text Cancel pack $Name -anchor nw -side right #---------- set x [expr [winfo rootx .ed_mainFrame] + 300] set y [expr [winfo rooty .ed_mainFrame] + [winfo height .ed_mainFrame]\ -300] wm geometry .ed_get_urlf +$x+$y wm deiconify .ed_get_urlf raise .ed_get_urlf update wm minsize .ed_get_urlf [winfo width .ed_get_urlf] [winfo height .ed_get_urlf] wm maxsize .ed_get_urlf [winfo width .ed_get_urlf] [winfo height .ed_get_urlf] } #---------- # ed_status_message -- update the status message in the main form proc ed_status_message {option {message ""}} { global _ED set _ED(status) "Now editing file: $_ED(packagekeyname)" set _ED(permstatus) "Now editing file: $_ED(packagekeyname)" switch -glob -- $option { -setperm { set _ED(permstatus) "$message" set _ED(status) "$message" } -temp { set _ED(status) "$message" if {$_ED(permstatus) != ""} { after 1000 "set _ED(status) [list $_ED(permstatus)]" } } -show { set _ED(status) "$message" } -help { set _ED(status) "$message" } -perm { set _ED(status) "$_ED(permstatus)" } -alert { bell; bell set _ED(status) "$message" catch "$_ED(status_widget) configure -foreground white" catch "$_ED(status_widget) configure -background red" update after 2000 catch "$_ED(status_widget) configure -foreground green" catch "$_ED(status_widget) configure -background black" if {$_ED(permstatus) != ""} { set _ED(status) "$_ED(permstatus)" } update } default {ed_status_message -temp "$message"} } } #---------- # ed_wait_if_blocked -- check and wait for blocked operation to complete proc ed_wait_if_blocked {} { global _ED # -- disable this feature set _ED(blockflag) 0 return set i 0 while {$_ED(blockflag)} { incr i # -- allow a maximum of 10 seconds of blockage if {$i > 20} { set _ED(blockflag) 0 return } after 500 } } #---------- # ed_error -- display an error pop-up proc ed_error {message} { bell bell after 100 { grab -global .xxx } tk_dialog .xxx "Weblet Developer - Alert" "$message" warning 0 Close grab release .xxx } #------------- # Icon image data set new { R0lGODlhEAAQAPcAAAAAAMbGxv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhJAAMIHEiwIEEACBMiNCgQwL+HEBcadAjxoUMAEytaTFiQokaLHT9GDCnyH8aDJU2SFHlyoMeP LRumjBngpUaaCnNKZMizJ8+AAAA7 } set open { R0lGODlhEAAPAPcAAAAAAMbGxv//AP////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQAA8A AAhMAAMIHEiwoMGDCBMSBMBQoUAAAv4JYEix4UKJAiJq/AegIESJIDV2vCiyoskAHydmXMmyIwCJ EFm2fKhS5sqRKGPanLjQ5EmHQIMGBAA7 } set save { R0lGODlhEAAQAPcAAAAAAAAAnAAA/8bGxs7Ozv////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAMALAAAAAAQABAA AAhhAAcIHEiwoMGDBgEEECAAgMOHAgIAGKiQIYGLAQIQiDhRYEUBFwlk3CiR4sKGDx1yNMmwpcuG JlPKdBjzn82b/x7WxGlTp0eJPHvS/AkgaM6hAxQWDeozqUOjTWdKRUg1IAA7 } set copy { R0lGODlhEAAQAPcAAAAAAM7Ozv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhSAAEIHEhwYICDAP4pXMjwH4CDARISbOgQokSBFCsidDiQ4sONFxNyLChSoUiMDFGmdNhQpcmX KUuOdMlxoUyPJW+2zJnRJs+eM2m2hBiRZMGAAAA7 } set cut { R0lGODlhEAAQAPcAAAAAAMbGxv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhEAAMIHCgQAMGDCA0iXBhAocB/DhMOhMiw4MOICw1SrFhwI8eGGAcCGEnSI8GIJBk6VBhS5EiX LSU2/DizJkeWNEEeDAgAOw== } set paste { R0lGODlhEAAQAPcAAAAAAAAAY2NjY8bGxv////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAMALAAAAAAQABAA AAhgAAcIHEiwoMEBABICOIhQIQABAhwuFAjgn8WHCSNa/DexIkeIIDVypHhRYsKLJDeqVNlxZYCX MF+m3BjAZYCZFmuqrHnTI81/MIHK9JlzZU6ENmPypOhQp8uDSmMyZBgQADs= } set search { R0lGODlhEAAQAPcAAAAAAMbGxs7Ozv////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAg9AAMIHEiwoMGDCBMqXAigIYCCDh8GkCiQIsWJGBtirDjxoceOHR2C/DjQIkGSHFOmjAjRoYCF MGPKnDkzIAA7 } set test { R0lGODlhEAAQAPcAAAAAAAD/AMbGxv////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAA AAhTAAUIFAigoMGBCAkGWMgQQEKFDCM6RAggosUAEwVUvGhx4kaODQkaHEnSI8aTKE+arFgQY0uW CllKVBnT5UiaGkFKHPiRY0aIF3/yDPqQJ8mEAQEAOw== } set stop { R0lGODlhEAAQAPcAAAAAAMbGxv8AAP////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhWAAMIFAigoMGBCAkKWMgQQEKFDCM6RAggokUBEwNUvGhxYkWDIA1iVLjxI8aTHjGa/FhwpMaF K0/ChBhzo0uWKFvOfMlR4kCbHDNCvCj0J9GHP0MmDAgAOw== } #============================================================================ # Start it all up #============================================================================ # -- make certain that we're running against the appropriate Tcl release # version if {[info exists tcl_version] == 0 || $tcl_version < 7.5} { error "Error -- Tcl Editor: This program requires Tcl 7.5 or higher" } # -- verify that Tk is loaded and that it is the appropriate release version if {[info exists tk_version] == 0 || $tk_version < 4.1} { error "Error -- Tcl Editor: This program requires Tk 4.1 or higher" } # -- clear previous global variables foreach globalvar [info globals *ED*] { catch "unset $globalvar" dummy } foreach globalvar [info globals *ed*] { catch "unset $globalvar" dummy } # -- initialize session global variables set _ED(menuCount) 0; set _ED(pwd) [pwd] set _ED(editcursor) "" set _ED(editcurold) "" set _ED(srch_old) "" set _ED(srch_new) "" set _ED(file) "" set _ED(runslave) "" set _ED(package) "" set _ED(temppackage) "" set _ED(packagekeyname) "" set _ED(status) "Now editing file: $_ED(file)" set _ED(permstatus) "Now editing file: $_ED(file)" set _ED(blockflag) 0 if {$tcl_platform(platform) == "windows"} { set _ED(courierfont) {{Courier New} 11 {normal}} } else { set _ED(courierfont) "-*-Helvetica-Medium-R-Normal--12-*-*-*-*-*-*-*" } catch "destroy .ed_mainFrame" source spynergy.tcl bind Entry {tkEntryBackspace %W} ed_start_gui #--------- end of program