>. In modified or unmodified form, it might serve the purpose of a "weeEdit." The program script, uncompressed, takes up slightly less than 100 KB. (The WISH acronym, originally derived from the wish interpreter, now stands for Wee Integrated Suite of Helpers, although the "integrated" aspect still needs some work.)Larry Smith The Wee project (aka the "We" project from Eolas) has not been static, but I have not had much time to work on it. I have integrated supernotepad, a browser (plume), a chat program, draw and paint programs, a notepad, two calculators - a four-banger and the IQ-15 from HP Calculator Simulations, and the tk# spreadsheet. The window manager is much improved, but there are a few more bugs to squash in order to get to a stable release. Eolas's Mike Doyle (MDD) has been funding this.I'm a home computer user and hobbyist who developed the various functions of WISH Supernotepad because I, or members of my family, needed or wanted them. It was designed to run on Linux, but no doubt it could be made to work on other operating systems (with a bit of assistance from people who know more than I do about those systems). The code is intended to be comprehensible, well organized, and easily modified. Here are some things it can do; let's see if anyone wants to compare them with things they think a "weeEdit" should or shouldn't do.- Basic text editing functions: New, Open, Save, Save As, Cut, Copy, Paste, Delete, Undo and Redo (unlimited, but stack is emptied when file is saved), Select All, Insert File, Find, Replace. A list of recently used files is maintained, and displayed when the "Open Recent" or "Insert Recent" command is invoked.
- Not-so-basic text editing functions: Single-click insertion of special characters; simultaneous global search and replace of multiple expressions; word count; insertion of time and date.
- Printing of monospaced text with word wrap (on Unix-type systems only, so far), using the X Printing Panel (XPP) if available, otherwise lpr.
- HTML editing functions: New HTML; Convert (plain text) to HTML; hexadecimal color code selection by color name or RGB content (using scale widgets that instantly cause the displayed color to change); toplevel windows for quick insertion of codes for Heading, Font, Anchor, Link, Image, List, and Table (creation, continuation, and data entry); single-keystroke (or single-key-combination, or single-click) insertion of codes for Paragraph, Line Break, Italics, Bold, and Center.
- Tcl/Tk code editing functions: New Script; Run Selected Code; automatic indentation; single key combinations for paired braces, brackets, etc., plus Next Braces and Leave Braces.
Zipguy 2014-01-24 - You can find out my email address by clicking on Zipguy.In case you just wondered what it looked like, I just added a screenshot of this program called weeEdit. This is what it looks like:
It only had one problem with Windows 7, which was at line number 2762, which was in the special characters section. I commented it out, and it ran just fine.and here's the program. #!/usr/bin/env wish
# WISH Supernotepad 2006
# (the ninth version of WISH Supernotepad)
# by David McClamrock <mcclamrock@locl.net>
# based on Tk NotePad 0.5.0 by Joseph Acosta
# and "textedit.tcl" by Eric Foster-Johnson
# with help from Eric Foster-Johnson,
# Graphical Applications with Tcl & Tk (2nd edition)
# and Christopher Nelson, Tcl/Tk Programmer's Reference
# Copyright ?2001-2006 David H. McClamrock
# Freely available under Maximum Use License for Everyone
# You should have received a copy of this license with this program.
# If you didn't, e-mail the author to get one.
### INITIALIZATION ###
# WISH applications require at least Tcl and Tk 8.4:
set version "2006"
set packtype regular
set tclo [package require Tcl]
set tko [package require Tk]
if {$tclo < 8.4 || $tko < 8.4} {
tk_messageBox -message "WISH Supernotepad requires at least version 8.4\
of Tcl and Tk" -type ok
exit
}
# Setup for Starkit or regular filesystem:
if {$packtype eq "starkit"} {
package provide app-supernotepad $version
set docdir [file join $starkit::topdir doc]
set libdir [file join $starkit::topdir lib]
} else {
# Default settings:
set docdir /usr/local/doc/wishes
set libdir /usr/local/lib/wishes
# May be altered by root's config file:
set hardfig [file join / root wishes]
if {[file isdirectory $hardfig]} {
set locfig [file join $hardfig comdirs.tcl]
if {[file readable $locfig]} {
source $locfig
}
}
}
# One or more features may work only on unix platforms (including Linux),
# so identify the platform:
set platform [split [array get tcl_platform] ]
if {[lsearch $platform unix] != -1} {
set platform unix
}
# Make directory for configuration, etc., if it isn't there already:
set wishdir [file join $env(HOME) wishes]
if {[file isdirectory $wishdir] == 0} {
file mkdir $wishdir
}
# Get lists of recently opened or inserted files,
# and recently cut or copied blocks of text:
set rece [file join $wishdir superece.tcl]
set superpaste [file join $wishdir superpaste.tcl]
if {[file readable $rece]} {
source $rece
} else {
set recentlist [list]
set reclim 1000
}
if {[file readable $superpaste]} {
source $superpaste
} else {
set pastelist [list]
set pastelim 1000
}
# Set some defaults (may be changed by configuration file--see below):
set currentfile "" ; # No name for open file yet
set addfile "" ; # No name for file to add, either
set curprint "" ; # Nor a name for file to print
set backfile "" ; # And no name for backup file
set openins Open ; # By default, open rather than insert file
set openew 0 ; # At first, don't open file in new window
set converto 0 ; # Don't convert existing text to HTML unless told to do it
set tabno 0 ; # No tabs have yet been automatically inserted
set dumpfile "" ; # Don't trash old name of file that hasn't yet been renamed
set filetosave none ; # Don't save a file when you haven't done anything
set texwid 80 ; # Width of text widget
set formawid 80 ; # Width of text formatted with newlines
set texhi 32 ; # Height of text widget
set wordwrap word ; # Word wrap on by default
set fonto "lucidatypewriter" ; # Default font
set siz 14 ; # Font size
set helpfont "times" ; # User Help Guide font
set helpsiz 14 ; # User Help Guide font size
set fontaine [list $fonto $siz] ; # Default font with size
set helpall [list $helpfont $helpsiz] ; # User Help Guide font with size
set reunito 0 ; # Replace needless newlines (if desired) with spaces
set parsep 1 ; # Keep paragraphs separate when omitting needless newlines
set expert 0 ; # Don't do expert search with regular expressions
set headsize 1 ; # size of HTML heading
set html_fontsize 0 ; # Default regular HTML font size
set listtype 1 ; # Use 1-2-3 numbering in HTML list
set autotab 1 ; # Auto-tab to write Tcl code
set palmdir "" ; # Directory to search for Palm Doc files
set t .tx ; # Global variable for text widget
set linkup 0 ; # Don't display Link-Text unless told to
set linklist [list] ; # Nothing yet in list of Link-Text links
# Read configuration file, if there is one:
set superfig [file join $wishdir superfig.tcl]
if {[file readable $superfig]} {
source $superfig
}
# Use WISH Color Picker Plus for color configuration
# (It sets color variables with default values;
# values may then be changed by configuration files):
# WISH Color Picker Plus (wishcolorplus.tcl)
# Megawidget and related code for color configuration
# in Tcl/Tk applications
# by David McClamrock <mcclamrock@locl.net>
# Copyright ?2002-2005 David H. McClamrock
# (Pre-2005 versions were incorporated in WISH Supernotepad)
# Freely available under Maximum Use License for Everyone
# You should have received a copy of this license with this file.
# If you didn't, e-mail the author to get one.
### List color names and values: ###
set colorlist [list \
{255 250 250 snow} \
{248 248 255 GhostWhite} \
{245 245 245 WhiteSmoke} \
{220 220 220 gainsboro} \
{255 250 240 FloralWhite} \
{253 245 230 OldLace} \
{250 240 230 linen} \
{250 235 215 AntiqueWhite} \
{255 239 213 PapayaWhip} \
{255 235 205 BlanchedAlmond} \
{255 228 196 bisque} \
{255 218 185 PeachPuff} \
{255 222 173 NavajoWhite} \
{255 228 181 moccasin} \
{255 248 220 cornsilk} \
{255 255 240 ivory} \
{255 250 205 LemonChiffon} \
{255 245 238 seashell} \
{240 255 240 honeydew} \
{245 255 250 MintCream} \
{240 255 255 azure} \
{240 248 255 AliceBlue} \
{230 230 250 lavender} \
{255 240 245 LavenderBlush} \
{255 228 225 MistyRose} \
{255 255 255 white} \
{0 0 0 black} \
{47 79 79 DarkSlateGray} \
{105 105 105 DimGray} \
{112 128 144 SlateGray} \
{119 136 153 LightSlateGray} \
{190 190 190 gray} \
{211 211 211 LightGray} \
{25 25 112 MidnightBlue} \
{0 0 128 NavyBlue} \
{100 149 237 CornflowerBlue} \
{72 61 139 DarkSlateBlue} \
{106 90 205 SlateBlue} \
{123 104 238 MediumSlateBlue} \
{132 112 255 LightSlateBlue} \
{0 0 205 MediumBlue} \
{65 105 225 RoyalBlue} \
{0 0 255 blue} \
{30 144 255 DodgerBlue} \
{0 191 255 DeepSkyBlue} \
{135 206 235 SkyBlue} \
{135 206 250 LightSkyBlue} \
{70 130 180 SteelBlue} \
{176 196 222 LightSteelBlue} \
{173 216 230 LightBlue} \
{176 224 230 PowderBlue} \
{175 238 238 PaleTurquoise} \
{0 206 209 DarkTurquoise} \
{72 209 204 MediumTurquoise} \
{64 224 208 turquoise} \
{0 255 255 cyan} \
{224 255 255 LightCyan} \
{95 158 160 CadetBlue} \
{102 205 170 MediumAquamarine} \
{127 255 212 aquamarine} \
{0 100 0 DarkGreen} \
{85 107 47 DarkOliveGreen} \
{143 188 143 DarkSeaGreen} \
{46 139 87 SeaGreen} \
{60 179 113 MediumSeaGreen} \
{32 178 170 LightSeaGreen} \
{152 251 152 PaleGreen} \
{0 255 127 SpringGreen} \
{124 252 0 LawnGreen} \
{0 255 0 green} \
{127 255 0 chartreuse} \
{0 250 154 MediumSpringGreen} \
{173 255 47 GreenYellow} \
{50 205 50 LimeGreen} \
{154 205 50 YellowGreen} \
{34 139 34 ForestGreen} \
{107 142 35 OliveDrab} \
{189 183 107 DarkKhaki} \
{240 230 140 khaki} \
{238 232 170 PaleGoldenrod} \
{250 250 210 LightGoldenrodYellow} \
{255 255 224 LightYellow} \
{255 255 0 yellow} \
{255 215 0 gold} \
{238 221 130 LightGoldenrod} \
{218 165 32 goldenrod} \
{184 134 11 DarkGoldenrod} \
{188 143 143 RosyBrown} \
{205 92 92 IndianRed} \
{139 69 19 SaddleBrown} \
{160 82 45 sienna} \
{205 133 63 peru} \
{222 184 135 burlywood} \
{245 245 220 beige} \
{245 222 179 wheat} \
{244 164 96 SandyBrown} \
{210 180 140 tan} \
{210 105 30 chocolate} \
{178 34 34 firebrick} \
{165 42 42 brown} \
{233 150 122 DarkSalmon} \
{250 128 114 salmon} \
{255 160 122 LightSalmon} \
{255 165 0 orange} \
{255 140 0 DarkOrange} \
{255 127 80 coral} \
{240 128 128 LightCoral} \
{255 99 71 tomato} \
{255 69 0 OrangeRed} \
{255 0 0 red} \
{255 105 180 HotPink} \
{255 20 147 DeepPink} \
{255 192 203 pink} \
{255 182 193 LightPink} \
{219 112 147 PaleVioletRed} \
{176 48 96 maroon} \
{199 21 133 MediumVioletRed} \
{208 32 144 VioletRed} \
{255 0 255 magenta} \
{238 130 238 violet} \
{221 160 221 plum} \
{218 112 214 orchid} \
{186 85 211 MediumOrchid} \
{153 50 204 DarkOrchid} \
{148 0 211 DarkViolet} \
{138 43 226 BlueViolet} \
{160 32 240 purple} \
{147 112 219 MediumPurple} \
{216 191 216 thistle} \
{255 250 250 snow1} \
{238 233 233 snow2} \
{205 201 201 snow3} \
{139 137 137 snow4} \
{255 245 238 seashell1} \
{238 229 222 seashell2} \
{205 197 191 seashell3} \
{139 134 130 seashell4} \
{255 239 219 AntiqueWhite1} \
{238 223 204 AntiqueWhite2} \
{205 192 176 AntiqueWhite3} \
{139 131 120 AntiqueWhite4} \
{255 228 196 bisque1} \
{238 213 183 bisque2} \
{205 183 158 bisque3} \
{139 125 107 bisque4} \
{255 218 185 PeachPuff1} \
{238 203 173 PeachPuff2} \
{205 175 149 PeachPuff3} \
{139 119 101 PeachPuff4} \
{255 222 173 NavajoWhite1} \
{238 207 161 NavajoWhite2} \
{205 179 139 NavajoWhite3} \
{139 121 94 NavajoWhite4} \
{255 250 205 LemonChiffon1} \
{238 233 191 LemonChiffon2} \
{205 201 165 LemonChiffon3} \
{139 137 112 LemonChiffon4} \
{255 248 220 cornsilk1} \
{238 232 205 cornsilk2} \
{205 200 177 cornsilk3} \
{139 136 120 cornsilk4} \
{255 255 240 ivory1} \
{238 238 224 ivory2} \
{205 205 193 ivory3} \
{139 139 131 ivory4} \
{240 255 240 honeydew1} \
{224 238 224 honeydew2} \
{193 205 193 honeydew3} \
{131 139 131 honeydew4} \
{255 240 245 LavenderBlush1} \
{238 224 229 LavenderBlush2} \
{205 193 197 LavenderBlush3} \
{139 131 134 LavenderBlush4} \
{255 228 225 MistyRose1} \
{238 213 210 MistyRose2} \
{205 183 181 MistyRose3} \
{139 125 123 MistyRose4} \
{240 255 255 azure1} \
{224 238 238 azure2} \
{193 205 205 azure3} \
{131 139 139 azure4} \
{131 111 255 SlateBlue1} \
{122 103 238 SlateBlue2} \
{105 89 205 SlateBlue3} \
{71 60 139 SlateBlue4} \
{72 118 255 RoyalBlue1} \
{67 110 238 RoyalBlue2} \
{58 95 205 RoyalBlue3} \
{39 64 139 RoyalBlue4} \
{0 0 255 blue1} \
{0 0 238 blue2} \
{0 0 205 blue3} \
{0 0 139 blue4} \
{30 144 255 DodgerBlue1} \
{28 134 238 DodgerBlue2} \
{24 116 205 DodgerBlue3} \
{16 78 139 DodgerBlue4} \
{99 184 255 SteelBlue1} \
{92 172 238 SteelBlue2} \
{79 148 205 SteelBlue3} \
{54 100 139 SteelBlue4} \
{0 191 255 DeepSkyBlue1} \
{0 178 238 DeepSkyBlue2} \
{0 154 205 DeepSkyBlue3} \
{0 104 139 DeepSkyBlue4} \
{135 206 255 SkyBlue1} \
{126 192 238 SkyBlue2} \
{108 166 205 SkyBlue3} \
{74 112 139 SkyBlue4} \
{176 226 255 LightSkyBlue1} \
{164 211 238 LightSkyBlue2} \
{141 182 205 LightSkyBlue3} \
{96 123 139 LightSkyBlue4} \
{198 226 255 SlateGray1} \
{185 211 238 SlateGray2} \
{159 182 205 SlateGray3} \
{108 123 139 SlateGray4} \
{202 225 255 LightSteelBlue1} \
{188 210 238 LightSteelBlue2} \
{162 181 205 LightSteelBlue3} \
{110 123 139 LightSteelBlue4} \
{191 239 255 LightBlue1} \
{178 223 238 LightBlue2} \
{154 192 205 LightBlue3} \
{104 131 139 LightBlue4} \
{224 255 255 LightCyan1} \
{209 238 238 LightCyan2} \
{180 205 205 LightCyan3} \
{122 139 139 LightCyan4} \
{187 255 255 PaleTurquoise1} \
{174 238 238 PaleTurquoise2} \
{150 205 205 PaleTurquoise3} \
{102 139 139 PaleTurquoise4} \
{152 245 255 CadetBlue1} \
{142 229 238 CadetBlue2} \
{122 197 205 CadetBlue3} \
{83 134 139 CadetBlue4} \
{0 245 255 turquoise1} \
{0 229 238 turquoise2} \
{0 197 205 turquoise3} \
{0 134 139 turquoise4} \
{0 255 255 cyan1} \
{0 238 238 cyan2} \
{0 205 205 cyan3} \
{0 139 139 cyan4} \
{151 255 255 DarkSlateGray1} \
{141 238 238 DarkSlateGray2} \
{121 205 205 DarkSlateGray3} \
{82 139 139 DarkSlateGray4} \
{127 255 212 aquamarine1} \
{118 238 198 aquamarine2} \
{102 205 170 aquamarine3} \
{69 139 116 aquamarine4} \
{193 255 193 DarkSeaGreen1} \
{180 238 180 DarkSeaGreen2} \
{155 205 155 DarkSeaGreen3} \
{105 139 105 DarkSeaGreen4} \
{84 255 159 SeaGreen1} \
{78 238 148 SeaGreen2} \
{67 205 128 SeaGreen3} \
{46 139 87 SeaGreen4} \
{154 255 154 PaleGreen1} \
{144 238 144 PaleGreen2} \
{124 205 124 PaleGreen3} \
{84 139 84 PaleGreen4} \
{0 255 127 SpringGreen1} \
{0 238 118 SpringGreen2} \
{0 205 102 SpringGreen3} \
{0 139 69 SpringGreen4} \
{0 255 0 green1} \
{0 238 0 green2} \
{0 205 0 green3} \
{0 139 0 green4} \
{127 255 0 chartreuse1} \
{118 238 0 chartreuse2} \
{102 205 0 chartreuse3} \
{69 139 0 chartreuse4} \
{192 255 62 OliveDrab1} \
{179 238 58 OliveDrab2} \
{154 205 50 OliveDrab3} \
{105 139 34 OliveDrab4} \
{202 255 112 DarkOliveGreen1} \
{188 238 104 DarkOliveGreen2} \
{162 205 90 DarkOliveGreen3} \
{110 139 61 DarkOliveGreen4} \
{255 246 143 khaki1} \
{238 230 133 khaki2} \
{205 198 115 khaki3} \
{139 134 78 khaki4} \
{255 236 139 LightGoldenrod1} \
{238 220 130 LightGoldenrod2} \
{205 190 112 LightGoldenrod3} \
{139 129 76 LightGoldenrod4} \
{255 255 224 LightYellow1} \
{238 238 209 LightYellow2} \
{205 205 180 LightYellow3} \
{139 139 122 LightYellow4} \
{255 255 0 yellow1} \
{238 238 0 yellow2} \
{205 205 0 yellow3} \
{139 139 0 yellow4} \
{255 215 0 gold1} \
{238 201 0 gold2} \
{205 173 0 gold3} \
{139 117 0 gold4} \
{255 193 37 goldenrod1} \
{238 180 34 goldenrod2} \
{205 155 29 goldenrod3} \
{139 105 20 goldenrod4} \
{255 185 15 DarkGoldenrod1} \
{238 173 14 DarkGoldenrod2} \
{205 149 12 DarkGoldenrod3} \
{139 101 8 DarkGoldenrod4} \
{255 193 193 RosyBrown1} \
{238 180 180 RosyBrown2} \
{205 155 155 RosyBrown3} \
{139 105 105 RosyBrown4} \
{255 106 106 IndianRed1} \
{238 99 99 IndianRed2} \
{205 85 85 IndianRed3} \
{139 58 58 IndianRed4} \
{255 130 71 sienna1} \
{238 121 66 sienna2} \
{205 104 57 sienna3} \
{139 71 38 sienna4} \
{255 211 155 burlywood1} \
{238 197 145 burlywood2} \
{205 170 125 burlywood3} \
{139 115 85 burlywood4} \
{255 231 186 wheat1} \
{238 216 174 wheat2} \
{205 186 150 wheat3} \
{139 126 102 wheat4} \
{255 165 79 tan1} \
{238 154 73 tan2} \
{205 133 63 tan3} \
{139 90 43 tan4} \
{255 127 36 chocolate1} \
{238 118 33 chocolate2} \
{205 102 29 chocolate3} \
{139 69 19 chocolate4} \
{255 48 48 firebrick1} \
{238 44 44 firebrick2} \
{205 38 38 firebrick3} \
{139 26 26 firebrick4} \
{255 64 64 brown1} \
{238 59 59 brown2} \
{205 51 51 brown3} \
{139 35 35 brown4} \
{255 140 105 salmon1} \
{238 130 98 salmon2} \
{205 112 84 salmon3} \
{139 76 57 salmon4} \
{255 160 122 LightSalmon1} \
{238 149 114 LightSalmon2} \
{205 129 98 LightSalmon3} \
{139 87 66 LightSalmon4} \
{255 165 0 orange1} \
{238 154 0 orange2} \
{205 133 0 orange3} \
{139 90 0 orange4} \
{255 127 0 DarkOrange1} \
{238 118 0 DarkOrange2} \
{205 102 0 DarkOrange3} \
{139 69 0 DarkOrange4} \
{255 114 86 coral1} \
{238 106 80 coral2} \
{205 91 69 coral3} \
{139 62 47 coral4} \
{255 99 71 tomato1} \
{238 92 66 tomato2} \
{205 79 57 tomato3} \
{139 54 38 tomato4} \
{255 69 0 OrangeRed1} \
{238 64 0 OrangeRed2} \
{205 55 0 OrangeRed3} \
{139 37 0 OrangeRed4} \
{255 0 0 red1} \
{238 0 0 red2} \
{205 0 0 red3} \
{139 0 0 red4} \
{255 20 147 DeepPink1} \
{238 18 137 DeepPink2} \
{205 16 118 DeepPink3} \
{139 10 80 DeepPink4} \
{255 110 180 HotPink1} \
{238 106 167 HotPink2} \
{205 96 144 HotPink3} \
{139 58 98 HotPink4} \
{255 181 197 pink1} \
{238 169 184 pink2} \
{205 145 158 pink3} \
{139 99 108 pink4} \
{255 174 185 LightPink1} \
{238 162 173 LightPink2} \
{205 140 149 LightPink3} \
{139 95 101 LightPink4} \
{255 130 171 PaleVioletRed1} \
{238 121 159 PaleVioletRed2} \
{205 104 137 PaleVioletRed3} \
{139 71 93 PaleVioletRed4} \
{255 52 179 maroon1} \
{238 48 167 maroon2} \
{205 41 144 maroon3} \
{139 28 98 maroon4} \
{255 62 150 VioletRed1} \
{238 58 140 VioletRed2} \
{205 50 120 VioletRed3} \
{139 34 82 VioletRed4} \
{255 0 255 magenta1} \
{238 0 238 magenta2} \
{205 0 205 magenta3} \
{139 0 139 magenta4} \
{255 131 250 orchid1} \
{238 122 233 orchid2} \
{205 105 201 orchid3} \
{139 71 137 orchid4} \
{255 187 255 plum1} \
{238 174 238 plum2} \
{205 150 205 plum3} \
{139 102 139 plum4} \
{224 102 255 MediumOrchid1} \
{209 95 238 MediumOrchid2} \
{180 82 205 MediumOrchid3} \
{122 55 139 MediumOrchid4} \
{191 62 255 DarkOrchid1} \
{178 58 238 DarkOrchid2} \
{154 50 205 DarkOrchid3} \
{104 34 139 DarkOrchid4} \
{155 48 255 purple1} \
{145 44 238 purple2} \
{125 38 205 purple3} \
{85 26 139 purple4} \
{171 130 255 MediumPurple1} \
{159 121 238 MediumPurple2} \
{137 104 205 MediumPurple3} \
{93 71 139 MediumPurple4} \
{255 225 255 thistle1} \
{238 210 238 thistle2} \
{205 181 205 thistle3} \
{139 123 139 thistle4} \
{169 169 169 DarkGray} \
{0 0 139 DarkBlue} \
{0 139 139 DarkCyan} \
{139 0 139 DarkMagenta} \
{139 0 0 DarkRed} \
{144 238 144 LightGreen}]
set colorlist [lsort -dictionary -index end $colorlist]
### Initialize directories and settings: ###
# Where program listings and configuration files go:
set wishdir [file join $env(HOME) .wishes]
set oldwishdir [file join $env(HOME) wishes]
if {[file isdirectory $wishdir] == 0} {
if {[file isdirectory $oldwishdir]} {
file link $wishdir $oldwishdir
set wishdir $oldwishdir
} else {
file mkdir $wishdir
}
}
# Where color schemes come from:
set schemedir [file join $wishdir colorschemes]
set sampledir [file join $libdir colorschemes] ; # App sets variable "libdir"
if {[file isdirectory $schemedir] == 0} {
catch {file copy $sampledir $schemedir}
}
# Default color settings for WISH applications
# (may be changed by configuration files)
set winback bisque ; # Window background
set winfore black ; # Window foreground
set selback cyan ; # Selection background
set selfore black ; # Selection foreground
set buttback bisque ; # Regular button background
set buttfore black ; # Regular button foreground
set miniback "#FFD0A0" ; # Mini-toolbar button background
set minifore black ; # Mini-toolbar button foreground
set listback "#FFFFF0" ; # Listbox background
set listfore black ; # Listbox foreground
set textback white ; # Text widget background
set textfore black ; # Text widget foreground
set inacback "#40E4FF" ; # Inactive selection background
set linktex blue ; # Link text color
set entback "#FFFFF0" ; # Entry widget background
set entfore black ; # Entry widget foreground
set headback "#FFC080" ; # Emphasized label background
set headfore black ; # Emphasized label foreground
set lightback "#FFF0E4" ; # Light label background
set lightfore black ; # Light label foreground
# Selection color for checkbuttons and radiobuttons is
# different in Tk 8.5 than in 8.4:
set newsel white ; # Tk 8.5
set oldsel blue ; # Tk 8.4
set tko [package require Tk]
if {$tko > 8.4} {
set regradio $newsel
} else {
set regradio $oldsel
}
set whatbutt "" ; # Nothing selected to configure yet
tk_setPalette background $winback foreground $winfore \
selectBackground $selback selectForeground $selfore
# Lists of widgets to configure
# (applications should add their own widgets
# after sourcing wishcolorplus.tcl):
set buttlist [list .colo.pickapply .colo.schemapply \
.colo.schemedel .colo.ok .colo.close] ; # Buttons
set minilist [list .colo.schemename] ; # Use this to show mini-toolbar color
set lublist [list .colo.list .colo.schemelist] ; # Listboxes
set texlist [list .colo.tx] ; # Text widgets
set entlist [list .colo.ent] ; # Entry widgets
set regradiolist [list] ; # No regular radiobuttons or checkbuttons here
set spinlist [list] ; # Nor spinboxes
# Alternating radiobuttons:
set headlist [list .colo.winfad .colo.selfad \
.colo.buttfad .colo.minifad .colo.listfad .colo.textfad \
.colo.linkup .colo.entfad .colo.headfad .colo.lightfad ]
set lightlist [list .colo.winbad .colo.selbad \
.colo.buttbad .colo.minibad .colo.listbad .colo.textbad \
.colo.inacbad .colo.entbad .colo.headbad .colo.lightbad]
### Procedure for setting up color selection box ###
# RGB Color-setting Scale
# from Graphical Applications with Tcl and Tk, 2nd edition, Chapter 3
# by Eric Foster-Johnson
# modified by David McClamrock
# Thanks to Ulrich Sch?? for suggesting that I add color names,
# and for contributing some code!
proc wishcolorplus {} {
# Set variables for red, green, blue, color selected,
# and hexadecimal code color; set background
# (number 128 will be midpoint of color scale):
global red green blue color hex colorlist showname appcolo
toplevel .colo
wm title .colo "WISH Color Picker Plus"
tk_setPalette background $::winback foreground $::winfore \
selectBackground $::selback selectForeground $::selfore
set red 255
set green 204
set blue 153
set color ""
set showname nothing
set hex black
grid [label .colo.pick -text "Right-click or double left-click\
color name (or move sliders)" -pady 4 -background $::lightback \
-foreground $::lightfore] \
-row 0 -column 0 -columnspan 3 -sticky news
# Sliding scale to change the amount of red:
set scaleng 200 ; # Length of scales
set scalwid 12 ; # Width of scales
set slidleng 24 ; # Length of sliders
grid [label .colo.reddo -text "Red : "] \
-row 1 -column 0 -sticky news
grid [scale .colo.red -from 0 -to 255 -orient horizontal \
-length $scaleng -width $scalwid -sliderlength $slidleng \
-variable red -activebackground red -tickinterval 64 \
-command "modify_color red"] \
-row 1 -column 1 -sticky news
# Same for green and blue:
grid [label .colo.greeno -text "Green : "] \
-row 2 -column 0 -sticky news
grid [scale .colo.green -from 0 -to 255 -orient horizontal \
-length $scaleng -width $scalwid -sliderlength $slidleng \
-variable green -activebackground green -tickinterval 64 \
-command "modify_color green"] \
-row 2 -column 1 -sticky news
grid [label .colo.bluey -text "Blue : "] \
-row 3 -column 0 -sticky news
grid [scale .colo.blue -from 0 -to 255 -orient horizontal \
-length $scaleng -width $scalwid -sliderlength $slidleng \
-variable blue -activebackground blue -tickinterval 64 \
-command "modify_color blue"] \
-row 3 -column 1 -sticky news
foreach scala [list .colo.red .colo.green .colo.blue] {
bind $scala <ButtonRelease-1> {
catch {.colo.list selection clear 0 end}
}
}
# Scrolling listbox for color names:
frame .colo.lib
listbox .colo.list -bg "#FFFFF0" -width 20
scrollbar .colo.rolly -width 12 -command ".colo.list yview"
.colo.list configure -yscrollcommand ".colo.rolly set"
pack .colo.list .colo.rolly -in .colo.lib \
-side left -expand 1 -fill both
grid .colo.lib -row 1 -column 2 -rowspan 6 -sticky news
foreach couleur $colorlist {
.colo.list insert end [lindex $couleur end]
}
bind .colo.list <Double-Button-1> {
set item [.colo.list curselection]
set showname [.colo.list get $item]
pickname $item
}
bind .colo.list <Button-3> {
.colo.list selection clear 0 end
set clixel %y
set clickline [.colo.list nearest $clixel]
.colo.list selection set $clickline $clickline
set item [.colo.list curselection]
set showname [.colo.list get $item]
pickname $item
}
# Labeled button to show the color selected:
grid [label .colo.pico -text "PICK: "] -row 4 -column 0 -sticky news
grid [button .colo.color -textvariable color -border 4 -pady 4] \
-row 4 -column 1 -sticky news
.colo.color configure -bg $::headback -fg $::headfore -command {
$whatbutt configure -text $color
after 10 {colorgrip $whatbutt}
}
# Color schemes:
grid [button .colo.schemename -bg $::miniback -fg $::minifore \
-relief groove -pady 2 -border 3 -text "Name This Color Scheme: " \
-command name_scheme] -row 5 -column 0 -columnspan 2 -sticky news
grid [entry .colo.schement -width 36 -bg $::entback \
-fg $::entfore -border 2 -exportselection 0] \
-row 6 -column 0 -columnspan 2 -sticky news
frame .colo.flub
listbox .colo.schemelist -width 36 -height 7 -bg $::listback \
-fg $::listfore -listvariable schemelist -selectmode single \
-exportselection 0
scrollbar .colo.schemeroll -width 12 -command ".colo.schemelist yview"
.colo.schemelist configure -yscrollcommand ".colo.schemeroll set"
pack .colo.schemelist .colo.schemeroll -in .colo.flub \
-side left -expand 1 -fill both
grid .colo.flub -row 7 -column 0 -columnspan 2 -sticky news
frame .colo.scutts
button .colo.pickapply -text "Apply Picked Colors" -command {
.colo.schemelist selection clear 0 end
pickapply
showcolo
}
button .colo.schemapply -text "Apply Color Scheme" \
-command apply_scheme
button .colo.schemedel -text "Delete Color Scheme" \
-activebackground red -command delete_scheme
button .colo.ok -text "OK" -command {
savecolo $appcolo
destroy .colo
}
button .colo.close -text "Close" -command {destroy .colo}
foreach butt [list .colo.pickapply .colo.schemapply \
.colo.schemedel .colo.ok .colo.close] {
$butt configure -border 1 -pady 0 -bg $::buttback -fg $::buttfore
}
pack .colo.pickapply .colo.schemapply .colo.schemedel .colo.ok \
.colo.close -in .colo.scutts -side top -expand 1 -fill both
grid .colo.scutts -row 7 -column 2 -sticky news
bind .colo.schement <Key-Return> name_scheme
bind .colo.schemelist <Button-1> showschemename
bind .colo.schemelist <Double-Button-1> apply_scheme
bind .colo.schemelist <Button-3> {
.colo.schemelist selection clear 0 end
set clixel %y
set clickline [.colo.schemelist nearest $clixel]
.colo.schemelist selection set $clickline
showschemename
apply_scheme
}
focus .colo.schement
getschemes
# Color-selection radiobuttons and display buttons:
grid [label .colo.choo -text "CHOOSE COLOR TO CHANGE" -bg $::headback \
-fg $::headfore] -row 0 -column 3 -columnspan 2 -sticky news
frame .colo.fradio
frame .colo.flabs
radiobutton .colo.winbad -text "Window background : " \
-variable whatbutt -value ".colo.winback"
button .colo.winback -bg $::winback -text $::winback
radiobutton .colo.winfad -text "Window text : " \
-variable whatbutt -value ".colo.winfore"
button .colo.winfore -bg $::winfore -text $::winfore
radiobutton .colo.selbad -text "Selection background : " \
-variable whatbutt -value ".colo.selback"
button .colo.selback -bg $::selback -text $::selback
radiobutton .colo.selfad -text "Selected text : " \
-variable whatbutt -value ".colo.selfore"
button .colo.selfore -bg $::selfore -text $::selfore
radiobutton .colo.buttbad -text "Regular button background : " \
-variable whatbutt -value ".colo.buttback"
button .colo.buttback -bg $::buttback -text $::buttback
radiobutton .colo.buttfad -text "Regular button text : " \
-variable whatbutt -value ".colo.buttfore"
button .colo.buttfore -bg $::buttfore -text $::buttfore
radiobutton .colo.minibad -text "Mini-toolbar button background : " \
-variable whatbutt -value ".colo.miniback"
button .colo.miniback -bg $::miniback -text $::miniback
radiobutton .colo.minifad -text "Mini-toolbar button text : " \
-variable whatbutt -value ".colo.minifore"
button .colo.minifore -bg $::minifore -text $::minifore
radiobutton .colo.listbad -text "Listbox background : " \
-variable whatbutt -value ".colo.listback"
button .colo.listback -bg $::listback -text $::listback
radiobutton .colo.listfad -text "Listbox text : " \
-variable whatbutt -value ".colo.listfore"
button .colo.listfore -bg $::listfore -text $::listfore
radiobutton .colo.textbad -text "Multi-line textbox background : " \
-variable whatbutt -value ".colo.textback"
button .colo.textback -bg $::textback -text $::textback
radiobutton .colo.textfad -text "Multi-line textbox text : " \
-variable whatbutt -value ".colo.textfore"
button .colo.textfore -bg $::textfore -text $::textfore
radiobutton .colo.inacbad -text "Inactive selection background : " \
-variable whatbutt -value ".colo.inacback"
button .colo.inacback -bg $::inacback -text $::inacback
radiobutton .colo.linkup -text "Link text : " \
-variable whatbutt -value ".colo.linktex"
button .colo.linktex -bg $::linktex -text $::linktex
radiobutton .colo.entbad -text "Single-line entry background : " \
-variable whatbutt -value ".colo.entback"
button .colo.entback -bg $::entback -text $::entback
radiobutton .colo.entfad -text "Single-line entry text : " \
-variable whatbutt -value ".colo.entfore"
button .colo.entfore -bg $::entfore -text $::entfore
radiobutton .colo.headbad -text "Emphasized label background : " \
-variable whatbutt -value ".colo.headback"
button .colo.headback -bg $::headback -text $::headback
radiobutton .colo.headfad -text "Emphasized label text : " \
-variable whatbutt -value ".colo.headfore"
button .colo.headfore -bg $::headfore -text $::headfore
radiobutton .colo.lightbad -text "Light label background : " \
-variable whatbutt -value ".colo.lightback"
button .colo.lightback -bg $::lightback -text $::lightback
radiobutton .colo.lightfad -text "Light label text : " \
-variable whatbutt -value ".colo.lightfore"
button .colo.lightfore -bg $::lightfore -text $::lightfore
# Get each widget's color-display button ready
# to transmit its color to others:
foreach colorbutt [list .colo.winback .colo.winfore .colo.selback \
.colo.selfore .colo.buttback .colo.buttfore .colo.miniback \
.colo.minifore .colo.listback .colo.listfore .colo.textback \
.colo.textfore .colo.inacback .colo.linktex \
.colo.entback .colo.entfore .colo.headback .colo.headfore \
.colo.lightback .colo.lightfore] {
colortext $colorbutt
$colorbutt configure -pady 0 -border 0
bind $colorbutt <Button-1> {
set mybutt %W
$::whatbutt configure -text [$mybutt cget -text]
after 10 {colorgrip $::whatbutt}
}
colorgrip $colorbutt
}
pack .colo.winbad .colo.winfad .colo.selbad .colo.selfad \
.colo.buttbad .colo.buttfad .colo.minibad .colo.minifad \
.colo.listbad .colo.listfad .colo.textbad .colo.textfad \
.colo.inacbad .colo.linkup .colo.entbad .colo.entfad \
.colo.headbad .colo.headfad .colo.lightbad .colo.lightfad \
-in .colo.fradio -side top -expand 1 -fill both
pack .colo.winback .colo.winfore .colo.selback .colo.selfore \
.colo.buttback .colo.buttfore .colo.miniback .colo.minifore \
.colo.listback .colo.listfore .colo.textback .colo.textfore \
.colo.inacback .colo.linktex .colo.entback .colo.entfore \
.colo.headback .colo.headfore .colo.lightback .colo.lightfore \
-in .colo.flabs -side top -expand 1 -fill both
grid .colo.fradio -row 1 -column 3 -rowspan 7 -sticky news
grid .colo.flabs -row 1 -column 4 -rowspan 7 -sticky news
frame .colo.tux
text .colo.tx -bg $::textback -fg $::textfore -height 3 \
-font "lucidatypewriter 14"
scrollbar .colo.tuxroll -width 12 -command ".colo.tx yview"
.colo.tx configure -yscrollcommand ".colo.tuxroll set"
pack .colo.tx .colo.tuxroll -in .colo.tux \
-side left -expand 1 -fill both
grid .colo.tux -row 8 -column 0 -columnspan 5 -sticky news
.colo.tx insert 1.0 "TEST TEXT HERE\nLinks look like this"
.colo.tx tag configure linklike -foreground $::linktex -underline 1
.colo.tx tag add linklike 2.0 "2.0 lineend"
# Make sure radiobutton and checkbutton colors are right:
colorcheck
}
### Color-selection procedures ###
# Procedure to show color name in display button:
proc colortext {butt} {
global winback winfore selback selfore buttback buttfore miniback \
minifore listback listfore textback textfore inacback linktex \
entback entfore headback headfore lightback lightfore
# A little quick trickery to get the variable names,
# abusing "file extension" for buttons not files:
set buttvar [string trimleft [file extension $butt] "."]
$butt configure -text [set $buttvar]
}
# Procedure to display picked color in button:
proc colorgrip {butt} {
global colorlist
set couleur [$butt cget -text]
if {[string first "#" $couleur] < 0} {
set listline [lsearch -regexp $colorlist "\\\W$couleur"]
set reds [lindex $colorlist $listline 0]
set greens [lindex $colorlist $listline 1]
set blues [lindex $colorlist $listline 2]
set couleur [format "#%2.2X%2.2X%2.2X" $reds $greens $blues]
}
set reds [string range $couleur 1 2]
set greens [string range $couleur 3 4]
set blues [string range $couleur 5 6]
if {[expr 0x$reds + 0x$greens + 0x$blues < 480] && \
[expr 0x$greens < 180]} {
$butt configure -fg white
} else {
$butt configure -fg black
}
$butt configure -bg $couleur
}
# Procedure to set new values for color variables
# in preparation for applying new colors:
proc pickapply {} {
global winback winfore selback selfore buttback buttfore miniback \
minifore listback listfore textback textfore inacback linktex \
entback entfore headback headfore lightback lightfore
foreach butt [list .colo.winback .colo.winfore .colo.selback \
.colo.selfore .colo.buttback .colo.buttfore .colo.miniback \
.colo.minifore .colo.listback .colo.listfore .colo.textback \
.colo.textfore .colo.inacback .colo.linktex .colo.entback \
.colo.entfore .colo.headback .colo.headfore .colo.lightback \
.colo.lightfore] {
# There's that quick trickery again:
set buttvar [string trimleft [file extension $butt] "."]
set $buttvar [$butt cget -text]
}
}
# Procedure for changing the color selected:
proc modify_color {which_color value} {
global color red green blue showname
switch $which_color {
red {set red $value}
green {set green $value}
blue {set blue $value}
}
if {[expr $red + $green + $blue < 480] && \
[expr $green < 180]} {
set hex white
} else {
set hex black
}
if {$color ne $showname} {
set color [format "#%2.2X%2.2X%2.2X" \
$red $green $blue]
}
.colo.color configure -background $color \
-foreground $hex
}
# Procedure for getting a color name selection
# to make the sliders move and the color code change:
proc pickname {item} {
global color colorlist red green blue showname whatbutt
set listline [lindex $colorlist $item]
set red [lindex $listline 0]
modify_color red $red
set green [lindex $listline 1]
modify_color green $green
set blue [lindex $listline 2]
modify_color blue $blue
set color $showname
set showname nothing
}
# Procedure to make sure radiobutton, checkbutton, \
# and label colors are right:
proc colorcheck {} {
# Labels, or radiobuttons with alternating label colors:
foreach head $::headlist {
if {[winfo exists $head]} {
$head configure -background $::headback \
-foreground $::headfore
}
}
foreach light $::lightlist {
if {[winfo exists $light]} {
$light configure -background $::lightback \
-foreground $::lightfore
}
}
# Get more or less correct selection colors
# for radiobuttons and checkbuttons:
set ::newsel [.colo.winfore cget -fg]
set ::oldsel $::winfore
if {$::tko > 8.4} {
set ::emphasel [.colo.headfore cget -fg]
set ::lightsel [.colo.lightfore cget -fg]
set ::regradio $::newsel
} else {
set ::emphasel $::headfore
set ::lightsel $::lightfore
set ::regradio $::oldsel
}
# Once more through the lists, to apply selection colors:
foreach head $::headlist {
if {[winfo exists $head] && [regexp \
{Radiobutton|Checkbutton} [winfo class $head]]} {
$head configure -selectcolor $::emphasel
}
}
foreach light $::lightlist {
if {[winfo exists $light] && [regexp \
{Radiobutton|Checkbutton} [winfo class $light]]} {
$light configure -selectcolor $::lightsel
}
}
foreach reg $::regradiolist {
if {[winfo exists $reg]} {
$reg configure -selectcolor $::regradio
}
}
}
# Procedure to show new configuration:
proc showcolo {} {
global winback winfore selback selfore buttback buttfore miniback \
minifore listback listfore textback textfore inacback linktex \
entback entfore headback headfore lightback lightfore newsel oldsel\
buttlist minilist lublist texlist entlist headlist lightlist spinlist
tk_setPalette background $winback foreground $winfore \
selectBackground $selback selectForeground $selfore
if {[winfo exists .colo.pick]} {
.colo.pick configure -bg $lightback -fg $lightfore
}
if {[winfo exists .colo.choo]} {
.colo.choo configure -bg $headback -fg $headfore
}
foreach butt $buttlist {
if {[winfo exists $butt]} {
$butt configure -bg $buttback -fg $buttfore
}
}
foreach mini $minilist {
if {[winfo exists $mini]} {
$mini configure -bg $miniback -fg $minifore
}
}
foreach lub $lublist {
if {[winfo exists $lub]} {
$lub configure -bg $listback -fg $listfore
}
}
foreach tex $texlist {
if {[winfo exists $tex]} {
$tex configure -bg $textback -fg $textfore
$tex tag configure linklike -foreground $linktex -underline 1
if {$::tko > 8.4} {
$tex configure -inactiveselectbackground $inacback
}
}
}
foreach ent $entlist {
if {[winfo exists $ent]} {
$ent configure -bg $entback -fg $entfore
}
}
foreach head $headlist {
if {[winfo exists $head]} {
$head configure -bg $headback -fg $headfore
}
}
foreach light $lightlist {
if {[winfo exists $light]} {
$light configure -bg $lightback -fg $lightfore
}
}
foreach spin $spinlist {
if {[winfo exists $spin]} {
$spin configure -buttonbackground $buttback
}
}
foreach butt [list .colo.winback .colo.winfore .colo.selback \
.colo.selfore .colo.buttback .colo.buttfore .colo.miniback \
.colo.minifore .colo.listback .colo.listfore .colo.textback \
.colo.textfore .colo.inacback .colo.linktex .colo.entback \
.colo.entfore .colo.headback .colo.headfore .colo.lightback \
.colo.lightfore] {
colorgrip $butt
}
colorcheck
}
# Procedure to save color configuration:
proc savecolo {colofile} {
set colosaver "set ::winback \"$::winback\"\
\nset ::winfore \"$::winfore\"\
\nset ::selback \"$::selback\"\
\nset ::selfore \"$::selfore\"\
\nset ::buttback \"$::buttback\"\
\nset ::buttfore \"$::buttfore\"\
\nset ::miniback \"$::miniback\"\
\nset ::minifore \"$::minifore\"\
\nset ::listback \"$::listback\"\
\nset ::listfore \"$::listfore\"\
\nset ::textback \"$::textback\"\
\nset ::textfore \"$::textfore\"\
\nset ::inacback \"$::inacback\"\
\nset ::linktex \"$::linktex\"\
\nset ::entback \"$::entback\"\
\nset ::entfore \"$::entfore\"\
\nset ::headback \"$::headback\"\
\nset ::headfore \"$::headfore\"\
\nset ::lightback \"$::lightback\"\
\nset ::lightfore \"$::lightfore\"\
\nset ::newsel \"$::newsel\"\
\nset ::oldsel \"$::oldsel\""
set filid [open $colofile w]
puts -nonewline $filid $colosaver
close $filid
}
### Color-scheme procedures
# Procedure to show color-scheme name in entry widget:
proc showschemename {} {
.colo.schement delete 0 end
after 10 {
set getline [.colo.schemelist curselection]
.colo.schement insert 0 [.colo.schemelist get $getline]
.colo.schement selection range 0 end
}
}
# Procedure to name color scheme:
proc name_scheme {} {
global schemelist
# Apply picked colors, if they haven't been applied:
.colo.schemelist selection clear 0 end
showcolo
set isaname [.colo.schement get]
# Don't accept a color scheme with no name:
if {$isaname eq ""} {
tk_messageBox -message "Please enter a name for this color scheme" \
type ok
return
}
# Ask whether to change an existing color scheme:
set thisname [lsearch $schemelist $isaname]
if {$thisname != -1} {
set revise [tk_messageBox -message "Revise\n\"$isaname\"\n\
color scheme?" -type yesno]
if {$revise eq "yes"} {
# Avoid duplication of name:
.colo.schemelist delete $thisname
}
}
# Get rid of any non-space characters that don't belong in file names:
set isaname [regsub -all \\W $isaname {}]
# Show the name in the list of color schemes:
lappend schemelist $isaname
set schemelist [lsort -dictionary $schemelist]
.colo.schemelist selection set [lsearch $schemelist $isaname]
# Blank out the entry line:
.colo.schement delete 0 end
# Now make a real file name:
set isafile [file join $::schemedir [string map "{ } _" $isaname].tcl]
# Save the current color scheme in the file:
set colorsaver "set ::winback \"$::winback\"\
\nset ::winfore \"$::winfore\"\
\nset ::selback \"$::selback\"\
\nset ::selfore \"$::selfore\"\
\nset ::buttback \"$::buttback\"\
\nset ::buttfore \"$::buttfore\"\
\nset ::miniback \"$::miniback\"\
\nset ::minifore \"$::minifore\"\
\nset ::listback \"$::listback\"\
\nset ::listfore \"$::listfore\"\
\nset ::textback \"$::textback\"\
\nset ::textfore \"$::textfore\"\
\nset ::inacback \"$::inacback\"\
\nset ::linktex \"$::linktex\"\
\nset ::entback \"$::entback\"\
\nset ::entfore \"$::entfore\"\
\nset ::headback \"$::headback\"\
\nset ::headfore \"$::headfore\"\
\nset ::lightback \"$::lightback\"\
\nset ::lightfore \"$::lightfore\"\
\nset ::newsel \"$::newsel\"\
\nset ::oldsel \"$::oldsel\""
set filid [open $isafile w]
if {[catch {puts -nonewline $filid $colorsaver} nosave]} {
tk_messageBox -message $nosave -type ok
}
close $filid
}
# Procedure to retrieve color-scheme names:
proc getschemes {} {
global schemelist
set schemelist [list]
set schemeroo [lsort -dictionary [glob -nocomplain -tails \
-directory $::schemedir *]]
foreach scheme $schemeroo {
lappend schemelist [string map "_ { }" [file rootname $scheme]]
}
}
# Procedure to apply color scheme:
proc apply_scheme {} {
set schemer [string map "{ } _" [.colo.schemelist get \
[.colo.schemelist curselection]]]
set schemefile [file join $::schemedir ${schemer}.tcl]
source $schemefile
foreach lab [list .colo.winback .colo.winfore .colo.selback \
.colo.selfore .colo.buttback .colo.buttfore .colo.miniback \
.colo.minifore .colo.listback .colo.listfore .colo.textback \
.colo.textfore .colo.inacback .colo.linktex .colo.entback \
.colo.entfore .colo.headback .colo.headfore .colo.lightback \
.colo.lightfore] {
colortext $lab
colorgrip $lab
}
showcolo
}
# Procedure to delete color scheme:
proc delete_scheme {} {
set picker [.colo.schemelist curselection]
set schemer [string map "{ } _" [.colo.schemelist get $picker]]
set schemefile [file join $::schemedir ${schemer}.tcl]
file delete $schemefile
.colo.schemelist delete $picker
}
# Get color configuration file, if available:
set appcolo [file join $wishdir comcolo.tcl]
if {[file readable $appcolo]} {
source $appcolo
}
# Use some of the specified color variables:
tk_setPalette background $winback foreground $winfore selectBackground \
$selback selectForeground $selfore
# Procedure to find out whether executable program is in system's PATH or not:
proc inpath {prog} {
global env
set exok 0
set envlist [split $env(PATH) :]
foreach direc $envlist {
if {[file executable [file join $direc $prog]]} {
set exok 1
break
}
}
return $exok
}
# Which program to use for printing (Unix-type systems only):
if {[inpath xpp]} {
set printprog xpp
} else {
set printprog lpr
}
# Integer range generator for "foreach"
# (to do a "for" loop without ugly, awkward "for" code):
proc range {start cutoff finish {step 1}} {
# If "start" and "finish" aren't integers, do nothing:
if {[string is integer -strict $start] == 0 || [string is\
integer -strict $finish] == 0} {
error"range:Rangemustcontaintwointegers"
}
# "Step" has to be an integer too, and
# no infinite loops that go nowhere are allowed:
if {$step == 0 || [string is integer -strict $step] == 0} {
error "range: Step must be an integer other than zero"
}
# Does the range include the last number?
switch $cutoff {
"to" {set inclu 1}
"no" {set inclu 0}
default {
error "range: Use \"to\" for an inclusive range,\
or \"no\" for a noninclusive range"
}
}
# Is the range ascending or descending (or neither)?
set ascendo [expr $finish - $start]
if {$ascendo > -1} {
set up 1
} else {
set up 0
}
# If range is descending and step is positive but doesn't have a "+" sign,
# change step to negative:
if {$up == 0 && $step > 0 && [string first "+" $start] != 0} {
set step [expr $step * -1]
}
set ranger [list] ; # Initialize list variable for generated range
switch "$up $inclu" {
"1 1" {set op "<=" ; # Ascending, inclusive range}
"1 0" {set op "<" ; # Ascending, noninclusive range}
"0 1" {set op ">=" ; # Descending, inclusive range}
"0 0" {set op ">" ; # Descending, noninclusive range}
}
# Generate a list containing the specified range of integers:
for {set i $start} "\$i $op $finish" {incr i $step} {
lappend ranger $i
}
return $ranger
}
### GUI SETUP ###
# Procedure to change display on title bar:
proc wmtitle {} {
global currentfile
if {$currentfile eq ""} {
if {[.tx edit modified]} {
wm title . "WISH Supernotepad (Save?)"
} else {
wm title . "WISH Supernotepad"
}
} else {
if {[.tx edit modified]} {
wm title . "WISH Supernotepad (Save?) : $currentfile "
} else {
wm title . "WISH Supernotepad : $currentfile"
}
}
bind . <Key> {after 10 saveup}
bind . <Button-2> {after 10 saveup}
}
# Make and arrange mini-toolbar buttons:
frame .froolbar
button .new -text "New" -command file_new
button .open -text "Open" -command {set openins Open ; openrece file}
button .ins -text "Insert" -command {matchinline file}
button .save -text "Save" -command file_save
button .backup -text "Backup" -command backup
button .print -text "Print?" -command printbox
button .cut -text "Cut" -command cut_text
button .copy -text "Copy" -command copy_text
button .paste -text "Paste" -command paste_text
button .undo -text "Undo" -command {catch {.tx edit undo}}
button .redo -text "Redo" -command {catch {.tx edit redo}}
button .special -text "Special" -command specialbox
button .findbutt -text "Find" -command findwhat
button .repbutt -text "Replace" -command search_replace
button .quit -text "Quit" -command gitoot
set miniline [list .new .open .ins .save .backup .print .cut .copy \
.paste .undo .redo .special .findbutt .repbutt .quit]
foreach mini $miniline {
$mini configure -pady 0 -padx 0 -bord 1 -bg $::miniback -fg $::minifore
pack $mini -in .froolbar -side left -expand 1 -fill both
}
grid .froolbar -row 0 -column 0 -columnspan 2 -sticky news
# Make the text area and scrollbars:
grid [text .tx -width $texwid -height $texhi -bg $::textback \
-fg $::textfore -wrap $wordwrap -setgrid 1 -undo 1 \
-font "$fontaine" -tabs {36 72 108 144 180 216 252 288}] \
-row 3 -column 0 -sticky news
if {$tclo > 8.4} {
.tx configure -inactiveselectbackground $::inacback
}
grid [scrollbar .ybar -width 12 -command ".tx yview"] \
-row 3 -column 1 -sticky news
grid [scrollbar .xbar -width 12 -command ".tx xview" \
-orient horizontal] \
-row 4 -column 0 -columnspan 2 -sticky news
.tx configure -xscrollcommand ".xbar set" \
-yscrollcommand ".ybar set"
grid rowconfigure . 3 -weight 1
grid columnconfigure . 0 -weight 1
focus .tx
set foco .tx
bind .tx <FocusIn> {set foco .tx}
.tx edit separator
.tx edit modified 0
wmtitle
# Procedure to get ready to remove old contents from text area:
proc readytogo {} {
set exitanswer ""
if {[.tx edit modified]} {
if {$::currentfile ne ""} {
file_save
} else {
set exitanswer [tk_messageBox -message "Save changes?" \
-title "Save changes?" -type yesnocancel -icon question]
if {$exitanswer eq "yes"} {
file_saveas
}
}
}
if {$exitanswer eq "cancel"} {
return 0
} else {
return 1
}
}
# Procedure to remove old contents from text area:
proc outwithold {} {
set ::currentfile ""
set ::backfile ""
.tx delete 1.0 end
.tx edit reset
.tx edit modified 0
}
# Procedure to get saved changes recognized at once:
proc saveup {} {
if {[.tx edit modified]} {
bind .tx <Key> {}
bind .tx <Button-2 {}
wmtitle
} else {
after 100 saveup
}
}
# Procedure to put contents of new file into text area:
proc inwithnew {} {
global newfile currentfile platform
if {$newfile eq "" || [file readable $newfile] == 0} {
return
}
set star [open $newfile "r"]
set filecont [read $star]
set filecont [string trimright $filecont]
.tx insert insert $filecont
set currentfile $newfile
.tx edit reset
.tx edit modified 0
wmtitle
close $star
}
# Procedure to clear out irrelevancies so that special widgets
# (Find, Replace, various HTML ones, etc.) can do their work:
proc clearout {} {
foreach w $::clearframes {
catch {grid remove $w}
}
}
# List of possible irrelevancies to be cleared out:
set clearframes [list .prin .need .findreg .replace .fin .fregexp \
.linenum .head .font .anchor .html_list]
# Procedure to dethrone special widget:
proc clearin {w_out} {
catch {grid remove $w_out}
focus .tx
set foco .tx
}
### MAIN MENU ###
menu .filemenu -tearoff 0 -borderwidth 1
### FILE MENU ###
menu .filemenu.files -tearoff 0
.filemenu add cascade -label "File" -underline 0 -menu .filemenu.files
### File -- New Text
.filemenu.files add command -label "New Text" \
-underline 0 -command file_new
proc file_new {} {
set go [readytogo]
if {$go == 0} {return}
outwithold
.tx edit separator
.tx edit modified 0
wmtitle
}
### File -- New HTML
.filemenu.files add command -label "New HTML" \
-underline 4 -command new_html
proc new_html {} {
global converto
set go [readytogo]
if {$go == 0} {return}
outwithold
.tx edit separator
.tx insert 1.0 "<html>\n<head>\
\n\t<meta name=\"generator\" content=\"WISH Supernotepad\" /> \
\n\t<meta http-equiv=\"Content-Type\" content=\"text/html;\
charset=ISO-8859-1\" /> \
\n<!-- Document title (to be displayed on title bar\
\n\tof browser) goes in space below -->\
\n\t<title>\n\n\
\n\n</title>\n\t<style type=\"text/css\">\
\n\t</style>\n</head>\n\n<body\
text=\"#000000\" link=\"#0000FF\" vlink=\"#FF0000\" alink\
=\"#FF0000\" bgcolor=\"#FFFFFF\">"
if {$converto == 0} {
.tx insert end "\n\
\n<!-- Contents of document (to be displayed in main browser\
window) go in space below -->\n\n\n\n</body>\n</html>"
} else {
.tx insert end "\n\n\n\n</body>\n</html>"
}
.tx mark set insert 9.0
.tx edit reset
.tx edit modified 0
after 1000 wmtitle
}
### File -- New Window
.filemenu.files add command -label "New Window" -underline 4 \
-accelerator Ctrl+n -command {eval exec supernotepad &}
bind . <Control-n> {eval exec supernotepad &}
.filemenu.files add separator
### File -- Open Any
.filemenu.files add command -label "Open Any" \
-underline 0 -command {file_open any}
proc file_open {which} {
global newfile currentfile filetosave openins openew
set openins Open
set go [readytogo]
if {$go == 0} {return}
if {$which eq "any"} {
set newfile [tk_getOpenFile]
}
if {$newfile ne ""} {
if {$openew == 1} {
eval exec supernotepad $newfile &
} else {
outwithold
inwithnew
.tx mark set insert 1.0
saverece
}
}
if {[winfo exists .rece]} {
destroy .rece
}
}
### File -- Open Recent
.filemenu.files add command -label "Open Recent" -underline 5 -command {
set openins Open
openrece file
} -accelerator "Ctrl+. (period)"
bind . <Control-period> {set openins Open ; openrece file}
# Procedure to make GUI box for selecting
# recently opened or inserted files
# (also used for selecting "Superpaste" items):
proc openrece {what} {
global wishdir recentlist reclim newfile addfile mandatum \
foco currentfile openins findum pastelist pastelim openew
# Open file in new window if there's one in current window:
if {$currentfile ne ""} {
set openew 1
}
set findum ""
toplevel .rece
grid [listbox .rece.list -width 72 -height 16 -bg $::listback \
-fg $::listfore -selectmode extended] -row 0 -column 0 -sticky news
grid [scrollbar .rece.rolly -width 12 -command [list .rece.list yview]] \
-row 0 -column 1 -sticky news
grid [scrollbar .rece.rollx -orient horizontal -width 12 \
-command [list .rece.list xview]] \
-row 1 -column 0 -columnspan 2 -sticky news
.rece.list configure -xscrollcommand ".rece.rollx set" \
-yscrollcommand ".rece.rolly set"
frame .rece.fir
button .rece.find -text "Search" -relief groove -border 3 \
-command findrece
entry .rece.ent -bg $::entback -fg $::entfore -width 48 \
-textvariable findum
label .rece.found -relief sunken -border 2 -text "0 found"
pack .rece.find .rece.ent .rece.found -in .rece.fir \
-side left -expand 1 -fill both
grid .rece.fir -row 2 -column 0 -columnspan 2 -sticky news
frame .rece.fr
checkbutton .rece.new -text "New window?" -variable openew \
-selectcolor $::regradio
if {$openins ne "Open" || $what ne "file"} {
.rece.new configure -state disabled
}
button .rece.open
# This button isn't for Superpaste:
button .rece.all -text "$openins Any" -command {
if {$openins == "Insert"} {
file_insert any
} else {
file_open any
}
}
button .rece.whole -text "See Whole" -command seewhole
label .rece.show -text "Show"
spinbox .rece.spin -width 4 -from 1 -to 9999 -bg $::entback \
-fg $::entfore -buttonbackground $::buttback
label .rece.fils
button .rece.unlist -text "Unlist" -command "unlisto $what"
button .rece.close -text "Close" -command {destroy .rece}
foreach butt [list .rece.find .rece.open .rece.all .rece.unlist \
.rece.whole .rece.close] {
$butt configure -pady 2 -padx 4 -bg $::buttback -fg $::buttfore
}
grid .rece.fr -row 3 -column 0 -columnspan 2 -sticky news
.rece.list see end
grid columnconfigure .rece 0 -weight 1
grid rowconfigure .rece 0 -weight 1
if {$what eq "paste"} {
wm title .rece "Superpaste"
.rece.list configure -listvariable pastelist
bind .rece <Key-Return> {findrece paste}
.rece.open configure -text "Superpaste" -command superpaste
.rece.spin configure -textvariable pastelim
.rece.fils configure -text "items"
pack .rece.new .rece.open .rece.whole .rece.show .rece.spin \
.rece.fils .rece.unlist .rece.close -in .rece.fr \
-side left -expand 1 -fill both
set mandatum superpaste
} else {
wm title .rece "$openins Recently Viewed File"
.rece.list configure -listvariable recentlist
bind .rece <Key-Return> {findrece rece}
.rece.open configure -text $openins -command openorins
.rece.spin configure -textvariable reclim
.rece.fils configure -text "files"
pack .rece.new .rece.open .rece.all .rece.show .rece.spin \
.rece.fils .rece.unlist .rece.close -in .rece.fr \
-side left -expand 1 -fill both
set mandatum openorins
}
bind .rece.list <Double-Button-1> {eval $mandatum}
bind .rece.list <Button-3> {
selection clear
set clixel %y
set clickline [.rece.list nearest $clixel]
.rece.list selection set $clickline $clickline
eval $mandatum
}
focus .rece.ent
.rece.list see end
}
# Procedure to paste item from "Superpaste" list:
proc superpaste {} {
global pastelist foco
set recenum [.rece.list curselection]
if {[llength $recenum] != 1} {
tk_messageBox -message "Please insert one selection\
at a time" -type ok
} else {
$foco insert insert [.rece.list get $recenum]
}
selection clear
.rece.found configure -text "0 found"
.rece.ent delete 0 end
}
# Procedure to see whole item on "Superpaste" list:
proc seewhole {} {
global foco
set seenum [.rece.list curselection]
if {[llength $seenum] != 1} {
tk_messageBox -message "Please select exactly one\
text item to view" -type ok
return
}
toplevel .see
wm title .see "See Whole"
grid [text .see.whole -bg $::textback -fg $::textfore] \
-row 0 -column 0 -sticky news
grid [scrollbar .see.ybar -width 12 -command ".see.whole yview"] \
-row 0 -column 1 -sticky news
grid [scrollbar .see.xbar -width 12 -orient horizontal \
-command "see.whole xview"] -row 1 -column 0 \
-columnspan 2 -sticky news
.see.whole configure -xscrollcommand ".see.xbar set" \
-yscrollcommand ".see.ybar set"
frame .see.fr
button .see.ins -text "Insert" -command {
superpaste
destroy .see
}
button .see.close -text "Close" -command {destroy .see}
pack .see.ins .see.close -in .see.fr -side left -expand 1 -fill both
grid .see.fr -row 2 -column 0 -columnspan 2 -sticky news
.see.whole insert insert [.rece.list get $seenum]
}
# Procedure to find name of recently viewed file
# or item in "Superpaste" list:
proc findrece {which} {
global findum recentlist pastelist
if {$which eq "paste"} {
set listo $pastelist
} else {
set listo $recentlist
}
set whatitis [lsearch -all $listo *$findum*]
set howmany [llength $whatitis]
if {$howmany > 0} {
.rece.found configure -text "$howmany found"
foreach it $whatitis {
.rece.list selection set $it
}
.rece.list see [lindex $whatitis 0]
} else {
set findum "NOT FOUND"
.rece.ent selection range 0 end
.rece.ent icursor end
}
}
# Procedure to open or insert recently viewed file:
proc openorins {} {
global addfile newfile openins openew
set recenum [.rece.list curselection]
if {[llength $recenum] != 1} {
tk_messageBox -message "Please select exactly one file" -type ok
selection clear
} else {
set receline [.rece.list get $recenum]
if {$openins eq "Insert"} {
set addfile $receline
file_insert recent
} else {
if {$openew == 1} {
eval exec supernotepad $receline &
} else {
set newfile $receline
file_open recent
}
}
if {[winfo exists .rece]} {
destroy .rece
}
}
}
# Procedure to delete listings of recently viewed files,
# or of "Superpaste" items:
proc unlisto {which} {
set delrec [.rece.list curselection]
set delleng [expr [llength $delrec] -1]
foreach d [range $delleng to 0] {
set delnum [lindex $delrec $d]
.rece.list delete $delnum
}
if {$which eq "paste"} {
savepaste
} else {
saverece
}
}
# Procedure to save list of recently opened or inserted files:
proc saverece {} {
global recentlist wishdir newfile currentfile \
reclim openins addfile dumpfile rece
set recleng [expr {[llength $recentlist] -1}]
foreach r [range $recleng to 0] {
set rindex [lindex $recentlist $r]
if {$openins eq "Insert" && $rindex eq $addfile} {
set recentlist [lreplace $recentlist $r $r]
} elseif {$rindex eq $currentfile || $rindex eq $dumpfile} {
set recentlist [lreplace $recentlist $r $r]
}
}
if {$recleng > $reclim} {
set limless [expr {$recleng-$reclim-1}]
set recentlist [lreplace $recentlist 0 $limless]
}
if {$openins eq "Insert"} {
lappend recentlist $addfile
} else {
lappend recentlist $currentfile
}
set recfil [open $rece "w"]
set recentex "set reclim $reclim\nset recentlist \[list $recentlist\]"
puts -nonewline $recfil $recentex
close $recfil
}
### File -- Open (New Window)
.filemenu.files add command -label "Open (New Window)" \
-underline 13 -command openwin
# Procedure to open file in new window:
proc openwin {} {
set newfie [tk_getOpenFile]
if {$newfie ne ""} {
eval exec supernotepad $newfie &
}
}
.filemenu.files add separator
### File -- Save
.filemenu.files add command -label "Save" -underline 0 \
-command "file_save" -accelerator Ctrl+s
bind . <Control-s> {file_save}
proc file_save {} {
global currentfile filecont
set filecont [.tx get 1.0 end]
set texttosave [string trimright $filecont]
if {$currentfile ne ""} {
set fileid [open $currentfile "w"]
puts $fileid $filecont
close $fileid
.tx edit reset
.tx edit modified 0
wm title . "WISH Supernotepad : Saved $currentfile"
after 1000 wmtitle
} else {file_saveas}
}
### File -- Save As
.filemenu.files add command -label "Save As" -underline 5 \
-command "file_saveas"
proc file_saveas {} {
global currentfile newfile filecont filetosave
if {[file writable $currentfile]} {
file_save
} else {
set filecont [.tx get 1.0 end]
}
set texttosave [string trimright $filecont]
if {$currentfile ne ""} {
set initdir [file dirname $currentfile]
} else {
set initdir [pwd]
}
set filetosave [tk_getSaveFile -initialdir $initdir]
if {$filetosave eq ""} {
return
}
set fileid [open $filetosave "w"]
puts $fileid $filecont
close $fileid
set currentfile $filetosave
.tx edit reset
.tx edit modified 0
saverece
wm title . "WISH Supernotepad : Saved $currentfile"
after 1000 wmtitle
}
### File -- Backup
.filemenu.files add command -label "Backup" -command backup
proc backup {} {
global currentfile backfile
if {$currentfile ne ""} {
if {[.tx edit modified]} {
file_save
}
} else {
tk_messageBox -message "Contents must be saved under one name\
before they can be backed up under another name" -type ok
return
}
if {[file writable $backfile]} {
file copy -force $currentfile $backfile
wm title . "WISH Supernotepad : File backed up as $backfile"
after 1000 wmtitle
} else {
backup_as
}
}
### File -- Backup As
.filemenu.files add command -label "Backup As" -underline 0 \
-command "backup_as"
proc backup_as {} {
global currentfile backfile
if {$currentfile ne ""} {
if {[.tx edit modified]} {
file_save
}
} else {
tk_messageBox -message "Contents must be saved under one name\
before they can be backed up under another name" -type ok
return
}
set initdir [file dirname $currentfile]
set backfile [tk_getSaveFile -title "Backup As" -initialdir $initdir]
if {$backfile ne ""} {
file copy -force $currentfile $backfile
wm title . "WISH Supernotepad : File backed up as $backfile"
after 1000 wmtitle
}
}
### File -- Move/Rename
.filemenu.files add command -label "Move/Rename" -underline 0 \
-command "file_rename"
# Procedure to move or rename file:
proc file_rename {} {
global currentfile dumpfile
if {$currentfile ne ""} {
set initdir [file dirname $currentfile]
} else {
set initdir [pwd]
}
set newname [tk_getSaveFile -title "Move/Rename File" -initialdir $initdir]
if {$newname ne ""} {
set dumpfile $currentfile
file rename -force $currentfile $newname
set currentfile $newname
file_save
saverece
}
}
.filemenu.files add separator
### File -- Import Palm Doc
.filemenu.files add command -label "Import Palm Doc" -command openpalm
proc openpalm {} {
global palmdir env newfile platform
# WISH Supernotepad uses "txt2pdbdoc" to convert
# to and from Palm Doc format:
foreach prog [list txt2pdbdoc html2pdbtxt] {
if {[inpath $prog] == 0} {
tk_messageBox -message "WISH Supernotepad requires the free\
\"txt2pdbdoc\" and \"html2pdbtxt\" programs for conversion\
to and from Palm Doc format" -type ok
return
} elseif {$platform ne "unix"} {
tk_messageBox -message "Sorry, WISH Supernotepad's Palm Doc\
conversion feature will work only on Unix-type systems"\
-type ok
return
}
}
if {$palmdir eq ""} {
set initdir $env(HOME)
} else {
set initdir $palmdir
}
set palmtype {
{"Palm Doc" {".pdb"}}
}
set texttype {
{"Plain Text" {".txt"}}
}
set newpalm [tk_getOpenFile -filetypes $palmtype -initialdir $initdir \
-title "Open Palm Doc"]
if {$newpalm ne ""} {
set palmdir [file dirname $newpalm]
set destiname [tk_getSaveFile -title "Name & Directory of\
Text File" -filetypes $texttype]
if {$destiname eq ""} {
tk_messageBox -message "Content from Palm Doc must be given\
name and directory as text file" -type ok
return
}
grid [label .palm -text "Converting from Palm Doc format ..." \
-font "helvetica 18 bold"] -row 1 -column 0 -columnspan 2 \
-sticky news
exec txt2pdbdoc -d "$newpalm" "$destiname"
set newfile $destiname
file_open palm
}
destroy .palm
}
### File -- Export As Palm Doc
.filemenu.files add command -label "Export As Palm Doc" -command exportpalm
proc exportpalm {} {
global currentfile wishdir platform palmdir env
# WISH Supernotepad uses "txt2pdbdoc" to convert
# to and from Palm Doc format:
foreach prog [list txt2pdbdoc html2pdbtxt] {
if {[inpath $prog] == 0} {
tk_messageBox -message "WISH Supernotepad requires the free\
\"txt2pdbdoc\" and \"html2pdbtxt\" programs for conversion\
to and from Palm Doc format" -type ok
return
} elseif {$platform ne "unix"} {
tk_messageBox -message "Sorry, WISH Supernotepad's Palm Doc\
conversion feature will work only on Unix-type systems"\
-type ok
return
}
}
if {$palmdir eq ""} {
set initdir $env(HOME)
} else {
set initdir $palmdir
}
set palmcont [string trim [.tx get 1.0 end]]
set tempee [file join $env(HOME) wishes tempee]
set tempnum [open $tempee w]
puts -nonewline $tempnum $palmcont
close $tempnum
set filtip [exec file $tempee]
if {[regexp HTML $filtip]} {
set textcont [exec html2pdbtxt "$tempee"]
set filid [open "$tempee" w]
puts -nonewline $filid $textcont
close $filid
}
set texttype {
{"Palm Doc" {".pdb"}}
}
set palmtitle [tk_getSaveFile -title "Descriptive Title for Palm Doc" \
-initialdir $initdir -filetypes $texttype -defaultextension .pdb]
if {$palmtitle ne ""} {
set palmroot [file tail [file rootname $palmtitle]]
exec txt2pdbdoc "$palmroot" "$tempee" "$palmtitle"
}
file delete $tempee
wm title . "WISH Supernotepad : Exported $palmtitle"
after 1000 wmtitle
}
.filemenu.files add separator
### File -- Print
.filemenu.files add command -label "Print?" -underline 0 \
-command printbox -accelerator Ctrl+q
bind . <Control-q> printbox
# Procedure to set up dialog bar for printing:
proc printbox {} {
global texwid formawid fonto printprog platform
if {$platform ne "unix"} {
tk_messageBox -message "Sorry, only Unix-type systems can print\
directly from WISH Supernotepad." -type ok
return
}
clearout
set formawid $texwid
if {[winfo exists .prin]} {
grid .prin
} else {
frame .prin
label .prin.tex -text "Text width:" -pady 0
spinbox .prin.spin -width 3 -from 20 -to 200 -textvariable formawid
label .prin.lab -text "Set other options when X Printing\
Panel (XPP) is running"
button .prin.ok -takefocus 0 -command {
filetoprint
clearin .prin
}
button .prin.close -text "Close" -pady 0 -border 1 \
-takefocus 0 -command {
clearin .prin
}
pack .prin.tex .prin.spin .prin.lab .prin.ok .prin.close \
-in .prin -side left -expand 1 -fill both
grid .prin -row 1 -column 0 -columnspan 2 -sticky news
focus .prin.spin
}
.prin.spin configure -bg $::entback -fg $::entfore \
-buttonbackground $::buttback
foreach butt [list .prin.ok .prin.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
printswitch
focus .prin.spin
}
# Procedure to use X Printing Panel (XPP) for printing
# if available, otherwise lpr:
proc printswitch {} {
global printprog
if {$printprog eq "xpp"} {
.prin.lab configure -state normal
.prin.ok configure -text "Print with XPP"
} else {
.prin.lab configure -state disabled
.prin.ok configure -text "Print with LPR"
}
}
# Procedure to save file (if necessary) and format it for printing;
proc filetoprint {} {
global platform currentfile fonto wishdir printprog \
formawid texwid wordwrap
set go [readytogo]
if {$go == 0} {return}
.tx configure -width $formawid -wrap word
wm geometry . {}
if {$currentfile ne ""} {
set ::curprint [file rootname $currentfile]
} else {
set ::curprint [file join $wishdir printtemp]
}
append ::curprint ".fmt"
after 1000 {
set formex [formatit print]
set fileid [open $::curprint "w"]
puts -nonewline $fileid $formex
close $fileid
.tx configure -width $texwid -wrap $wordwrap
wm geometry . {}
eval exec $printprog $::curprint &
}
}
.filemenu.files add separator
### File -- Exit
.filemenu.files add command -label "Exit" -underline 1 -command gitoot
# Procedure to shut down properly:
proc gitoot {} {
global curprint
if {[.tx edit modified]} {
set seeya 1
} else {
set seeya 0
}
set go [readytogo]
if {$go == 0} {return}
savefig
if {[file exists $curprint]} {
file delete $curprint
}
if {$seeya == 0 || [regexp {Saved} [wm title .]] == 0} {
exit
} else {
# Give the user half a second to see that changes have been saved:
after 500 exit
}
}
# Procedure to save configuration:
proc savefig {} {
set figlines "set openins $::openins\
\nset texwid $::texwid\
\nset formawid $::formawid\
\nset texhi $::texhi\
\nset wordwrap $::wordwrap\
\nset fonto \"$::fonto\"\
\nset siz $::siz\
\nset fontaine \"$::fontaine\"\
\nset printprog $::printprog\
\nset reunito $::reunito\
\nset parsep $::parsep\
\nset expert $::expert\
\nset headsize $::headsize\
\nset html_fontsize $::html_fontsize\
\nset listtype $::listtype\
\nset autotab $::autotab"
set filid [open $::superfig w]
puts -nonewline $filid $figlines
close $filid
}
### EDIT MENU ###
# using built-in procedures tk_textCut, tk_textCopy, tk_textPaste
menu .filemenu.edit -tearoff 0
.filemenu add cascade -label "Edit" -underline 0 -menu .filemenu.edit
### Edit -- Cut
.filemenu.edit add command -label "Cut" -underline 2 \
-command cut_text -accelerator Ctrl+x
bind . <Control-x> {cut_text ; break}
proc cut_text {} {
global foco
if {[winfo class $foco] eq "Text"} {
tk_textCut $foco
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
}
}
### Edit -- Copy
.filemenu.edit add command -label "Copy" -underline 0 \
-command copy_text -accelerator Ctrl+c
bind . <Control-c> {copy_text ; break}
proc copy_text {} {
global foco
if {[winfo class $foco] eq "Text"} {
tk_textCopy $foco
}
}
### Edit -- Paste
.filemenu.edit add command -label "Paste" -underline 0 \
-command paste_text -accelerator Ctrl+g
bind . <Control-g> paste_text
# <Control-v> didn't work quite right--I don't know why.
proc paste_text {} {
global foco
if {[winfo class $foco] eq "Text"} {
tk_textPaste $foco
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
}
}
### Edit -- Delete
.filemenu.edit add command -label "Delete" -underline 0 \
-command delete_text -accelerator Del
proc delete_text {} {
.tx delete sel.first sel.last
.tx edit separator
wmtitle
}
.filemenu.edit add separator
### Edit -- Supercut
.filemenu.edit add command -label "Supercut" \
-command supercut -accelerator Ctrl+X
bind . <Control-X> supercut
proc supercut {} {
global foco pastelist
if {[winfo class $foco] eq "Text"} {
set anysel [catch {$foco get sel.first sel.last} pastee]
if {$anysel == 0} {
if {[lsearch $pastelist $pastee] == -1} {
lappend pastelist $pastee
}
savepaste
}
tk_textCut $foco
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
}
}
### Edit -- Supercopy
.filemenu.edit add command -label "Supercopy" \
-command supercopy -accelerator Ctrl+C
bind . <Control-C> supercopy
proc supercopy {} {
global foco pastelist
if {[winfo class $foco] eq "Text"} {
set anysel [catch {$foco get sel.first sel.last} pastee]
if {$anysel == 0} {
if {[lsearch $pastelist $pastee] == -1} {
lappend pastelist $pastee
}
savepaste
}
tk_textCopy $foco
} else {
if {[selection own] eq $foco} {
lappend pastelist [selection get]
savepaste
}
}
}
### Edit -- Superpaste
.filemenu.edit add command -label "Superpaste" -underline 3 \
-command {matchinline paste} -accelerator F1
bind . <F1> {matchinline paste}
# Procedures to view, select, and paste text from "Superpaste" list
# are under the "File--Open" menu item above, because they use the
# same listbox with slightly different names for buttons and things
# Procedure to paste text from "Superpaste" list
# or to insert file from "Recent File" list, without
# opening the box, if possible; if not, then to open the box:
proc matchinline {whatfor} {
global pastelist recentlist foco addfile openins
set anysel [catch {$foco get sel.first sel.last} texas]
if {$anysel == 0} {
set firstum [$foco index sel.first]
set lastum [$foco index sel.last]
} else {
set realine [realword]
set texas [lindex $realine 0]
set firstum [lindex $realine 1]
set lastum [lindex $realine end]
}
set selgo [$foco index $firstum]
$foco delete $firstum $lastum
if {$whatfor eq "paste"} {
set whatitis [lsearch -all $pastelist *$texas*]
} else {
set whatitis [lsearch -all $recentlist *$texas*]
}
set howmany [llength $whatitis]
if {$howmany == 1} {
set it [lindex $whatitis 0]
if {$whatfor eq "paste"} {
$foco insert $selgo [lindex $pastelist $it]
} else {
set addfile [lindex $recentlist $it]
file_insert recent
}
} else {
set openins Insert
openrece $whatfor
}
}
# Procedure to identify the real beginning of a real word
# in a text widget (unlike "string wordstart"):
proc realword {} {
global foco
set linum [line_number]
set insum [$foco index insert]
set linget [string trim [$foco get $linum.0 $insum]]
set spa [string last " " $linget]
set ta [string last "\t" $linget]
if {$spa == -1 && $ta == -1} {
set wordo $linget
set wordleng [string length $wordo]
set firsto [$foco index "$insum - $wordleng char"]
} else {
set spend [expr {$spa+1}]
set tabend [expr {$ta+1}]
if {$spend > $tabend} {
set wordo [$foco get $linum.$spend $insum]
set firsto $linum.$spend
} else {
set wordo [$foco get $linum.$tabend $insum]
set firsto $linum.$tabend
}
}
return [list $wordo $firsto $insum]
}
# Procedure to save "superpaste" list:
proc savepaste {} {
global pastelist pastelim superpaste
set pastleng [expr {[llength $pastelist] -1}]
if {$pastleng > $pastelim} {
set limless [expr {$pastleng-$pastelim-1}]
set pastelist [lreplace $pastelist 0 $limless]
}
set pastfil [open $superpaste "w"]
set pastex "set pastelim $pastelim\nset pastelist \[list $pastelist\]"
puts -nonewline $pastfil $pastex
close $pastfil
}
.filemenu.edit add separator
### Edit -- Undo
.filemenu.edit add command -label "Undo" -underline 0 -command {
catch {.tx edit undo}
} -accelerator Ctrl+z
# Binding Ctrl+z is built in
### Edit -- Redo
.filemenu.edit add command -label "Redo" -underline 0 \
-command {catch {.tx edit redo}} -accelerator Ctrl+r
bind . <Control-r> {catch {.tx edit redo}}
bind . <space> {.tx edit separator}
bind . <BackSpace> {.tx edit separator}
### Edit -- Undo All Since Last Save
.filemenu.edit add command -label "Undo All Since Last Save" \
-underline 9 -command undolast
# Procedure to undo all changes since last save:
proc undolast {} {
global currentfile newfile
if {[.tx edit modified]} {
.tx delete 1.0 end
if {$currentfile ne ""} {
set newfile $currentfile
inwithnew
} else {
.tx edit reset
.tx edit modified 0
wmtitle
}
} else {
tk_messageBox -message "No changes have been made since\
the last save" -type ok
}
}
.filemenu.edit add separator
### Edit -- Title
.filemenu.edit add command -label "Title" -command title
proc title {} {
if {[.tx tag ranges sel] eq ""} {return}
set input [.tx get sel.first sel.last]
set output ""
set nocaps [list a an and at but by for from in into of on or the to with]
set count 0
foreach word [split $input] {
# Strip quotation marks:
if {[string index $word 0] == "\""} {
set quote 1
set word [string trim $word \"]
} else {
set quote 0
}
# Always capitalize the first word; otherwise,
# don't capitalize any words in the "nocaps" list:
if {$count == 0 || [lsearch $nocaps $word] == -1} {
set word [string totitle $word]
}
# Add word plus space, with or without quotation marks, to output:
if {$quote} {
append output "\"$word\" "
} else {
append output "$word "
}
# Capitalize any word after a colon:
if {[string index $word end] == ":"} {
set count 0
} else {
incr count
}
}
set inhere [.tx index sel.first]
.tx delete sel.first sel.last
.tx insert $inhere [string trim $output]
}
.filemenu.edit add command -label "Untitle" -command untitle
### Edit -- Untitle
proc untitle {} {
if {[.tx tag ranges sel] eq ""} {return}
set input [.tx get sel.first sel.last]
set inhere [.tx index sel.first]
.tx delete sel.first sel.last
.tx insert $inhere [string tolower $input]
}
.filemenu.edit add separator
### Edit -- Select All
.filemenu.edit add command -label "Select all" -underline 7 \
-command ".tx tag add sel 1.0 end" -accelerator Ctrl+/
# binding <Control-/> is built-in
### Edit -- Auto-tab
.filemenu.edit add checkbutton -variable autotab -label "Auto-tab"\
-underline 5 -selectcolor $winfore -command autotaborno
proc autotaborno {} {
global autotab
if {$autotab == 1} {
bind . <Key-Return> {autotab go ; .tx edit separator}
bind . <Shift-Return> {autotab stop}
} else {
bind . <Key-Return> {.tx edit separator}
bind . <Shift-Return> {}
}
}
autotaborno
# Procedure to find out how many tabs at beginning of line:
proc tabgrab {} {
global charno tabno bogno
if {[.tx get $bogno.$charno] eq "\t"} {
incr tabno
incr charno
tabgrab
}
}
# Procedure to auto-tab:
proc autotab {stoporgo} {
global tabno charno bogno
set bogno [expr [line_number] -1]
set charno 0
set tabno 0
tabgrab
set herenow [.tx index insert]
set gripchar [.tx get "$herenow -2c" $herenow]
set gripchar [string trim $gripchar]
if {$gripchar eq "\{"} {
incr tabno
}
if {$stoporgo eq "stop"} {
if {$tabno > 0} {
incr tabno -1
}
}
set tabstring [string repeat "\t" $tabno]
.tx insert insert $tabstring
.tx edit separator
if {$stoporgo eq "stop"} {
.tx mark set insert "insert +1c"
}
}
### INSERT MENU ###
menu .filemenu.insert -tearoff 0
.filemenu add cascade -label "Insert" -underline 0 -menu .filemenu.insert
### Insert -- File -- Any
.filemenu.insert add command -label "File--Any" -underline 0 \
-command "file_insert any"
proc file_insert {which} {
global addfile openins foco
set openins Insert
# Variable "addfile" may already have been set
# by another procedure. If not, do this:
if {$which eq "any"} {
set addfile [tk_getOpenFile -title "Insert File"]
}
if {$addfile ne ""} {
set star [open $addfile "r"]
set filecont [read $star]
close $star
set filecont [string trimright $filecont]
$foco insert insert $filecont
$foco edit separator
$foco see insert
wmtitle
} else {
unset addfile
}
if {[winfo exists .rece]} {
destroy .rece
}
}
.filemenu.insert add command -label "File--Recent" -underline 6 \
-command {matchinline file} -accelerator "Ctrl+, (comma)"
bind . <Control-comma> {matchinline file}
.filemenu.insert add separator
### Insert -- Special Characters
.filemenu.insert add command -label "Special Characters" \
-underline 0 -command specialbox -accelerator F4
bind . <F4> specialbox
set charlist [list \
"b "¢ "â "G "T \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "" "b "¢ "â \
"G "T "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "? "? \
"? "? "? "?"?\
"?"?"?"?"?\
"?"?"?"?"?\
"?"?"?"?"??
"??????????
"??????????
"????????
# Procedure for finding correct text or entry widget
# and inserting special (or non-special) characters:
proc findwin {char} {
global foco
set winclass [winfo class $foco]
$foco insert insert $char
if {$winclass == "Text"} {
$foco edit separator
wmtitle
}
after 10 {focus $foco}
}
# Procedure for setting up special-character selection box:
set specialbutts [list]
proc specialbox {} {
global charlist foco buttlist minilist
toplevel .spec
wm title .spec "Special"
set bigfons -adobe-helvetica-bold-r-normal--14-*-*-*-*-*-*
set row 0
set col 0
foreach c [range 0 no [llength $charlist]] {
set chartext [lindex $charlist $c]
grid [button .spec.but($c) -text $chartext -font $bigfons \
-pady 1 -padx 2 -borderwidth 1] \
-row $row -column $col -sticky news
.spec.but($c) configure -bg $::buttback -fg $::buttfore
if {[lsearch $buttlist ".spec.but($c)"] < 0} {
lappend buttlist .spec.but($c)
}
bind .spec.but($c) <Button-1> {
set butt %W
set charx [$butt cget -text]
findwin $charx
}
incr col
if {$col > 4} {
set col 0
incr row
}
}
grid [button .spec.amp -text "&"] -row $row -column 4 -sticky news
bind .spec.amp <Button-1> {findwin "&"}
set bigoe_data "
#define bigoe_width 17
#define bigoe_height 13
static unsigned char bigoe_bits[] = {
0xf8, 0xfe, 0x01, 0xfe, 0xff, 0x01, 0xcf, 0x07, \
0x00, 0x87, 0x07, 0x00, 0x07, 0x07, 0x00, 0x07, \
0x3f, 0x00, 0x07, 0x3f, 0x00, 0x07, 0x07, 0x00, \
0x07, 0x07, 0x00, 0x07, 0x07, 0x00, 0x8e, 0x07, \
0x00, 0xfc, 0xff, 0x01, 0xf8, 0xfe, 0x01 };"
image create bitmap bigoe -data $bigoe_data
grid [button .spec.oebig -image bigoe \
-pady 1 -padx 2 -borderwidth 1] \
-row [expr $row+1] -column 0 -sticky news
bind .spec.oebig <Button-1> {findwin "Œ"}
set liloe_data "
#define liloe_width 13
#define liloe_height 9
static unsigned char liloe_bits[] = {
0xbc, 0x07, 0xfe, 0x0f, 0xc3, 0x18, 0xc3, 0x18, \
0xc3, 0x1f, 0xc3, 0x00, 0xe7, 0x18, 0xfe, 0x0f, \
0x3c, 0x07 };"
image create bitmap liloe -data $liloe_data
grid [button .spec.oelil -image liloe -pady 1 \
-pady 1 -padx 2 -borderwidth 1] \
-row [expr $row+1] -column 1 -sticky news
bind .spec.oelil <Button-1> {findwin "œ"}
grid [button .spec.lt -text "<"] \
-row [expr $row+1] -column 2 -sticky news
bind .spec.lt <Button-1> {findwin "<"}
grid [button .spec.gt -text ">"] \
-row [expr $row+1] -column 3 -sticky news
bind .spec.gt <Button-1> {findwin ">"}
grid [button .spec.quot -text "\""] \
-row [expr $row+1] -column 4 -sticky news
bind .spec.quot <Button-1> {findwin """}
grid [button .spec.nbsp -text " "] \
-row [expr $row+2] -column 0 -columnspan 2 -sticky news
bind .spec.nbsp <Button-1> {findwin " "}
grid [button .spec.close -text "Close" \
-command {destroy .spec}] -row [expr $row+2] \
-column 2 -columnspan 3 -sticky news
foreach butt [list .spec.oebig .spec.oelil .spec.nbsp .spec.amp \
.spec.lt .spec.gt .spec.quot .spec.close] {
$butt configure -pady 1 -padx 2 -borderwidth 1 \
-bg $::miniback -fg $::minifore -font $bigfons
if {[lsearch $minilist $butt] < 0} {
lappend minilist $butt
}
}
}
.filemenu.insert add separator
### Insert -- Color Code
# Get WISH Color Picker to do this job:
bind . <Control-F4> {
wishcolor
.col.color configure -command {
$foco insert insert "\"$colo\""
}
}
.filemenu.insert add command -label "Color Code" -underline 0 -command {
wishcolor
.col.color configure -command {
$foco insert insert "\"$colo\""
}
} -accelerator Ctrl+F4
.filemenu.insert add separator
### Insert -- Time/Date
.filemenu.insert add command -label "Time/Date" \
-underline 0 -command printtime
proc printtime {} {
set nowtime [clock seconds]
set clocktime [clock format $nowtime -format "%R %p %D"]
.tx insert insert $clocktime
.tx edit separator
wmtitle
}
### SEARCH MENU ###
menu .filemenu.search -tearoff 0
.filemenu add cascade -label "Search" -underline 0 -menu .filemenu.search
### Search -- Find
.filemenu.search add command -label "Find" -underline 0 \
-command findwhat -accelerator F2
bind . <F2> findwhat
proc findwhat {} {
if {[catch {grid info .findreg} whatnot] == 0 && $whatnot != ""} {
find_text find
} else {
search_find
}
}
# Initialize some variables:
set casematch nocase
set searchway forward
set search_for ""
# This shows up when search is done (see proc "find_text," below):
frame .fin
label .fin.is -font "helvetica 18 bold" -relief raised -border 2
button .fin.clo -pady 2 -border 2 -bg $::buttback -fg $::buttfore \
-text "Close" -command whichnew
pack .fin.is .fin.clo -in .fin -side left -expand 1 -fill both
# Procedure to determine whether to start over in "Find" or "Replace":
proc whichnew {} {
set gridslaves [grid slaves .]
if {[regexp {.findreg} $gridslaves]} {
newfind find
} elseif {[regexp {.replace} $gridslaves]} {
newfind replace
}
clearin .fin
}
# Procedure to insert starting and ending codes for HTML
# (or Tcl/Tk) code and to put cursor in the right place:
proc dualcodes {star cont fin} {
global foco
set winclass [winfo class $foco]
set selon [catch {$foco index sel.first}]
if {$selon == 1} {
# No selected text:
if {$cont == {}} {
$foco insert insert "$star$fin"
set goback [string length $fin]
if {$winclass == "Text"} {
$foco mark set insert "[$foco index insert] \
- $goback chars"
$foco see insert
$foco edit separator
if {$foco == ".tx"} {
wmtitle
}
} else {
$foco icursor [expr [$foco index insert] - $goback]
}
} else {
$foco insert insert "$star$cont$fin"
}
} else {
# Text selected:
$foco insert sel.first $star
$foco insert sel.last "$fin"
set goforth [expr {[string length $fin] +1}]
if {$winclass == "Text"} {
$foco mark set insert "sel.last + $goforth chars"
$foco see insert
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
} else {
$foco icursor [expr {[$foco index insert] + $goforth}]
}
}
selection clear
after 10 {focus $foco}
}
# Procedure to set up "Find" dialog bar:
proc search_find {} {
global search_for casematch searchway foco anytries regexy expert findex
set findex .findreg
clearout
if {[winfo exists .findreg]} {
grid .findreg
} else {
frame .findreg
frame .find
button .find.next -text "Find (F2)" -command {find_text find}
entry .find.enter -width 90 -bg white -textvariable search_for
pack .find.next .find.enter -in .find -side left -expand 1 -fill both
frame .findex
checkbutton .findex.exp -text "Expert search (with regular\
expressions)" -variable expert
checkbutton .findex.match -text "Match case" \
-variable casematch -onvalue "exact" -offvalue "nocase"
radiobutton .findex.up -text "Search Up" -variable searchway \
-value "backward"
radiobutton .findex.down -text "Search Down" -variable searchway \
-value "forward"
button .findex.new -text "New Search" -command {newfind find}
button .findex.close -text "Close" -command {
newfind find
clearin .fin
clearin .findreg
}
pack .findex.exp .findex.match .findex.up .findex.down .findex.new \
.findex.close -in .findex -side left -expand 1 -fill both
foreach butt [list .find.next .findex.match .findex.up \
.findex.down .findex.close] {
$butt configure -pady 2
}
bind .find <Button-1> {set foco .find.enter}
bind .find <F2> {find_text find}
bind .find <F3> {findwin {<br />}}
foreach {key star fin} {
<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center> } {
bind .find.enter $key "dualcodes $star {} $fin"
}
pack .find .findex -in .findreg -side top -expand 1 -fill both
grid .findreg -row 1 -column 0 -columnspan 2 -sticky news
}
foreach butt [list .find.next .findex.new .findex.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
foreach butt [list .findex.exp .findex.match .findex.up .findex.down] {
$butt configure -selectcolor $::regradio
}
focus .find.enter
set foco .find.enter
if {$search_for ne ""} {
set searchlength [string length $search_for]
.find.enter selection range 0 $searchlength
}
set anytries 0
}
# Set search direction and case sensitivity, and search for match
# (Variables "present_place" and "findlength"
# are set in "proc find_text," below)
proc whichway {} {
global casematch searchway search_reg present_place countum place
switch "$casematch $searchway" {
"nocase forward" {
set place [.tx search -nocase -forward -regexp \
-count countum $search_reg $present_place end]
}
"exact forward" {
set place [.tx search -forward -regexp \
-count countum $search_reg $present_place end]
}
"nocase backward" {
set place [.tx search -nocase -backward -regexp \
-count countum $search_reg $present_place 1.0]
}
"exact backward" {
set place [.tx search -backward -regexp \
-count countum $search_reg $present_place 1.0]
}
}
}
# Actually find some matching text
proc find_text {whatfor} {
global starting_place present_place search_for search_reg countum \
casematch searchway findway anytries replacelength bojo place \
replace_with expert
if {$anytries == 0} {
set anytries 1
set starting_place [.tx index insert]
set present_place $starting_place
set place $starting_place
if {$whatfor eq "replace"} {
set replacelength [string length $replace_with]
.place.yesdo configure -text "Replace This" -command replace_one
focus .with.leave
bind .rep.enter <Key-Return> replace_one
bind .with.leave <Key-Return> replace_one
.place.nodont configure -state normal
set bojo ".with.leave"
} else {
set bojo ".find.enter"
}
}
set search_reg [regup $search_for]
whichway
if {$place eq ""} {
if {$present_place eq $starting_place} {
set endmess "No matching text found"
} else {
if {$searchway eq "forward"} {
set finis "end"
} else {
set finis "beginning"
}
set endmess "Search completed from line\
[expr int($starting_place)] to $finis"
}
.fin.is configure -text $endmess
grid .fin -row 2 -column 0 -columnspan 2 -sticky news
} else {
catch {.tx tag remove sel sel.first sel.last}
.tx tag add sel $place "$place + $countum chars"
.tx see $place
if {$searchway eq "forward"} {
.tx mark set insert "$place + $countum chars"
} else {
.tx mark set insert $place
}
set present_place [.tx index insert]
}
if {$whatfor eq "find"} {
focus .tx
set foco .tx
}
}
# Procedure to start searching from scratch:
proc newfind {why} {
set ::search_for ""
set ::anytries 0
clearin .fin
if {$why eq "find"} {
focus .find.enter
} else {
clearin .fin
set ::replace_with ""
set ::replacelength 0
.place.yesdo configure -text "Find First" -command {find_text replace}
.place.nodont configure -state disabled
set ::starting_place [.tx index insert]
bind .rep.enter <Key-Return> {find_text replace}
bind .with.leave <Key-Return> {find_text replace}
focus .rep.enter
}
}
# Procedure to prepare search string for use:
proc regup {textin} {
global expert
if {$expert == 1} {
set textout [string map "{ } {\\s}" $textin]
} else {
set textout [string map {"\{" "\\\{" "\}"\
"\\\}" "\\" "\\\\"} $textin]
set textout [string map "{ } {\\s} {.} {\\.} {+} {\\+}\
{*} {\\*} {?} {\\?} {|} {\\|} {(} {\\(} {)} {\\)} {^} {\\^}\
{\$} {\\\$} {\[} {\\\[} {\]} {\\\]}" $textout]
}
return $textout
}
.filemenu.search add separator
### Search -- Replace (Standard)
.filemenu.search add command -label "Replace (Standard)" -underline 0 \
-command "search_replace" -accelerator Ctrl+F2
bind . <Control-F2> search_replace
# Procedures for replacing text
# Set up "Replace" dialog bar:
proc search_replace {} {
global casematch searchway starting_place foco anytries \
search_for replace_with regexy expert findex autotab oldautotab
if {$autotab == 1} {
set oldautotab 1
set autotab 0
autotaborno
} else {
set oldautotab 0
}
set findex .replace
set searchway forward
set starting_place [.tx index insert]
clearout
if {[winfo exists .replace]} {
grid .replace
} else {
frame .replace
frame .rep
label .rep.what -text "Replace:"
entry .rep.enter -width 90 -bg white -textvariable search_for
pack .rep.what .rep.enter -in .rep -side left -expand 1 -fill both
frame .with
label .with.what -text "With: "
entry .with.leave -width 90 -bg white -textvariable replace_with
pack .with.what .with.leave -in .with -side left -expand 1 -fill both
frame .place
button .place.yesdo -text "Find First" -relief groove -border 3 \
-command {find_text replace}
button .place.nodont -text "Skip" \
-command {find_text replace} -state disabled
button .place.all -text "Replace All" \
-command replace_all
checkbutton .place.exp -text "Expert search" -variable expert
radiobutton .place.up -text "Up" -variable searchway \
-value "backward"
radiobutton .place.down -text "Down" -variable searchway \
-value "forward"
checkbutton .place.match -text "Match case" \
-variable casematch -onvalue "exact" -offvalue "nocase"
button .place.new -text "New Search" -command {newfind replace}
button .place.close -text "Close" -command repdoon
foreach w [list .rep.what .with.what .place.yesdo .place.nodont \
.place.all .place.up .place.down .place.match .place.close] {
$w configure -padx 4
}
foreach butt [list .place.nodont .place.all .place.new .place.close] {
$butt configure -pady 2 -border 1 -takefocus 0
}
pack .place.yesdo .place.nodont .place.all .place.exp .place.up \
.place.down .place.match .place.new .place.close -in .place \
-side left -expand 1 -fill both
pack .rep .with .place -in .replace -side top -expand 1 -fill both
bind .rep.enter <Key-Return> {find_text replace}
bind .with.leave <Key-Return> {find_text replace}
bind .rep.enter <F3> {findwin {<br />}}
bind .with.leave <F3> {findwin {<br />}}
foreach {key star fin} {<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>} {
bind .rep.enter $key "dualcodes $star {} $fin"
bind .with.leave $key "dualcodes $star {} $fin"
}
bind .rep.enter <Button-1> {set foco .rep.enter}
bind .with.leave <Button-1> {set foco .with.leave}
grid .replace -row 1 -column 0 -columnspan 2 -sticky news
}
foreach butt [list .place.yesdo .place.nodont .place.all \
.place.new .place.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
foreach butt [list .place.exp .place.up .place.down .place.match] {
$butt configure -selectcolor $::regradio
}
focus .rep.enter
set foco .rep.enter
set anytries 0
}
# Procedure to get done with replacing:
proc repdoon {} {
global autotab oldautotab
if {$oldautotab == 1} {
set autotab 1
autotaborno
}
newfind replace
clearin .fin
clearin .replace
}
# Replace one instance at a time, with confirmation or disconfirmation
proc replace_one {} {
global place findlength searchway replacelength countum \
starting_place present_place search_reg replace_with currentfile
.tx delete $place "$place + $countum chars"
.tx insert $place $replace_with
.tx edit separator
wmtitle
find_text replace
}
# Replace all instances, without confirmation
proc replace_all {} {
global replace_with search_for casematch expert
selection clear
set alltext [.tx get 1.0 end]
set search_reg [regup $search_for]
if {$casematch eq "nocase"} {
set anysubs [regsub -all -nocase $search_reg $alltext\
$replace_with allsub]
} else {
set anysubs [regsub -all $search_reg $alltext $replace_with allsub]
}
if {$anysubs > 0} {
.tx delete 1.0 end
.tx insert 1.0 $allsub
set finis "All matching text replaced"
} else {
set finis "No matching text found"
}
.fin.is configure -text $finis
grid .fin -row 2 -column 0 -columnspan 2 -sticky news
}
### Search -- Replace (Multiple)
.filemenu.search add command -label "Replace (Multiple)" -underline 9 \
-command multirep -accelerator Ctrl+F3
bind . <Control-F3> multirep
# Procedure to set up GUI box for multiple replace:
proc multirep {} {
global m n foco expert casematch
set m 1
toplevel .mult
wm title .mult "Replace (Multiple)"
set n [expr $m-1]
grid [label .mult.place($n) -text "Replace: "] \
-row $n -column 0 -sticky news
grid [entry .mult.ent($n) -bg $::entback -fg $::entfore -width 60] \
-row $n -column 1 -sticky news
if {[lsearch $::entlist ".mult.ent($n)"] < 0} {
lappend ::entlist .mult.ent($n)
}
grid [label .mult.with($m) -text "with: "] \
-row $m -column 0 -sticky news
grid [entry .mult.wix($m) -bg $::entback -fg $::entfore -width 60] \
-row $m -column 1 -sticky news
if {[lsearch $::entlist ".mult.wix($m)"] < 0} {
lappend ::entlist .mult.wix($m)
}
frame .mult.fr
button .mult.more -text "Show More Pairs" -relief groove -border 3 \
-command morepairs
checkbutton .mult.expert -text "Expert search" \
-selectcolor $::regradio -variable expert
checkbutton .mult.match -text "Match case" -selectcolor $::regradio \
-variable casematch -onvalue exact -offvalue nocase
button .mult.replall -text "Replace All" -command replall
button .mult.close -text "Close" -takefocus 0 -command {
set m 1
set n 0
destroy .mult
focus .tx
set foco .tx
}
foreach butt [list .mult.more .mult.replall .mult.close] {
$butt configure -pady 2 -takefocus 0 -bg $::buttback -fg $::buttfore
}
pack .mult.more .mult.expert .mult.match .mult.replall \
.mult.close -in .mult.fr -side left -expand 1 -fill both
morepairs
focus .mult.ent(0)
set foco .mult.ent(0)
bind .mult <Key-Return> morepairs
}
# Procedure to add more entry widgets for multiple replace:
proc morepairs {} {
global m n foco expert
incr m 2
set n [expr $m-1]
grid forget .mult.fr
grid [label .mult.place($n) -text "Replace: "] \
-row $n -column 0 -sticky news
grid [entry .mult.ent($n) -bg $::entback -fg $::entfore -width 60] \
-row $n -column 1 -sticky news
if {[lsearch $::entlist ".mult.ent($n)"] < 0} {
lappend ::entlist .mult.ent($n)
}
grid [label .mult.with($m) -text "with: "] \
-row $m -column 0 -sticky news
grid [entry .mult.wix($m) -bg $::entback -fg $::entfore -width 60] \
-row $m -column 1 -sticky news
if {[lsearch $::entlist ".mult.wix($m)"] < 0} {
lappend ::entlist .mult.wix($m)
}
grid .mult.fr -row [expr $m+1] -column 0 -columnspan 2 -sticky news
if {$n > 2} {
focus .mult.ent($n)
set foco .mult.ent($n)
}
bind .mult <F3> {findwin {<br />}}
foreach {key star fin} {
<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>
} {bind .mult $key "dualcodes $star {} $fin"}
foreach i [range 0 to $m] {
if {[winfo exists .mult.ent($i)]} {
bind .mult.ent($i) <Button-1> "set foco .mult.ent($i)"
} elseif {[winfo exists .mult.wix($i)]} {
bind .mult.wix($i) <Button-1> "set foco .mult.wix($i)"
}
}
}
# Procedure to perform multiple replace:
proc replall {} {
global m n foco expert casematch
set replist [list]
set itall [.tx get 1.0 "end -1c"]
foreach e [range 1 to $m 2] {
set f [expr $e-1]
set rep($f) [.mult.ent($f) get]
set rep($e) [.mult.wix($e) get]
if {$rep($f) ne ""} {
lappend replist $rep($f) $rep($e)
}
}
if {$expert == 0} {
if {$casematch eq "exact"} {
set newitall [string map "$replist" $itall]
} else {
set newitall [string map -nocase "$replist" $itall]
}
} else {
set newitall $itall
if {$casematch eq "exact"} {
foreach e [range 1 to $m 2] {
set f [expr $e-1]
regsub -all "$rep($f)" $newitall "$rep($e)" newitall
}
} else {
foreach e [range 1 to $m 2] {
set f [expr $e-1]
regsub -all -nocase "$rep($f)" $newitall "$rep($e)" newitall
}
}
}
.tx delete 1.0 "end -1c"
.tx insert 1.0 $newitall
.tx edit separator
wmtitle
focus .tx
set foco .tx
destroy .mult
}
.filemenu.search add separator
# Search -- Line Number
.filemenu.search add command -label "Line Number/Word Count" -underline 0 \
-command wordline -accelerator Ctrl+w
bind . <Control-w> wordline
# Procedure to find out what line number the cursor is on:
proc line_number {} {
global foco
set herenow [$foco index insert]
set lineno [expr int($herenow)]
return $lineno
}
# Procedure to count words:
proc wordcount {} {
set wordsnow [.tx get 1.0 {end -1c}]
set wordlist [split $wordsnow]
set countnow 0
foreach item $wordlist {
if {$item ne ""} {
incr countnow
}
}
return $countnow
}
# Set up "Line Number/Word Count" dialog bar:
proc wordline {} {
clearout
if {[winfo exists .line]} {
grid .line
} else {
frame .line
label .line.goto -text "Go to line number: " -pady 2
entry .line.number -width 6
button .line.ok -text "GO" -relief groove -border 3 -command gotoline
label .line.word -text "Word count: " -pady 2
label .line.count -relief sunken -width 12 -pady 2
button .line.recount -border 1 -text "Recount" -pady 2 \
-command recount
button .line.close -border 1 -text "Close" -pady 2 -command {
clearin .line
}
bind .line.number <Key-Return> gotoline
pack .line.goto .line.number .line.ok .line.word .line.count \
.line.recount .line.close -in .line \
-side left -expand 1 -fill both
grid .line -row 1 -column 0 -columnspan 2 -sticky news
}
.line.number configure -bg $::entback -fg $::entfore
foreach butt [list .line.ok .line.recount .line.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
.line.count configure -bg $::lightback -fg $::lightfore
recount
}
# Procedure to recount words and re-identify line number:
proc recount {} {
set lineno [line_number]
.line.number delete 0 end
.line.number insert 0 $lineno
set linedigits [string length $lineno]
.line.number selection range 0 $linedigits
focus .line.number
.line.count configure -text [wordcount]
}
# Procedure to go to another line, identified by number:
proc gotoline {} {
set newlineno [.line.number get]
.tx mark set insert $newlineno.0
.tx see insert
focus .tx
set foco .tx
}
### HTML MENU ###
menu .filemenu.html -tearoff 0
.filemenu add cascade -label "HTML" -underline 2 -menu .filemenu.html
# HTML -- Plain Text to HTML
.filemenu.html add command -label "Plain Text to HTML" -underline 14 \
-command {convert_to_html plain} -accelerator Ctrl+H
bind . <Control-H> {convert_to_html plain}
.filemenu.html add command -label "Link-Text to HTML" -underline 7 \
-command {convert_to_html link}
proc convert_to_html {what} {
global converto lincoln linkhead
set converto 1
if {$lincoln} {
# Show codes, don't display Link-Text:
set lincoln 0
unlink .tx
}
if {$what eq "link"} {
set linkhead [.tx search "<end linkhead>" 1.0 end]
if {$linkhead eq ""} {
set linkhead 1.0
}
# Find link beginnings and ends:
if {$::tko > 8.4} {
set linkstars [.tx search -regexp -all \
-count clink "<link .+?>" 1.0 end]
set linkends [.tx search -all "</link>" 1.0 end]
} else {
set ::place 1.0
set ::linkline [list]
set ::countline [list]
set starlog [findtags "<link .+?>" ::linkline ::countline]
set linkstars [lindex $starlog 0]
set cti [lindex $starlog end]
set ::place 1.0
set ::linkline [list]
set ::countline [list]
set endlog [findtags "</link>" ::linkline ::countline]
set linkends [lindex $endlog 0]
}
# Make list of links; then temporarily hide them
# so they won't be mistaken for their targets:
.tx tag configure hide -elide 1
for {set i 0} {$i < [llength $linkstars]} {incr i} {
set star [lindex $linkstars $i] ; # Begin link-start tag
set starleng [lindex $clink $i] ; # Length of link-start tag
set starsplit [split $star "."]
set starline [lindex $starsplit 0] ; # Line number in text
set starchar [lindex $starsplit end] ; # Position in line
set starend $starline.[expr {$starchar + $starleng}]
set linkstar [.tx get $star $starend]
set linkname [string map "{link } {} {\"} {} {<} {} {>} {}" \
$linkstar]
lappend linklist [list $starend "$linkname"]
set finis [lindex $linkends $i]
.tx tag add hide $star "$finis +7c"
}
# Search for targets and make a non-duplicative list of them:
set targlist [list]
set loclist [list]
foreach link $linklist {
set targ [lindex $link end]
if {[lsearch $targlist $targ] == -1} {
set linkloc [lindex $link 0]
if {[.tx compare $linkloc < $linkhead]} {
set target [.tx search -count ct "$targ" $linkhead end]
} else {
set target [.tx search -count ct "$targ" $linkloc end]
if {$target eq ""} {
set target [.tx search -backwards -count ct "$targ" \
$linkloc $linkhead]
}
}
if {$target ne ""} {
lappend targlist $targ
lappend loclist [list $target $ct]
}
}
}
# Run backward through the list,
# adding anchor codes all the way:
set locleng [expr {[llength $loclist] -1}]
foreach t [range $locleng to 0] {
set targstar [lindex $loclist $t 0]
set targleng [lindex $loclist $t end]
set targname [lindex $targlist $t]
set targend [.tx index "$targstar + $targleng chars"]
.tx insert $targend "</a>"
.tx insert $targstar "<a name=\"$targname\">"
}
}
.tx tag delete hide
set textutnunc [.tx get 1.0 {end -1c}]
outwithold
if {$what eq "link"} {
set textutnunc [string map {
"<link \"" "<a href=\"#"\
"</link>" "</a>"\
"<a name=\"" "<a name=\""
"\">" "\">"
"&" "&"\
"?" "<"\
">? ">"\
"\"" """\
"<end linkhead>" ""\
"<c>" "<center>"\
"</c>" "</center>"\
"<bi>" "<b><i>"\
"<ib>" "<i><b>"\
"<bc>" "<b><center>"\
"<cb>" "<center><b>"\
"<ic>" "<i><center>"\
"<ci>" "<center><i>"\
"</bi>" "</b></i>"\
"</ib>" "</i></b>"\
"</bc>" "</b></center>"\
"</cb>" "</center></b>"\
"</ic>" "</i></center>"\
"</ci>" "</center></i>"\
"<bic>" "<b><i><center>"\
"<bci>" "<b><center><i>"\
"<icb>" "<i><center><b>"\
"<ibc>" "<i><b><center>"\
"<cib>" "<center><i><b>"\
"<cbi>" "<center><b><i>"\
"</bic>" "</b></i></center>"\
"</bci>" "</b></center></i>"\
"</icb>" "</i></center></b>"\
"</ibc>" "</i></b></center>"\
"</cib>" "</center></i></b>"\
"</cbi>" "</center></b></i>"\
} $textutnunc]
} else {
set textutnunc [string map {
"&" "&"\
"<" "<"\
">" ">"\
"\"" """
} $textutnunc]
}
new_html
.tx insert 18.0 $textutnunc\n
set lastend [.tx index end]
set lastnums [split $lastend .]
set lastline [lindex $lastnums 0]
set lastbutfour [expr $lastline - 4]
.tx mark set insert 18.0
.tx insert 18.0 "<p>"
set lineno [line_number]
while {$lineno < $lastbutfour} {
set endoline [.tx index "$lineno.0 lineend"]
set isthisblank [expr $endoline - $lineno.0]
set nextline [expr $lineno + 1]
set endonext [.tx index "$nextline.0 lineend"]
set isnextblank [expr $endonext - $nextline.0]
if {$isthisblank ne 0.0 && $isnextblank eq 0.0} {
.tx insert $endoline "</p>"
}
if {$isthisblank ne 0.0 && $isnextblank ne 0.0} {
.tx insert $nextline.0 "<br />"
}
if {$isthisblank eq 0.0 && $isnextblank ne 0.0} {
.tx insert $nextline.0 "<p>"
}
incr lineno
}
.tx mark set insert 9.0
.tx edit separator
set converto 0
after 1000 wmtitle
}
.filemenu.html add separator
# Procedure to tell whether to put HTML codes into
# main text widget or HTML Table Data Entry box:
# HTML -- Heading
.filemenu.html add command -label "Heading" -underline 0 \
-command headingbox -accelerator Ctrl+F9
bind . <Control-F9> headingbox
set headsize 1
# Procedure to set up heading selection dialog bar:
proc headingbox {} {
global headsize selon foco lastfoco autotab oldautotab
set lastfoco $foco
clearout
if {$autotab == 1} {
set oldautotab 1
set autotab 0
autotaborno
} else {
set oldautotab 0
}
if {[winfo exists .head]} {
grid .head
} else {
frame .head
label .head.text -text "Heading Text: "
entry .head.enter -width 50
set selon [catch {.tx get sel.first sel.last}]
if {$selon == 0} {
.head.enter insert insert [.tx get sel.first sel.last]
}
label .head.size -text "Heading size:"
spinbox .head.spin -width 1 -from 1 -to 6 -textvariable headsize \
-buttonbackground $::buttback
button .head.insert -text "Insert" -pady 2 -border 3 \
-relief groove -command headin
button .head.close -text "Close" -pady 2 -border 1 -command doonhead
bind . <Key-Return> headin
bind .head <F3> {findwin {<br />}}
foreach {key star fin} {
<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>} {
bind . $key "dualcodes $star {} $fin"
}
pack .head.text .head.enter .head.size .head.spin .head.insert \
.head.close -in .head -side left -expand 1 -fill both
grid .head -row 1 -column 0 -columnspan 2 -sticky news
}
foreach ent [list .head.enter .head.spin] {
$ent configure -bg $::entback -fg $::entfore
}
foreach butt [list .head.insert .head.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .head.enter
set foco .head.enter
bind .head <FocusIn> {set foco .head.enter}
}
# Procedure for inserting heading and codes:
proc headin {} {
global headsize foco lastfoco
set foco $lastfoco
set cont [.head.enter get]
dualcodes <h$headsize> "$cont" </h$headsize>
.head.enter delete 0 end
focus $foco
}
# Procedure to get done with headings:
proc doonhead {} {
global autotab oldautotab
if {$oldautotab == 1} {
set autotab 1
}
autotaborno
clearin .head
}
# HTML -- Font
.filemenu.html add command -label "Font" -underline 0 \
-command fontbox -accelerator Ctrl+F8
bind . <Control-F8> fontbox
set html_fontsize 0
set html_fontcolor ""
set colorcall ""
# Procedure to stop displaying font widgets:
proc dumpboxes {} {
global foco
if {[winfo exists .colo]} {destroy .colo}
clearin .font
focus $foco
}
# Procedure to set up font selection dialog bar:
proc fontbox {} {
global colo html_fontsize html_fontcolor colorcall
clearout
if {[winfo exists .font]} {
grid .font
} else {
frame .font
label .font.size -text "Font size:"
spinbox .font.spin -bg white -width 1 -textvariable html_fontsize \
-buttonbackground $::buttback -from "-2" -to 4
label .font.color -text "Font Color:"
entry .font.colornum -width 10 -textvariable colo -bg white
button .font.select -text "Select Color" -command {
if {$colorcall ne ""} {set colorcall ""}
wishcolor
}
button .font.insertcolor -text "Insert Color" \
-command insert_fontcolor
button .font.insertsize -text "Insert size" \
-command insert_fontsize
button .font.insertboth -text "Insert size + Color" \
-command insert_sizencolor
button .font.close -text "Close" -command dumpboxes
foreach butt [list .font.select .font.insertcolor .font.insertsize \
.font.insertboth .font.close] {
$butt configure -padx 2 -borderwidth 1
}
pack .font.size .font.spin .font.color .font.colornum .font.select \
.font.insertcolor .font.insertsize .font.insertboth .font.close \
-in .font -side left -expand 1 -fill both
grid .font -row 1 -column 0 -columnspan 2 -sticky news
}
foreach ent [list .font.spin .font.colornum] {
$ent configure -bg $::entback -fg $::entfore
}
foreach butt [list .font.select .font.insertcolor .font.insertsize \
.font.insertboth .font.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .font.spin
}
# Procedure to insert font color in HTML code:
proc insert_fontcolor {} {
global colo html_fontcolor foco
set html_fontcolor $colo
dualcodes "<font color=\"$html_fontcolor\">" {} </font>
}
# Procedure to insert font size in HTML code:
proc insert_fontsize {} {
global html_fontsize foco
if {$html_fontsize > 0} {
set sizz "+$html_fontsize"
} elseif {$html_fontsize < 0} {
set size "-$html_fontsize"
}
dualcodes "<font size=\"$sizz\">" {} </font>
}
# Procedure to insert font size and color in HTML code:
proc insert_sizencolor {} {
global colo html_fontsize html_fontcolor foco
if {$html_fontsize > 0} {
set sizz "+$html_fontsize"
} elseif {$html_fontsize < 0} {
set sizz "-$html_fontsize"
}
set html_fontcolor $colo
dualcodes "<font size=\"$sizz\"\
color=\"$html_fontcolor\">" {} </font>
}
.filemenu.html add separator
# HTML -- Anchor
.filemenu.html add command -label "Anchor" -underline 0 \
-command "anchorbox" -accelerator Ctrl+F7
bind . <Control-F7> anchorbox
set lastanchor ""
# Procedure to set up anchor insertion dialog bar:
proc anchorbox {} {
global lastanchor foco lastfoco autotab oldautotab
if {$autotab == 1} {
set oldautotab 1
set autotab 0
autotaborno
} else {
set oldautotab 0
}
set lastfoco $foco
clearout
if {[winfo exists .anchor]} {
grid .anchor
} else {
frame .anchor
label .anchor.name -text "Anchor name: "
entry .anchor.enter -width 64 -textvariable lastanchor
if {[catch {.tx get sel.first sel.last}] == 0} {
.anchor.enter insert insert [.tx get sel.first sel.last]
}
button .anchor.insert -text "Insert" -border 3 -relief groove \
-pady 2 -command insert_anchor
button .anchor.close -text "Close" -border 1 -pady 2 \
-command anchordoon
pack .anchor.name .anchor.enter .anchor.insert .anchor.close \
-in .anchor -side left -expand 1 -fill both
bind .anchor <FocusIn> {set foco .anchor.enter}
grid .anchor -row 1 -column 0 -columnspan 2 -sticky news
bind . <Key-Return> insert_anchor
}
.anchor.enter configure -bg $::entback -fg $::entfore
foreach butt [list .anchor.insert .anchor.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .anchor.enter
set foco .anchor.enter
}
# Procedure to insert anchor:
proc insert_anchor {} {
global lastanchor foco lastfoco
set foco $lastfoco
set cont [.anchor.enter get]
dualcodes "<a name=\"$lastanchor\">" "$cont" </a>
}
# Procedure to get done with anchors:
proc anchordoon {} {
global autotab oldautotab
if {$oldautotab == 1} {
set autotab 1
}
autotaborno
clearin .anchor
}
# HTML -- Link
.filemenu.html add command -label "Link" -underline 3 \
-command linkbox -accelerator F7
bind . <F7> linkbox
set linktype "http://www."
set textype html
# Procedure to set up link entry dialog bar:
proc linkbox {} {
global linktype lastanchor foco lastfoco autotab oldautotab
set lastfoco $foco
if {$autotab == 1} {
set oldautotab 1
set autotab 0
autotaborno
} else {
set oldautotab 0
}
if {[winfo exists .link]} {
grid .link
.url.linkent insert 0 $linktype
bind . <Key-Return> insert_link
} else {
frame .link
frame .url
label .url.urlink -text "Link to what? "
entry .url.linkent -width 90
.url.linkent insert 0 $linktype
pack .url.urlink .url.linkent -in .url \
-side left -expand 1 -fill both
frame .show
label .show.display -text "Display name: "
entry .show.name -width 90 -bg white
if {[catch {.tx get sel.first sel.last}] == 0} {
.show.name insert insert [.tx get sel.first sel.last]
}
pack .show.display .show.name -in .show \
-side left -expand 1 -fill both
frame .butt
button .butt.www -text "WWW" -command {
set textype html
linkup "http://www."
}
button .butt.email -text "E-mail" -command {
set textype html
linkup "mailto:"
}
button .butt.ftp -text "FTP" -command {
set textype html
linkup "ftp://"
}
button .butt.anchor -text "Anchor" -command {
set textype html
linkup "#"
}
button .butt.linktext -text "Link-Text" -command {
set textype link
linkup ""
}
button .butt.other -text "Other" -command {
set textype html
linkup ""
}
button .butt.insert -text "Insert Link" -relief groove -border 3 \
-pady 2 -command insert_link
button .butt.close -text "Close" -border 3 -relief groove \
-command linkdoon
foreach butt [list .butt.www .butt.email .butt.ftp .butt.anchor \
.butt.linktext .butt.other .butt.close] {
$butt configure -pady 0 -border 1
}
foreach butt [list .butt.www .butt.email .butt.ftp .butt.anchor \
.butt.linktext .butt.other .butt.insert .butt.close] {
pack $butt -in .butt -side left -expand 1 -fill both
}
bind . <Key-Return> insert_link
bind .show.name <F3> {findwin {<br />}}
foreach {key star fin} {
<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>} {
bind .show.name $key "dualcodes $star {} $fin"}
bind .url.linkent <FocusIn> {set foco .url.linkent}
bind .show.name <FocusIn> {set foco .show.name}
pack .url .show .butt -in .link -side top -expand 1 -fill both
grid .link -row 1 -column 0 -columnspan 2 -sticky news
}
foreach ent [list .url.linkent .show.name] {
$ent configure -bg $::entback -fg $::entfore
}
foreach butt [list .butt.www .butt.email .butt.ftp .butt.anchor \
.butt.linktext .butt.other .butt.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .url.linkent
set foco .url.linkent
}
# Procedure to insert link prefix:
proc linkup {prefix} {
global linktype textype
if {$linktype ne $prefix} {
set linktype $prefix
.url.linkent delete 0 end
.show.name delete 0 end
.url.linkent insert 0 $linktype
focus .url.linkent
}
}
# Procedure to insert link:
proc insert_link {} {
global linktype textype foco lastfoco
set foco $lastfoco
set link_id [.url.linkent get]
set link_name [.show.name get]
if {$textype eq "html"} {
dualcodes "<a href=\"$link_id\">" "$link_name" </a>
} else {
dualcodes "<link \"$link_id\">" "$link_name" </link>
}
.url.linkent delete 0 end
.show.name delete 0 end
linkdoon
}
# Procedure to get done with links:
proc linkdoon {} {
global autotab oldautotab
if {$oldautotab == 1} {
set autotab 1
}
autotaborno
clearin .link
}
.filemenu.html add separator
# HTML -- Image
.filemenu.html add command -label "Image" -underline 1 \
-command imagebox -accelerator Ctrl+F11
bind . <Control-F11> imagebox
# Procedure for setting up image insertion box:
proc imagebox {} {
global alignimage imagedir image_hspace image_vspace imageheight \
imagewidth imagebordo imagepath imagedir dirurl foco lastfoco
if {[info exists imagepath] == 0} {
set imagepath relative
}
if {[info exists alignimage] == 0} {
set alignimage left
}
if {[info exists dirurl] == 0} {
set dirurl ""
}
foreach var [list image_hspace image_vspace imageheight \
imagewidth imagebordo] {set $var 0}
set lastfoco $foco
if {[winfo exists .image]} {destroy .image}
toplevel .image
wm title .image "Insert Image Source"
grid [label .image.dest -text "Directory URL:" -pady 6] \
-row 0 -column 0 -sticky news
grid [entry .image.url -bg white -textvariable dirurl] \
-row 0 -column 1 -columnspan 2 -sticky news
if {$imagepath eq "relative"} {
foreach widget [list .image.dest .image.url] {
$widget configure -state disabled
}
} else {
foreach widget [list .image.dest .image.url] {
$widget configure -state normal
}
}
grid [label .image.filename -text "Image file name:" -pady 6] \
-row 1 -column 0 -sticky news
grid [entry .image.enter -width 56 -bg white] \
-row 1 -column 1 -columnspan 2 -sticky news
frame .image.fr2
button .image.pick -text "Pick Image" -command pickimage
label .image.path -text "Path to Image: " -pady 6
radiobutton .image.rel -text "Relative" -variable imagepath \
-value "relative" -selectcolor $::regradio -command {
foreach widget [list .image.dest .image.url] {
$widget configure -state disabled
}
focus .image.enter
}
radiobutton .image.abso -text "Absolute" -variable imagepath \
-value "absolute" -selectcolor $::regradio -command {
foreach widget [list .image.dest .image.url] {
$widget configure -state normal
}
focus .image.url
}
label .image.align -text "Align:"
pack .image.pick .image.path .image.rel .image.abso .image.align \
-in .image.fr2 -side left -expand 1 -fill both
grid .image.fr2 -row 2 -column 0 -columnspan 2 -sticky news
tk_optionMenu .image.lineup alignimage left right top middle bottom
grid .image.lineup -row 2 -column 2 -sticky news
grid [label .image.optinfo -bg $::lightback -fg $::lightfore \
-text "O P T I O N A L I N F O R M A T I O N :" -pady 6] \
-row 3 -column 0 -columnspan 3 -sticky news
grid [label .image.alt -text "Image description:" -pady 6] \
-row 4 -column 0 -sticky news
grid [entry .image.altinhere -width 56 -bg white] \
-row 4 -column 1 -columnspan 2 -sticky news
frame .image.fr5
label .image.horspace -text "Spacing: Horiz" -pady 6
spinbox .image.horizhere -width 4 -bg white \
-buttonbackground $::buttback \
-textvariable image_hspace -from 0 -to 1000
label .image.vertspace -text " Vert"
spinbox .image.vertinhere -width 4 -bg white \
-buttonbackground $::buttback\
-textvariable image_vspace -from 0 -to 1000
label .image.height -text " Height"
spinbox .image.heightinhere -width 5 -bg white \
-buttonbackground $::buttback\
-textvariable imageheight -from 0 -to 10000
label .image.width -text " Width"
spinbox .image.widthinhere -width 5 -bg white \
-buttonbackground $::buttback \
-textvariable imagewidth -from 0 -to 10000
label .image.bordo -text " Border"
spinbox .image.bordohere -width 3 -bg white \
-buttonbackground $::buttback \
-textvariable imagebordo -from 0 -to 100
pack .image.horspace .image.horizhere .image.vertspace .image.vertinhere \
.image.height .image.heightinhere .image.width .image.widthinhere \
.image.bordo .image.bordohere -in .image.fr5 \
-side left -expand 1 -fill both
grid .image.fr5 -row 5 -column 0 -columnspan 3 -sticky news
frame .image.fr6
button .image.insert -text "Insert" -default active \
-command insert_image
button .image.close -text "Close" -default normal -command {
focus .tx
set foco .tx
destroy .image
}
pack .image.insert .image.close -in .image.fr6 \
-side left -expand 1 -fill both
grid .image.fr6 -row 6 -column 0 -columnspan 3 -sticky news
bind .image <Key-Return> insert_image
if {$imagepath eq "relative"} {
focus .image.enter
set foco .image.enter
} else {
focus .image.url
set foco .image.url
}
foreach ent [list .image.url .image.enter .image.altinhere] {
bind $ent <FocusIn> "set foco $ent"
}
foreach ent [list .image.url .image.enter .image.altinhere \
.image.horizhere .image.vertinhere .image.heightinhere \
.image.widthinhere .image.bordohere ] {
$ent configure -bg $::entback -fg $::entfore
}
foreach butt [list .image.insert .image.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
}
# Procedure to pick image file name:
proc pickimage {} {
global imagepath foco currentfile
if {$currentfile ne ""} {
set imagedir [file dirname $currentfile]
} else {
set imagedir [pwd]
}
set imagefile [tk_getOpenFile -title "Pick Image File" \
-initialdir $imagedir]
set imagename [file tail $imagefile]
.image.enter insert 0 $imagename
focus .image.enter
set foco .image.enter
}
# Procedure to insert image source into HTML code:
proc insert_image {} {
global alignimage codestart codend image_hspace image_vspace \
imageheight imagewidth imagebordo foco imagepath dirurl lastfoco
set foco $lastfoco
set img_src [.image.enter get]
if {$imagepath eq "absolute" && [regexp "$dirurl" $img_src] == 0} {
set dirurl [string trimright $dirurl "/"]
set img_src $dirurl/$img_src
}
set alttext [.image.altinhere get]
if {$alttext ne ""} {
set alttext " alt=\"$alttext\""
}
if {$image_hspace > 0} {
set imhup " hspace=\"$image_hspace\""
} else {
set imhup ""
}
if {$image_vspace > 0} {
set imvup " vspace=\"$image_vspace\""
} else {
set imvup ""
}
if {$imageheight > 0} {
set imhut " height=\"$imageheight\""
} else {
set imhut ""
}
if {$imagewidth > 0} {
set imgwid " width=\"$imagewidth\""
} else {
set imgwid ""
}
if {$imagebordo > 0} {
set imbord " border=\"$imagebordo\""
} else {
set imbord ""
}
$foco insert insert \
"<img src=\"$img_src\"\
align=\"$alignimage\"$alttext$imhup$imvup$imhut$imgwid$imbord>"
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
foreach var [list image_hspace image_vspace imageheight \
imagewidth imagebordo] {set $var 0}
destroy .image
}
.filemenu.html add separator
# HTML -- List
.filemenu.html add command -label "List" -underline 2 \
-command html_list -accelerator F11
bind . <F11> html_list
set listtype 1
set liston 0
set ordo 1
# Procedure to set up dialog bar for list item entry:
proc html_list {} {
global listtype liston foco lastfoco autotab oldautotab
if {$autotab == 1} {
set oldautotab 1
set autotab 0
autotaborno
} else {
set oldautotab 0
}
if {[winfo class $foco] eq "Text"} {
set lastfoco $foco
} else {
set lastfoco .tx
}
if {$liston == 1} {set liston 0}
if {[winfo exists .html_list]} {
grid .html_list
} else {
frame .html_list
frame .html
label .html.item -text "List item: "
entry .html.itemhere -width 72 -bg white
if {[catch {$foco get sel.first sel.last}] == 0} {
.html.itemhere insert insert [$foco get sel.first sel.last]
}
button .html.insert -text "Insert" -relief groove -border 3 \
-pady 2 -command insert_item
button .html.done -text "Done" -border 1 -pady 2 \
-command finish_list
pack .html.item .html.itemhere .html.insert .html.done \
-in .html -side left -expand 1 -fill both
frame .list
label .list.style -text "Style: "
radiobutton .list.123 -text "1-2-3" -variable listtype -value 1
radiobutton .list.capa -text "A-B-C" -variable listtype -value A
radiobutton .list.abc -text "a-b-c" -variable listtype -value a
radiobutton .list.capi -text "I-II-III" -variable listtype -value I
radiobutton .list.iii -text "i-ii-iii" -variable listtype -value i
radiobutton .list.disc -text "Discs" -variable listtype -value disc
radiobutton .list.circle -text "Circles" -variable listtype \
-value circle
radiobutton .list.square -text "Squares" -variable listtype \
-value square
pack .list.style .list.123 .list.capa .list.abc .list.capi .list.iii \
.list.disc .list.circle .list.square -in .list \
-side left -expand 1 -fill both
pack .list .html -in .html_list -side top -expand 1 -fill both
grid .html_list -row 1 -column 0 -columnspan 2 -sticky news
bind .html_list <FocusIn> {set foco .html.itemhere}
bind .html.itemhere <Key-Return> insert_item
bind .html_list <F3> {findwin {<br />}}
foreach {key star fin} {
<F6> <p> </p> \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>
} {bind .html_list $key "dualcodes $star {} $fin"}
}
.html.itemhere configure -bg $::entback -fg $::entfore
foreach butt [list .html.insert .html.done] {
$butt configure -bg $::buttback -fg $::buttfore
}
foreach reg [list .list.123 .list.capa .list.abc .list.capi \
.list.iii .list.disc .list.circle .list.square] {
$reg configure -selectcolor $::regradio
}
focus .html.itemhere
set foco .html.itemhere
}
# Procedure to create list and insert items:
proc insert_item {} {
global listchoice listtype liston ordo foco lastfoco
set list_item [.html.itemhere get]
if {[catch {$lastfoco get sel.first sel.last}] == 0} {
$lastfoco delete sel.first sel.last
}
if {$liston == 0} {
switch $listtype {
1 -
A -
a -
I -
i {
set ordo 1
}
disc -
circle -
square {
set ordo 0
}
}
if { $ordo == 1 } {
$lastfoco insert insert \
"<ol type=$listtype>\n\t<li>$list_item</li>\n"
} else {
$lastfoco insert insert \
"<ul type=$listtype>\n\t<li>$list_item</li>\n"
}
set liston 1
} else {
$lastfoco insert insert "\t<li>$list_item</li>\n"
}
.html.itemhere delete 0 end
$lastfoco edit separator
wmtitle
focus .html.itemhere
set foco .html.itemhere
}
# Procedure to finish off list:
proc finish_list {} {
global ordo foco lastfoco autotab oldautotab
if {$ordo == 1} {
$lastfoco insert insert "</ol>\n\n"
} else {
$lastfoco insert insert "</ul>\n\n"
}
set liston 0
set foco $lastfoco
$foco edit separator
if {$foco eq ".tx"} {
wmtitle
}
clearin .html_list
if {$oldautotab == 1} {
set autotab 1
autotaborno
}
}
# HTML -- Table
.filemenu.html add command -label "Table: Create" -underline 0 \
-command tablebox -accelerator F12
bind . <F12> tablebox
.filemenu.html add command -label "Table: Continue" -underline 8 -command {
set rowon 0
set celltype Data
.tx insert insert "\n\t"
databox
} -accelerator Ctrl+F12
bind . <Control-F12> {
set rowon 0
set celltype Data
.tx insert insert "\n\t"
databox
}
# Initialize variables for table attributes:
foreach var [list tableon tablesum table_hspace table_vspace tableheight \
tablewidth tablebordo cellpad cellspace] {set $var 0}
set tablecolor ""
# Procedure to create Table Setup box:
proc tablebox {} {
global color tablecolor blankrows blankcols tablesum table_hspace \
table_vspace tableheight tablewidth tablebordo cellpad cellspace \
tablecolor celltype foco
if { [winfo exists .table] } { destroy .table }
toplevel .table
wm title .table "HTML Table Setup"
grid [button .table.withdata -text "M A K E T A B L E" \
-default active -bg $::buttback -fg $::buttfore -command {
get_tablecodes
make_table
set celltype Header
databox
destroy .table
}] -row 0 -column 0 -columnspan 7 -sticky news
grid [button .table.close -text "Close" -default normal \
-bg $::buttback -fg $::buttfore -command {
destroy .table
focus .tx
set foco .tx
}] -row 0 -column 7 -columnspan 5 -sticky news
grid [label .table.optinfo -bg $::lightback -fg $::lightfore \
-text "O P T I O N A L I N F O R M A T I O N :" -pady 6] \
-row 1 -column 0 -columnspan 11 -sticky news
grid [label .table.sum -text "Table summary:" -pady 6] \
-row 2 -column 0 -columnspan 2 -sticky news
grid [entry .table.suminhere -width 40] \
-row 2 -column 2 -columnspan 9 -sticky news
grid [label .table.horspace -text "Spacing: Horiz" -pady 6] \
-row 3 -column 0 -columnspan 2 -sticky news
grid [spinbox .table.horizhere -width 4 \
-buttonbackground $::buttback \
-textvariable table_hspace -from 0 -to 1000] \
-row 3 -column 2 -sticky news
grid [label .table.vertspace -text "Vert"] \
-row 3 -column 3 -sticky news
grid [spinbox .table.vertinhere -width 4 -bg white \
-buttonbackground $::buttback \
-textvariable table_vspace -from 0 -to 1000] \
-row 3 -column 4 -sticky news
grid [label .table.height -text "Height"] \
-row 3 -column 5 -sticky news
grid [spinbox .table.heightinhere -width 5 -bg white \
-buttonbackground $::buttback \
-textvariable tableheight -from 0 -to 10000] \
-row 3 -column 6 -sticky news
grid [label .table.width -text "Width"] \
-row 3 -column 7 -sticky news
grid [spinbox .table.widthinhere -width 5 -bg white \
-buttonbackground $::buttback \
-textvariable tablewidth -from 0 -to 10000] \
-row 3 -column 8 -sticky news
grid [label .table.bordo -text "Border"] \
-row 3 -column 9 -sticky news
grid [spinbox .table.bordohere -width 3 -bg white \
-buttonbackground $::buttback \
-textvariable tablebordo -from 0 -to 100] \
-row 3 -column 10 -sticky news
grid [label .table.cellpad -text "Space inside cells" -pady 6] \
-row 4 -column 0 -columnspan 2 -sticky news
grid [spinbox .table.padhere -width 3 -bg white \
-buttonbackground $::buttback \
-textvariable cellpad -from 0 -to 100] \
-row 4 -column 2 -sticky news
grid [label .table.cellspace -text "Space between cells"] \
-row 4 -column 3 -columnspan 3 -sticky news
grid [spinbox .table.spacehere -width 3 -bg white \
-buttonbackground $::buttback \
-textvariable cellspace -from 0 -to 100] \
-row 4 -column 6 -sticky news
grid [label .table.allinpixels -text "(all in pixels)"] \
-row 4 -column 7 -columnspan 4 -sticky news
grid [label .table.tablecolor -text "Background color:"] \
-row 5 -column 0 -columnspan 2 -sticky news
grid [label .table.colorcode -textvariable color] \
-row 5 -column 2 -columnspan 2 -sticky news
grid [button .table.colorsel -text "Select color" -command {
if {$colorcall ne ""} {set colorcall ""}
wishcolor
}] -row 5 -column 4 -columnspan 3 -sticky news
grid [button .table.colordesel -text "Deselect color" \
-command { set color "" }] \
-row 5 -column 7 -columnspan 4 -sticky news
bind .table <Key-Return> {
get_tablecodes ; make_table ; databox ; destroy .table
}
foreach ent [list .table.suminhere .table.horizhere .table.vertinhere \
.table.heightinhere .table.widthinhere .table.bordohere \
.table.padhere .table.spacehere] {
$ent configure -bg $::entback -fg $::entfore
}
foreach butt [list .table.withdata .table.close .table.colorsel \
.table.colordesel] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .table.suminhere
set foco .table.suminhere
bind .table.suminhere <FocusIn> {set foco .table.suminhere}
}
# Procedure to get HTML codes for table attributes from user input:
proc get_tablecodes {} {
global blankcols blankrows color tablecolor table_hspace table_vspace \
tableheight tablewidth tablebordo cellpad cellspace tablesum \
tabhup tabvup tabhut tabwid tabbord tabcol celpa celspa
set tablesum [.table.suminhere get]
if {$color ne ""} {
set tablecolor $color
set tabcol " bgcolor=\"$tablecolor\""
} else {
set tabcol ""
}
if {$tablesum ne ""} {
set tablesum " summary=\"$tablesum\""
}
if {$table_hspace > 0} {
set tabhup " hspace=\"$table_hspace\""
} else {
set tabhup ""
}
if {$table_vspace > 0} {
set tabvup " vspace=\"$table_vspace\""
} else {
set tabvup ""
}
if {$tableheight > 0} {
set tabhut " height=\"$tableheight\""
} else {
set tabhut ""
}
if {$tablewidth > 0} {
set tabwid " width=\"$tablewidth\""
} else {
set tabwid ""
}
if {$tablebordo > 0} {
set tabbord " border=\"$tablebordo\""
} else {
set tabbord ""
}
if {$cellpad > 0} {
set celpa " cellpadding=\"$cellpad\""
} else {
set celpa ""
}
if {$cellspace > 0} {
set celspa " cellspacing=\"$cellspace\""
} else {
set celspa ""
}
}
# Procedure to insert HTML codes for beginning and end of table:
proc make_table {} {
global tabcol table_hspace table_vspace horowin vertrowin rowcolor \
tableheight tablewidth tablebordo cellpad cellspace tablesum \
tabhup tabvup tabhut tabwid tabbord celpa celspa
.tx insert insert \
"<table$tablesum$tabcol$tabhup$tabvup\
$tabhut$tabwid$tabbord$celpa$celspa>\n\n\n\n</table>"
set lineno [expr int([.tx index insert])]
.tx mark set insert [expr $lineno-2].0
.tx insert insert "\t"
.tx edit separator
wmtitle
}
# Initialize variables for row attributes:
set horowalign left
set vertrowalign middle
set horowin ""
set vertrowin ""
set rowcolor ""
set rowon 0
# Initialize variables for cell attributes:
set horcellalign left
set vertcellalign middle
set horcellin ""
set vertcellin ""
set rowspannum 1
set colspannum 1
set rowcolor ""
set cellcolor ""
# Procedure to create HTML Table Data Entry box:
proc databox {} {
global horowalign vertrowalign horcellalign \
vertcellalign colspannum rowspannum textbox \
color rowcolor cellcolor celltype colorcall fonto foco
toplevel .data
wm title .data "HTML Table Data Entry"
grid [label .data.cellcont -text "C E L L C O N T E N T S :" \
-bg $::lightback -fg $::lightfore -pady 6] \
-row 0 -column 0 -columnspan 6 -sticky news
frame .data.but1
button .data.line -text "New Line (F3)" -command {
.data.cont insert insert "\n<br />"
.data.cont edit separator
.data.cont see insert
}
button .data.par -text "New Par (F6)"
foreach {butt star fin} {<FocusIn> {\n<p>} {</p>}} {
bind .data.par $butt "dualcodes $star {} $fin"
}
button .data.ital -text "Italic (F8)" -command {
dualcodes <i> {} </i>
}
button .data.bold -text "Bold (F9)" -command {
dualcodes <b> {} </b>
}
set insbutts [list .data.line .data.par .data.ital .data.bold]
foreach butt $insbutts {
$butt configure -pady 0 -padx 0 -borderwidth 1 \
-bg $::buttback -fg $::buttfore
pack $butt -in .data.but1 -side left -expand 1 -fill both
}
grid .data.but1 -row 1 -column 0 -columnspan 6 -sticky news
frame .data.but2
button .data.ins -text "Insert" -command {
set openins Insert
set foco .data.cont
openrece file
}
bind .data <Control-comma> {
set openins Insert
set foco .data.cont
openrece file
}
button .data.cut -text "Cut" -command {
set foco .data.cont
cut_text
}
bind .data <Control-x> {
set foco .data.cont
cut_text
}
button .data.copy -text "Copy" -command {
set foco .data.cont
copy_text
}
bind .data <Control-c> {
set foco .data.cont
copy_text
}
button .data.paste -text "Paste" -command {
set foco .data.cont
paste_text
}
bind .data <Control-g> {
set foco .data.cont
paste_text
}
bind .data <Control-X> {
set foco .data.cont
supercut
}
bind .data <Control-C> {
set foco .data.cont
supercopy
}
bind .data <F1> {openrece paste}
button .data.undo -text "Undo" -command {
catch {.data.cont edit undo}
}
button .data.redo -text "Redo" -command {
catch {.data.cont edit redo}
}
button .data.special -text "Special" -command specialbox
set databutts [list .data.ins .data.cut .data.copy .data.paste \
.data.undo .data.redo .data.special]
foreach butt $databutts {
$butt configure -pady 0 -padx 0 -borderwidth 1 \
-bg $::buttback -fg $::buttfore
pack $butt -in .data.but2 -side left -expand 1 -fill both
}
grid .data.but2 -row 2 -column 0 -columnspan 6 -sticky news
frame .data.tx
text .data.cont -bg $::textback -fg $::textfore -width 44 \
-height 8 -font $fonto -wrap word -setgrid 1 -undo 1 \
-inactiveselectbackground $::inacback
scrollbar .data.roll -width 12 -command ".data.cont yview"
.data.cont configure -yscrollcommand ".data.roll set"
pack .data.cont .data.roll -in .data.tx \
-side left -expand 1 -fill both
grid .data.tx -row 3 -column 0 -columnspan 6 -sticky news
grid [label .data.celltype -text "Cell type:"] \
-row 4 -column 0 -sticky news
tk_optionMenu .data.cellmenu celltype Header Data
grid .data.cellmenu -row 4 -column 1 -sticky news
grid [label .data.colspan -text "Column span:"] \
-row 4 -column 2 -sticky news
grid [spinbox .data.colspannum -width 3 -bg $::entback -fg $::entfore \
-buttonbackground $::buttback \
-textvariable colspannum -from 1 -to 100] \
-row 4 -column 3 -sticky news
grid [label .data.rowspan -text "Row span:"] \
-row 4 -column 4 -sticky news
grid [spinbox .data.rowspannum -width 3 -bg $::entback -fg $::entfore \
-buttonbackground $::buttback \
-textvariable rowspannum -from 1 -to 100] \
-row 4 -column 5 -sticky news
frame .data.fr1
button .data.enter -text "Enter" -default active \
-command insert_cell
button .data.newrow -text "Begin new row" -default normal \
-command newrow
button .data.done -text "Done" -default normal -command {
if {$rowon == 1} {
.tx insert insert "\t</tr>\n"
}
set rowon 0
destroy .data
}
button .data.close -text "Close" -default normal -command {
destroy .data
focus .tx
set foco .tx
}
foreach butt [list .data.enter .data.newrow .data.done .data.close] {
$butt configure -bg $::buttback -fg $::buttfore
pack $butt -in .data.fr1 -side left -expand 1 -fill both
}
grid .data.fr1 -row 5 -column 0 -columnspan 6 -sticky news
grid [label .data.optinfo -bg $::lightback -fg $::lightfore \
-text "O P T I O N A L I N F O R M A T I O N :" -pady 6] \
-row 6 -column 0 -columnspan 6 -sticky news
grid [label .data.rowalign -text "Align in row:"] \
-row 7 -column 0 -sticky news
grid [label .data.horowalign -text "Horizontal" ] \
-row 7 -column 1 -sticky news
tk_optionMenu .data.horowmenu horowalign left center right
grid .data.horowmenu -row 7 -column 2 -sticky news
grid [label .data.vertrowalign -text "Vertical"] \
-row 7 -column 3 -sticky news
tk_optionMenu .data.vertrowmenu vertrowalign \
top middle bottom baseline
grid .data.vertrowmenu -row 7 -column 4 -columnspan 2 -sticky news
grid [label .data.cellalign -text "Align in cell:"] \
-row 8 -column 0 -sticky news
grid [label .data.horcellalign -text "Horizontal" ] \
-row 8 -column 1 -sticky news
tk_optionMenu .data.horcellmenu horcellalign left center right
grid .data.horcellmenu -row 8 -column 2 -sticky news
grid [label .data.vertcellalign -text "Vertical"] \
-row 8 -column 3 -sticky news
tk_optionMenu .data.vertcellmenu vertcellalign \
top middle bottom baseline
grid .data.vertcellmenu -row 8 -column 4 -columnspan 2 -sticky news
frame .data.froth
frame .data.frow
button .data.rowcolorsel -text "Select row color" -command {
set colorcall row
wishcolor
}
button .data.rowcolordesel -text "Deselect row color" -command {
set color ""
set rowcolor ""
}
pack .data.rowcolorsel .data.rowcolordesel -in .data.frow \
-side top -expand 1 -fill both
frame .data.frell
button .data.cellcolorsel -text "Select cell color" -command {
set colorcall cell
wishcolor
}
button .data.cellcolordesel -text "Deselect cell color" -command {
set color ""
set cellcolor ""
}
pack .data.cellcolorsel .data.cellcolordesel -in .data.frell \
-side top -expand 1 -fill both
pack .data.frow .data.frell -in .data.froth -side left -expand 1 -fill both
grid .data.froth -row 9 -column 0 -columnspan 6 -sticky news
foreach butt [list .data.rowcolorsel .data.rowcolordesel \
.data.cellcolorsel .data.cellcolordesel] {
$butt configure -bg $::buttback -fg $::buttfore
}
bind .data <Key-Return> insert_cell
bind .data <F3> {
.data.cont insert insert "\n<br />"
.data.cont edit separator
.data.cont see insert
}
foreach {key star fin} {
<F6> {\n<p>} {</p>} \
<F8> <i> </i> \
<F9> <b> </b> \
<Control-F6> <center> </center>
} {bind .data $key "dualcodes $star {} $fin"}
bind .data <Control-r> { catch {.data.cont edit redo} }
bind .data <space> {.data.cont edit separator}
bind .data <BackSpace> {.data.cont edit separator}
focus .data.cont
set foco .data.cont
bind .data <FocusIn> {set foco .data.cont}
}
# Procedure to get HTML codes for row attributes from user input
# ("left" and "middle" are defaults for
# horizontal and vertical alignment of contents):
proc get_rowcodes {} {
global horowalign vertrowalign vertrowin horowin rowcolor
if {$horowalign eq "left"} {
set horowin ""
} else {
set horowin " align=\"$horowalign\""
}
if {$vertrowalign eq "middle"} {
set vertowin ""
} else {
set vertrowin " valign=\"$vertrowalign\""
}
if {$rowcolor ne ""} {
set rowcolor " bgcolor=\"$rowcolor\""
}
}
# Procedure to get HTML codes for cell attributes from user input:
proc get_cellcodes {} {
global colspannum rowspannum horcellalign vertcellalign \
horcellin vertcellin cellcolor rowspa colspa
if {$rowspannum > 1} {
set rowspa " rowspan=\"$rowspannum\""
} else {
set rowspa ""
}
if {$colspannum > 1} {
set colspa " colspan=\"$colspannum\""
} else {
set colspa ""
}
if {$horcellalign eq "left"} {
set horcellin ""
} else {
set horcellin " align=\"$horcellalign\""
}
if {$vertcellalign == "middle"} {
set vertcellin ""
} else {
set vertcellin " valign=\"$vertcellalign\""
}
if {$cellcolor ne ""} {
set cellcolor " bgcolor=\"$cellcolor\""
}
}
# Procedure to insert new data cell in existing row of HTML table:
proc insert_cell {} {
global codestart codend colspannum rowspannum horowin vertrowin \
horcellin vertcellin rowcolor cellcolor celltype rowon \
colspa rowspa
set cellcontents [string trimright [.data.cont get 1.0 end-1c]]
if {$rowon == 0} {
get_rowcodes
get_cellcodes
.tx insert insert "<tr$horowin$vertrowin$rowcolor>\n"
set rowon 1
} else {
get_cellcodes
}
if {$celltype eq "Header"} {
set star "\t\t<th$colspa$rowspa$horcellin$vertcellin$cellcolor>"
set fin "</th>\n"
} else {
set star "\t\t<td$colspa$rowspa$horcellin$vertcellin$cellcolor>"
set fin "</td>\n"
}
.tx insert insert $star$cellcontents$fin
.tx edit modified
wmtitle
set lineno [line_number]
set downfour [expr $lineno + 4]
.tx see $downfour.0
.data.cont delete 1.0 end
focus .data.cont
}
# Procedure to insert new row in HTML table with data contents:
proc newrow {} {
global celltype horowin vertrowin rowcolor rowon
if {$celltype eq "Header"} {set celltype Data}
get_rowcodes
if {$rowon == 1} {
.tx insert insert \
"\t</tr>\n\n\t<tr$horowin$vertrowin$rowcolor>\n"
} else {
.tx insert insert "\n\t<tr$horowin$vertrowin$rowcolor>\n"
}
if {$rowon == 0} {set rowon 1}
set lineno [line_number]
.tx see [expr $lineno+3].0
.tx edit separator
wmtitle
}
.filemenu.html add separator
# HTML -- Paragraph
.filemenu.html add command -label "Paragraph <p>" -underline 0 -command {
dualcodes "<p>" {} </p>
} -accelerator F6
bind . <F6> {dualcodes "<p>" {} "</p>"}
# HTML -- Line Break
.filemenu.html add command -label "Line Break <br>" -underline 0 -command {
.tx insert insert "<br />"
.tx edit separator
.tx see insert
wmtitle
} -accelerator F3
bind . <F3> {
.tx insert insert "<br />"
.tx edit separator
.tx see insert
wmtitle
}
# HTML -- Emphasis
.filemenu.html add command -label "Italics <i>" -underline 0 -command {
dualcodes <i> {} </i>
} -accelerator F8
bind . <F8> {dualcodes <i> {} </i>}
# HTML -- Strong
.filemenu.html add command -label "Bold <b>" -underline 0 -command {
dualcodes <b> {} </b>
} -accelerator F9
bind . <F9> {dualcodes <b> {} </b>}
# HTML -- Center
.filemenu.html add command -label "Center <center>" -underline 5 -command {
dualcodes <center> {} </center>
} -accelerator Ctrl+F6
bind . <Control-F6> {dualcodes <center> {} </center>}
### TCL/TK MENU ###
menu .filemenu.tcl -tearoff 0
.filemenu add cascade -label "Tcl/Tk" -underline 0 -menu .filemenu.tcl
# Tcl/Tk -- New Script
.filemenu.tcl add command -label "New Script" -underline 0 \
-command new_wish -accelerator Ctrl+F5
bind . <Control-F5> new_wish
proc new_wish {} {
set go [readytogo]
if {$go == 0} {return}
outwithold
.tx insert 1.0 "#!/usr/bin/env wish\n\n# "
.tx edit separator
wmtitle
}
.filemenu.tcl add separator
# Tcl/Tk -- Run Selected Code
.filemenu.tcl add command -label "Run Selected Code" -underline 0 \
-command runcode -accelerator F5
bind . <F5> runcode
proc runcode {} {
if {[interp exists testrunner]} {interp delete testrunner}
set anysel [catch {.tx get sel.first sel.last} codetorun]
if {$anysel == 0} {
interp create testrunner
load {} Tk testrunner
testrunner eval $codetorun
} else {
tk_messageBox -message "Please select some code to run" \
-title "Select Code" -type ok
}
}
.filemenu.tcl add separator
# Tcl/Tk -- Find Closing
.filemenu.tcl add command -label "Find Closing" -underline 0 \
-command findclose -accelerator Ctrl+Alt+\[
bind . <Control-Alt-bracketleft> findclose
proc findclose {} {
global lev ope clo whence whither here
# Find what to search for and where to search from:
if {[catch {set ope [.tx get sel.first sel.last]}]} {
set ope ""
}
set whence [.tx index sel.last]
set whither ""
set lev 1 ; # Opening found, closing not yet found
switch $ope {
"\{" {
set clo "\}"
}
"\[" {
set clo "\]"
}
"\"" {
set clo $ope
}
default {
tk_messageBox -message "Please select an opening\
brace ( \{ ), bracket ( \[ ), or quote ( \" )" -type ok
return
}
}
set here $whence
findmatch
if {$lev == 0 && $whither ne ""} {
.tx tag add sel $whence $whither
} else {
tk_messageBox -message "Closing not found" -type ok
}
}
proc findmatch {} {
global lev ope clo whence whither here
if {$clo eq $ope} {
set whereat [.tx search $clo $whence end]
} else {
set up [.tx search $ope $here end]
set down [.tx search $clo $here end]
if {$up eq ""} {
set whichendup down
set whereat $down
}
if {$down eq ""} {
set whereat ""
}
if {$up ne "" && $down ne ""} {
if {[.tx compare $up > $down]} {
set whichendup down
set whereat $down
} else {
set whichendup up
set whereat $up
}
}
}
if {$whereat ne ""} {
set whatbefore [.tx get "$whereat -1c"]
if {$whatbefore eq "\\"} {
set here [.tx index "$whereat +1c"]
findmatch
} else {
if {$clo eq $ope} {
set whither [.tx index "$whereat +1c"]
set lev 0
return
} else {
set here [.tx index "$whereat +1c"]
if {$whichendup eq "up"} {
incr lev
} else {
incr lev -1
}
}
}
}
if {$lev == 0} {
set whither $here
return
} elseif {$whereat ne ""} {
findmatch
}
}
.filemenu.tcl add separator
# Tcl/Tk -- Matching Braces { }
.filemenu.tcl add command -label "Curly Braces \{ \}" -underline 0 -command {
dualcodes "{" {} "}"
} -accelerator Ctrl+\{
bind . <Control-braceleft> {dualcodes "{" {} "}"}
bind . <Shift-Home> {
.tx mark set insert "[.tx index insert] lineend"
.tx insert insert " "
.tx insert insert "\{\}"
.tx mark set insert "insert -1c"
selection clear
}
.filemenu.tcl add command -label "Next Braces" -underline 2 -command {
.tx mark set insert "[.tx index insert] lineend"
.tx insert insert " "
.tx insert insert "\{\}"
.tx mark set insert "insert -1c"
selection clear
} -accelerator Shift+Home
.filemenu.tcl add command -label "Leave Braces" -underline 0 -command {
autotab stop
} -accelerator Shift+Enter
.filemenu.tcl add separator
# Tcl/Tk -- Matching Brackets [ ]
.filemenu.tcl add command -label "Square Brackets \[ \]" \
-underline 0 -command {
dualcodes {[} {} {]}
} -accelerator Ctrl+\[
bind . <Control-bracketleft> {dualcodes {[} {} {]}}
# Tcl/Tk -- Matching Angle Brackets < >
.filemenu.tcl add command -label "Angle Brackets < >" \
-underline 0 -command {
dualcodes {<} {} {>}
} -accelerator Ctrl+<
bind . <Control-less> {dualcodes {<} {} {>}}
# Tcl/Tk -- Matching Parentheses ( )
.filemenu.tcl add command -label "Parentheses ( )" \
-underline 0 -command {
dualcodes {(} {} {)}
} -accelerator Ctrl+(
bind . <Control-parenleft> {dualcodes {(} {} {)}}
# Tcl/Tk -- Matching Quotes " "
.filemenu.tcl add command -label "Quotes \" \"" \
-underline 0 -command {
dualcodes {"} {} {"}
} -accelerator Ctrl+\"
bind . <Control-quotedbl> {dualcodes {"} {} {"}}
### DISPLAY MENU ###
menu .filemenu.display -tearoff 0
.filemenu add cascade -label "Display" -underline 0 -menu .filemenu.display
### Display -- Format/Window size
.filemenu.display add command -label "Format/Window Size" -underline 1 \
-command formato
# Procedures to format text with newlines:
proc formato {} {
global texwid texhi oldwid oldhi formawid
set oldwid $texwid ; set oldhi $texhi
clearout
if {[winfo exists .forma]} {
grid .forma
} else {
frame .forma
label .forma.hi -text "Height: "
spinbox .forma.disphi -from 1 -to 100 -textvariable texhi \
-buttonbackground $::buttback -width 3
label .forma.wid -text "Window width: "
spinbox .forma.dispwid -from 20 -to 200 -textvariable texwid \
-buttonbackground $::buttback -width 3
label .forma.form -text "Format to width: "
spinbox .forma.formawid -from 20 -to 200 -textvariable formawid \
-buttonbackground $::buttback -width 3
button .forma.chug -text "Resize window" -command {
.tx configure -height $texhi -width $texwid
wm geometry . {}
savefig
}
button .forma.ok -text "Format" -command {formatit show}
button .forma.close -text "Close" -command {
set texwid $oldwid
set texhi $oldhi
clearin .forma
}
pack .forma.hi .forma.disphi .forma.wid .forma.dispwid \
.forma.form .forma.formawid .forma.chug .forma.ok .forma.close \
-in .forma -side left -expand 1 -fill both
grid .forma -row 1 -column 0 -columnspan 2 -sticky news
}
foreach spin [list .forma.disphi .forma.dispwid .forma.formawid] {
$spin configure -bg $::entback -fg $::entfore
}
foreach butt [list .forma.chug .forma.ok .forma.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
}
proc formatit {whattodo} {
global formawid texwid wordwrap printorshow
clearin .forma
if {[winfo exists .tinga] == 0} {
grid [label .tinga -text "Formatting ... may take a while for\
long text .... Please wait"] \
-row 1 -column 0 -columnspan 2 -sticky news
}
if {$whattodo eq "print"} {
set printout [formanew print]
destroy .tinga
return $printout
} else {
.tx configure -width $formawid -wrap word
wm geometry . {}
after 100 {
formanew show
destroy .tinga
.tx configure -width $texwid -wrap $wordwrap
wm geometry . {}
}
}
}
proc formanew {whattodo} {
global formawid
# Identify beginning and end of text to format, and
# omit needless newlines:
omitneedless plus
if {[.tx tag ranges sel] eq ""} {
set selon 1.0
set seloff [.tx index end]
} else {
set selon [.tx index sel.first]
set seloff [.tx index sel.last]
}
set texin [expr int($selon)]
set texend [expr int($seloff)]
# Initialize variable to hold output:
set formatext ""
# Dig in and format text:
for {set i $texin} {$i <= $texend} {incr i} {
# Get text to newline:
set endolin [.tx index $i.end]
set endochar [lindex [split $endolin "."] end]
set whatline [.tx get $i.0 $endolin]
# If line is blank, insert only newline into output:
if {[string trim $whatline] eq ""} {
append formatext "\n"
continue
}
# If not, then find out where line is wrapped:
for {set c 1} {$c <= $endochar} {incr c} {
.tx see $i.$c
set ceemin [expr {$c-1}]
set boxie [.tx get $i.$ceemin]
# Get y coordinates of bounding boxes for adjoining characters:
set pixy [lindex [.tx bbox $i.$ceemin] 1]
set nexy [lindex [.tx bbox $i.$c] 1]
# If y coordinate of bounding box is greater than for
# preceding character, line has been wrapped, so
# insert preceding character plus newline into output:
if {$nexy > $pixy} {
append formatext $boxie\n
.tx see $i.$c
} else {
# Otherwise, insert only the preceding character:
append formatext $boxie
}
}
# Replicate existing newline from text widget:
if {$i < $texend} {
append formatext "\n"
}
}
if {$whattodo eq "print"} {
return $formatext
} else {
.tx delete $selon $seloff
.tx insert $selon $formatext
.tx edit separator
after 100 wmtitle
}
}
.filemenu.display add command -label "Omit Needless Newlines" -underline 5 \
-command newlino
### Procedures to omit needless newlines:
proc newlino {} {
global reunito parsep
clearout
if {[winfo exists .need]} {
grid .need
} else {
frame .need
radiobutton .need.unite -text "Reunite broken words" \
-variable reunito -value 1
radiobutton .need.replace -text "No broken words" \
-variable reunito -value 0
checkbutton .need.par -text "Keep paragraphs separate" \
-variable parsep
button .need.ok -text "Eject needless newlines" -command {
omitneedless only
clearin .need
}
button .need.close -text "Close" -pady 0 -border 1 \
-command {
clearin .need
}
pack .need.unite .need.replace .need.par .need.ok \
.need.close -in .need -side left -expand 1 -fill both
grid .need -row 1 -column 0 -columnspan 2 -sticky news
}
foreach reg [list .need.unite .need.replace .need.par] {
$reg configure -selectcolor $::regradio -takefocus 0
}
foreach butt [list .need.ok .need.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
focus .need
}
proc omitneedless {andwhat} {
global reunito parsep
if {[.tx tag ranges sel] eq ""} {
set selon 1.0
set seloff [.tx index end]
set selmore 0
} else {
set selon [.tx index sel.first]
set seloff [.tx index sel.last]
set selmore 1
}
set texin [expr int($selon)]
set texend [expr int($seloff)]
set texauld [.tx get $selon $seloff]
switch "$reunito $parsep" {
"1 1" {
set texnoo [string map "{\n\n} {\n\n} {\n\t} {\n\t} {\n} {}"\
$texauld]
}
"1 0" {
set texnoo [string map "{\n} {}" $texauld]
}
"0 1" {
set texnoo [string map "{\n\n} {\n\n} {\n\t} {\n\t}\
{ \n} { } {\n} { }" $texauld]
}
"0 0" {
set texnoo [string map "{ \n} { } {\n} { }" $texauld]
}
}
.tx delete $selon $seloff
.tx insert $selon $texnoo
if {$selmore == 1 && $andwhat eq "plus"} {
.tx tag add sel $selon [.tx index insert]
}
.tx edit separator
after 100 wmtitle
}
.filemenu.display add separator
### Display -- HTML in Browser
.filemenu.display add command -label "HTML in Browser" -underline 0 \
-command {browsier $currentfile}
proc browsier {fil} {
global env currentfile
if {$fil eq ""} {
tk_messageBox -message "Please save HTML file before trying\
to display it in a browser" -type ok
return
}
if {$env(BROWSER) ne ""} {
if {[catch {eval exec $env(BROWSER) $currentfile &} outage]} {
tk_messageBox -message $outage -type ok
}
} else {
browbox
}
}
### Display -- Change Browser
.filemenu.display add command -label "Change Browser" -underline 7 \
-command browbox
proc browbox {} {
global env
clearout
if {[winfo exists .brow]} {
grid .brow
.brow.ent delete 0 end
.brow.ent insert 0 $env(BROWSER)
.brow.ent selection range 0 end
focus .brow.ent
} else {
frame .brow
label .brow.blab -bg $::headback -fg $::headfore \
-text "Please designate a browser: "
entry .brow.ent -bg $::entback -fg $::entfore
.brow.ent insert 0 $env(BROWSER)
.brow.ent selection range 0 end
button .brow.ok -bg $::buttback -fg $::buttfore -text "OK" -command {
set env(BROWSER) [.brow.ent get]
clearin .brow
}
button .brow.close -bg $::buttback -fg $::buttfore -text "Close" \
-command {clearin .brow}
pack .brow.blab .brow.ent .brow.ok .brow.close -in .brow \
-side left -expand 1 -fill both
grid .brow -row 1 -column 0 -columnspan 2 -sticky news
focus .brow.ent
}
}
.filemenu.display add separator
### Display -- Colors
.filemenu.display add command -label "Colors" -underline 0 -command colodisp
# List of widgets (to add to lists originally set
# by WISH Color Picker Plus):
# Regular buttons:
foreach butt [list .rece.find .rece.open .rece.all .rece.whole \
.rece.unlist .rece.close .prin.ok .prin.close .forma.chug .forma.ok \
.forma.close .need.ok .need.close .fin.clo .find.next .findex.new \
.findex.close .place.yesdo .place.nodont .place.all .place.new \
.place.close .mult.more .mult.replall .mult.close .line.ok \
.line.recount .line.close .head.insert .head.close .font.select \
.font.insertcolor .font.insertsize .font.insertboth .font.close \
.anchor.insert .anchor.close .butt.www .butt.email .butt.ftp \
.butt.anchor .butt.other .butt.insert .butt.close .image.pick \
.image.insert .image.close .html.insert .html.done .table.withdata \
.table.close .table.colorsel .table.colordesel .data.line \
.data.par .data.ital .data.bold .data.undo .data.redo .data.special \
.data.enter .data.newrow .data.done .data.close .data.rowcolorsel \
.data.rowcolordesel .data.cellcolorsel .data.cellcolordesel \
.see.ins .see.close .fontshow.ok .fontshow.close] {
lappend buttlist $butt
}
# Mini-toolbar buttons:
foreach mini $miniline {
lappend minilist $mini
}
# Listboxes:
foreach lub [list .rece.list .fontshow.list] {
lappend lublist $lub
}
# Text widgets:
foreach tex [list .tx .see.whole .data.cont] {
lappend texlist $tex
}
# Entry widgets and spinboxes:
foreach ent [list .rece.ent .rece.spin .prin.spin .forma.disphi \
.forma.dispwid .forma.formawid .find.enter .rep.enter .with.leave \
.line.number .head.enter .head.spin .font.spin .font.colornum \
.anchor.enter .url.linkent .show.name .image.url .image.altinhere \
.image.horizhere .image.vertinhere .image.heightinhere .image.widthinhere \
.image.bordohere .html.itemhere .table.suminhere .table.horizhere \
.table.vertinhere .table.heightinhere .table.widthinhere .table.bordohere \
.table.padhere .table.spacehere .data.colspannum .data.rowspannum \
.fontshow.spin] {
lappend entlist $ent
}
# Emphasized labels:
foreach head [list] {
lappend headlist $head
}
# Light labels:
foreach light [list .rece.found .line.count .image.optinfo .table.optinfo \
.data.cellcont .data.optinfo .fontshow.lab] {
lappend lightlist $light
}
# Radiobuttons and checkbuttons:
foreach reg [list .rece.new .need.unite .need.replace .need.par \
.findex.exp .findex.match .findex.up .findex.down .place.exp \
.place.up .place.down .place.match .mult.expert .mult.match \
.image.rel .image.abso .list.123 .list.capa .list.abc .list.capi \
.list.iii .list.disc .list.circle .list.square] {
lappend regradiolist $reg
}
# Spinbox buttons:
foreach spin [list .rece.spin .prin.spin .head.spin .font.spin \
.image.horizhere .image.vertinhere .image.heightinhere \
.image.widthinhere .image.bordohere .table.horizhere \
.table.vertinhere .table.heightinhere .table.widthinhere \
.table.bordohere .table.padhere .table.spacehere \
.data.colspannum .data.rowspannum .fontshow.spin .forma.disphi \
.forma.dispwid .forma.formawid] {
lappend spinlist $spin
}
# Procedure to set up GUI box for configuring color display:
proc colodisp {} {
global color red green blue whatfig whatbutt colorlist \
winback winfore selback selfore buttback buttfore miniback minifore \
listback listfore textback textfore inacback linktex entback \
entfore headback headfore lightback lightfore regradio
wishcolorplus ; # This does all the work--from WISH Color Picker Plus
wm title .colo "WISH Supernotepad : WISH Color Picker Plus"
}
### Display -- Font
.filemenu.display add command -label "Font" -underline 0 -command fontshow
# List available fonts:
set fontlist [lsort -dictionary [font families]]
# Procedure to make font selection box:
proc fontshow {} {
global fontlist fontgrip fonto siz fontaine
toplevel .fontshow
wm title .fontshow "WISH Supernotepad: Choose Font"
set fontgrip $fonto
grid [listbox .fontshow.list -bg $::listback -fg $::listfore -height 12 \
-width 52 -selectmode single -listvariable fontlist] \
-row 0 -column 0 -sticky news
grid [scrollbar .fontshow.roll -width 12 -command ".fontshow.list yview"] \
-row 0 -column 1 -rowspan 2 -sticky news
.fontshow.list configure -yscrollcommand ".fontshow.roll set"
set siz 14
bind .fontshow.list <Button-1> {
after 10 {
set fontgrip [.fontshow.list get [.fontshow.list curselection]]
set fontaine [list $fontgrip $siz]
.fontshow.lab configure -text "$fontgrip" -font "$fontaine"
}
}
bind .fontshow.list <Double-Button-1> fontok
bind .fontshow.list <Button-3> {
set clixel %y
set clickline [.fontshow.list nearest $clixel]
.fontshow.list selection set $clickline
set fontgrip [.fontshow.list get [.fontshow.list curselection]]
set fontaine [list $fontgrip $siz]
.fontshow.lab configure -text "$fontgrip" -font "$fontaine"
fontok
}
frame .fontshow.butts
label .fontshow.lab -bg $::lightback -fg $::lightfore \
-text "$fonto" -font "$fontaine"
spinbox .fontshow.spin -textvariable siz -width 2 -from 8 -to 48 \
-buttonbackground $::buttback \
-bg $::entback -fg $::entfore -command {
set fontaine [list $fontgrip $siz]
.fontshow.lab configure -font "$fontaine"
}
button .fontshow.ok -text "OK" -bg $::buttback -fg $::buttfore \
-relief groove -border 3 -command fontok
button .fontshow.close -text "Close" -bg $::buttback -fg $::buttfore \
-command {destroy .fontshow}
pack .fontshow.lab .fontshow.spin .fontshow.ok .fontshow.close \
-in .fontshow.butts -side left -expand 1 -fill both
grid .fontshow.butts -row 1 -column 0 -sticky news
bind .fontshow <Key-Return> fontok
focus .fontshow.spin
}
# Procedure to apply and save new default font:
proc fontok {} {
global t fontgrip fonto siz fontaine linkup
set fonto $fontgrip
set fontaine [list $fonto $siz]
.tx configure -font "$fontaine"
$t tag configure bold -font "[list $::fonto $::siz bold]"
$t tag configure ital -font "[list $::fonto $::siz italic]"
$t tag configure bi -font "[list $::fonto $::siz bold italic]"
$t tag configure cent -justify center
$t tag configure boldcent -font "[list $::fonto $::siz bold]" \
-justify center
$t tag configure italcent -font "[list $::fonto $::siz italic]" \
-justify center
$t tag configure bicent -font "[list $::fonto $::siz bold italic]" \
-justify center
savefig
destroy .fontshow
}
.filemenu.display add separator
### Display -- Link-Text
.filemenu.display add checkbutton -label "Link-Text" -underline 0 \
-variable lincoln -accelerator Ctrl+Alt+l -command linkuporno
bind .tx <Control-Alt-l> {
if {$lincoln} {
set lincoln 0
unlink .tx
} else {
set lincoln 1
linktext .tx
}
}
# Procedure to put Link-Text tags in or take them out:
proc linkuporno {} {
global lincoln
if {$lincoln} {
linktext .tx
} else {
unlink .tx
}
}
# Procedure to find markup tags with Tk 8.4, which doesn't have
# the "-all" flag for text-widget searches as Tk 8.5 does:
proc findtags {what lister counter} {
set ::present_place $::place
catch {set ::place [.tx search -regexp \
-count countum "$what" "$::present_place +1c" end]}
if {$::place ne ""} {
lappend $lister $::place
lappend $counter $countum
findtags $what
} else {
return [list [set $lister] [set $counter]]
}
}
# Procedure to make clickable links, hide markup tags,
# and show text as bold, italic, and/or centered:
proc linktext {t} {
global linklist linkex linkhead
# Configure tag to hide things:
$t tag configure hide -elide 1
# Find end of opening "link section" of file,
# beginnings and ends of all links, and
# beginnings of bold, italic, and/or center tags:
set linkhead [$t search "<end linkhead>" 1.0 end]
if {$linkhead ne ""} {
$t tag add hide $linkhead "$linkhead +14c"
}
if {$::tko > 8.4} {
# First find angle quotes (?) used to disguise angle brackets
# that are *not* to be interpreted as designating tags,
# and whip up a quick disguise:
set angstars [$t search -all "?" 1.0 end]
set angends [$t search -all ">? 1.0 end]
$t tag configure ang -elide 1
foreach star $angstars {
$t tag add hide $star
$t tag add ang "$star +1c"
}
foreach end $angends {
$t tag add ang $end
$t tag add hide "$end +1c"
}
# Find link beginnings and ends:
set linkstars [$t search -regexp -all \
-count clink "<link .+?>" 1.0 end]
set linkends [$t search -all "</link>" 1.0 end]
# Find tag beginnings and ends:
set tagstars [$t search -regexp -all -count ctag {
<bi?c?>|<bc?i?>|<ib?c?>|<ic?b?>|<cb?i?>|<ci?b?>|<center>
} 1.0 end]
# Now reveal the non-tag-designating angle brackets:
$t tag configure ang -elide 0
} else {
# Delete this clunky code if you don't need Tk 8.4 any more
set ::place 1.0
set ::angline [list]
set starlog [findtags "?<" ::angline]
set angstars [lindex $starlog 0]
set :: place 1.0
set ::angline [list]
set endlog [findtags "\>? ::angline]
set angends [lindex $endlog 0]
$t tag configure ang -elide 1
foreach star $angstars {
$t tag add hide $star
$t tag add ang "$star +1c"
}
foreach end $angends {
$t tag add ang $end
$t tag add hide "$end +1c"
}
set ::place 1.0
set ::linkline [list]
set ::countline [list]
set starlog [findtags "<link .+?>" ::linkline ::countline]
set linkstars [lindex $starlog 0]
set cti [lindex $starlog end]
set ::place 1.0
set ::linkline [list]
set ::countline [list]
set endlog [findtags "</link>" ::linkline ::countline]
set linkends [lindex $endlog 0]
set ::place 1.0
set ::taglist [list]
set ::tagcount [list]
set startag [findtags {
<bi?c?>|<bc?i?>|<ib?c?>|<ic?b?>|<cb?i?>|<ci?b?>|<center>
} ::taglist ::tagcount]
set tagstars [lindex $startag 0]
set ctag [lindex $startag end]
$t tag configure ang -elide 0
unset ::linkline ::countlist ::boldlist ::bountlist ::angline
}
# Embolden, italicize, and/or center:
$t tag configure bold -font "[list $::fonto $::siz bold]"
$t tag configure ital -font "[list $::fonto $::siz italic]"
$t tag configure bi -font "[list $::fonto $::siz bold italic]"
$t tag configure cent -justify center
$t tag configure boldcent -font "[list $::fonto $::siz bold]" \
-justify center
$t tag configure italcent -font "[list $::fonto $::siz italic]" \
-justify center
$t tag configure bicent -font "[list $::fonto $::siz bold italic]" \
-justify center
for {set b 0} {$b < [llength $tagstars]} {incr b} {
set bar [lindex $tagstars $b] ; # Begin starting tag
set barsplit [split $bar "."]
set barline [lindex $barsplit 0] ; # Line number in text
set barchar [lindex $barsplit end] ; # Position in line
set tagoff [$t search ">" $bar end]
$t tag add hide $bar "$tagoff +1c"
set whattag [$t get "$bar +1c" $tagoff]
switch $whattag {
b {
set tagend [$t search "</b>" $tagoff end]
$t tag add hide $tagend "$tagend +4c"
$t tag add bold $tagoff $tagend
}
i {
set tagend [$t search "</i>" $tagoff end]
$t tag add hide $tagend "$tagend +4c"
$t tag add ital $tagoff $tagend
}
c {
set tagend [$t search "</c>" $tagoff end]
$t tag add hide $tagend "$tagend +4c"
$t tag add cent $tagoff $tagend
}
center {
set tagend [$t search "</center>" $tagoff end]
$t tag add hide $tagend "$tagend +9c"
$t tag add cent $tagoff $tagend
}
bi -
ib {
set tagend [$t search -regexp {</bi>|</ib>} $tagoff end]
$t tag add hide $tagend "$tagend +5c"
$t tag add bi $tagoff $tagend
}
bc -
cb {
set tagend [$t search -regexp {</bc>|</cb>} $tagoff end]
$t tag add hide $tagend "$tagend +5c"
$t tag add boldcent $tagoff $tagend
}
ic -
ci {
set tagend [$t search -regexp {</ic>|</ci>} $tagoff end]
$t tag add hide $tagend "$tagend +5c"
$t tag add italcent $tagoff $tagend
}
bic -
ibc -
bci -
cbi -
icb -
cib {
set tagend [$t search -regexp {
</bic>|</ibc>|</bci>|</cbi>|</icb>|</cib>
} $tagoff end]
$t tag add hide $tagend "$tagend +6c"
$t tag add bicent $tagoff $tagend
}
}
}
# Fix the links up to work:
$t configure -cursor top_left_arrow
for {set i 0} {$i < [llength $linkstars]} {incr i} {
set star [lindex $linkstars $i] ; # Begin link-start tag
set starleng [lindex $clink $i] ; # Length of link-start tag
set starsplit [split $star "."]
set starline [lindex $starsplit 0] ; # Line number in text
set starchar [lindex $starsplit end] ; # Position in line
# End of link-start tag:
set starend $starline.[expr {$starchar + $starleng}]
# Content of link-start tag:
set linkstar [$t get $star $starend]
set linkname [string trim $linkstar "<>"] ; # Link name
$t tag add hide $star $starend
# Add tag for clickable link between link-start and link-end tags:
set finis [lindex $linkends $i]
$t tag add $linkname $starend $finis
lappend linklist "$linkname"
# And one to hide the link-end tag:
$t tag add hide $finis "$finis +7c"
# Get clickable tag to look right and do things:
$t tag configure $linkname -foreground blue -underline 1
$t tag bind $linkname <ButtonRelease-1> "linkfind $t"
}
}
# Procedure to search for link name in text:
proc linkfind {t} {
global linkhead
# See where clicked link is:
set clickpos [$t index insert]
# Verify that it's really a link:
set tagnames [$t tag names $clickpos]
set tagplace [lsearch $tagnames "link *"]
if {$tagplace > -1} {
# If so, strip off everything but its name:
set tagname [lindex $tagnames $tagplace]
set searchname [string map "{link } {} {\"} {}" $tagname]
# And find where the name appears in the text:
if {$linkhead ne ""} {
set target [$t search "$searchname" $linkhead end]
} else {
set tagend [lindex [$t tag range "$tagname"] end]
set target [$t search "$searchname" $tagend end]
if {$target eq ""} {
set target [$t search -backwards "$searchname" $tagend end]
}
}
if {$target ne ""} {
$t see $target
} else {
tk_messageBox -message "Link \"$searchname\" not found" -type ok
}
}
}
# Procedure to undo Link-Text display:
proc unlink {t} {
global linklist
$t tag delete bold ital bi cent boldcent italcent bicent hide ang
foreach link $linklist {
$t tag delete "$link"
}
$t configure -cursor xterm
}
.filemenu.display add separator
### Display -- Word Wrap
.filemenu.display add checkbutton -variable wordwrap \
-label "Word wrap" -onvalue word -offvalue none \
-underline 0 -selectcolor blue -command wraponoroff
proc wraponoroff {} {
global wordwrap
if {$wordwrap eq "none"} {
.tx configure -wrap none
} else {
.tx configure -wrap word
}
}
### HELP MENU ###
menu .filemenu.help -tearoff 0
.filemenu add cascade -label "Help" -underline 0 -menu .filemenu.help
set helpfile [file join $docdir superhelp_link.txt] ; # User Help Guide
set licfile [file join $docdir mule_license.txt] ; # License
### Help -- About WISH Supernotepad
.filemenu.help add command -label "About WISH Supernotepad" \
-underline 0 -command {
tk_messageBox -message "WISH Supernotepad $version\n\
by David McClamrock\n <mcclamrock@locl.net>\n\n\
Based on Tk NotePad 0.5.0\n by Joseph Acosta\n\
and \"textedit.tcl\"\n by Eric Foster-Johnson\n"\
-title "About WISH Supernotepad" -type ok
}
.filemenu.help add separator
### Help -- User Help
.filemenu.help add command -label "User Help" -underline 0 -command superhelp
# Procedure for setting up user help display
proc superhelp {} {
global fonto siz
set oldfonto $fonto
set oldsiz $siz
uhelp ; # Set up user help window
wm title .uhelp "WISH Supernotepad - User Help"
# set helplink [open $::helpfile r]
set helplink [open /home/david/9.com/wish/suite/superhelp_link.txt r]
set helpcontents [read $helplink]
close $helplink
.uhelp.tx insert 1.0 $helpcontents
linktext .uhelp.tx ; # Show links in text
set fonto $oldfonto
set siz $oldsiz
.uhelp.tx see 1.0
}
# Procedure for making user help window
# (Color variables come from WISH Color Picker Plus)
proc uhelp {} {
global helpfont helpsiz fonto siz
set fonto $helpfont
set siz $helpsiz
toplevel .uhelp
wm title .uhelp "WISH User Help"
frame .uhelp.fr0
button .uhelp.find -text "Find (F2)" -bg $::buttback -fg $::buttfore \
-command findhelp
entry .uhelp.lookup -width 40 -bg $::entback -fg $::entfore
pack .uhelp.find .uhelp.lookup -in .uhelp.fr0 \
-side left -expand 1 -fill both
grid .uhelp.fr0 -sticky news
frame .uhelp.fr1
text .uhelp.tx -width 65 -height 25 -bg $::textback -fg $::textfore \
-font "[list $helpfont $helpsiz]" -wrap word -cursor top_left_arrow
scrollbar .uhelp.scrolly -width 12 -command ".uhelp.tx yview"
.uhelp.tx configure -yscrollcommand ".uhelp.scrolly set"
.uhelp.tx tag configure bold -font "[list $helpfont $helpsiz bold]"
.uhelp.tx tag configure ital -font "[list $helpfont $helpsiz italic]"
.uhelp.tx tag configure bi -font "[list $helpfont $helpsiz bold italic]"
.uhelp.tx tag configure boldcent -font "[list $helpfont $helpsiz bold]" \
-justify center
.uhelp.tx tag configure italcent -font "[list $helpfont $helpsiz italic]" \
-justify center
.uhelp.tx tag configure bicent -font "[list $helpfont $helpsiz\
bold italic]" -justify center
pack .uhelp.tx .uhelp.scrolly -in .uhelp.fr1 \
-side left -expand 1 -fill both
grid .uhelp.fr1 -sticky news
frame .uhelp.fr2
button .uhelp.big -text "Bigger" -command {fontsize big}
button .uhelp.small -text "Smaller" -command {fontsize small}
button .uhelp.close -text "Close" -command {destroy .uhelp}
foreach butt [list .uhelp.big .uhelp.small .uhelp.close] {
$butt configure -bg $::buttback -fg $::buttfore
}
pack .uhelp.big .uhelp.small .uhelp.close -in .uhelp.fr2 \
-side left -expand 1 -fill both
grid .uhelp.fr2 -sticky news
bind .uhelp <F2> findhelp
focus .uhelp.lookup
}
# Procedure for changing font size in user help display:
proc fontsize {how} {
global helpfont helpsiz
set sizzes [list 10 12 14 18 24]
set siznow [lsearch $sizzes $helpsiz]
if {$how eq "big" && $siznow < 4} {
set helpsiz [lindex $sizzes [expr {$siznow+1}]]
}
if {$how eq "small" && $siznow > 0} {
set helpsiz [lindex $sizzes [expr {$siznow-1}]]
}
if {$helpsiz == 10} {
.uhelp.small configure -state disabled
} else {
.uhelp.small configure -state normal
}
if {$helpsiz == 24} {
.uhelp.big configure -state disabled
} else {
.uhelp.big configure -state normal
}
.uhelp.tx configure -font "[list $helpfont $helpsiz]"
.uhelp.tx tag configure bold -font "[list $helpfont $helpsiz bold]"
.uhelp.tx tag configure ital -font "[list $helpfont $helpsiz italic]"
.uhelp.tx tag configure bi -font "[list $helpfont $helpsiz bold italic]"
.uhelp.tx tag configure boldcent -font "[list $helpfont $helpsiz bold]" \
-justify center
.uhelp.tx tag configure italcent -font "[list $helpfont $helpsiz italic]" \
-justify center
.uhelp.tx tag configure bicent -font "[list $helpfont $helpsiz\
bold italic]" -justify center
}
# Procedure for searching for user help text
proc findhelp {} {
set startout [.uhelp.tx index insert]
set wherenow $startout
set look_for [.uhelp.lookup get]
set stringlength [string length $look_for]
set foundit [.uhelp.tx search -nocase -forward $look_for \
$wherenow end]
if {$foundit == ""} {
set wherenow $startout
tk_messageBox -message "Not Found" \
-title "Not Found" -type ok
} else {
catch {.uhelp.tx tag remove sel sel.first sel.last}
.uhelp.tx tag add sel $foundit "$foundit + $stringlength chars"
.uhelp.tx mark set insert "$foundit + $stringlength chars"
.uhelp.tx see insert
focus .uhelp.tx
}
}
### GET GOING ###
# At last, make the menu visible:
. configure -menu .filemenu
# Open file from the command line, if you wish:
if {[info exists argv]} {
if {[file readable [lindex $argv 0]]} {
set newfile [lindex $argv 0]
inwithnew
.tx mark set insert 1.0
set currentfile $newfile
saverece
.tx edit separator
wmtitle
}
}
