#!/usr/bin/wish
proc get_fname {{dir .}} {
global _fname
set _fname ""
catch {destroy .file}
toplevel .file
wm title .file {File Dialog}
frame .file.file -border 6 -relief groove
frame .file.dir -border 6 -relief groove
frame .file.cmd -border 6 -relief groove
label .file.file.l -text {File Name:}
entry .file.file.name -width 20 -font 7x14
listbox .file.file.lb -height 10 -width 20 -selectmode browse -yscrollcommand {.file.file.sb set}
scrollbar .file.file.sb -orient v -command {.file.file.lb yview}
label .file.dir.l -text {Directory}
button .file.cmd.ok -text {OK} -command {
set tmp [.file.file.name get]
if {$tmp==""} {
set tmp [.file.file.lb curselection]
if {$tmp==""} {
bell
return
}
set tmp [.file.file.lb get $tmp]
}
set _fname $tmp
destroy .file
}
button .file.cmd.cancel -text {Cancel} -command { destroy .file }
listbox .file.dir.up -height 0 -width 20 -selectmode browse
label .file.dir.cur -text "Current"
listbox .file.dir.dir
pack .file.file -side left -fill y
pack .file.dir -side left -fill y
pack .file.cmd -side left -fill y
pack .file.file.l -side top
pack .file.file.name -side top
pack .file.file.lb -side left -fill y
pack .file.file.sb -side left -fill y
pack .file.dir.l -side top
pack .file.cmd.ok -side top -fill x
pack .file.cmd.cancel -side top -fill x
pack .file.dir.up .file.dir.cur -side top
pack .file.dir.dir -side left
foreach name [glob $dir/*] {
if [file isdirectory $name] {
.file.dir.dir insert end [file tail $name]
} else {
.file.file.lb insert end [file tail $name]
}
}
bind .file.file.lb <1> {
.file.file.name delete 0 end
.file.file.name insert 0 [.file.file.lb get @%x,%y]
}
bind .file.file.lb <Double-1> {
.file.cmd.ok invoke
}
grab .file
tkwait window .file
return $_fname
}
proc load fname {
global edit_mode
return [
catch {
set file [open $fname r]
.t delete 1.0 end
.t insert end [read -nonewline $file]
close $file
.f.n configure -text $fname
set_mode "flat"
}
]
}
proc fi_new {} {
catch {destroy .load }
catch {destroy .save }
set conf [tk_dialog .confirm "Confirmation" "Are you sure you want to wipe out the current document?" questhead {} NO! Yes]
if {$conf == 1} {
.t delete 1.0 end
.f.n configure -text "untitled"
}
}
proc fi_load {} {
set fname [get_fname]
if {$fname == ""} return
load $fname
}
proc fi_save {} {
chk_edit_mode flat
catch { destroy .save }
toplevel .save
wm title .save "Save File"
label .save.q -text {File to save:}
entry .save.fname -font 7x14
.save.fname insert end [.f.n cget -text]
button .save.confirm -text "Confirm" -command {
catch {
# Get file mode
set fmod 644
catch {
file stat [.save.fname get] stat
set fmod [expr $stat(mode) & 0777]
set fmod "[expr $fmod / 64][expr ($fmod/8) % 8][expr $fmod % 8]"
}
# Make backups
catch {eval exec /bin/mv [.save.fname get]~ [.save.fname get]~~}
catch {eval exec /bin/mv [.save.fname get] [.save.fname get]~}
# Save the file
set file [open [.save.fname get] w]
puts -nonewline $file [.t get 1.0 end]
close $file
# Set the file permissions
catch {eval exec /bin/chmod $fmod [.save.fname get]}
# Clean up
.f.n configure -text [.save.fname get]
}
destroy .save
}
pack .save.q .save.fname .save.confirm
}
proc ins stuff {
.t insert insert $stuff
}
proc wcc name {
global contlist
catch {destroy .wcc}
toplevel .wcc
wm title .wcc [concat $name "Widget Code Creator"]
frame .wcc.n
label .wcc.n.cl -text "Container"
eval tk_optionMenu .wcc.n.cont cont $contlist
label .wcc.n.nl -text "Name"
entry .wcc.n.name -width 30 -font 7x14
frame .wcc.a -relief raised -border 3
frame .wcc.p
label .wcc.p.lside -text "Side"
tk_optionMenu .wcc.p.side side top left right bottom
label .wcc.p.lfill -text "Fill"
tk_optionMenu .wcc.p.fill fill none x y both
label .wcc.p.lanch -text "Anchor"
tk_optionMenu .wcc.p.anch anchor center n s e w ne se sw nw
checkbutton .wcc.p.expand -text "Expand" -variable expand
frame .wcc.c
frame .wcc.b -border 3 -relief sunken
button .wcc.b.dismiss -text "Dismiss" -command { destroy .wcc }
pack .wcc.n.cl .wcc.n.cont .wcc.n.nl .wcc.n.name -side left
pack .wcc.n
pack .wcc.a
pack .wcc.p.lside .wcc.p.side .wcc.p.lfill .wcc.p.fill -side left
pack .wcc.p.lanch .wcc.p.anch .wcc.p.expand -side left
pack .wcc.p .wcc.c .wcc.b -side top -fill x
pack .wcc.b -fill x
}
proc widpath {} {
global cont
return ${cont}[.wcc.n.name get]
}
proc packline {} {
global side fill anchor expand widlist
set tmp [widpath]
ins "\npack $tmp -side $side -fill $fill"
if {$anchor != "center"} {ins " -anchor $anchor"}
if {$expand} {ins " -expand 1"}
ins "\n"
lappend widlist $tmp
catch {.wl.lb insert end $tmp}
}
proc add_obj {} {
global oarr obj widlist side fill anchor expand q_nid
set obj(name) [widpath]
set tmp "-side $side"
if {$fill != "none"} {set tmp "$tmp -fill $fill"}
if {$anchor != "center"} {set tmp "$tmp -anchor $anchor"}
if {$expand} {set tmp "$tmp -expand 1"}
set obj(pack) $tmp
set enum $q_nid
incr q_nid
set oarr($enum) [array get obj]
lappend widlist $enum
catch {
eval "$obj(type) .ex$obj(name) $obj(app)"
eval "pack .ex$obj(name) $obj(pack)"
}
catch {
.wl.lb insert end $obj(name)
}
}
proc code_oarr root {
global oarr widlist
ins "\n"
# Spout widget creation commands
set max [array size oarr]
foreach i $widlist {
catch {unset obj}
array set obj $oarr($i)
ins "$obj(type) $root$obj(name) $obj(app) $obj(cfg)\n"
}
ins "\n"
# Spout widget packing commands
foreach i $widlist {
catch {unset obj}
array set obj $oarr($i)
ins "pack $root$obj(name) $obj(pack)\n"
}
ins "\n"
}
proc put_oarr {} {
global widlist oarr
set f [open test w]
puts $f "*** --- This is a generated file. Do not hand edit --- ***"
puts $f $widlist
puts $f [array get oarr]
close $f
}
proc get_oarr {} {
global widlist oarr
set f [open test r]
catch {
gets $f
gets $f widlist
unset oarr
array set oarr [read -nonewline $f]
}
close $f
}
proc setlang {} {
global lang
set_menu_bar
cluehunt ""
}
proc cluehunt_sql clue {
set cl {{select} {insert} {update} {delete} {where}}
clue_offer $cl
}
proc cluehunt clue {
global lang
# First try to get some context
# Then hit up a database to get guesses
# One source of guesses is a markov-like chain
# Can make one from a text file if can parse into words
# Can maintain one in a few arrays
# {{select} {insert} {update} {delete}}
# {{from} {into} {where} {sort by} {group by}}
switch $lang {
sql {cluehunt_sql $clue}
eng {cluehunt_english $clue}
tk {cluehunt_tk $clue}
}
}
proc cluehit hit {
set tmp [.clue.b${hit} cget -text]
ins $tmp
cluehunt $tmp
}
proc mk_label {} {
global contlist
wcc {Label}
label .wcc.a.cl -text "Label Contents:"
entry .wcc.a.ce -width 60 -font 7x14
button .wcc.b.code -text "Write Code" -command {
.t insert insert "\nlabel [widpath] -text \{[.wcc.a.ce get]\}\n"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "label"
set obj(app) "-text \{[.wcc.a.ce get]\}"
set obj(cfg) ""
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.cl .wcc.a.ce -side top
pack .wcc.b.code -side left
pack .wcc.b.dismiss -side right
}
proc mk_entry {} {
global contlist
wcc {Entry}
scale .wcc.a.width -orient h -label "Width" -from 4 -to 80
.wcc.a.width set 20
button .wcc.b.code -text "Write Code" -command {
ins "\nentry [widpath] -width [.wcc.a.width get] -font 7x14\n"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "entry"
set obj(app) "-width [.wcc.a.width get] -font 7x14"
set obj(cfg) ""
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.width -fill x -side top
pack .wcc.b.code .wcc.b.dismiss -side left
pack .wcc.b.dismiss -side right
}
proc mk_scale {} {
global contlist
wcc {Scale}
label .wcc.a.cl -text "Label Contents:"
entry .wcc.a.ce -width 60 -font 7x14
frame .wcc.a.f
label .wcc.a.f.lfrom -text {From}
entry .wcc.a.f.from -width 6 -font 7x14
label .wcc.a.f.lto -text {To}
entry .wcc.a.f.to -width 6 -font 7x14
label .wcc.a.f.lres -text {Resolution}
entry .wcc.a.f.res -width 6 -font 7x14
label .wcc.a.f.lori -text {Orientation}
tk_optionMenu .wcc.a.f.ori orient h v
button .wcc.b.code -text "Write Code" -command {
ins "\nscale [widpath]"
if { "" != [.wcc.a.f.from get]} {ins " -from [.wcc.a.f.from get]"}
if { "" != [.wcc.a.f.to get]} {ins " -to [.wcc.a.f.to get]"}
if { "" != [.wcc.a.f.res get]} {ins " -resolution [.wcc.a.f.res get]"}
ins " -orient $orient"
if { "" != [.wcc.a.ce get]} {ins " -label \{[.wcc.a.ce get]\}"}
ins "\n"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "scale"
set tmp "-orient $orient"
if { "" != [.wcc.a.f.from get]} {set tmp "$tmp -from [.wcc.a.f.from get]"}
if { "" != [.wcc.a.f.to get]} {set tmp "$tmp -to [.wcc.a.f.to get]"}
if { "" != [.wcc.a.f.res get]} {set tmp "$tmp -resolution [.wcc.a.f.res get]"}
if { "" != [.wcc.a.ce get]} {set tmp "$tmp -label \{[.wcc.a.ce get]\}"}
set obj(app) $tmp
set obj(cfg) ""
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.f.lfrom .wcc.a.f.from .wcc.a.f.lto .wcc.a.f.to .wcc.a.f.lres .wcc.a.f.res .wcc.a.f.lori .wcc.a.f.ori -side left
pack .wcc.a.cl .wcc.a.ce -side top
pack .wcc.a.f -fill x -side top
pack .wcc.b.code -side left
pack .wcc.b.dismiss -side right
}
proc mk_scrollbar {} {
global contlist
wcc {Scrollbar}
label .wcc.a.lori -text {Orientation}
tk_optionMenu .wcc.a.ori orient h v
label .wcc.c.l1 -text {Command:}
entry .wcc.c.command -width 40 -font 7x14
button .wcc.b.code -text "Write Code" -command {
ins "\nscrollbar [widpath] -orient $orient -command \{[.wcc.c.command get]\}"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "scrollbar"
set obj(app) "-orient $orient"
set obj(cfg) "-command \{[.wcc.c.command get]\}"
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.lori .wcc.a.ori -side left
pack .wcc.c.l1 -side left -fill none
pack .wcc.c.command -side left -fill none
pack .wcc.b.code -side left
pack .wcc.b.dismiss -side right
}
proc mk_frame {} {
global widlist contlist cont
wcc "Frame"
scale .wcc.a.border -to 25 -orient h -label {Border Size}
label .wcc.a.lbev -text {Relief Type:}
tk_optionMenu .wcc.a.rel relief flat groove raised ridge sunken
button .wcc.b.code -text "Write Code" -command {
set tmp [widpath]
ins "\nframe $tmp"
if [.wcc.a.border get] {ins " -border [.wcc.a.border get] -relief $relief"}
ins "\n"
packline
lappend contlist ${tmp}.
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "frame"
set obj(app) "-border [.wcc.a.border get] -relief $relief"
set obj(cfg) ""
add_obj
lappend contlist [widpath].
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.border .wcc.a.lbev .wcc.a.rel -side left
pack .wcc.b.code .wcc.b.dismiss -side left
pack .wcc.b.dismiss -side right
}
proc mk_button {} {
global contlist
wcc {Button}
label .wcc.a.cl -text "Label Contents:"
entry .wcc.a.ce -width 30 -font 7x14
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "button"
set obj(app) "-text {[.wcc.a.ce get]}"
set obj(cfg) "-command \{[.wcc.c.comm get 1.0 end ]\}"
add_obj
}
pack .wcc.b.al -side left -fill none
label .wcc.c.lc -text {Button Command:}
text .wcc.c.comm -font 7x14 -width 60 -height 5
scrollbar .wcc.c.sb -orient v -command ".wcc.c.comm yview"
.wcc.c.comm configure -yscrollcommand ".wcc.c.sb set"
pack .wcc.a.cl .wcc.a.ce -side top
pack .wcc.c.lc -side top
pack .wcc.c.comm .wcc.c.sb -side left -fill y
pack .wcc.b.al -side left
pack .wcc.b.dismiss -side right
}
proc mk_text {} {
global contlist
wcc {Text}
scale .wcc.a.width -orient h -label "Width" -from 10 -to 120 -length 220
scale .wcc.a.height -orient v -label "Height" -from 2 -to 50 -length 100
checkbutton .wcc.a.sg -text "Set Grid" -variable setgrid
checkbutton .wcc.a.font -text "7x14 Font" -variable tfont
.wcc.a.width set 80
.wcc.a.height set 24
button .wcc.b.code -text "Write Code" -command {
ins "\ntext [widpath] -width [.wcc.a.width get] -height [.wcc.a.height get]"
if {$setgrid} {ins " -setgrid 1"}
if {$tfont} {ins " -font 7x14"}
ins "\n"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "text"
set tmp "-width [.wcc.a.width get] -height [.wcc.a.height get]"
if {$setgrid} {set tmp "$tmp -setgrid 1"}
if {$tfont} {set tmp "$tmp -font 7x14"}
set obj(app) $tmp
set obj(cfg) ""
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.width -side left -anchor n
pack .wcc.a.height -side left
pack .wcc.a.sg .wcc.a.font -side top
pack .wcc.b.code -side left
pack .wcc.b.dismiss -side right
}
proc mk_listbox {} {
global contlist
wcc {Listbox}
scale .wcc.a.height -orient h -label "Height" -from 0 -to 35 -length 105
scale .wcc.a.width -orient h -label "Width" -from 10 -to 120 -length 220
label .wcc.a.l1 -text {Select Mode}
tk_optionMenu .wcc.a.sm selmode single browse multiple extended
.wcc.a.width set 20
.wcc.a.height set 10
button .wcc.b.code -text "Write Code" -command {
ins "\nlistbox [widpath] -height [.wcc.a.height get] -width [.wcc.a.width get] -selectmode $selmode"
packline
}
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "listbox"
set obj(app) "-height [.wcc.a.height get] -width [.wcc.a.width get] -selectmode $selmode"
set obj(cfg) ""
add_obj
}
pack .wcc.b.al -side left -fill none
pack .wcc.a.height .wcc.a.width -side left
pack .wcc.a.l1 .wcc.a.sm -side top -fill none
pack .wcc.b.code -side left
pack .wcc.b.dismiss -side right
}
proc mk_toplevel {} {
global toplist contlist cont
catch {destroy .wcc}
toplevel .wcc
wm title .wcc "Top Level Window Creator"
label .wcc.l1 -text {Toplevel Widget Name (without the leading dot)}
pack .wcc.l1 -side top -fill none
entry .wcc.name -width 20 -font 7x14
pack .wcc.name -side top -fill none
label .wcc.l2 -text {Window Title}
pack .wcc.l2 -side top -fill none
entry .wcc.title -width 40 -font 7x14
pack .wcc.title -side top -fill none
button .wcc.code -text {Code} -command {
set tmp .[.wcc.name get]
# Put the actual lines in the file.
ins "catch \{destroy $tmp\}\n"
ins "toplevel $tmp\n"
ins "wm title $tmp \{[.wcc.title get]\}\n"
# From here down would need redone later on.
lappend toplist ${tmp}.
lappend contlist ${tmp}.
# No longer do this: lappend widlist $tmp
set cont ${tmp}.
# The point of the below is to make sure the widget previewer works
catch {destroy .ex}
toplevel .ex
wm title .ex [.wcc.title get]
bind .ex <3> {widpop %X %Y %W}
frame .ex.[.wcc.name get] -width 50 -height 50
pack .ex.[.wcc.name get] -side top -fill both -expand 1
}
pack .wcc.code -side left -fill none
}
proc mk_combo {} {
}
proc mk_proc {} {
catch {destroy .wcc}
toplevel .wcc
wm title .wcc {Procedure Template}
label .wcc.l1 -text {Procedure Name}
entry .wcc.name -width 20 -font 7x14
label .wcc.l2 -text {Arguments}
pack .wcc.l1 -side top -fill none
pack .wcc.name -side top -fill none
pack .wcc.l2 -side top -fill none
frame .wcc.a -border 3 -relief sunken
pack .wcc.a -side top -fill both -expand 1
listbox .wcc.a.l -yscrollcommand {.wcc.a.sb set}
scrollbar .wcc.a.sb -orient v -command {.wcc.a.l yview}
pack .wcc.a.l -side left -fill both -expand 1
pack .wcc.a.sb -side left -fill y
label .wcc.l3 -text {New Argument (and default)}
pack .wcc.l3 -side top -fill none
entry .wcc.arg -width 20 -font 7x14
pack .wcc.arg -side top -fill none
button .wcc.add -text {Add Argument} -command {
.wcc.a.l insert end [.wcc.arg get]
}
pack .wcc.add -side top -fill none
button .wcc.code -text {Write Code} -command {
ins "\nproc [.wcc.name get] "
ins [list [.wcc.a.l get 0 end]]
ins " \{\n\}\n"
}
pack .wcc.code -side top -fill none
bind .wcc.arg <Key-Return> { .wcc.add invoke }
}
proc wi_immediate {} {
catch {destroy .im}
toplevel .im
wm title .im "immediate mode executor"
frame .im.h
label .im.h.l -text "History List"
listbox .im.h.lb -width 60 -height 5 -font 7x14 -selectmode extended -yscrollcommand {.im.h.sb set}
scrollbar .im.h.sb -orient v -command {.im.h.lb yview}
frame .im.c
label .im.c.l -text "Command Entry"
text .im.c.line -height 4 -width 60 -font 7x14 -yscrollcommand {.im.c.sb set}
scrollbar .im.c.sb -orient v -command {.im.c.line yview}
button .im.eval -command {
set tmp [eval [.im.c.line get 1.0 end]]
if {""!=$tmp} {puts $tmp}
} -text Evaluate
button .im.clear -text Clear -command {.im.c.line delete 1.0 end}
button .im.append -text Append -command {.im.h.lb insert end [.im.c.line get 1.0 end]}
button .im.dismiss -text "Dismiss" -command {destroy .im}
pack .im.h.l -side top
pack .im.h.sb -side right -fill y
pack .im.h.lb -side left -expand 1 -fill x
pack .im.c.l -side top
pack .im.c.sb -side right -fill y
pack .im.c.line -side left -expand 1 -fill both
pack .im.h -side top -fill x
pack .im.c -side top -expand 1 -fill both
pack .im.dismiss .im.clear .im.append .im.eval -side right
}
proc wi_widgetlist {} {
global widlist oarr
catch {destroy .wl}
toplevel .wl
wm title .wl {Widget List}
listbox .wl.lb -height 0 -font 7x14
foreach w $widlist {
array set obj $oarr($w)
.wl.lb insert end $obj(name)
}
pack .wl.lb
frame .wl.move
pack .wl.move
button .wl.move.up -text {Move up} -command {
set num [.wl.lb curselection]
if {""==$num} return
if {$num==0} return
widflip $num
incr num -1
.wl.lb selection set $num
.wl.lb see $num
}
pack .wl.move.up -side left -fill none
button .wl.move.dn -text {Move down} -command {
set num [.wl.lb curselection]
if {""==$num} return
incr num 1
if {$num==[.wl.lb index end]} return
widflip $num
.wl.lb selection set $num
.wl.lb see $num
}
pack .wl.move.dn -side left -fill none
frame .wl.rank
frame .wl.edit
pack .wl.rank .wl.edit
button .wl.rank.pro -text "Promote"
button .wl.rank.dem -text "Demote"
pack .wl.rank.pro .wl.rank.dem -side left
button .wl.edit.edit -text "Edit" -command {
set num [.wl.lb curselection]
if {""==$num} return
widedit [lindex $widlist $num]
}
button .wl.edit.dele -text "Delete" -command {
qtk_delwidget
}
pack .wl.edit.edit .wl.edit.dele -side left
}
proc wi_example {} {
catch {destroy .ex}
toplevel .ex
wm title .ex "Example Dialog"
bind .ex <3> {widpop %X %Y %W}
qtk_inval_example
}
proc wi_toplist {} {
global toplist
catch {destroy .tl}
toplevel .tl
wm title .tl {Toplevel List}
frame .tl.f -border 4 -relief groove
listbox .tl.f.l -height 10 -yscrollcommand {.tl.f.sb set}
scrollbar .tl.f.sb -orient v -command {.tl.f.l yview}
pack .tl.f.l -side left -fill both -expand 1
pack .tl.f.sb -side left -fill y
pack .tl.f -side top -fill both -expand 1
button .tl.prev -text {Preview} -command {toplev_preview}
pack .tl.prev -side left -fill none
button .tl.select -text {Select} -command {toplev_select}
pack .tl.select -side left -fill none
button .tl.code -text {Write Code} -command {toplev_code}
pack .tl.code -side left -fill none
button .tl.dismiss -text {Dismiss} -command {destroy .tl}
pack .tl.dismiss -side right -fill none
foreach b $toplist {
.tl.f.l insert end $b
}
}
proc qtk_manpage {} {
catch {destroy .man}
toplevel .man
wm title .man {TCL/Tk Man Pages}
label .man.l1 -text {Select a man page}
frame .man.f -border 4 -relief ridge
listbox .man.f.lb -height 20 -width 30 -selectmode browse -yscrollcommand {.man.f.sb set}
scrollbar .man.f.sb -orient v -command {.man.f.lb yview}
button .man.view -text {View} -command {
catch {
exec xterm -e man n [.man.f.lb get active] &
}
}
frame .man.s
label .man.s.l -text "Search:"
entry .man.s.e -width 5
button .man.dis -text {Dismiss} -command {destroy .man}
pack .man.l1 -side top
pack .man.f -side top -fill both
pack .man.f.lb -side left -fill both -expand 1
pack .man.f.sb -side left -fill y
pack .man.view -side left
pack .man.s -side left -fill x -expand 1
pack .man.s.l .man.s.e -side left
pack .man.dis -side right
set cmds ""
foreach i [exec ls /usr/man/mann] {
set sl [string first . $i]
incr sl -1
if {$sl > 0} {
set tmp [string range $i 0 $sl]
.man.f.lb insert end $tmp
lappend cmds $tmp
}
}
bind .man.f.lb <Double-1> {
.man.view invoke
}
bind .man.s.e <KeyRelease> [subst -nocommands {.man.f.lb yview [lsearch -glob {$cmds} [.man.s.e get]* ]} ]
}
proc qtk_invalidate_views {} {
global q_curbuf
set q_curbuf invalid
qtk_inval_example
qtk_inval_funclist
}
proc qtk_flush_buffer {} {
global q_curbuf qtk q_func_args q_func_body
set a [lindex $q_curbuf 0]
if {$a=="invalid"} {return}
if {$a=="func"} {
set name [lindex $q_curbuf 1]
set argys [.metabits.args get]
set body [.t get 1.0 "end-1c"]
set q_func_args($name) $argys
set q_func_body($name) $body
# set q_funcs([lindex $q_curbuf 1]) [.t get 1.0 "end-1c"]
} else {
set qtk($a) [.t get 1.0 "end-1c"]
}
}
proc qtk_flush_all {} {
qtk_flush_buffer
}
proc qtk_set_buffer {a b} {
global q_curbuf
qtk_flush_buffer
.t delete 1.0 end
.t insert 1.0 $a
set q_curbuf $b
.f.s config -text $b
}
proc qtk_load {} {
global qtk q_func_args q_func_body edit_mode widlist oarr contlist q_nid
set_mode qtk
qtk_eraseproj
set f [open "Project" "r"]
catch { array set qtk [read $f] }
close $f
array set q_func_args $qtk(func_args)
array set q_func_body $qtk(func_body)
unset qtk(func_args)
unset qtk(func_body)
catch {
## try to extract graphical/interface information, where possible
array set oarr $qtk(oarr)
set widlist $qtk(widlist)
set contlist $qtk(contlist)
set q_nid $qtk(q_nid)
unset qtk(widlist)
unset qtk(oarr)
unset qtk(contlist)
unset qtk(q_nid)
}
qtk_invalidate_views
.f.n config -text $qtk(name)
catch {qtk_showfunc [lindex $qtk(rec_func) 0]}
qtk_selfunc
}
proc qtk_newproj {} {
global qtk q_func_body q_func_args
qtk_eraseproj
qtk_setname "tk.out"
set q_func_body(__HEADER__) "#!/usr/bin/wish\n"
set q_func_body(__MAIN__) "# A new QTK Project Begins Here\n"
set q_func_args(__HEADER__) ""
set q_func_args(__MAIN__) ""
set qtk(funclist) {__HEADER__ __MAIN__}
qtk_showfunc __MAIN__
qtk_selfunc
}
proc qtk_mk_func name {
global qtk q_func_body q_func_args
if {$name==""} {return 0}
if {[lsearch -exact $qtk(funclist) $name] >= 0} {return 0}
set p [llength $qtk(funclist)]
incr p -1
set qtk(funclist) [linsert $qtk(funclist) $p $name]
set q_func_body($name) "\n"
set q_func_args($name) ""
qtk_inval_funclist
qtk_showfunc $name
return 1
}
proc qtk_newfunc {} {
catch {destroy .newfunc}
toplevel .newfunc
wm title .newfunc {New Function}
label .newfunc.l1 -text {New Function Name}
entry .newfunc.name -width 20 -font 7x14
button .newfunc.create -text {Create} -command {
if [qtk_mk_func [.newfunc.name get]] {
destroy .newfunc
} else {
bell
return
}
}
button .newfunc.cancel -text {Cancel} -command {destroy .newfunc}
pack .newfunc.l1 -side top
pack .newfunc.name -side top
pack .newfunc.create -side left
pack .newfunc.cancel -side right
focus .newfunc.name
}
proc qtk_save {} {
global qtk q_func_args q_func_body widlist oarr contlist q_nid
qtk_flush_all
set qtk(func_args) [array get q_func_args]
set qtk(func_body) [array get q_func_body]
set f [open "Project" "w"]
## Also save graphical/interface information now.
set qtk(widlist) $widlist
set qtk(oarr) [array get oarr]
set qtk(contlist) $contlist
set qtk(q_nid) $q_nid
## Write out the file
puts $f [array get qtk]
close $f
## Clean up some
unset qtk(widlist)
unset qtk(oarr)
unset qtk(contlist)
unset qtk(q_nid)
unset qtk(func_args)
unset qtk(func_body)
}
proc qtk_compile {} {
chk_edit_mode qtk
global qtk q_func_args q_func_body
qtk_flush_all
set f [open $qtk(name) "w" 0755]
puts -nonewline $f $q_func_body(__HEADER__)
set n [llength $qtk(funclist)]
set func [lrange $qtk(funclist) 1 [expr $n - 2]]
foreach i $func {
puts $f "[list proc $i $q_func_args($i)] {\n$q_func_body($i)}"
}
puts -nonewline $f $q_func_body(__MAIN__)
close $f
}
proc qtk_run {} {
chk_edit_mode qtk
qtk_compile
exec -keepnewline wish << tk.out &
}
proc qtk_notes {} {
global qtk
qtk_flush_buffer
qtk_set_buffer $qtk(notes) notes
}
proc qtk_selfunc {} {
global qtk edit_mode
if {$edit_mode!="qtk"} {
bell
return
}
catch {destroy .fl}
toplevel .fl
wm title .fl {Functions}
frame .fl.s
label .fl.s.l -text "Search: "
entry .fl.s.e -width 10
frame .fl.f -border 0 -relief flat
listbox .fl.f.l -height 25 -width 30 -selectmode browse -yscrollcommand {.fl.f.s set}
scrollbar .fl.f.s -orient v -command {.fl.f.l yview}
button .fl.view -text {View} -command {
set tmp [.fl.f.l curselection]
if {[llength $tmp]} {
qtk_showfunc [.fl.f.l get $tmp]
.fl.s.e delete 0 end
} else {bell}
}
button .fl.new -text {New} -command {qtk_newfunc}
button .fl.del -text "Delete" -command {
set tmp [.fl.f.l curselection]
if {[llength $tmp]} { qtk_delfunc [.fl.f.l get $tmp] } else {bell}
}
button .fl.dis -text {Dismiss} -command {destroy .fl}
pack .fl.s -side top -fill x
pack .fl.s.l .fl.s.e -side left
pack .fl.f -side top -fill both
pack .fl.f.s -side right -fill y
pack .fl.f.l -side left -fill both -expand 1
pack .fl.view .fl.new .fl.del -side left
pack .fl.dis -side right
qtk_inval_funclist
bind .fl.f.l <Double-1> {.fl.view invoke}
bind .fl.s.e <KeyRelease> {
.fl.f.l yview [lsearch -glob [lsort $qtk(funclist)] [.fl.s.e get]*]
}
}
proc ed_cut widget {
global clipboard
set range [$widget tag ranges sel]
catch {
set clipboard [eval $widget get $range]
eval $widget delete $range
}
}
proc ed_copy widget {
global clipboard
set range [$widget tag ranges sel]
catch {
set clipboard [eval $widget get $range]
}
}
proc ed_paste widget {
global clipboard
$widget insert insert $clipboard
}
proc ed_search {} {
catch {destroy .search}
toplevel .search
wm title .search "Search / Replace"
frame .search.a
label .search.a.l -text {Search For:}
pack .search.a.l -side left -fill none
entry .search.a.pat -width 30 -font 7x14
pack .search.a.pat -side left -fill none
pack .search.a.pat
pack .search.a -side top -fill none
frame .search.b
label .search.b.ldir -text {Direction}
tk_optionMenu .search.b.dir sdir forward backward
label .search.b.lt -text {Search Type:}
tk_optionMenu .search.b.type stype nocase exact regexp
pack .search.b.ldir .search.b.dir -side left -fill none
pack .search.b.lt .search.b.type -side left -fill none
pack .search.b -side top -fill none
frame .search.c
button .search.c.find -text "Find"
button .search.c.dismiss -text "Dismiss" -command {destroy .search}
pack .search.c.find .search.c.dismiss -side left
pack .search.c -side top
.search.c.find configure -command {
set stmp [.t search -$sdir -$stype -count scount -- [.search.a.pat get] insert]
if {$stmp != ""} {
.t see $stmp
.t mark set insert "$stmp + $scount chars"
set acmd ".t tag delete hilite"
after cancel $acmd
catch $acmd
.t tag add hilite $stmp "$stmp + $scount chars"
.t tag configure hilite -background white
after 1000 $acmd
}
}
}
proc ed_set {} {
.t mark set book insert
}
proc ed_recall {} {
.t see book
.t mark set insert book
}
proc ed_indent {} {
set interval [.t tag ranges sel]
for {set i [lindex $interval 0]} {$i < [lindex $interval 1]} {set i [expr $i + 1]} {
.t insert "$i linestart" " "
}
}
proc ht_arbtag {} {
global ht_closetag
catch {destroy .html}
toplevel .html
wm title .html {HTML Tag}
frame .html.t
label .html.t.l1 -text {Tag}
entry .html.t.tag -width 10 -font 7x14
label .html.t.l2 -text {Attributes}
entry .html.t.att -width 20 -font 7x14
checkbutton .html.t.close -text "Close Tag" -variable ht_closetag
pack .html.t -side top -fill none
pack .html.t.l1 -side left -fill none
pack .html.t.tag -side left -fill none
pack .html.t.l2 -side left -fill none
pack .html.t.att -side left -fill none
pack .html.t.close -side left -fill none
button .html.code -text {Code} -command {
ins "<"
ins [.html.t.tag get]
if {""!=[.html.t.att get]} {
ins " "
ins [.html.t.att get]
}
ins ">"
if {$ht_closetag} {
set tmp [.t index insert]
ins "</"
ins [.html.t.tag get]
ins ">"
.t mark set index $tmp
}
}
pack .html.code -side left -fill none
button .html.dismiss -text {Dismiss} -command {destroy .html}
pack .html.dismiss -side right -fill none
}
proc ht_skel {} {
catch {destroy .html}
toplevel .html
wm title .html {HTML Skeleton Page}
label .html.l1 -text {Title for your new page}
entry .html.title -width 40 -font 7x14
button .html.code -text {Write Code} -command {
ins "<html><head><title>\n"
ins [.html.title get]
ins "\n</title></head>\n<body>\n\n</body>\n</html>\n"
}
button .html.dismiss -text Dismiss -command { destroy .html }
pack .html.l1 -side top
pack .html.title -side top
pack .html.code -side left
pack .html.dismiss -side right
}
proc ht_hr {} {
catch {destroy .html}
toplevel .html
wm title .html {Horizontal Rule Maker}
frame .html.f
scale .html.f.width -orient h -from 0 -to 100 -label {Width}
scale .html.f.size -orient h -from 1 -to 10 -label {Size}
pack .html.f.width -side left
pack .html.f.size -side left
pack .html.f -side top
button .html.code -text {Write} -command {
ins "<hr"
if {[.html.f.width get] !=100} {ins " width=\"[.html.f.width get]%\""}
if {[.html.f.size get] != 1} {ins " size=[.html.f.size get]"}
ins ">\n"
}
pack .html.code -side left -fill none
button .html.dismiss -text "Dismiss" -command {destroy .html}
pack .html.dismiss -side right
.html.f.width set 100
.html.f.size set 1
}
proc ht_link {} {
global ht_targlist
catch {destroy .link}
toplevel .link
wm title .link {Link}
label .link.l1 -text {Link To:}
entry .link.href -width 40 -font 7x14
label .link.l2 -text {Target Frame:}
entry .link.target -width 20 -font 7x14
frame .link.f1 -border 0 -relief flat
listbox .link.f1.lb -height 5 -width 20 -selectmode browse -yscrollcommand {.link.f1.sb set}
scrollbar .link.f1.sb -orient v -command {.link.f1.lb yview}
label .link.l3 -text {ToolTip/Title:}
entry .link.title -width 40 -font 7x14
frame .link.f2 -border 0 -relief flat
button .link.f2.code -text {Write Code} -command {
set href [.link.href get]
set target [.link.target get]
set title [.link.title get]
set attrs "href=\"$href\""
if {$title != ""} { set attrs "$attrs title=\"$title\"" }
if {$target != ""} { set attrs "$attrs target=\"$target\"" }
ht_tag "a" $attrs
set target [string tolower $target]
if {-1==[lsearch -exact $ht_targlist $target]} {lappend ht_targlist $target}
destroy .link
}
button .link.f2.dismiss -text {Dismiss} -command {destroy .link}
pack .link.l1 -side top
pack .link.href -side top
pack .link.l2 -side top
pack .link.target -side top
pack .link.f1 -side top
pack .link.f1.lb -side left
pack .link.f1.sb -side left -fill y
pack .link.l3 -side top
pack .link.title -side top
pack .link.f2 -side bottom -fill x
pack .link.f2.code -side left
pack .link.f2.dismiss -side right
foreach tmp $ht_targlist {
.link.f1.lb insert end $tmp
}
.link.f1.lb see end
bind .link.f1.lb <Double-1> {
catch {
.link.target delete 0 end
.link.target insert 0 [.link.f1.lb get [.link.f1.lb curselection]]
}
}
}
proc ht_init {} {
global ent_nums ent_names ent_longnames ht_closetag ht_targlist
set ht_closetag 1
set ht_targlist {{} _self _blank _parent _top}
set ent_nums {
34 38 60 62
160 161 162 163 164 165 166 167 168 169
170 171 172 173 174 175 176 177 178 179
180 181 182 183 184 185 186 187 188 189
190 191 192 193 194 195 196 197 198 199
200 201 202 203 204 205 206 207 208 209
210 211 212 213 214 215 216 217 218 219
220 221 222 223 224 225 226 227 228 229
230 231 232 233 234 235 236 237 238 239
240 241 242 243 244 245 246 247 248 249
250 251 252 253 254 255
}
set ent_names {
quot amp lt gt
nbsp iexcl cent pound curren yen brvbar sect uml copy ordf laquo not shy reg
macr deg plusmn sup2 sup3 acute micro para middot cedil sup1 ordm raquo
frac14 frac12 frac34 iquest Agrave Aacute Acirc Atilde Auml Aring AElig
Ccedil Egrave Eacute Ecirc Euml Igrave Iacute Icirc Iuml ETH Ntilde Ograve
Oacute Ocirc Otilde Ouml times Oslash Ugrave Uacute Ucirc Uuml Yacute THORN
szlig agrave aacute acirc atilde auml aring aelig ccedil egrave eacute ecirc
euml igrave iacute icirc iuml eth ntilde ograve oacute ocirc otilde ouml
divide oslash ugrave uacute ucirc uuml yacute thorn yuml
}
set ent_longnames {
{ Quote (") } { Ampersand (&) } { Less-than (<) } { Greater-than (>) }
{ Non-breaking Space } { Inverted exclamation } { Cent sign } { Pound sterling }
{ General currency sign } { Yen sign } { Broken vertical bar } { Section sign }
{ Umlaut (dieresis) } { Copyright } { Feminine ordinal }
{ Left angle quote, guillemotleft } { Not sign } { Soft hyphen }
{ Registered trademark } { Macron accent } { Degree sign } { Plus or minus }
{ Superscript two } { Superscript three } { Acute accent } { Micro sign }
{ Paragraph sign } { Middle dot } { Cedilla } { Superscript one }
{ Masculine ordinal } { Right angle quote, guillemotright }
{ Fraction one-fourth } { Fraction one-half } { Fraction three-fourths }
{ Inverted question mark } { Capital A, grave accent }
{ Capital A, acute accent } { Capital A, circumflex accent }
{ Capital A, tilde } { Capital A, dieresis or umlaut mark } { Capital A, ring }
{ Capital AE dipthong (ligature) } { Capital C, cedilla }
{ Capital E, grave accent } { Capital E, acute accent }
{ Capital E, circumflex accent } { Capital E, dieresis or umlaut mark }
{ Capital I, grave accent } { Capital I, acute accent }
{ Capital I, circumflex accent } { Capital I, dieresis or umlaut mark }
{ Capital Eth, Icelandic } { Capital N, tilde } { Capital O, grave accent }
{ Capital O, acute accent } { Capital O, circumflex accent }
{ Capital O, tilde } { Capital O, dieresis or umlaut mark } { Multiply sign }
{ Capital O, slash } { Capital U, grave accent } { Capital U, acute accent }
{ Capital U, circumflex accent } { Capital U, dieresis or umlaut mark }
{ Capital Y, acute accent } { Capital THORN, Icelandic }
{ Small sharp s, German (sz ligature) } { Small a, grave accent }
{ Small a, acute accent } { Small a, circumflex accent } { Small a, tilde }
{ Small a, dieresis or umlaut mark } { Small a, ring }
{ Small ae dipthong (ligature) } { Small c, cedilla } { Small e, grave accent }
{ Small e, acute accent } { Small e, circumflex accent }
{ Small e, dieresis or umlaut mark } { Small i, grave accent }
{ Small i, acute accent } { Small i, circumflex accent }
{ Small i, dieresis or umlaut mark } { Small eth, Icelandic } { Small n, tilde }
{ Small o, grave accent } { Small o, acute accent }
{ Small o, circumflex accent } { Small o, tilde }
{ Small o, dieresis or umlaut mark } { Division sign } { Small o, slash }
{ Small u, grave accent } { Small u, acute accent }
{ Small u, circumflex accent } { Small u, dieresis or umlaut mark }
{ Small y, acute accent } { Small thorn, Icelandic }
{ Small y, dieresis or umlaut mark }
}
}
proc ht_charent {} {
global ent_longnames
catch {destroy .charent}
toplevel .charent
wm title .charent {HTML Character Entity}
label .charent.l1 -text {Select Character Entity}
frame .charent.f -border 0 -relief flat
listbox .charent.f.lb -height 10 -width 30 -selectmode browse -yscrollcommand { .charent.f.sb set }
scrollbar .charent.f.sb -orient v -command {.charent.f.lb yview}
button .charent.paste -text {Paste} -command {
catch {
set tmp "&[lindex $ent_names [.charent.f.lb curselection]];"
ins $tmp
}
}
button .charent.pastenum -text {Paste Numeric} -command {
catch {
set tmp "&#[lindex $ent_nums [.charent.f.lb curselection]];"
ins $tmp
}
}
button .charent.dismiss -text {Dismiss} -command {destroy .charent}
pack .charent.l1 -side top
pack .charent.f -side top -fill both
pack .charent.f.lb -side left -fill both -expand 1
pack .charent.f.sb -side left -fill y
pack .charent.paste .charent.pastenum -side left
pack .charent.dismiss -side right
foreach name $ent_longnames { .charent.f.lb insert end $name }
bind .charent.f.lb <Double-1> { .charent.paste invoke }
}
proc ht_tag {t {a ""}} {
set r [.t tag ranges sel]
if {$a==""} {
set tagstart "<$t>"
} else {
set tagstart "<$t $a>"
}
if [string length $r] {
.t insert [lindex $r 1] "</$t>"
.t insert [lindex $r 0] $tagstart
} else {
.t insert insert $tagstart
set tmp [.t index insert]
.t insert insert "</$t>"
.t mark set insert $tmp
}
}
proc help jump {
catch {destroy .help}
toplevel .help
wm title .help "About Quick-Tk"
label .help.title -font "-*-*-bold-*-*-*-30-*-*-*-*-*-*-*" -text "Quick-Tk"
set f .help.nav
frame $f
button $f.about -text "About" -command {
.help.m.t config -state normal
.help.m.t delete 1.0 end
.help.m.t insert end \
{Quick-Tk aims first to be a relatively complete graphical Tk development environment which will work under Tk4.1 and above.
Working features include:
o Cut, Copy, and Paste
o Right-Click menus in text boxes
o Jump around from function to function
o An immediate mode window with history
o A moderate set of "widget wizards"
o Preview of generated widgets
o "Preview Compiler"
o Project save capability
Currently known bugs:
o Parsing out a Tk project fails if last proc takes arguments. It seems that the parser gets confused and associates the body of the procedure with the __MAIN__ section.
o "Project | Run" does not work
o toplevel widget creator not yet integrated with new widget tree controls
o some widget hierarchy controls not yet functional
o several loose ends flying about
Features under or awaiting construction:
o Widget Editor - rapidly gaining features.
o Better Help
o Better Widget editing support
o Context Sensitive Auto-Complete - Cluehunting
o Syntax Highlighting - not essential.
o HTML4, CSS, JavaScript support
o PHP3/SQL supoprt
Delusions of Granduer:
o C/C++ support
o English, Natural Language support
o Mind Reading
o The direct conversion of thought to results :)
}
.help.m.t config -state disabled
}
button $f.tips -text "Tips" -command {
.help.m.t config -state normal
.help.m.t delete 1.0 end
.help.m.t insert end \
{Tips on using QTK:
1. Getting started painting a Tk Interface:
Open the example dialog and widget list windows, then tear off the widget menu (select the menu and click the dotted line on top). Just make interface elements as you need them, and use the widget list to shove them into place. Go back and edit the widgets to reflect new decisions for pack options.
2. Q: What do the buttons on the Widget List do?
A: Assuming you have selected a widget by name, then you can move that widget earlier or later in the pack order by choosing "move up" or "move down".
Promote will move a widget out of its innermost containing frame, and demote lets you select a frame within the same scope to push a widget into.
Edit lets you change the properties of a given widget, and delete removes the widget entirely.
3. Q: What do I do when I'm happy with my layout?
A: From the "Widget" menu, choose Code, then Code Widget List. This will paste interface creation code into your editor at the cursor.
It is your responsibility to do something inteligent with that code afterwards.
4. Q: What if I want to modify existing interface code?
A: Take advantage of the GPL. At the moment, QTK does not have a reverse-compiler function for interface code. You might code one up and send me patches.
As a side note, there is some work on saving and restoring interface definitions. This could be useful in conjunction with a recursive pack-tree scanner function.
5. Canvases, text-embeds, Place, and other geometry managers: There is no support here YET. I'm having enough fun trying to get the other parts of this program working to put off support for other geometry managers until later. You want sooner? Send me patches.
6. HTML editing: From the Options menu, choose language, then HTML. The menu will change to be relevant to HTML. This area is not as advanced as the Tk interface editor, and mostly amounts to a collection of typing aids, but clearly this can be greatly expanded on with little work. Send me patches for anything interesting you do. Please.
7. Other features, like syntax highlighting:
Coming soon.
}
.help.m.t config -state disabled
}
button $f.license -text "License" -command {
.help.m.t config -state normal
.help.m.t delete 1.0 end
.help.m.t insert end \
{This program is distributed under the terms of the Gnu General Public License (GPL). You can find a copy of this license at http://www.gnu.org/copyleft/gpl.html
}
.help.m.t config -state disabled
}
button $f.credits -text "Credits" -command {
.help.m.t config -state normal
.help.m.t delete 1.0 end
.help.m.t insert end \
{Quick-Tk was written from scratch by Ian Kjos.
You can send him e-mail at:
brooke@jump.net
}
.help.m.t config -state disabled
}
pack $f.about $f.tips $f.license $f.credits -side top
frame .help.m -border 4 -relief ridge
text .help.m.t -width 50 -height 12 -setgrid 1 -font 7x14 -yscrollcommand {.help.m.s set} -wrap word
scrollbar .help.m.s -orient v -command {.help.m.t yview}
pack .help.m.t -side left -fill both -expand 1
pack .help.m.s -side left -fill y
button .help.dismiss -text "Dismiss" -command {destroy .help}
pack .help.title -side top
pack .help.nav -side left -anchor n
pack .help.m -side top -expand 1 -fill both
pack .help.dismiss -side top
.help.nav.$jump invoke
}
proc menu_file {} {
####### File Menu
set m .menu.file.m
menubutton .menu.file -text "File" -menu $m -underline 0
menu $m
$m add command -label "Run" -command {exec -keepnewline wish << [.t get 1.0 end ] &} -underline 0
$m add command -label "New" -command {fi_new} -underline 0
$m add command -label "Load" -command {fi_load} -underline 0
$m add command -label "Save" -command {fi_save} -underline 0 -accelerator "Ctrl-S"
$m add command -label "Quit" -command {destroy .} -underline 0
}
proc menu_edit {} {
####### Edit Menu
set m .menu.edit.m
menubutton .menu.edit -text "Edit" -menu $m -underline 0
menu $m
$m add command -label "Copy" -command {ed_copy .t} -underline 0 -accelerator "Ctrl-Ins"
$m add command -label "Cut" -command {ed_cut .t} -underline 2 -accelerator "Shift-Del"
$m add command -label "Paste" -command {ed_paste .t} -underline 0 -accelerator "Shift-Ins"
$m add separator
$m add command -label "Search" -command {ed_search} -underline 0
$m add separator
$m add command -label "Set Bookmark" -command {ed_set} -underline 1
$m add command -label "Go to Bookmark" -command {ed_recall} -underline 6
$m add separator
$m add command -label "Indent Selection" -command {ed_indent} -underline 0
$m add separator
$m add cascade -label "Font" -menu .menu.edit.m.font
set m .menu.edit.m.font
menu $m -tearoff 0
$m add command -label "7x14" -command {.t config -font 7x14} -underline 0
$m add command -label "8x16" -command {.t config -font 8x16} -underline 0
$m add command -label "10x20" -command {.t config -font 10x20} -underline 0
}
proc menu_widget {} {
####### Widget Menu
set m .menu.widget.m
menubutton .menu.widget -text "Widget" -menu $m -underline 0
menu $m
$m add command -label "Label" -command {mk_label} -underline 0
$m add command -label "Entry" -command {mk_entry} -underline 0
$m add command -label "Scale" -command {mk_scale} -underline 2
$m add cascade -label "Buttons" -menu $m.buttons -underline 0
$m add command -label "Listbox" -command {mk_listbox} -underline 1
$m add command -label "Text" -command {mk_text} -underline 0
$m add command -label "Scrollbar" -command {mk_scrollbar} -underline 2
$m add separator
$m add command -label "Frame" -command {mk_frame} -underline 0
$m add command -label "Toplevel" -command {mk_toplevel} -underline 0
$m add separator
$m add command -label "Combo Gallery" -command {mk_combo} -underline 6
$m add separator
$m add cascade -menu .menu.widget.m.code -label "Code" -underline 2
set m .menu.widget.m.code
menu $m -tearoff 0
$m add command -label "Code widget list" -command {code_widlist} -underline 0
$m add command -label "Empty widget list" -command {empty_widlist} -underline 0
set m .menu.widget.m.buttons
menu $m -tearoff 0
$m add command -label "Push Button" -command {mk_button} -underline 0
$m add command -label "Check Button" -command {mk_checkbutton} -underline 0
$m add command -label "Radio Button" -command {mk_radiobutton} -underline 0
$m add command -label "Menu Button" -command {mk_menubutton} -underline 0
$m add command -label "OptionMenu Button" -command {mk_optmenubutton} -underline 0
}
proc menu_tcl {} {
####### TCL Menu
set m .menu.tcl.m
menubutton .menu.tcl -text "TCL" -menu $m -underline 0
menu $m
$m add command -label "New Procedure" -command {qtk_newfunc}
$m add separator
$m add cascade -menu .menu.tcl.m.string -label "String" -underline 0
$m add cascade -menu .menu.tcl.m.array -label "Array" -underline 0
$m add cascade -menu .menu.tcl.m.list -label "List" -underline 0
$m add cascade -menu .menu.tcl.m.file -label "File" -underline 0
$m add separator
$m add command -label "Man Pages" -command {qtk_manpage}
set m .menu.tcl.m.string
menu $m
foreach i {
compare first index last length match range tolower
toupper trim trimleft trimright wordend wordstart
} {
$m add command -label $i -command [subst {ins "string $i "}]
}
$m add separator
$m add command -label "Manual Page" -command {exec xterm -e man n string &}
set m .menu.tcl.m.array
menu $m
foreach {i u} {
anymore 0 donesearch 0 exists 0 get 0 names 0
nextelement 0 set 0 size 1 startsearch 1
} {
$m add command -label $i -command [subst {ins "array $i "}] -underline $u
}
$m add separator
$m add command -label "Manual Page" -command {exec xterm -e man n array &}
set m .menu.tcl.m.list
menu $m
foreach i {concat lappend lindex linsert list
llength lrange lreplace lsearch lsort} {
$m add command -label $i -command [subst {ins "$i "}]
}
set m .menu.tcl.m.file
menu $m
foreach {i u} {
atime 0 dirname 0 executable 4 exists 0 extension 1
isdirectory 0 isfile 2 join 0 lstat 0 mtime 0 owned 0
pathtype 3 readable 0 readlink 7 rootname 4 size 2
split 1 stat 0 tail 0 type 1 writable 0
} {
$m add command -label $i -command [subst {ins "file $i "}] -underline $u
}
$m add separator
$m add command -label "Manual Page" -command {exec xterm -e man n file &}
}
proc menu_tk_proj {} {
set m .menu.tk_proj.m
menubutton .menu.tk_proj -text "Project" -menu $m -underline 0
menu $m
$m add command -label "Compile Project" -command {qtk_compile} -underline 0
$m add command -label "Run Project" -command {qtk_run}
$m add command -label "Set Target Name" -command {qtk_name}
$m add separator
$m add command -label "Load Project" -command {qtk_load}
$m add command -label "Save Project" -command {qtk_save} -underline 0
$m add command -label "New Project" -command {qtk_newproj}
$m add command -label "Parse TK to Project" -command {qtk_decompose}
}
proc menu_window {} {
####### Window Menu
set m .menu.window.m
menubutton .menu.window -text "Window" -menu $m -underline 2
menu $m
$m add command -label "Function List" -command {qtk_selfunc}
$m add command -label "Project Notes" -command {qtk_notes}
$m add separator
$m add command -label "Immediate Mode" -command {wi_immediate}
$m add command -label "Widget List" -command {wi_widgetlist}
$m add command -label "Example Dialog" -command {wi_example}
$m add command -label "Toplevel List" -command {wi_toplist}
}
proc menu_html {} {
####### HTML Menu
set m .menu.html.m
menubutton .menu.html -text "HTML" -menu $m -underline 2
menu $m
$m add command -label "Horizontal Rule" -command {ht_hr} -underline 11
$m add command -label "Link" -command {ht_link} -underline 0
$m add command -label "Character Entity" -command {ht_charent} -underline 11
$m add command -label "Table" -command {ht_table_create} -underline 0
$m add separator
$m add cascade -menu $m.spells -label "Spells" -underline 0
$m add separator
$m add command -label "Arbitrary Tag" -command {ht_arbtag} -underline 0
$m add command -label "HTML Skeleton File" -command {ht_skel} -underline 6
$m add separator
$m add command -label "Highlight Now" -command {html_highlight} -underline 1
set m .menu.html.m.spells
menu $m
$m add command -label "Refresh" -command {ht_spell_refresh} -underline 0
$m add command -label "Import Style Sheet" -command {ht_spell_style_import} -underline 0
}
proc menu_options {} {
set m .menu.options.m
menubutton .menu.options -text "Options" -menu $m -underline 0
menu $m
$m add check -label "AutoIndent" -variable autoindent -underline 4
$m add cascade -label "Word Wrap" -menu .menu.options.m.wrap -underline 0
$m add cascade -label "Language" -menu .menu.options.m.lang -underline 0
set m .menu.options.m.wrap
menu $m
$m add command -label "char" -underline 0 -command {.t config -wrap char}
$m add command -label "none" -underline 0 -command {.t config -wrap none}
$m add command -label "word" -underline 0 -command {.t config -wrap word}
set m .menu.options.m.lang
menu $m
$m add radio -label "Tk" -command setlang -var lang -value tk -underline 0
$m add radio -label "HTML" -command setlang -var lang -value html -underline 0
$m add radio -label "C++" -command setlang -var lang -value c++ -underline 0
$m add radio -label "PHP" -command setlang -var lang -value php -underline 0
$m add radio -label "SQL" -command setlang -var lang -value sql -underline 0
$m add radio -label "English" -command setlang -var lang -value eng -underline 0
$m add radio -label "Text" -command setlang -var lang -value text -underline 2
}
proc menu_help {} {
####### Help Menu
set m .menu.help.m
menubutton .menu.help -text "Help" -menu $m -underline 0
menu $m -tearoff 0
$m add command -label "About Quick-Tk" -command {help about}
$m add command -label "Tips on Quick-Tk" -command {help tips}
$m add command -label "License" -command {help license}
$m add command -label "Credits" -command {help credits}
}
proc pos {} {
.f.p config -text [.t index insert]
}
proc main {} {
#########################
#
# Main Interface Setup
#
#########################
wm title . "Quick Tk"
frame .menu -relief raised -bd 2
frame .clue -relief sunken -bd 2
frame .f
label .f.n -text {untitled} -bd 2 -relief ridge
label .f.s -text {} -bd 2 -relief ridge
label .f.p -text {1.0} -bd 2 -relief ridge
# A place to put (changable) info regarding the current view
frame .metabits
text .t -font 7x14 -setgrid 1
scrollbar .sy -orient v -command ".t yview"
.t configure -yscrollcommand ".sy set"
focus .t
# Eliminate some undesired bindings
bind Text <Control-Key-k> {}
# Make the clipboard work right
bind Text <Shift-Key-Insert> {ed_paste %W}
bind Text <Shift-Key-Delete> {ed_cut %W}
bind Text <Control-Key-Insert> {ed_copy %W}
bind Text <3> {rt_menu %W %X %Y}
# Make the accelerator bindings
bind .t <Control-Key-s> {fi_save}
bind .t <KeyRelease> {
pos
}
bind .t <1> {
.f.p config -text [.t index insert]
}
# Other cool bindings
bind Text <Key-Return> {
if {$autoindent} {
set str [%W get "insert linestart" "insert lineend"]
set indent [expr [string length $str] - [string length [string trimleft $str ]]]
tkTextInsert %W \n
for {set i 0} {$i < $indent} {incr i} {%W insert insert " "}
} else {
tkTextInsert %W \n
}
}
# Some Clue-hunting Bindings
#bindtags .t {Text .t . all}
foreach k {space Return dollar} {
bind .t <KeyRelease-$k> {
cluehunt %K
pos
}
}
pack .menu -side top -fill x -anchor n
pack .f -side top
pack .f.n .f.s .f.p -side left
pack .metabits -fill x
pack .clue -side bottom -fill x -anchor s
pack .sy -side right -fill y
pack .t -side left -expand 1 -fill both
# Create Menus
set_menu_bar
# Create Cluehunt button bar (with bindings)
foreach i {1 2 3 4 5} {
label .clue.l$i -text "F${i}:"
button .clue.b$i -text {} -command "cluehit $i"
pack .clue.l$i -side left
pack .clue.b$i -side left
bind .t <Key-F${i}> "cluehit $i"
}
}
proc develop {} {
bind all <3> {set clipboard %W}
bind .metabits.name <2> {
set tmp [lindex $q_curbuf 1]
set clipboard "[list proc $tmp $q_func_args($tmp)] {\n$q_func_body($tmp)}"
}
}
proc qtk_init {} {
global widlist contlist toplist cont selmode orient curtop
global q_nid qtk
# for dialog editor
set widlist {}
set contlist {.}
set toplist {.}
set q_nid 0
# This is the current container we work within.
set cont {.}
# Set some defaults
set selmode browse
set orient v
set curtop .
catch {unset obj}
set qtk(rec_func) {}
}
proc qtk_showfunc name {
global q_func_args q_func_body
#qtk_flush_buffer
qtk_set_buffer $q_func_body($name) [list func $name]
.metabits.name config -text $name
do_recent_funcs $name
.metabits.args delete 0 end
.metabits.args insert 0 $q_func_args($name)
}
proc qtk_inval_funclist {} {
# The general idea is to refresh the function list IFF it is present and
# visible, otherwise do nothing.
global qtk
catch {
.fl.f.l delete 0 end
foreach i [lsort $qtk(funclist)] {
.fl.f.l insert end $i
}
}
}
proc qtk_delfunc name {
global q_func_body q_func_args qtk q_curbuf
set resp [tk_dialog .confirm "Confirmation" "Are you sure you want to utterly anhilate ${name}?" questhead -1 "I mean it" "Ooops - don't do that"]
if {$resp==0} {
set num [lsearch -exact $qtk(funclist) $name]
if {($num <1) || ($num == [llength $qtk(funclist)]-1)} {
tk_dialog .confirm "Affirmation" "Function $name cannot be deleted. It's vital." exclamation 0 "Whatever"
return
}
set qtk(funclist) [lreplace $qtk(funclist) $num $num]
unset q_func_args($name)
unset q_func_body($name)
qtk_inval_funclist
if {$q_curbuf==[list func $name]} {
set q_curbuf invalid
qtk_notes
}
}
}
proc qtk_eraseproj {} {
global qtk q_func_args q_func_body edit_mode
set_mode qtk
catch {unset qtk}
catch {unset q_func_args}
catch {unset q_func_body}
foreach i {notes funclist funcs globals widgets menus settings rec_func} {
set qtk($i) {}
}
qtk_invalidate_views
qtk_notes
}
proc qtk_setname name {
global qtk
set qtk(name) $name
.f.n config -text $name
}
proc qtk_name {} {
catch {destroy .name}
toplevel .name
wm title .name {Set Target Name}
entry .name.name -width 32 -font 7x14
button .name.ok -text {OK} -command {set tmp [.name.name get]
if {$tmp != ""} {
qtk_setname $tmp
destroy .name
} else {bell}
}
button .name.cancel -text {Cancel} -command {destroy .name
}
pack .name.name -side top
pack .name.ok -side left
pack .name.cancel -side right
focus .name.name
}
proc history_box {w l} {
# History Box takes a widget name and a list of recent entries.
# It will create a frame containing an entry widget $w.e and
# a menubutton $w.m. The menubutton will be bound to a menu of
# recent entries (given by list $l) and selection of any of those
# menu options will replace the contents of the entry box by the
# label in the menu option.
#
# It is up to the user of the function to pack the frame widget.
frame $w
entry $w.e -font 7x14
menubutton $w.m -menu $w.m.m -text "-V-" -relief raised
menu $w.m.m -tearoff no
foreach i $l {
$w.m.m add command -label $i -command [subst {$w.e delete 0 end; $w.e insert 0 $i}]
}
pack $w.e $w.m -side left
}
proc mk_checkbutton {} {
# To make a checkbutton
global contlist qtk
wcc {CheckButton}
label .wcc.a.cl -text "Label Contents:"
entry .wcc.a.ce -width 30 -font 7x14
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "checkbutton"
set obj(app) "-text {[.wcc.a.ce get]}"
set obj(cfg) "-variable \{[.wcc.c.var.e get]\}"
add_obj
}
pack .wcc.b.al -side left -fill none
label .wcc.c.lv -text {Associated Global Variable:}
history_box .wcc.c.var $qtk(globals)
pack .wcc.a.cl .wcc.a.ce -side top
pack .wcc.c.lv .wcc.c.var -side top
pack .wcc.b.al -side left
pack .wcc.b.dismiss -side right
}
proc set_menu_bar {} {
global lang
foreach bob [pack slaves .menu] {
destroy $bob
}
if {$lang == "tk"} {
set ml {widget tcl window tk_proj}
}
if {$lang == "html"} {
set ml {font htlists forms html}
}
menu_file
menu_edit
pack .menu.file .menu.edit -side left
lappend ml options
foreach bob $ml {
menu_${bob}
pack .menu.$bob -side left
}
menu_help
pack .menu.help -side right
}
proc menu_font {} {
set m .menu.font.m
menubutton .menu.font -text "Font" -menu $m -underline 2
menu $m
$m add cascade -label "Heading" -menu $m.head -underline 0
$m add cascade -label "Size" -menu $m.size -underline 2
$m add separator
foreach {i u} {strong 0 em 0 code 0 pre 0 cite 2 address 0 var 0} {
$m add command -label $i -command [subst {ht_tag "$i"}] -underline $u
}
$m add separator
foreach {name tag u} {Bold b 0 Italic i 0 Typewriter tt 1} {
$m add command -label $name -command [subst {ht_tag "$tag"}] -underline $u
}
set m .menu.font.m.head
menu $m -tearoff 0
foreach i {1 2 3 4 5 6} {
$m add command -label "Heading $i" -command "ht_tag h$i" -underline 8
}
set m .menu.font.m.size
menu $m -tearoff 0
foreach i {+4 +3 +2 +1 +0 -1 -2 -3} {
$m add command -label "size $i" -command "ht_tag font size=$i"
}
}
proc menu_htlists {} {
set m .menu.htlists.m
menubutton .menu.htlists -text "Lists" -menu $m -underline 0
menu $m
$m add command -label {List Element} -command {ins "<li>"} -underline 0
$m add command -label {Ordered List} -command {ins "<ol>\n</ol>\n"} -underline 0
$m add command -label {Unordered List} -command {ins "<ul>\n</ul>\n"} -underline 0
$m add separator
$m add command -label "Quick List" -command html_quicklist
$m add command -label "Listify" -command html_listify
}
proc html_quicklist {} {
catch {destroy .ql}
toplevel .ql
wm title .ql {Quick List}
tk_optionMenu .ql.type ht_listtype ordered 1 I A i a unordered disc square circle
pack .ql.type -side top
button .ql.code -text {Code} -command {
if {[lsearch -exact {1 I A i a} $ht_listtype] != -1} {
ins [subst {<ol type="$ht_listtype">\n</ol>\n}]
}
if {[lsearch -exact {disc square circle} $ht_listtype] != -1} {
ins [subst {<ul type="$ht_listtype">\n</ul>\n}]
}
if {$ht_listtype == "ordered"} {ins "<ol>\n</ol>\n"}
if {$ht_listtype == "unordered"} {ins "<ul>\n</ul>\n"}
destroy .ql
}
button .ql.cancel -text {Cancel} -command {
destroy .ql
}
pack .ql.code -side top
pack .ql.cancel -side top
}
proc html_listify {} {
set interval [.t tag ranges sel]
for {set i [lindex $interval 0]} {$i < [lindex $interval 1]} {set i [expr $i + 1]} {
.t insert "$i linestart" "<li> "
}
}
proc code_widlist {} {
catch {destroy .cw}
toplevel .cw
wm title .cw {Code Widgets}
label .cw.l1 -text {Enter Parent Name (Without trailing dot)}
entry .cw.root -width 25 -font 7x14
button .cw.ok -text {OK} -command {
set tmp [.cw.root get]
code_oarr $tmp
destroy .cw
}
button .cw.cancel -text {Cancel} -command {destroy .cw}
pack .cw.l1 -side top
pack .cw.root -side top
pack .cw.ok -side left
pack .cw.cancel -side right
}
proc widpop {x y w} {
catch {destroy .popup}
menu .popup -tearoff no
set m .popup
set widname [string range $w 3 end]
set tmp $widname
if {$tmp == ""} {set tmp .}
while {$widname != ""} {
$m add command -label $widname -command "widedit [widlookup $widname]"
set widname [string range $widname 1 [expr [string last . $widname] -1]]
}
$m add command -label "Root Window" -command {puts UNIMPLEMENTED}
$m add separator
$m add command -label "Copy Widget Name" -command "set clipboard $tmp"
tk_popup .popup $x $y
}
proc widedit w {
}
proc widflip n {
# Flip elements n and n-1
global widlist
.wl.lb selection clear 0 end
set above [expr $n - 1]
set tmp [.wl.lb get $n]
.wl.lb insert $above $tmp
.wl.lb delete [expr $n + 1]
set tmp [concat [lrange $widlist 0 [expr $n-2]] \
[lindex $widlist $n] [lindex $widlist $above] \
[lrange $widlist [expr $n+1] end] ]
set widlist $tmp
qtk_inval_example
}
proc qtk_inval_example {} {
# Redraw the example dialog box where available.
global oarr widlist
catch {
foreach w [pack slaves .ex] {destroy $w}
foreach w $widlist {
array set obj $oarr($w)
eval $obj(type) .ex$obj(name) $obj(app)
eval pack .ex$obj(name) $obj(pack)
}
}
}
proc empty_widlist {} {
global widlist contlist toplist oarr
catch {unset oarr}
set widlist ""
set contlist {.}
set toplist {.}
qtk_inval_example
catch {.wl.lb delete 0 end}
}
proc widlookup w {
global widlist oarr
foreach n $widlist {
array set obj $oarr($n)
if {$obj(name) == $w} {return $n}
}
return ""
}
proc cluehunt_english clue {
if {$clue == " "} {
# Look for a word to play the Markov Game with.
# Basically a two step process:
# Get the two most recent words and add the pair to the Markov array.
# Set the clue bar to the Markov array point for the most recent word.
}
# For now, I'm playing real simple games.
set index [.t index insert]
set curlin [.t get "$index linestart" "$index lineend"]
set cw [.t get "$index wordstart" "$index wordend"]
.clue.b1 config -text $cw
.clue.b2 config -text $curlin
}
proc mk_radiobutton {} {
# To make a radiobutton
global contlist qtk
wcc {RadioButton}
label .wcc.a.cl -text "Label Contents:"
entry .wcc.a.ce -width 30 -font 7x14
button .wcc.b.al -text {Add to List} -command {
catch {unset obj}
set obj(type) "radiobutton"
set obj(app) "-text {[.wcc.a.ce get]}"
set obj(cfg) "-variable \{[.wcc.c.var.h.e get]\} -value \{[.wcc.c.val.e get]\}"
add_obj
}
pack .wcc.b.al -side left -fill none
frame .wcc.c.var
frame .wcc.c.val
label .wcc.c.var.l -text {Associated Global Variable:}
history_box .wcc.c.var.h $qtk(globals)
label .wcc.c.val.l -text "Value for this choice:"
entry .wcc.c.val.e
pack .wcc.a.cl .wcc.a.ce -side top
pack .wcc.c.var .wcc.c.val -side left -fill y -expand 1
pack .wcc.c.var.l .wcc.c.var.h -side top
pack .wcc.c.val.l .wcc.c.val.e -side top
pack .wcc.b.al -side left
pack .wcc.b.dismiss -side right
}
proc chk_edit_mode mode {
global edit_mode
if {$edit_mode != $mode} {
bell
return -code return
}
}
proc deduce_lang filename {
global lang
# Should give correct language mode id given file name
set ext [file extension $filename]
set lang text
foreach {id el} {
tk {.tk .tcl}
html {.html .htm .phtml .php .php3}
c++ {.c .cc .C .cpp .cxx .c++ .C++}
sql {.sql}
} {
if {[lsearch -exact $el $ext] >= 0} {set lang $id}
}
setlang
}
proc cluehunt_tk clue {
if {$clue == "dollar"} {
set l [lrange [lindex [.t get 1.0 "1.0 lineend"] 2] 0 4]
clue_offer $l
}
}
proc clue_offer cl {
set i 1
foreach try $cl {
.clue.b$i config -text "$try "
incr i
if {$i == 6} {return}
}
}
proc html_highlight {} {
# This should highlight the syntax of an entire page.
# Essentially, I will scan through the page reading HTML and maintaining a small
# amount of state which enables me to tell what color the current character
# should be. This, combined with a knowledge of state changes, should let me
# sprinkle tags appropriately.
# First, clean out the tags:
.t tag delete htext htag hcomment hquote hres hdubious
# Initialize data
# States are text, tag, comment, quote, dubious
set state text
set lastloc 1.0
set laststate text
# Loop across all lines
set maxy [lindex [split [.t index end] .] 0]
for {set y 1} {$y < $maxy} {incr y} {
# Loop across all characters
set maxx [lindex [split [.t index "$y.0 lineend"] .] 1]
for {set x 0} {$x < $maxx} {incr x} {
set consume 0
set ch [.t get $y.$x]
switch $state {
text {
if {$ch == "\<"} {set state tag}
}
tag {
if {$ch == "\""} {set state quote}
if {$ch == "\>"} {
set state text
set consume 1
}
}
comment {
}
quote {
if {$ch == "\""} {
set state tag
set consume 1
}
if {$ch == "\>"} {
set state dubious
set consume 1
}
}
dubious {
}
}
# Set the character to be part of the tag.
if {$state != $laststate} {
set pt $y.[expr $x + $consume]
.t tag add h${laststate} $lastloc $pt
set laststate $state
set lastloc $y.$x
}
}
# X
if {$state == "dubious"} {
set state text
set pt $y.[expr $x + $consume]
.t tag add hdubious $lastloc $pt
set laststate text
set lastloc $y.$x
}
}
# Y
.t tag add h${laststate} $lastloc end
set laststate $state
set lastloc $y.$x
.t tag config htag -foreground blue
.t tag config hquote -foreground darkgreen
}
proc qtk_delwidget {} {
# This function relies on being able to see the widget list.
# Perhaps better would be to take an argument as an index into the widget list.
global widlist oarr
# get index into widget array to delete
set wn [.wl.lb curselection]
if {[llength $wn] != 1} {
bell
return
}
#remove it from the viewer.
.wl.lb delete $wn
# Get widget id to delete
set wid [lindex $widlist $wn]
# remove widget from list
set prefix [lrange $widlist 0 [expr $wn - 1]]
set suffix [lrange $widlist [expr $wn + 1] end]
set widlist [concat $prefix $suffix]
# delete the widget
unset oarr($wid)
# Invalidate the widget list and/or the example dialog
qtk_inval_example
}
proc ht_table_create {} {
catch {destroy .httc}
toplevel .httc
wm title .httc {Table Creatrix}
label .httc.l -text {Table Creatrix}
frame .httc.ali -border 0 -relief flat
frame .httc.clr -border 0 -relief flat
frame .httc.row -border 0 -relief flat
frame .httc.col -border 0 -relief flat
frame .httc.wid -border 0 -relief flat
frame .httc.hei -border 0 -relief flat
frame .httc.cap -border 0 -relief flat
frame .httc.cmd -border 0 -relief flat
label .httc.ali.l -text {Align}
label .httc.clr.l -text {BgColor}
label .httc.row.l -text {Rows}
label .httc.col.l -text {Columns}
label .httc.wid.l -text {Width}
label .httc.hei.l -text {Height}
label .httc.cap.l -text {Caption}
entry .httc.ali.e -width 20 -font 7x14
entry .httc.clr.e -width 20 -font 7x14
entry .httc.row.e -width 20 -font 7x14
entry .httc.col.e -width 20 -font 7x14
entry .httc.wid.e -width 20 -font 7x14
entry .httc.hei.e -width 20 -font 7x14
entry .httc.cap.e -width 20 -font 7x14
button .httc.cmd.ok -text {Write Code} -command {
ht_table_write
destroy .httc
}
button .httc.cmd.dis -text {Dismiss} -command {
destroy .httc
}
pack .httc.l -side top
pack .httc.ali -side top -fill x
pack .httc.clr -side top -fill x
pack .httc.row -side top -fill x
pack .httc.col -side top -fill x
pack .httc.wid -side top -fill x
pack .httc.hei -side top -fill x
pack .httc.cap -side top -fill x
pack .httc.cmd -side top -fill x
pack .httc.ali.l -side left -anchor e
pack .httc.clr.l -side left -anchor e
pack .httc.row.l -side left -anchor e
pack .httc.col.l -side left -anchor e
pack .httc.wid.l -side left -anchor e
pack .httc.hei.l -side left -anchor e
pack .httc.cap.l -side left -anchor e
pack .httc.ali.e -side left -anchor e
pack .httc.clr.e -side left -anchor e
pack .httc.row.e -side left -anchor e
pack .httc.col.e -side left -anchor e
pack .httc.wid.e -side left -anchor e
pack .httc.hei.e -side left -anchor e
pack .httc.cap.e -side left -anchor e
pack .httc.cmd.ok -side left -expand 1
pack .httc.cmd.dis -side left -expand 1
}
proc ht_table_write {} {
set ali [.httc.ali.e get]
set clr [.httc.clr.e get]
set row [.httc.row.e get]
set col [.httc.col.e get]
set wid [.httc.wid.e get]
set hei [.httc.hei.e get]
set cap [.httc.cap.e get]
ins "<table"
if {$ali!=""} {ins " align=$ali"}
if {$clr!=""} {ins " bgcolor=$clr"}
if {$wid!=""} {ins " width=$wid"}
if {$hei!=""} {ins " height=$hei"}
ins ">\n"
if {$cap!=""} {
ins "<caption>\n"
ins $cap
ins "</caption>\n"
}
for {set y 0} {$y<$row} {incr y} {
ins "<tr>"
for {set x 0} {$x<$col} {incr x} {
ins "<td> </td>"
}
ins "</tr>\n"
}
ins "</table>\n"
}
proc ht_spell_refresh {} {
catch {destroy .spell}
toplevel .spell
wm title .spell {HTML Spells}
label .spell.l -text {Refresh Spell}
frame .spell.delay -border 0 -relief flat
frame .spell.url -border 0 -relief flat
frame .spell.cmd -border 0 -relief flat
label .spell.delay.l -text {Delay}
label .spell.url.l -text {URL}
entry .spell.delay.e -width 10 -font 7x14
entry .spell.url.e -width 19 -font 7x14
button .spell.cmd.ok -text {Code} -command {
ins {<meta http-equiv="refresh" content="}
ins [expr [.spell.delay.e get]+0]
ins {;url=}
ins [.spell.url.e get]
ins {">}
ins \n
destroy .spell
}
button .spell.cmd.dis -text {Cancel} -command {destroy .spell}
pack .spell.l -side top
pack .spell.delay -side top -fill x
pack .spell.url -side top -fill x
pack .spell.cmd -side top -fill x
pack .spell.delay.l -side left -fill x
pack .spell.url.l -side left -fill x
pack .spell.delay.e -side left
pack .spell.url.e -side left
pack .spell.cmd.ok -side left -expand 1
pack .spell.cmd.dis -side left -expand 1
}
proc ht_spell_style_import {} {
catch {destroy .spell}
toplevel .spell
wm title .spell {HTML Spells}
label .spell.l -text {Style Sheet Spell}
frame .spell.url -border 0 -relief flat
frame .spell.cmd -border 0 -relief flat
label .spell.url.l -text {css url}
entry .spell.url.e -width 20 -font 7x14
button .spell.cmd.ok -text {Code} -command {
ins {<link rel=stylesheet href="}
ins [.spell.url.e get]
ins {" type="TEXT/CSS">}
ins \n
destroy .spell
}
button .spell.cmd.dis -text {Cancel} -command {destroy .spell}
pack .spell.l -side top
pack .spell.url -side top -fill x
pack .spell.cmd -side top -fill x
pack .spell.url.l -side left -fill x
pack .spell.url.e -side right -fill x
pack .spell.cmd.ok -side left -expand 1
pack .spell.cmd.dis -side left -expand 1
}
proc menu_forms {} {
set m .menu.forms.m
menubutton .menu.forms -text "Forms" -menu $m -underline 2
menu $m
$m add command -label "Form" -command {ins "<form method=POST>\n</form>"} -underline 0
$m add cascade -label "Input" -menu $m.input -underline 0
$m add cascade -label "Textarea" -menu $m.textarea -underline 0
# Input types
set inputs {text password button submit reset checkbox radio}
set m .menu.forms.m.input
menu $m
foreach type $inputs {
set cmd [subst {ins "<input type=$type>"}]
$m add command -label $type -command $cmd -underline 0
}
set m .menu.forms.m.textarea
menu $m
foreach {label cols rows} {Small 30 3 Medium 45 5 Large 60 7} {
set cmd [subst {ins "<textarea cols=$cols rows=$rows></textarea>"}]
$m add command -label $label -command $cmd -underline 0
}
$m add command -label "Generic" -command {ins "<textarea></textarea>"} -underline 0
}
proc qtk_decompose {} {
#global qtk q_funcs q_curbuf edit_mode
global qtk q_func_args q_func_body
set fname [get_fname]
if {$fname==""} return
set_mode qtk
qtk_eraseproj
# Intention of this function: Take a file of tcl/tk code and
# apply string functions to tear such file apart into syntactic blocks.
# Should be robust against most forms of badly written or quirky code.
# First read file into string.
# Prepare initial strings
set main ""
set header ""
set qtk(funclist) "__HEADER__"
# Use precalculated knowledge of where procedures start (pass 1) to speed
# parsing by avoiding manipulating too much text at once.
set cluehelper {$1=="proc" {print NR}}
set lineclues [exec awk $cluehelper $fname]
# Create a loop, reading sections of a file until it's all used up.
# Should reduce time used from O(n^2) to O(n log n) -- Much Faster
set f [open $fname r]
set test [read $f]
close $f
while {[string length $test]} {
# Next start picking apart lines.
set linelen [string first \n $test]
set line [string range $test 0 $linelen]
set cmd [lindex $line 0]
if {$cmd == "proc"} {
# Do we need to twiddle header?
# Stuff before first procedure should be in header.
if {$header == ""} {
set header $main
set main ""
}
# Parse procedure
set lproc [lrange $test 0 3]
set name [lindex $lproc 1]
set argys [lindex $lproc 2]
set body [lindex $lproc 3]
# Clean things up a bit
if {[string index $body 0] == "\n"} {set body [string range $body 1 end]}
# Stick it in data structure
lappend qtk(funclist) $name
set q_func_args($name) $argys
set q_func_body($name) $body
# Now have to figure out how to pluck the right number of lines from $test.
# Turns out that inter-element white space is preserved in list operations.
set test [string range $test [string length $lproc] end]
# Now remove the last bits on the end of the line closing the procedure.
set linelen [string first \n $test]
set test [string range $test [expr $linelen + 1] end]
# Let people know it's been parsed
puts [list $cmd $name $argys]
} else {
# add line to "__MAIN__"
set main "$main$line"
set test [string range $test [expr $linelen + 1] end]
}
}
lappend qtk(funclist) "__MAIN__"
set q_func_body(__HEADER__) $header
set q_func_args(__HEADER__) ""
set q_func_body(__MAIN__) $main
set q_func_args(__MAIN__) ""
qtk_invalidate_views
qtk_setname $fname
qtk_selfunc
}
proc rt_menu {wid x y} {
set m .rt_menu
catch {destroy $m}
menu $m -tearoff 0
$m add command -label "Copy" -command "ed_copy $wid" -underline 0 -accelerator "Ctrl-Ins"
$m add command -label "Cut" -command "ed_cut $wid" -underline 2 -accelerator "Shift-Del"
$m add command -label "Paste" -command "ed_paste $wid" -underline 0 -accelerator "Shift-Ins"
tk_popup .rt_menu $x $y
}
proc set_mode mode {
global edit_mode
set edit_mode $mode
foreach widget [pack slaves .metabits] {
destroy $widget
}
if {$mode == "qtk"} {
label .metabits.l1 -text "proc"
menubutton .metabits.name -text {$name} -relief raised
entry .metabits.args -width 30 -font 7x14
pack .metabits.l1 -side left
pack .metabits.name -side left -anchor w -ipady 2 -ipadx 4
pack .metabits.args -side left -anchor w
}
}
proc do_recent_funcs name {
global qtk
set index [lsearch -exact $qtk(rec_func) $name]
if {$index == -1} {
set qtk(rec_func) [lrange [concat $name $qtk(rec_func)] 0 4 ]
} else {
set first [lrange $qtk(rec_func) 0 [expr $index - 1]]
set mid [lindex $qtk(rec_func) $index]
set last [lrange $qtk(rec_func) [expr $index + 1] end]
set qtk(rec_func) [concat $mid $first $last]
}
## By this time qtk(rec_func) is in a state where we can make a menu.
set m .metabits.name.m
catch { destroy $m }
menu $m -tearoff 0
foreach f $qtk(rec_func) {
$m add command -label $f -command "qtk_showfunc $f"
}
$m add separator
$m add command -label "Project Notes" -command {qtk_notes}
$m add command -label "All Functions" -command {qtk_selfunc}
.metabits.name configure -menu $m
}
proc hl_annoying {} {
# This should highlight an entire page in alternating colors.
# Its purpose is to discover the issues behind syntax highlighting.
# It will decide what is whitespace, punctuation, or a word.
# Whitespace no longer gets a green background.
# Punctuation turns brown.
# Words turn blue.
# Numbers turn green.
# First, clean out the tags:
hl_unhighlight
# The basic algorithm is to keep track of state transitions.
# I.E. what point the scanner moves from one lexical object to the next.
# This means we need to store the "mark", "point", and "scan" positions.
# Presumably when we come to a conclusion about the extent of a lexical object,
# we tag that object according to the scheme in place. We may also set some
# other state information about how future scanning should take place.
# Presumably scanners could be stacked....
# Initialize data
set mark 1.0
set point 1.0
set collecting ws
set wants 1
set terminal 0
# Options: WhiteSpace, Number, Punctuation, Alnum
# Loop across all lines
set maxy [lindex [split [.t index end] .] 0]
for {set y 1} {$y < $maxy} {incr y} {
# In real life, we need a list of continuation options for each recognizer
# state so we can run through the recognizer (possibly multiple ones in
# parallel) as a (multiple) state graph transition algorithm.
# This is simple to think about but nontrivial to program.
# The compromise here is to presume that the "recognizer" degenerates to a
# single case for the first character.
# There are two cases: a recognizer "wants" the character, or it doesn't.
# The recognizer may optionally advise that it is finished. (in a terminal
# state)
# Loop across all characters
set maxx [lindex [split [.t index "$y.0 lineend"] .] 1]
set x 0
while {$x < $maxx} {
set ch [.t get "$y.$x"]
# Classify this character:
set ct [ctype $ch]
switch $collecting {
ws {
if {$ct != "ws"} {
set terminal 1
set wants 0
} else {
set wants 1
}
}
punc {
if {$ct != "punc"} {
set terminal 1
set wants 0
} else {
set wants 1
}
}
num {
if {$ct != "digit"} {
set terminal 1
set wants 0
} else {
set wants 1
}
}
alnum {
if {($ct == "punc") || ($ct == "ws")} {
set terminal 1
set wants 0
} else {
set wants 1
}
}
}
# switch
# Now process the "wants" variable
if $wants {
incr x
}
# Now check for a terminal state.
if {$terminal == 1} {
# set the point:
set point "$y.$x"
# add the tag: (maybe generalize to a function returning the tag name?)
switch $collecting {
ws {.t tag add ws $mark $point}
punc {.t tag add punc $mark $point}
num {.t tag add num $mark $point}
alnum {.t tag add alnum $mark $point}
}
# reset the "terminal" state.
set terminal 0
# set the mark:
set mark $point
# Read ahead a character so we can make the appropriate
# collector transition.
set ra [.t get $point]
set ct [ctype $ra]
switch $ct {
ws {set collecting ws}
punc {set collecting punc}
digit {set collecting num}
lcase -
ucase {set collecting alnum}
}
# switch $ct
}
# if $terminal
}
# while x
# In real life, each recognizer would return the terminal state ID and
# we could color appropriately. For this excercise, the color is according
# to which recognizer turned up its nose at further input.
# It would be good to update things regularly. Do it after every line.
update
}
# for y
# The last thing to do is color the final (unfinished?) string.
# This amounts to re-running the $terminal routine on the last bit of text
# but not performing the associated read-ahead (which really should be
# separate...)
# The below is a copy from above. Presumably it will be proceduralized
# when enough details of the general case are known.
set point "$y.$x"
# add the tag: (maybe generalize to a function returning the tag name?)
switch $collecting {
ws {.t tag add ws $mark $point}
punc {.t tag add punc $mark $point}
num {.t tag add num $mark $point}
alnum {.t tag add alnum $mark $point}
}
# The only thing left is to actually CONFIGURE the tags we've been sprinkling
# so liberally throughout the text.
.t tag config alnum -foreground blue
.t tag config num -foreground darkgreen
.t tag config punc -foreground brown
#.t tag config ws -background green
}
proc hl_unhighlight {} {
foreach victim [.t tag names] {
.t tag delete $victim
}
}
proc ctype ch {
# Return a code indicating the type of the character
# Do this by making some key comparisons.
# Outputs: lcase ucase digit punc ws
if {( "a" <= $ch) && ("z" >= $ch)} {
return lcase
}
if {" " >= $ch} {
return ws
}
if {("0" <= $ch) && ("9" >= $ch)} {
return digit
}
if {("A" <= $ch) && ("Z" >= $ch)} {
return ucase
}
return punc
}
proc hl_php {} {
}
proc hl_generic {} {
global hl_def_state hl_context_other hl_term hl_other hl_cmd hl_context
# Initialize tables:
hl_init
# Set initial context and stack.
set hl_context "php"
set cstack {}
# Initialize data
set mark 1.0
set point 1.0
set state $hl_def_state($hl_context)
set wants 1
# Clean out the old tags:
hl_unhighlight
#
# What we need to do here is the state transition function.
# This entails getting the S-T list for the current state, then
# making key comparisons to find the "NEXT STATE".
# Afterwards we check the "terminal" array to find if the given
# next state is a terminal box, and if so, color the lexical
# unit appropriately.
# If we can't find a "next state" based on the S-T list, then
# we try the "hl_other" array. If that has a value, we use it.
# Should the "other" entry lead to a terminal state, the
# character is not gobbled. (If you want it gobbled, insert an
# extra state.)
# Otherwise we assume that this character can't be used by the
# state graph and that we have matched an invalid lexical unit.
# This ONLY gobbles the character IF the current state is the
# default state for the context.
# Next it applies the coloring for the context's "other" tag
# and sets the state back to the default for the context.
#
# Terminal states are also checked for context push/pull status.
# If the state number appears in the hl_cmd array, then the
# value therein is used to determine whether to push or pull,
# and if push, then which context to switch to.
# Stack code takes place after coloring.
#
# Loop across all lines
set maxy [lindex [split [.t index end] .] 0]
for {set y 1} {$y < $maxy} {incr y} {
# Loop across all characters
set maxx [lindex [split [.t index "$y.0 lineend"] .] 1]
set x 0
while {$x < $maxx} {
set ch [.t get "$y.$x"]
set wants [hl_trans state $ch]
# Now process the "wants" variable
incr x $wants
# Now check for a terminal state.
if {$hl_term($state)} {
# Do the highlighting
set point "$y.$x"
hl_do_terminal $mark $point $state
set mark $point
# Perform any context commands
catch {
set cmd $hl_cmd($state)
switch [lindex $cmd 0] {
pop {
set hl_context [lindex $cstack 0]
set cstack [lrange $cstack 1 end]
}
push {
set cstack [concat $context $cstack]
set hl_context [lindex $cmd 1]
}
}
}
# Reset the state.
set state $hl_def_state($hl_context)
}
# if $hl_term($state)
}
# while x
# Need to pass the "eol" character through the state graph.
hl_trans state \n
if {$hl_term($state)} {
# Do the highlighting
set point [expr $y + 1 ]
set point "$point.0"
hl_do_terminal $mark $point $state
set mark $point
}
# It would be good to update things regularly. Do it after every line.
update
}
# for y
# Now we have to "terminate" whatever token we've been collecting.
# Presumably this is done with "EOF" which is "other" than any character.
# Thus we state-transition to the "context-other" entry for where we are, then color.
# Some things (e.g. Quotes) may want to color
set point "$y.$x"
hl_do_terminal $mark $point $hl_def_state($hl_context)
# The only thing left is to actually CONFIGURE the tags we've been sprinkling
# so liberally throughout the text.
.t tag config 103 -background red -foreground black
foreach {ts color} {
4 purple
9 grey37
13 grey37
18 #ddf38fd30000
37 brown
41 darkgreen
42 darkgreen
30 darkgreen
35 darkgreen
59 grey37
61 blue
62 darkgreen
66 brown
70 blue
72 darkgreen
74 darkgreen
101 #00006b169ba5
105 #00006b169ba5
108 #00006b169ba5
112 #00006b169ba5
113 #00006b169ba5
117 #00006b169ba5
} { .t tag config $ts -foreground $color }
}
proc hl_do_terminal {mark point state} {
# This needs to consult a terminal highlight table and apply the appropriate tag.
# Perhaps one easy thing is to name the tag after the terminal state number, then
# use the coloring table to configure the tags.
.t tag add $state $mark $point
# This should maybe see about context push/pull? Or maybe that should be done
# outside this framework?}
proc hl_init {} {
global hl_def_state hl_x hl_context_other hl_term hl_other hl_cmd hl_lists hl_chars
# The general idea here is to initialize the state transition graph
# and related parameters.
# There will be much static data here....
array set hl_def_state {
html 50
php 0
tag 75
dquote 39
squote 40
}
array set hl_context_other {
html 50
php 0
tag 75
dquote 39
squote 40
}
array set hl_x {
0 {
a z 19
A Z 19
"\0" " " 1
1 9 109
}
1 { "\0" " " 1 }
15 { a z 16 A Z 16 }
16 { a z 16 A Z 16 }
17 { a z 17 A Z 17 0 9 17 }
19 { a z 20 A Z 20 0 9 20 }
20 { a z 20 A Z 20 0 9 20 }
100 { 0 7 104 }
100 { 8 9 102 }
104 { 0 7 104 }
106 { 0 9 107 a f 107 A F 107 }
109 { 0 9 110 }
110 { 0 9 110 }
111 { 0 9 114 }
115 { 0 9 116 }
116 { 0 9 116 }
}
array set hl_chars {
0 { _ 19 $ 15 0 100 ? 22 / 3 \" 25 \' 31 # 14}
3 { * 5 / 10 }
5 { * 7 }
6 { * 7 }
7 { / 8 }
10 { \n 12 }
11 { \n 12 }
14 { \n 12 }
15 { _ 16 $ 15 }
16 { _ 16 }
17 { _ 17 }
19 { _ 20 }
20 { _ 20 }
22 { > 24 }
26 { \\ 27 \" 29 }
33 { \\ 32 \' 34 }
39 { \\ 27 \" 29 }
40 { \\ 32 \' 34 }
50 { < 51 & 63 }
51 { ! 52 ? 60 }
52 { - 53 }
53 { - 54 }
54 { - 56 }
55 { - 56 }
56 { - 57 }
57 { > 58 }
64 { ; 65 }
67 { \" 69 }
68 { \" 69 }
75 { \" 67 > 71 }
109 { . 111 }
110 { . 111 }
}
array set hl_lists {
0 { "()[]{}" 37 }
100 { xX 106 }
109 { eE 115 }
110 { eE 115 }
111 { eE 115 }
}
array set hl_other {
0 38 1 2 3 4 5 6
6 6 7 6 8 9 10 11 11 11
12 13 14 11 16 18 17 18
19 21 20 21 22 4 24 23
25 41 26 26 27 26 31 42
32 33 33 33 34 35 38 4
39 26 40 33
51 62 52 62 53 62 54 55
55 55 56 55 57 66 58 59
60 61 63 64 64 64 65 66
67 68 69 70 71 72 75 73
73 74
100 101 102 103 104 105
107 108 109 112 110 112
114 113 116 117
}
array set hl_cmd {
41 {push dquote}
42 {push squote}
30 pop
35 pop
23 pop
61 {push php}
62 {push tag}
72 pop
}
set term_states {
2 4 9 13 18 21 23 30 35 37 41 42
59 61 62 66 70 72 74
101 103 105 108 112 113 117
}
# Automatically populate hl_term array.
foreach a [concat [ array names hl_x ] [ array names hl_chars ] [ array names hl_lists ] [ array names hl_other ] ] {
set hl_term($a) 0
}
foreach a $term_states {
set hl_term($a) 1
}
}
proc hl_trans {state_v ch} {
global hl_x hl_term hl_lists hl_chars hl_context hl_def_state hl_other hl_context_other
upvar $state_v state
set xl {}
catch {set xl $hl_x($state)}
# Try to match against the hl_x (transition) array
foreach {first last dest} $xl {
if {("$first" <= "$ch") && ("$ch" <= "$last")} {
set state $dest;
return 1
}
}
# Try the state->chars strategy
set xl {}
catch { set xl $hl_chars($state) }
foreach {char dest} $xl {
if {"$char" == "$ch"} {
set state $dest;
return 1
}
}
# Try the "state->lists" strategy
set xl {}
catch { set xl $hl_lists($state) }
foreach {ch_list dest} $xl {
if {-1 != [lsearch -exact $ch_list]} {
set state $dest;
return 1
}
}
# Try the "state->other" strategy
set next_state {}
if {$next_state == {}} {
catch {
set next_state $hl_other($state)
set wants 1
# Have a next state. Is it terminal?
if {$hl_term($next_state)} {
set wants 0
}
}
}
# Try the "context->other" strategy
if {$next_state == {}} {
set next_state $hl_context_other($hl_context)
if {$state == $hl_def_state($hl_context)} {
set wants 1
} else {
set wants 0
}
}
set state $next_state
return $wants
}
# For the HTML module
ht_init
# For the QTK module
qtk_init
##################
#
# Global Variables
#
##################
# for editor
set clipboard {}
set autoindent 1
set lang tk
set edit_mode flat
# Set up main interface window:
main;
#########################
# #
# Read Command Line #
# #
#########################
if {$argv != ""} {
if [load $argv] {
set tmp [tk_dialog .confirm "Information" "Unable to read a file by the name \"$argv\". Would you like to create a new file?" info 0 "OK" "Nope." ]
if {$tmp == 0} {
.f.n config -text $argv
}
}
deduce_lang $argv
}
if {($argv == "") && ([glob -nocomplain Project] != "")} {
if {[tk_dialog .lp "Load Project?" "There's a project file in this directory. Do you want to load it?" question 0 "Yep" "Not Now"] == 0} {
qtk_load
}
}