💾 Archived View for gemini.ctrl-c.club › ~nttp › toys › toyed › toyed.tcl captured on 2024-02-05 at 10:53:30.

View Raw

More Information

⬅️ Previous capture (2023-11-04)

🚧 View Differences

-=-=-=-=-=-=-

#!/usr/bin/env tclsh
#
# ToyEd: a toy text editor for educational purposes in Tcl/Tk.
# Copyright 2022, 2023 Felix Pleșoianu <https://felix.plesoianu.ro/>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.

package require Tcl 8.6
package require Tk 8.6

package require ctext
package require getstring
namespace import getstring::*

set window_title "ToyEd Text Editor"

set about_text "A toy text editor\nVersion 1.3 (23 Jan 2024)\nMIT License"
set credits_text "Made by No Time To Play\nbased on knowledge\nfrom TkDocs.com"
set site_link "https://ctrl-c.club/~nttp/toys/toyed/"

set file_types {
	{"All files" ".*"}
	{"Text files" ".txt .md"}
	{"Script files" ".py .tcl .sh"}
}

set file_name ""
set search_term ""
set _word_wrap 1

namespace eval font_size {
	variable minimum 6
	variable default 11
	variable maximum 16

	namespace export increase decrease reset
	namespace ensemble create

	variable current $default

	proc increase {widget {family "Courier"}} {
		variable current
		variable maximum
		if {$current < $maximum} {
			incr current
		}
		$widget configure -font "$family $current"
	}
	
	proc decrease {widget {family "Courier"}} {
		variable current
		variable minimum
		if {$current > $minimum} {
			incr current -1
		}
		$widget configure -font "$family $current"
	}

	proc reset {widget {family "Courier"}} {
		variable current
		variable default
		set current $default
		$widget configure -font "$family $current"
	}
}

namespace eval tk_util {
	proc pack_scrolled widget {
		set parent [winfo parent $widget]
		if {$parent == "."} {
			set scroll .scroll
		} else {
			set scroll $parent.scroll
		}
		ttk::scrollbar $scroll -orient "vertical" \
			-command "$widget yview"
		pack $widget -side "left" -fill "both" -expand 1
		$widget configure -yscrollcommand "$scroll set"
		pack $scroll -side "right" -fill y
	}

	proc load_text {widget content} {
		$widget delete 1.0 end
		$widget insert end $content
		$widget edit reset
		$widget edit modified 0
	}

	proc text_selection widget {
		if {[llength [$widget tag ranges sel]] > 0} {
			return [$widget get sel.first sel.last]
		} else {
			return ""
		}
	}

	proc paste_content widget {
		if {[llength [$widget tag ranges sel]] > 0} {
			$widget delete sel.first sel.last
		}
		tk_textPaste $widget
	}

	proc select_all widget {
		$widget tag remove sel 1.0 end
		$widget tag add sel 1.0 end
	}

	proc highlight_text {widget content {start "1.0"}} {
		set idx [$widget search -nocase $content $start]
		if {$idx ne ""} {
			set len [string length $content]
			set pos "$idx +$len chars"
			$widget tag remove "sel" "1.0" "end"
			$widget tag add "sel" $idx $pos
			$widget mark set "insert" $pos
			$widget see "insert"
			focus $widget
		}
		return $idx
	}

	proc open_line widget {
		$widget insert "insert +0 chars" "\n"
		$widget mark set "insert" "insert -1 chars"
	}

	proc word_wrap widget {
		if {[$widget cget -wrap] eq "word"} {
			$widget configure -wrap "none"
		} else {
			$widget configure -wrap "word"
		}
	}

	proc full_screen window {
		if {[wm attributes $window -fullscreen]} {
			wm attributes $window -fullscreen 0
		} else {
			wm attributes $window -fullscreen 1
		}
	}
}

wm title . $window_title
option add *tearOff 0
. configure -padx 4

if {[tk windowingsystem] == "x11"} {
	ttk::style theme use "clam"
}

pack [ttk::frame .toolbar] -side top -pady 4

ttk::frame .status
ttk::label .status.line -relief sunken -textvar status
ttk::sizegrip .status.grip

pack .status -side bottom -fill x -pady 4
pack .status.line -side left -fill x -expand 1
pack .status.grip -side right -anchor s

ctext .editor -width 80 -height 24 -wrap "word" -undo 1 -linemap 0
font_size::reset .editor
tk_util::pack_scrolled .editor

ttk::button .toolbar.new -text "New" -width 8 -command do_new
ttk::button .toolbar.bOpen -text "Open" -width 8 -command do_open
ttk::button .toolbar.save -text "Save" -width 8 -command do_save
ttk::button .toolbar.reload -text "Reload" -width 8 -command do_reload

ttk::separator .toolbar.sep1 -orient vertical

ttk::button .toolbar.undo -text "Undo" -width 8 -command {.editor edit undo}
ttk::button .toolbar.redo -text "Redo" -width 8 -command {.editor edit redo}
ttk::button .toolbar.find -text "Find" -width 8 -command do_find
ttk::button .toolbar.next -text "Next" -width 8 -command find_again

pack .toolbar.new -side left
pack .toolbar.bOpen -side left
pack .toolbar.save -side left
pack .toolbar.reload -side left

pack .toolbar.sep1 -side left -padx 4 -pady 4 -fill y

pack .toolbar.undo -side left
pack .toolbar.redo -side left
pack .toolbar.find -side left
pack .toolbar.next -side left

. configure -menu [menu .menubar]

set m [menu .menubar.mFile]
$m add command -label "New" -command do_new -under 0 -accel "Ctrl-N"
$m add command -label "Open..." -command do_open -under 0 -accel "Ctrl-O"
$m add command -label "Save" -command do_save -under 0 -accel "Ctrl-S"
$m add separator
$m add command -label "Save as..." -command do_save_as -under 5
$m add command -label "Reload" -command do_reload -under 0 -accel "Ctrl-R"
$m add command -label "Statistics" -command show_stats -under 1 -accel "Ctrl-T"
$m add separator
$m add command -label "Quit" -command do_quit -under 0 -accel "Ctrl-Q"
.menubar add cascade -menu .menubar.mFile -label "File" -underline 0

set m [menu .menubar.edit]
$m add command -label "Undo" -command {.editor edit undo} \
	-underline 0 -accelerator "Ctrl-Z"
$m add command -label "Redo" -command {.editor edit redo} \
	-underline 0 -accelerator "Ctrl-Y"
$m add separator
$m add command -label "Cut" -command {tk_textCut .editor} \
	-underline 0 -accelerator "Ctrl-X"
$m add command -label "Copy" -command {tk_textCopy .editor} \
	-underline 1 -accelerator "Ctrl-C"
$m add command -label "Paste" -command {tk_util::paste_content .editor} \
	-underline 0 -accelerator "Ctrl-V"
$m add separator
$m add command -label "Select all" -under 7 -accel "Ctrl-A" \
	-command {tk_util::select_all .editor; break}
$m add command -label "Find..." -command do_find -under 0 -accel "Ctrl-F"
$m add command -label "Again" -command find_again -under 1 -accel "Ctrl-G"
.menubar add cascade -menu .menubar.edit -label "Edit" -underline 0

set m [menu .menubar.mFormat]
$m add command -label "Join lines" -command join_lines -under 0 -accel "Alt-J"
$m add command -label "Open line" -under 0 -accel "Alt-O" \
	-command {tk_util::open_line .editor}
$m add separator
$m add command -label "Lower case" -command lower_case -under 0 -accel "Alt-L"
$m add command -label "Title case" -command title_case -under 1 -accel "Alt-T"
$m add command -label "Upper case" -command upper_case -under 0 -accel "Alt-U"
$m add separator
$m add command -label "Prefix lines..." -command prefix_lines \
	-under 0 -accel "Alt-P"
.menubar add cascade -menu .menubar.mFormat -label "Format" -underline 3

set m [menu .menubar.view]
$m add checkbutton -label "Word wrap" -under 0 -var _word_wrap \
	-command {tk_util::word_wrap .editor}
$m add checkbutton -label "Line numbers" -under 0 -var _line_nums \
	-command {toggle_lines .editor}
$m add separator
$m add command -label "Bigger font" -under 0 -accel "Ctrl +" \
	-command {font_size incr .editor}
$m add command -label "Smaller font" -under 0 -accel "Ctrl -" \
	-command {font_size decr .editor}
$m add command -label "Reset font" -under 0 -accel "Ctrl-0" \
	-command {font_size reset .editor}
$m add separator
if {[llength [info commands "console"]] > 0} {
	$m add command -label "Console" -command {console show} \
		-underline 5 -accelerator "Ctrl-L"
}
$m add checkbutton -label "Full screen" -command {tk_util::full_screen .} \
	-underline 10 -accelerator "F11" -var _full_screen
.menubar add cascade -menu .menubar.view -label "View" -underline 0

set m [menu .menubar.help]
$m add command -label "About" -command {alert $about_text} -under 0
$m add command -label "Credits" -command {alert $credits_text} -under 0
$m add command -label "Website" -command {open_in_app $site_link} -under 0
.menubar add cascade -menu .menubar.help -label "Help" -underline 0

wm protocol . WM_DELETE_WINDOW do_quit
bind .editor <<Modified>> show_modified

bind . <Control-n> do_new
bind . <Control-o> do_open
bind . <Control-s> do_save
bind . <Control-r> do_reload
bind . <Control-t> show_stats
bind . <Control-q> do_quit

bind . <Command-n> do_new
bind . <Command-o> do_open
bind . <Command-s> do_save
bind . <Command-r> do_reload
bind . <Command-t> show_stats
bind . <Command-q> do_quit

# Undo, cut and copy are already bound to their usual keys by default.
# Many bindings here have to override broken defaults.

bind .editor <Control-y> {.editor edit redo}
bind .editor <Control-v> {tk_util::paste_content .editor; break}
bind .editor <Control-a> {tk_util::select_all .editor; break}
bind . <Control-f> do_find
bind . <Control-g> find_again

bind .editor <Command-y> {.editor edit redo}
bind .editor <Command-v> {tk_util::paste_content .editor; break}
bind .editor <Command-a> {tk_util::select_all .editor; break}
bind . <Command-f> do_find
bind . <Command-g> find_again

bind Text <Control-o> {}
bind .editor <Alt-j> join_lines
bind .editor <Alt-o> {tk_util::open_line .editor; break}
bind .editor <Alt-l> {lower_case; break}
bind .editor <Alt-t> {title_case; break}
bind .editor <Alt-u> upper_case
bind .editor <Alt-p> prefix_lines

bind . <Control-equal> {font_size::increase .editor}
bind . <Control-minus> {font_size::decrease .editor}
bind . <Control-Key-0> {font_size::reset .editor}

bind . <Command-equal> {font_size::increase .editor}
bind . <Command-minus> {font_size::decrease .editor}
bind . <Command-Key-0> {font_size::reset .editor}

bind . <F11> {tk_util::full_screen .}

if {[llength [info commands "console"]] > 0} {
	bind . <Control-l> {console show}
	bind . <Command-l> {console show}
}

proc show_modified {} {
	global status
	if {[.editor edit modified]} {
		set status "(modified)"
	}
}

proc do_new {} {
	global status file_name window_title

	if {[.editor edit modified]} {
		set answer [tk_messageBox -parent . \
			-type "yesno" -icon "question" \
			-title $window_title \
			-message "New file?" \
			-detail "File isn't saved.\nStart another?"]
		if {!$answer} {
			set status "New file canceled."
			return
		}
	}
	wm title . $window_title
	set file_name ""
	.editor delete "1.0" "end"
	.editor edit reset
	.editor edit modified 0
	set status [clock format [clock seconds]]
}

proc do_open {} {
	global status file_types file_name window_title
	
	if {[.editor edit modified]} {
		set answer [tk_messageBox -parent . \
			-type "yesno" -icon "question" \
			-title $window_title \
			-message "Open another file?" \
			-detail "File isn't saved.\nOpen another?"]
		if {!$answer} {
			set status "Opening canceled."
			return
		}
	}
	
	if {[tk windowingsystem] == "x11" && [auto_execok "zenity"] ne ""} {
		set choice [open_with_zenity $file_name]
	} else {
		set choice [tk_getOpenFile -parent . \
			-title "Open existing file" \
			-initialdir [file_dir $file_name] \
			-filetypes $file_types]
	}
	
	if {[string length $choice] == 0} {
		set status "Opening canceled."
	} elseif {![file isfile $choice]} {
		tk_messageBox -parent . \
			-type "ok" -icon "error" \
			-title $window_title \
			-message "Error opening file" \
			-detail "File not found: $choice"
	} elseif {[load_file $choice]} {  
		set file_name $choice
	}
}

proc open_with_zenity file_name {
	try {
		if {$file_name ne ""} {
			return [exec zenity --file-selection \
				--title "Open existing file" \
				--filename $file_name \
				--file-filter "All files | *" \
				--file-filter "Text files | *.txt *.md" \
				--file-filter "Script files | *.py *.tcl *.sh"]
		} else {
			return [exec zenity --file-selection \
				--title "Open existing file" \
				--file-filter "All files | *" \
				--file-filter "Text files | *.txt *.md" \
				--file-filter "Script files | *.py *.tcl *.sh"]
		}
	} trap CHILDSTATUS {results options} {
		return ""
	}
}

proc load_file full_path {
	global status window_title
	
	set fn [file tail $full_path]
	try {
		set f [open $full_path]
		tk_util::load_text .editor [read $f]
		set status "Opened $fn"
		wm title . "$fn | $window_title"
		return 1
	} on error e {
		tk_messageBox -parent . \
			-type "ok" -icon "error" \
			-title $window_title \
			-message "Error opening file" \
			-detail $e
		return 0
	} finally {
		close $f
	}
}

proc file_dir name {
	if {$name ne ""} {
		return [file dirname $name]
	} else {
		return [pwd]
	}
}

proc do_save {} {
	global file_name
	if {$file_name eq ""} {
		do_save_as
	} else {
		save_file $file_name
	}
}

proc do_save_as {} {
	global file_name file_types status
	
	if {[tk windowingsystem] == "x11" && [auto_execok "zenity"] ne ""} {
		set choice [save_with_zenity $file_name]
	} else {
		set choice [tk_getSaveFile -parent . \
			-title "Save file as..." \
			-initialdir [file_dir $file_name] \
			-filetypes $file_types]
	}
	if {[string length $choice] == 0} {
		set status "Save canceled."
	} elseif {[save_file $choice]} {
		set file_name $choice
	}
}

proc save_with_zenity file_name {
	try {
		if {$file_name ne ""} {
			return [exec zenity --file-selection \
				--title "Save file as..." \
				 --save --confirm-overwrite \
				--filename $file_name \
				--file-filter "All files | *" \
				--file-filter "Text files | *.txt *.md" \
				--file-filter "Script files | *.py *.tcl *.sh"]
		} else {
			return [exec zenity --file-selection \
				--title "Save file as..." \
				 --save --confirm-overwrite \
				--file-filter "All files | *" \
				--file-filter "Text files | *.txt *.md" \
				--file-filter "Script files | *.py *.tcl *.sh"]
		}
	} trap CHILDSTATUS {results options} {
		return ""
	}
}

proc save_file full_path {
	global status window_title

	set fn [file tail $full_path]
	set data [.editor get "1.0" "end"]
	set data [string trimright $data "\n"]
	try {
		set f [open $full_path "w"]
		puts -nonewline $f "$data\n"
		flush $f
		.editor edit modified 0
		set status "Saved $fn"
		wm title . "$fn | $window_title"
		return 1
	} on error e {
		tk_messageBox -parent . \
			-type "ok" -icon "error" \
			-title $window_title \
			-message "Error saving file" \
			-detail $e
		return 0
	} finally {
		close $f
	}
}

proc do_reload {} {
	global file_name status window_title
	if {$file_name eq ""} {
		tk_messageBox -parent . \
			-type "ok" -icon "warning" \
			-title $window_title \
			-message "Can't reload." \
			-detail "The file was never saved."
	} else {
		set answer [tk_messageBox -parent . \
			-type "yesno" -icon "question" \
			-title $window_title \
			-message "Reload file?" \
			-detail "Reload last save?"]
		if {$answer eq "yes"} {
			load_file $file_name
		} else {
			set status "Reloading canceled."
		}
	}
}

proc show_stats {} {
	global window_title
	set data [tk_util::text_selection .editor]
	if {$data eq ""} {
		set data [.editor get "1.0" "end"]
		set msg "File statistics"
	} else {
		set msg "Selection stats"
	}
	set clean [string trimright $data "\n"]
	set lines [llength [split $clean "\n"]]
	set words [regexp -all {\S+} $data]
	set chars [string length $data]
	set stats "Lines: $lines\nWords: $words\nCharacters: $chars"
	tk_messageBox -parent . \
		-type "ok" -icon "info" -title $window_title \
		-message $msg -detail $stats
}

proc do_quit {} {
	global window_title
	if {[.editor edit modified]} {
		set answer [tk_messageBox -parent . \
			-type "yesno" -icon "question" \
			-title $window_title \
			-message "Quit $window_title?" \
			-detail "File is unsaved.\nQuit anyway?"]
	} else {
		set answer "yes"
	}
	if {$answer eq "yes"} {
		destroy .
	}
}

proc do_find {} {
	global search_term status
	set term [tk_util::text_selection .editor]
	set ret [tk_getString .gs answer "Search term:" \
		-title "Find" -entryoptions "-textvar search_term"]
	if {!$ret} {
		set status "Search canceled."
		return
	}
	set search_term $answer; # Possibly redundant
	step_search
}

proc find_again {} {
	global search_term status
	if {$search_term eq ""} {
		do_find
	} else {
		step_search
	}
}

proc step_search {} {
	global search_term status
	set res [tk_util::highlight_text .editor $search_term "insert"]
	if {$res eq ""} {
		set search_term ""
		set status "Nothing found."
	}
}

proc join_lines {} {
	global status
	set t [tk_util::text_selection .editor]
	if {[string length $t] > 0} {
		set t [string map {"\n" " "} $t]
		.editor replace sel.first sel.last $t
	} else {
		set status "Nothing selected."
	}
}

proc lower_case {} {
	global status
	set t [tk_util::text_selection .editor]
	if {[string length $t] > 0} {
		.editor replace sel.first sel.last [string tolower $t]
	} else {
		set status "Nothing selected."
	}
}

proc title_case {} {
	global status
	set sel [tk_util::text_selection .editor]
	if {[string length $sel] > 0} {
		.editor replace sel.first sel.last [string totitle $sel]
	} else {
		set status "Nothing selected."
	}
}

proc upper_case {} {
	global status
	set sel [tk_util::text_selection .editor]
	if {[string length $sel] > 0} {
		.editor replace sel.first sel.last [string toupper $sel]
	} else {
		set status "Nothing selected."
	}
}

proc prefix_lines {} {
	global status
	set sel [tk_util::text_selection .editor]
	if {$sel eq ""} {
		set status "Nothing selected."
		return
	}
	set ret [tk_getString .gs answer "Prefix selected lines with:"]
	if {!$ret} {
		set status "Prefix canceled."
		return
	}
	set lines [split $sel "\n"]
	set result [list]
	foreach l $lines {
		lappend result $answer$l
	}
	.editor replace sel.first sel.last [join $result "\n"]
}

proc toggle_lines widget {
	if {[$widget cget -linemap]} {
		$widget configure -linemap 0
	} else {
		$widget configure -linemap 1
	}
}

proc alert message {
	global window_title
	tk_messageBox -parent . \
		-type "ok" -icon "info" \
		-title $window_title \
		-message $message
}

proc open_in_app link {
	global status
	if {[auto_execok "xdg-open"] ne ""} {
		catch {exec "xdg-open" $link &}
	} elseif {[auto_execok "open"] ne ""} {
		catch {exec "open" $link &}
	} elseif {[auto_execok "start"] ne ""} {
		catch {exec "start" $link &}
	} else {
		set status "Can't open website."
	}
}

set status [clock format [clock seconds]]

if {[llength $argv] > 0} {
	set fn [lindex $argv 0]
	if {![file exists $fn]} {
		set file_name [file normalize $fn]
		set fn [file tail $file_name]
		wm title . "$fn | $window_title"
	} elseif {[load_file $fn]} {
		set file_name [file normalize $fn]
	}
}