$pagename
\n\n" 108 | append out $text 109 | append out "\n\n" 110 | 111 | return $out 112 | } 113 | 114 | # htmltext markup 115 | # 116 | # markup Notebook markup to translate 117 | 118 | method htmltext {markup} { 119 | # Set up for processing. 120 | set result "" 121 | set this(indent) 0 122 | set this(para) : 123 | set this(inpara) 0 124 | set last(indent) 0 125 | set last(para) : 126 | 127 | foreach {tag value} [::markupparser::parse $markup] { 128 | switch -exact $tag { 129 | META { } 130 | BR { 131 | append result 132 | } 133 | PRE { 134 | # Otherwise, just display the preformatted text. 135 | append result "[AddEscapes $value]\n" 136 | } 137 | TCL { 138 | # Tcl code is always displayed as preformatted text... 139 | # for now. It would be fun to do code coloring, etc. 140 | append result "
[AddEscapes $value]\n" 141 | } 142 | DATA { 143 | array set fields $value 144 | 145 | # "html" data is passed through unchanged; other data is 146 | # shown as PRE. 147 | if {$fields(type) eq "html"} { 148 | append result $fields(data) 149 | } else { 150 | append result "
[AddEscapes $fields(data)]\n" 151 | } 152 | } 153 | HASH { 154 | if {[string match \#pre* $value] || 155 | [string match \#unpre* $value] || 156 | [string match \#Tcl* $value] || 157 | [string match \#unTcl* $value] || 158 | [string match \#data* $value] || 159 | [string match \#undata* $value] || 160 | [string match \#meta* $value] || 161 | [string match \#rem* $value] 162 | } { 163 | if {$options(-showhashes) eq "all"} { 164 | append result "
[AddEscapes $value]\n" 165 | } 166 | continue 167 | } 168 | 169 | if {[string match \#---* $value]} { 170 | # If last indent was > 0, close the indentation. 171 | set this(indent) 0 172 | for {set i 0} {$i < $last(indent)} {incr i} { 173 | append result "\n\n" 174 | } 175 | array set last [array get this] 176 | 177 | if {$options(-showhashes) eq "all"} { 178 | append result "
[AddEscapes $value]\n" 179 | } 180 | append result "
\n" 181 | continue 182 | } 183 | 184 | # Otherwise, it's an unknown hash; display as PRE. 185 | if {$options(-showhashes) eq "unknown"} { 186 | append result "
[AddEscapes $value]\n" 187 | } 188 | } 189 | H { 190 | # Next, if we're indented, close the indentation. 191 | set this(indent) 0 192 | for {set i 0} {$i < $last(indent)} {incr i} { 193 | append result "\n\n" 194 | } 195 | array set last [array get this] 196 | 197 | set lev [lindex $value 0] 198 | set htext [lindex $value 1] 199 | 200 | # Increment level: we want
, and
201 | # tags.
202 | incr lev
203 |
204 | append result "[AddEscapes $htext] \n"
205 | }
206 | /P {
207 | set this(inpara) 0
208 | foreach letter [array names sty] {
209 | if {$sty($letter)} {
210 | append result $htmlStyles(${letter}0)
211 | }
212 | }
213 | array set last [array get this]
214 |
215 | if {$this(indent) == 0} {
216 | # Then this is the end of a normal paragraph, which
217 | # needs to be closed.
218 | append result ""
219 | }
220 | }
221 | P {
222 | set this(inpara) 1
223 |
224 | # FIRST, reset all text styles.
225 | array set sty {
226 | m 0 i 0 b 0
227 | h 0 s 0 x 0
228 | }
229 |
230 | # Next, get the paragraph style.
231 | set this(para) [lindex $value 0]
232 | set this(indent) [lindex $value 1]
233 |
234 | # Next, if we're indented less than before, close
235 | # the indentation.
236 | for {set i $this(indent)} {$i < $last(indent)} {incr i} {
237 | append result "\n\n"
238 | }
239 |
240 | # Next, if we're indented more than before, open
241 | # the indentation.
242 | for {set i $last(indent)} {$i < $this(indent)} {incr i} {
243 | append result "\n\n"
244 | }
245 |
246 | # Next, if the indentation is 0, start a new
247 | # paragraph; otherwise start a list item.
248 | if {$this(indent) == 0} {
249 | append result ""
250 | } elseif {$this(para) eq "*"} {
251 | append result "
- "
252 | } elseif {$last(para) eq "*" &&
253 | $this(para) eq ":"} {
254 | append result "
\n"
255 | }
256 | }
257 | TXT {
258 | # Handle Notebook markup pseudo-escapes.
259 | set value [string map [list "&lb;" \[ "&rb;" \]] $value]
260 |
261 | append result $value
262 | }
263 | HTML {
264 | append result $value
265 | }
266 | NL {
267 | append result "\n"
268 | }
269 | STY {
270 | set code [lindex $value 0]
271 | set letter [string index $code 0]
272 | set flag [string index $code 1]
273 |
274 | set sty($letter) $flag
275 | append result $htmlStyles($code)
276 | }
277 | LINK {
278 | set value [::markupparser::normalizeSpace $value]
279 |
280 | if {![regexp {^([^|]+)\|(.*$)} $value dummy linktext name]} {
281 | set linktext $value
282 | set name $value
283 | }
284 |
285 | if {$options(-linkcmd) eq ""} {
286 | append result [AddEscapes $linktext]
287 | continue
288 | }
289 |
290 | set cmd $options(-linkcmd)
291 | lappend cmd $linktext $name
292 |
293 | append result [uplevel \#0 $cmd]
294 | }
295 | BTN {
296 | # Extract just the button text.
297 | set value [lindex [split $value |] 0]
298 |
299 | append result $value
300 | }
301 | OBJECT {
302 | set obj [getobj $value]
303 |
304 | switch -exact [lindex $obj 0] {
305 | image {
306 | set fname [lindex $obj 1]
307 | array set opts [lindex $obj 2]
308 |
309 | append result "![\"$opts(-text)\""](\"$fname\"")
"
321 | }
322 | error -
323 | default {
324 | append result [ErrText "
\[!$value!\]
"]
325 | }
326 | }
327 | }
328 | MACRO {
329 | # There shouldn't be any macros. Format the macro
330 | # in red.
331 | append result [ErrText "\[@$value@\]"]
332 | }
333 | }
334 | }
335 |
336 | # If last indent was > 0, close the indentation.
337 | for {set i 0} {$i < $last(indent)} {incr i} {
338 | append result "\n\n"
339 | }
340 |
341 | if {$this(inpara)} {
342 | foreach letter [array names sty] {
343 | if {$sty($letter)} {
344 | append result $htmlStyles(${letter}0)
345 | }
346 | }
347 |
348 | if {$this(indent) == 0} {
349 | # Then this is the end of a normal paragraph, which
350 | # needs to be closed.
351 | append result ""
352 | }
353 | }
354 |
355 | return $result
356 | }
357 |
358 | #-------------------------------------------------------------------
359 | # Utility Procs
360 |
361 | # ErrText text
362 | #
363 | # Wraps the text in a red font.
364 |
365 | proc ErrText {text} {
366 | return "$text"
367 | }
368 |
369 | # AddEscapes text
370 | #
371 | # text plain text to be included in HTML output.
372 | #
373 | # Converts &, <, and > to &, <, and >.
374 |
375 | proc AddEscapes {text} {
376 | regsub -all "&" $text {\&} text
377 | regsub -all "<" $text {\<} text
378 | regsub -all ">" $text {\>} text
379 |
380 | return $text
381 | }
382 | }
383 |
384 |
385 |
386 |
387 |
--------------------------------------------------------------------------------
/lib/app_notebook/nb2mediawiki.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # nb2mediawiki.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # MediaWiki markup exportation code for Notebook files. This module
10 | # knows very little about the Notebook application as a whole;
11 | # such intelligence will be provided by hooks.
12 | #
13 | # LICENSE:
14 | # Copyright (C) 2005 by William H. Duquette. This file may
15 | # be used subject to the terms in license.txt.
16 | #
17 | #-----------------------------------------------------------------------
18 |
19 | #-----------------------------------------------------------------------
20 | # Required Packages
21 |
22 | package require markupparser
23 |
24 | #-----------------------------------------------------------------------
25 | # namespace declaration
26 |
27 | namespace eval ::nb2mediawiki:: {
28 | variable wikiStyles
29 |
30 | # This table indicates the MediaWiki equivalents for each
31 | # Notebook style code.
32 | array set wikiStyles {
33 | m1
34 | m0
35 | i1 ''
36 | i0 ''
37 | b1 '''
38 | b0 '''
39 | h1 {=== }
40 | h0 { ===}
41 | s1
42 | s0
43 | x1
44 | x0
45 | }
46 | }
47 |
48 |
49 |
50 | #-----------------------------------------------------------------------
51 | # Public functions
52 |
53 |
54 | # wikitext markup args
55 | #
56 | # markup Notebook markup to translate
57 | # args Option/value pairs, as follows:
58 | #
59 | # -embeddedhtml 0|1
60 | # If 1, it's assumed that TXT can contain embedded HTML.
61 | # Otherwise, &, <, and > are quoted.
62 | #
63 | # -showhashes unknown|none|all
64 | # Indicates whether hash directives should be included
65 | # in the output. If "unknown", only unknown directives
66 | # are included. If "none", no directives are included;
67 | # if "all", all directives are included. Included
68 | # directives are rendered as preformatted text.
69 |
70 | proc nb2mediawiki::wikitext {markup args} {
71 | variable wikiStyles
72 |
73 | # Allow the options to be passed as a single argument.
74 | if {[llength $args] == 1} {
75 | set args [lindex $args 0]
76 | }
77 |
78 | # Get default option values
79 | array set opts {
80 | -embeddedhtml 0
81 | -showhashes unknown
82 | }
83 |
84 | # Get the caller's values.
85 | # TBD: check errors better.
86 | array set opts $args
87 |
88 | # Set up for processing.
89 | set result ""
90 | set gotNL 1
91 |
92 | foreach {tag value} [::markupparser::parse $markup] {
93 | switch -exact $tag {
94 | META { }
95 | BR {
96 | append result
97 | }
98 | PRE {
99 | # PRE is used to mark blank lines in the input;
100 | # these should be handled separately.
101 | # TBD: See if this statement can be removed.
102 | if {[regexp {^\s*\n\s*$} $value]} {
103 | append result "\n"
104 | continue
105 | }
106 |
107 | # Otherwise, just display the preformatted text.
108 | append result "[AddEscapes $value]
\n"
109 | }
110 | TCL {
111 | # Tcl code is always displayed as preformatted text...
112 | # for now. It would be fun to do code coloring, etc.
113 | append result "[AddEscapes $value]
\n"
114 | }
115 | DATA {
116 | array set fields $value
117 |
118 | # data is shown as PRE.
119 | append result "[AddEscapes $fields(data)]
\n"
120 | }
121 | HASH {
122 | if {[string match \#pre* $value] ||
123 | [string match \#unpre* $value] ||
124 | [string match \#Tcl* $value] ||
125 | [string match \#unTcl* $value] ||
126 | [string match \#data* $value] ||
127 | [string match \#undata* $value] ||
128 | [string match \#meta* $value] ||
129 | [string match \#rem* $value]
130 | } {
131 | if {$opts(-showhashes) eq "all"} {
132 | append result "[AddEscapes $value]
\n"
133 | }
134 | continue
135 | }
136 |
137 | if {[string match \#---* $value]} {
138 | append result "----\n"
139 | continue
140 | }
141 |
142 | # Otherwise, it's an unknown hash; display as PRE.
143 | if {$opts(-showhashes) eq "unknown"} {
144 | append result "[AddEscapes $value]
\n"
145 | }
146 | }
147 | H {
148 | set lev [lindex $value 0]
149 | set htext [lindex $value 1]
150 |
151 | set tag [string repeat "=" $lev]
152 | append result "$tag $htext $tag\n"
153 | }
154 | /P {
155 | foreach letter [array names sty] {
156 | if {$sty($letter)} {
157 | append result $wikiStyles($letter$sty($letter))
158 | }
159 | }
160 | }
161 | P {
162 | # FIRST, reset all text styles.
163 | array set sty {
164 | m 0 i 0 b 0
165 | h 0 s 0 x 0
166 | }
167 |
168 | # Next, get the paragraph style.
169 | set para [lindex $value 0]
170 | set indent [lindex $value 1]
171 |
172 | if {$para eq ":" && !$gotNL} {
173 | append result "
\n"
174 | } elseif {$para eq "*"} {
175 | append result "\n[string repeat * $indent] "
176 | }
177 |
178 | set gotNL 0
179 | }
180 | TXT {
181 | if {!$opts(-embeddedhtml)} {
182 | set value [AddEscapes $value]
183 | }
184 |
185 | set value [string map [list "\n" " " "&lb;" \[ "&rb;" \]] $value]
186 |
187 | append result $value
188 | }
189 | HTML {
190 | append result $value
191 | }
192 | NL {
193 | set gotNL 1
194 | append result "\n\n"
195 | }
196 | STY {
197 | set code [lindex $value 0]
198 | set letter [string index $code 0]
199 | set flag [string index $code 1]
200 |
201 | set sty($letter) $flag
202 | append result $wikiStyles($code)
203 | }
204 | LINK {
205 | set value [::markupparser::normalizeSpace $value]
206 |
207 | # Note: with "|" notation, MediaWiki's format
208 | # puts the page name first and the displayed
209 | # text second, so we need to swap them.
210 | set list [split $value "|"]
211 |
212 | if {[llength $list] == 2} {
213 | set value "[lindex $list 1]|[lindex $list 2]"
214 | }
215 |
216 | append result "\[\[$value\]\]"
217 | }
218 | BTN {
219 | # Extract just the button text.
220 | set value [lindex [split $value |] 0]
221 |
222 | append result $value
223 | }
224 | OBJECT {
225 | set obj [getobj $value]
226 |
227 | switch -exact [lindex $obj 0] {
228 | image {
229 | set fname [lindex $obj 1]
230 | array set opts [lindex $obj 2]
231 |
232 | append result "\[\[Image:$fname\]\]"
233 | }
234 | error -
235 | default {
236 | append result "\[!$value!\] "
237 | }
238 | }
239 | }
240 | MACRO {
241 | # There shouldn't be any macros.
242 | append result "\[@$value@\] "
243 | }
244 | }
245 | }
246 |
247 | return $result
248 | }
249 |
250 |
251 | #-----------------------------------------------------------------------
252 | # Utility Procs
253 |
254 | # AddEscapes text
255 | #
256 | # text plain text to be included in HTML output.
257 | #
258 | # Converts &, <, and > to &, <, and >.
259 |
260 | proc nb2mediawiki::AddEscapes {text} {
261 | regsub -all "&" $text {\&} text
262 | regsub -all "<" $text {\<} text
263 | regsub -all ">" $text {\>} text
264 |
265 | return $text
266 | }
267 |
268 |
269 |
270 |
--------------------------------------------------------------------------------
/lib/app_notebook/nbobjects.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # nbobjects.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # This module contains the parser for Notebook "objects", e.g.,
10 | # things found in [!...!] markup.
11 | #
12 | # At some point, this might allow some kind of plug-in
13 | # architecture.
14 | #
15 | #-----------------------------------------------------------------------
16 |
17 | # getobj objstring
18 | #
19 | # Parses objstring and returns a list. The first element is the valid
20 | # object type, or "error". The subsequent elements depend on the
21 | # object type.
22 |
23 | proc getobj {objstring} {
24 | # FIRST, it must be a valid list.
25 | if {[catch {lindex $objstring 0} objectType]} {
26 | return [list error "Invalid object: $objstring"]
27 | }
28 |
29 | # NEXT, we only have one kind of object at the moment.
30 | if {$objectType != "image"} {
31 | return [list error "Unrecognized object type: $objstring"]
32 | }
33 |
34 | return [ParseImageObject $objstring]
35 | }
36 |
37 | # ParseImageObject obj
38 | #
39 | # The first token of obj is "image". The second is the path to the
40 | # image file. The remaining elements are options and values.
41 | #
42 | # Returns a list {image path optlist}. The list contains all
43 | # options allowed for images, with values.
44 |
45 | proc ParseImageObject {obj} {
46 | set result [lrange $obj 0 1]
47 |
48 | array set opts {
49 | -width 0
50 | -height 0
51 | -padwidth 0
52 | -text ""
53 | }
54 |
55 | foreach {opt val} [lrange $obj 2 end] {
56 | if {[info exists opts($opt)]} {
57 | if {$opt eq "-text" ||
58 | [regexp {^[0-9]+[cimp]?$} $val]} {
59 | set opts($opt) $val
60 | continue
61 | }
62 | }
63 |
64 | return [list error "Invalid image option: $opt $val"]
65 | }
66 |
67 | lappend result [array get opts]
68 |
69 | return $result
70 | }
71 |
--------------------------------------------------------------------------------
/lib/app_notebook/notebook.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # notebook.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Wiki-like personal notebook
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2005 by William H. Duquette. This file may
13 | # be used subject to the terms in license.txt.
14 |
15 | #-----------------------------------------------------------------------
16 | # Catch Mac OS X open events at startup.
17 | #
18 | # We aren't really ready for open events until the end of this file;
19 | # however, we call "update" when we popup the splash screen, so we
20 | # might well receive some. The following definition of
21 | # ::tk::mac::OpenDocument just saves any file names we receive so
22 | # that they can be opened later. We will redefine OpenDocument
23 | # at the end of the file to open notebooks properly.
24 | #
25 | # If we aren't running under Aqua, then this is irrelevant.
26 |
27 | set osxDocsToOpen {}
28 |
29 | if {[tk windowingsystem] eq "aqua"} {
30 | proc ::tk::mac::OpenDocument {args} {
31 | set ::osxDocsToOpen $args
32 | }
33 | }
34 |
35 | #-----------------------------------------------------------------------
36 | # Copy Encodings
37 |
38 | set appdir [file dirname [info script]]
39 |
40 | set encodingGlob [file join $appdir .. encoding *]
41 | set encodings [encoding names]
42 |
43 | foreach encodingFile [glob -nocomplain $encodingGlob] {
44 | set encoding [file rootname [file tail $encodingFile]]
45 | if {[lsearch -exact $encodings $encoding] == -1} {
46 | file copy -force $encodingFile [file join $tcl_library encoding]
47 | }
48 | }
49 |
50 | #-----------------------------------------------------------------------
51 | # Version
52 |
53 | # FIXME
54 | set notebookVersion "V2.2.0"
55 |
56 | #-----------------------------------------------------------------------
57 | # Allow notebook to execute scripts.
58 |
59 | if {"-script" == [lindex $argv 0]} {
60 | set script [lindex $argv 1]
61 | set argv [lreplace $argv 0 1]
62 | source [lindex $script]
63 | exit
64 | }
65 |
66 | #-------------------------------------------------------------------------
67 | # Do the splash screen
68 |
69 | # Withdraw the main window; we might not need it at all. We'll pop it
70 | # back up if we do.
71 | wm withdraw .
72 |
73 | toplevel .splash -background white
74 | wm title .splash "Notebook $notebookVersion"
75 |
76 | image create photo splash.gif \
77 | -file [file join [file dirname [info script]] splash.gif]
78 |
79 | pack [label .splash.image \
80 | -foreground black \
81 | -background white \
82 | -justify center \
83 | -image splash.gif]
84 |
85 | set sw [winfo screenwidth .splash]
86 | set sh [winfo screenheight .splash]
87 | set rw [winfo reqwidth .splash]
88 | set rh [winfo reqheight .splash]
89 |
90 | set x [expr ($sw - $rw)/2]
91 | set y [expr ($sh - $rh)/2]
92 |
93 | wm geometry .splash +$x+$y
94 |
95 | update
96 |
97 | #-----------------------------------------------------------------------
98 | # Utility functions
99 |
100 | # Display a message. This should only be used for debugging.
101 | proc msg {messageText {icon "error"}} {
102 | tk_messageBox -icon $icon -parent . \
103 | -title "Notebook Message" \
104 | -message $messageText \
105 | -type ok
106 | }
107 |
108 | # Return the current version
109 | proc version {} {
110 | global notebookVersion
111 |
112 | return $notebookVersion
113 | }
114 |
115 | #-----------------------------------------------------------------------
116 | # Other required packages
117 |
118 | set appdir [file dirname [info script]]
119 |
120 | package require gui 1.0
121 | namespace import ::gui::*
122 |
123 | package require markupparser
124 | package require notebookdb
125 |
126 | # Source in the application files
127 |
128 | source [file join $appdir nb2html.tcl]
129 | source [file join $appdir nb2mediawiki.tcl]
130 | source [file join $appdir userprefs.tcl]
131 | source [file join $appdir renderpane.tcl]
132 | source [file join $appdir nbobjects.tcl]
133 | source [file join $appdir pageeditor.tcl]
134 | source [file join $appdir prefs_dialog.tcl]
135 |
136 | namespace import ::app_notebook::prefs
137 |
138 | source [file join $appdir nbactionmanager.tcl]
139 | source [file join $appdir dbmanager.tcl]
140 | source [file join $appdir messagelog.tcl]
141 | source [file join $appdir welcomer.tcl]
142 | source [file join $appdir pageviewer.tcl]
143 | source [file join $appdir helpbrowser.tcl]
144 | namespace import ::app_notebook::HelpBrowser::*
145 |
146 | source [file join $appdir notebookbrowser.tcl]
147 |
148 | # Create images
149 | image create photo ::app_notebook::missing \
150 | -file [file join $appdir missing.gif]
151 |
152 | #-----------------------------------------------------------------------
153 | # Mainline code
154 |
155 | # Check the arguments
156 | if {[llength $argv] == 0} {
157 | set notebooks {}
158 | } else {
159 | foreach name $argv {
160 | set name [file normalize $name]
161 | lappend notebooks [file join [pwd] $name]
162 | }
163 | }
164 |
165 | # Read the preferences
166 | prefs load
167 |
168 | # Initialize the help browser
169 | helpbrowser [file join $appdir help.nbk]
170 |
171 | # Initialize the message log
172 | messagelog init
173 |
174 | # Copy the extensions path to the auto_path, and
175 | # try to load the extension packages.
176 | set extpath [string trim [prefs get extpath]]
177 | if {$extpath ne ""} {
178 | lappend auto_path $extpath
179 | }
180 |
181 | if {[catch {package require Img 1.3} result]} {
182 | messagelog logmessage "Img Extension: not loaded"
183 | } else {
184 | messagelog logmessage "Img Extension: loaded"
185 | }
186 |
187 | # Add the initial OS X file names, if any
188 | set notebooks [concat $notebooks $osxDocsToOpen]
189 |
190 | # Create the initial Notebook browsers
191 | notebookbrowser appdir $appdir
192 |
193 | if {[llength $notebooks] == 0} {
194 | welcomer .%AUTO%
195 | destroy .splash
196 | } else {
197 | destroy .splash
198 | foreach notebook $notebooks {
199 | try {
200 | if {[file extension $notebook] eq ""} {
201 | append notebook ".nbk"
202 | }
203 |
204 | set db [dbmanager openfile $notebook]
205 | notebookbrowser .%AUTO% -db $db
206 | } trap notebookdb::loaderror {msg} {
207 | welcomer .%AUTO% -errormsg $msg
208 | }
209 | }
210 | }
211 |
212 | #-----------------------------------------------------------------------
213 | # Redefine ::tk::mac::OpenDocument
214 | #
215 | # See the discussion at the top of this file.
216 | #
217 | # This proc will receive OS X open events after the application has
218 | # gotten initialized, and will open new windows for the specified
219 | # notebook files.
220 |
221 | if {[tk windowingsystem] eq "aqua"} {
222 | proc ::tk::mac::OpenDocument {args} {
223 | foreach name $args {
224 | try {
225 | set newdb [dbmanager openfile $name]
226 | } trap notebookdb::loaderror {msg} {
227 | throw USER $msg
228 | }
229 |
230 | if {$newdb eq ""} {
231 | error "Cancelled." {} USER
232 | }
233 |
234 | notebookbrowser .%AUTO% -db $newdb
235 | }
236 | }
237 | }
238 |
--------------------------------------------------------------------------------
/lib/app_notebook/pageviewer.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # pageviewer.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A viewer for browsing Notebook pages.
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2005 by William H. Duquette. This file may
13 | # be used subject to the terms in license.txt.
14 | #
15 | #-----------------------------------------------------------------------
16 |
17 | snit::widget pageviewer {
18 | #-------------------------------------------------------------------
19 | # Creation Options
20 | #
21 | # These options should only be set at creation time. This isn't
22 | # enforced, so be careful
23 |
24 | # 1 if we're read-only, and 0 otherwise.
25 | option -readonly 0
26 |
27 | # A command to use for outputting messages. The message will be
28 | # appended.
29 | option -messagecommand {}
30 |
31 | # The notebook file directory, used as the root for relative paths.
32 | option -dbdir {}
33 |
34 | #-------------------------------------------------------------------
35 | # Other options
36 |
37 | # A command that's called when the displayed page changes. The
38 | # command gets one argument, the page name.
39 | option -pagecommand {}
40 |
41 | # A command that's called when we try to display a page that
42 | # doesn't exist.
43 | option -unknowncommand {}
44 |
45 | #-------------------------------------------------------------------
46 | # Components
47 |
48 | # The toplevel window (the notebookbrowser)
49 | variable top
50 |
51 | # The renderpane is the component that actually displays the
52 | # rendered page.
53 | variable rp
54 |
55 | #--------------------------------------------------------------------
56 | # Other variables
57 |
58 | # The history list is a list of {PageName PagePos} pairs.
59 | variable history {}
60 |
61 | # The histPos is the index of the currently displayed page in the
62 | # history list. It's initially -1 because there's nothing in the
63 | # list.
64 | variable histPos -1
65 |
66 | # A list of recently displayed pages. Each page appears only once,
67 | # regardless of how often (and where) it appears in the history list.
68 | # There will be ten pages listed, maximum; no more than one of them
69 | # are guaranteed to still exist.
70 | variable recentPages {}
71 |
72 | #--------------------------------------------------------------------
73 | # Constructor
74 |
75 | constructor {args} {
76 | # Get the toplevel widget
77 | set top [winfo toplevel $win]
78 |
79 | # As yet we have no option delegation, so go ahead and get the
80 | # args
81 | $self configurelist $args
82 |
83 | # Create the renderpane.
84 | install rp using renderpane $win.rp \
85 | -yscrollcommand "$win.scroll set" \
86 | -querycommand [list $top pageexists] \
87 | -titlecommand [mymethod TitleHandler] \
88 | -linkcommand [mymethod LinkHandler] \
89 | -buttoncommand [mymethod ButtonHandler] \
90 | -macroerrorcommand [mymethod MacroErrorHandler] \
91 | -messagecommand $options(-messagecommand) \
92 | -dbdir $options(-dbdir)
93 |
94 | scrollbar $win.scroll \
95 | -command "$win.rp yview"
96 |
97 | # Pack them in.
98 | pack $win.scroll -side right -fill y -expand false
99 | pack $rp -side top -fill both -expand true
100 |
101 | #---------------------------------------------------------------
102 | # User Interactions
103 |
104 | # Add the pageviewer window itself to the renderpane's bindtags,
105 | # so that keys bound to the pageviewer will take effect when the
106 | # renderpane has focus
107 | set tags [bindtags $rp]
108 | lappend tags $win
109 | bindtags $rp $tags
110 |
111 | # Go to the previous page when is pressed.
112 | bind $rp [list $self backpage]
113 |
114 | # User Menu.
115 | menu $rp.user -tearoff no -postcommand [mymethod PostUserMenu]
116 |
117 | $rp.user add command -label "User Menu"
118 | $rp.user add separator
119 | $rp.user add command -label "Dummy"
120 |
121 | bind $rp [list tk_popup $rp.user %X %Y 2]
122 | bind $rp <3> [list tk_popup $rp.user %X %Y 2]
123 |
124 | # Recent Pages Menu.
125 | menu $rp.recent -tearoff no -postcommand [mymethod PostRecent]
126 |
127 | $rp.recent add command -label "Recent Pages"
128 | $rp.recent add separator
129 | $rp.recent add command -label "Dummy"
130 |
131 | bind $rp [list tk_popup $rp.recent %X %Y 2]
132 |
133 | #---------------------------------------------------------------
134 | # Prepare to receive preferences events; unregister on
135 | # destroy.
136 | prefs register $selfns [mymethod UsePreferences]
137 | }
138 |
139 | destructor {
140 | catch {prefs unregister $selfns}
141 | }
142 |
143 | method UsePreferences {} {
144 | # Update the display when the preferences change.
145 | $self showpage
146 | }
147 |
148 | #-------------------------------------------------------------------
149 | # Public Methods
150 |
151 | delegate method searchfor to rp
152 |
153 | # Returns the name of the currently displayed page, or "" if none.
154 | # Note that during a deletion or page renaming the named page
155 | # is not guaranteed to exist.
156 | method current {} {
157 | return [lindex $history $histPos 0]
158 | }
159 |
160 | # Tells the pageviewer to take the keyboard focus.
161 | # If -friendly, we take the focus only if our toplevel already
162 | # has it (e.g., we take the focus back from the search box).
163 | method focus {{option {}}} {
164 | set focusWin [focus]
165 |
166 | if {$focusWin eq ""} {
167 | return
168 | }
169 |
170 | if {$option ne "-friendly" ||
171 | [winfo toplevel $win] eq [winfo toplevel $focusWin]} {
172 | focus $rp
173 | }
174 | }
175 |
176 | # Shows the named page. The -unknowncommand is called if the
177 | # page doesn't exist.
178 | method showpage {{name ""}} {
179 | # FIRST, remember the position for the page we're showing now.
180 | if {$histPos >= 0} {
181 | lset history $histPos 1 [$self GetPos]
182 | }
183 |
184 | # NEXT, default to the current page.
185 | if {$name eq ""} {
186 | set name [$self current]
187 |
188 | if {$name eq ""} {
189 | error "no current page."
190 | }
191 | }
192 |
193 | # NEXT, if the page doesn't exist, call the -unknowncommand.
194 | if {![$top pageexists $name]} {
195 | if {$options(-unknowncommand) ne {}} {
196 | set command $options(-unknowncommand)
197 | lappend command $name
198 | uplevel \#0 $command
199 | } else {
200 | $return -code error -errorcode USER "No such page: '$name'"
201 | }
202 |
203 | return
204 | }
205 |
206 | # NEXT, save the new page in the history list. When we show
207 | # a new page, any pages forward of our position go away.
208 | set history [lrange $history 0 $histPos]
209 | lappend history [list [$top pagename $name] 0]
210 | incr histPos
211 |
212 | # NEXT, display it.
213 | $self DisplayPage
214 | }
215 |
216 | # Steps back one page, if possible
217 | method backpage {} {
218 | # FIRST, remember the position for the page we're showing now.
219 | if {$histPos >= 0} {
220 | lset history $histPos 1 [$self GetPos]
221 | }
222 |
223 | # NEXT, Look back through the history list for a page that exists,
224 | # and is also different than the current page.
225 | set current [lindex $history $histPos 0]
226 | set pos [expr {$histPos - 1}]
227 |
228 | while {$pos >= 0} {
229 | set candidate [lindex $history $pos 0]
230 |
231 | if {[$top pageexists $candidate]} {
232 |
233 | if {![string equal -nocase $candidate $current]} {
234 | break
235 | }
236 | }
237 |
238 | incr pos -1
239 | }
240 |
241 | if {$pos < 0} {
242 | bell
243 | return
244 | }
245 |
246 | set histPos $pos
247 |
248 | $self DisplayPage
249 | }
250 |
251 | # Steps forward one page, if possible
252 | method forwardpage {} {
253 | # FIRST, remember the position for the page we're showing now.
254 | if {$histPos >= 0} {
255 | lset history $histPos 1 [$self GetPos]
256 | }
257 |
258 | # NEXT, Look forward through the history list for a page that exists,
259 | # and is also different than the current page.
260 | set current [lindex $history $histPos 0]
261 | set pos [expr {$histPos + 1}]
262 | set len [llength $history]
263 |
264 | while {$pos < $len} {
265 | set candidate [lindex $history $pos 0]
266 |
267 | if {[$top pageexists $candidate]} {
268 |
269 | if {![string equal -nocase $candidate $current]} {
270 | break
271 | }
272 | }
273 |
274 | incr pos
275 | }
276 |
277 | if {$pos >= $len} {
278 | bell
279 | return
280 | }
281 |
282 | set histPos $pos
283 |
284 | $self DisplayPage
285 | }
286 |
287 | # Shows the page from the beginning of the Recent Pages list, if it exists.
288 | method cyclerecent {} {
289 | foreach id $recentPages {
290 | if {[$top pageexists $id]} {
291 | $self showpage $id
292 | break
293 | }
294 | }
295 | }
296 |
297 | #-------------------------------------------------------------------
298 | # Private Methods
299 |
300 | # Display the current page
301 | method DisplayPage {} {
302 | # FIRST, Get the current page specs
303 | set name [$top pagename [lindex $history $histPos 0]]
304 | set ypos [lindex $history $histPos 1]
305 |
306 | # NEXT, add the name to the list of recent pages
307 | $self SaveRecentPage $name
308 |
309 | # NEXT, Expand the requested page and display it.
310 | set pagetext [$top pageexpand $name]
311 |
312 | $rp render $name $pagetext
313 | $rp searchfor [$top searchtext]
314 |
315 | # NEXT, give the renderpane the focus so that we don't
316 | # need to click in it.
317 | $self focus -friendly
318 |
319 | $self setpos $ypos
320 |
321 | # NEXT, notify those concerned.
322 | if {$options(-pagecommand) ne {}} {
323 | set command $options(-pagecommand)
324 | lappend command $name
325 | uplevel \#0 $command
326 | }
327 | }
328 |
329 | # Save the specified page to the recent pages list, removing
330 | # any previous entry with the same name. Names are stored
331 | # in lower case. No more than ten names are stored.
332 | method SaveRecentPage {name} {
333 | set name [string tolower $name]
334 |
335 | set ndx [lsearch -exact $recentPages $name]
336 |
337 | if {$ndx != -1} {
338 | set recentPages [lreplace $recentPages $ndx $ndx]
339 | }
340 |
341 | lappend recentPages $name
342 |
343 | # Cut down back to ten, if need be
344 | if {[llength $recentPages] == 11} {
345 | set recentPages [lreplace $recentPages 0 0]
346 | }
347 | }
348 |
349 |
350 | # Get the y-position of the text at the top of the window.
351 | method GetPos {} {
352 | lindex [$rp yview] 0
353 | }
354 |
355 | # Set the y-position of the text at the top of the window.
356 | method setpos {ypos} {
357 | $rp yview moveto $ypos
358 | }
359 |
360 | # Called when the user clicks on the title text.
361 | method TitleHandler {title} {
362 | $top showsearch $title
363 | }
364 |
365 | # Called when the user clicks on a link; shows the linked page.
366 | method LinkHandler {linkName} {
367 | $self showpage $linkName
368 | }
369 |
370 | # Called when the user clicks on a magic button; calls the button's script
371 | method ButtonHandler {script} {
372 | $top evaluser $script
373 | }
374 |
375 | # Finds the macro error text and displays the error message.
376 | method MacroErrorHandler {macro} {
377 | $top evaluser $macro
378 | # TBD: If macros are disabled, then clicking on this won't
379 | # display an error. We need to handle this somehow.
380 | }
381 |
382 | # Called before the Recent Pages context menu is popped up.
383 | method PostRecent {} {
384 | # FIRST, delete any existing items.
385 | $rp.recent delete 2 end
386 |
387 | # NEXT, add items for the recent items.
388 | foreach id $recentPages {
389 | if {[$top pageexists $id]} {
390 | set name [$top pagename $id]
391 | $rp.recent add command \
392 | -label $name \
393 | -command [list $self showpage $name]
394 | }
395 | }
396 | }
397 |
398 | # Called before the User Menu context menu is popped up.
399 | method PostUserMenu {} {
400 | # FIRST, delete any existing items.
401 | $rp.user delete 2 end
402 |
403 | # NEXT, retrieve the user's choices
404 | set items [$top evaluser usermenu]
405 |
406 | # NEXT, add items for the user's choices.
407 | foreach {label command} $items {
408 | if {$label eq "separator"} {
409 | $rp.user add separator
410 | } else {
411 | $rp.user add command \
412 | -label $label \
413 | -command [list $top evaluser $command]
414 | }
415 | }
416 | }
417 | }
418 |
419 |
420 |
421 |
--------------------------------------------------------------------------------
/lib/app_notebook/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # pkgIndex.tcl
4 | #
5 | # PROJECT:
6 | # notebook: Your project description
7 | #
8 | # DESCRIPTION:
9 | # app_notebook(n): pkgIndex file
10 | #
11 | # Generated by Quill
12 | #
13 | #-------------------------------------------------------------------------
14 |
15 | # -quill-ifneeded-begin DO NOT EDIT BY HAND
16 | package ifneeded app_notebook 2.2.0 [list source [file join $dir pkgModules.tcl]]
17 | # -quill-ifneeded-end
18 |
--------------------------------------------------------------------------------
/lib/app_notebook/pkgModules.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # pkgModules.tcl
4 | #
5 | # PROJECT:
6 | # notebook: Your project description
7 | #
8 | # DESCRIPTION:
9 | # app_notebook(n): Package Loader
10 | #
11 | # Generated by Quill
12 | #
13 | #-------------------------------------------------------------------------
14 |
15 | #-------------------------------------------------------------------------
16 | # Provide Package
17 |
18 | # -quill-provide-begin DO NOT EDIT BY HAND
19 | package provide app_notebook 2.2.0
20 | # -quill-provide-end
21 |
22 | #-------------------------------------------------------------------------
23 | # Require Packages
24 |
25 | # -quill-require-begin INSERT PACKAGE REQUIRES HERE
26 | package require snit 2.3
27 | # -quill-require-end
28 |
29 | #-------------------------------------------------------------------------
30 | # Get the library directory
31 |
32 | namespace eval ::app_notebook:: {
33 | variable library [file dirname [info script]]
34 | }
35 |
36 | source [file join $::app_notebook::library main.tcl]
37 |
--------------------------------------------------------------------------------
/lib/app_notebook/splash.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/app_notebook/splash.gif
--------------------------------------------------------------------------------
/lib/app_notebook/userprefs.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # userprefs.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Notebook application user preferences.
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2002,2003,2004,2005 by William H. Duquette.
13 | # This file may be used subject to the terms in license.txt.
14 |
15 | package require Tk
16 |
17 | #-----------------------------------------------------------------------
18 | # UserPrefs
19 |
20 | # prefs could be implemented as an ensemble: a type with no instances but
21 | # only typemethods. For historical reasons, though, it's been
22 | # implemented as a normal type with just one instance.
23 | snit::type ::app_notebook::prefsmanager {
24 | # Preferences array
25 | variable prefs
26 |
27 | # Observers array. index is observer name, value is command to execute.
28 | variable observers
29 |
30 | # System font lists
31 | variable fonts
32 |
33 | # Pseudo-preferences
34 | #
35 | # Pseudo-preferences aren't saved to the preferences file.
36 | variable pseudoprefs {
37 | defaultscaling
38 | }
39 |
40 | constructor {} {
41 | # Scaling Preference
42 | set prefs(defaultscaling) [tk scaling]
43 | set prefs(scaling) [tk scaling]
44 |
45 | # Font preferences
46 | set prefs(bodytext) {Times 12}
47 | set prefs(monotext) {Courier 10}
48 | set prefs(header1text) {Helvetica 16 bold}
49 | set prefs(header2text) {Helvetica 14 bold}
50 | set prefs(header3text) {Helvetica 12 bold}
51 | set prefs(titletext) {Helvetica 20}
52 | set prefs(smalltext) {Helvetica 8}
53 |
54 | # Color preferences
55 | set prefs(editorfg) black
56 | set prefs(editorbg) white
57 | set prefs(normalfg) black
58 | set prefs(normalbg) white
59 | set prefs(prefg) black
60 | set prefs(prebg) white
61 | set prefs(tclfg) black
62 | set prefs(tclbg) white
63 | set prefs(titlefg) blue
64 | set prefs(titlebg) white
65 | set prefs(linkfg) blue
66 | set prefs(linkbg) white
67 | set prefs(buttonfg) magenta
68 | set prefs(buttonbg) white
69 | set prefs(warningfg) red
70 | set prefs(warningbg) white
71 | set prefs(searchfg) white
72 | set prefs(searchbg) red
73 |
74 | # Editor preferences
75 | set prefs(tabwidth) 4
76 | set prefs(autowrap) 1
77 | set prefs(wrapcolumn) 74
78 | set prefs(autoindent) 1
79 |
80 | # Tcl/Tk Preferences
81 | set prefs(extpath) {}
82 |
83 | # Miscellaneous Options
84 | set prefs(includetour) 1
85 | set prefs(editbottom) 0
86 | set prefs(displaydirectives) 0
87 | set prefs(silentcreation) 0
88 | set prefs(showsidebar) 0
89 | set prefs(incrementalsearch) 1
90 | set prefs(contentsearch) 1
91 |
92 | # Initialize font lists
93 | set fonts(all) {}
94 | set fonts(mono) {}
95 | set fonts(prop) {}
96 | }
97 |
98 | # Register observer. obj is the observing object; command is the
99 | # command to execute when preferences are saved.
100 | method register {obj command} {
101 | set observers($obj) $command
102 | }
103 |
104 | # Unregister observer. obj is the observing object.
105 | method unregister {obj} {
106 | unset observers($obj)
107 | }
108 |
109 | # Set a preference variable's value
110 | method set {var value} {
111 | # HACK: handle translation of "headertext" to "header[123]text"
112 | # This handles a preferences change in V2.1.1
113 | if {$var eq "headertext"} {
114 | $self set header1text $value
115 | $self set header2text $value
116 | $self set header3text $value
117 | return
118 | }
119 |
120 | # Retain and save unknown preferences; this means they can
121 | # switch between this version and a later version with more
122 | # preferences and not have any trouble.
123 | set prefs($var) $value
124 | }
125 |
126 | # Get a preference variable's value
127 | method get {var} {
128 | if {[info exists prefs($var)]} {
129 | return $prefs($var)
130 | } else {
131 | error "Unknown prefs variable: '$var'"
132 | }
133 | }
134 |
135 | # Load the preferences from disk. The file name is system-dependent.
136 | method load {} {
137 | set fname [PrefFileName]
138 |
139 | if {[file exists $fname]} {
140 | try {
141 | source [PrefFileName]
142 | tk scaling $prefs(scaling)
143 | } on error errmsg {
144 | msg "Error in user preferences file '$fname'; preferences might not be set. The error was: $errmsg"
145 | }
146 | }
147 | }
148 |
149 | # Save the preferences and notify observers.
150 | method save {} {
151 | try {
152 | set f [open [PrefFileName] w]
153 |
154 | puts $f "# Notebook [version] Preferences File"
155 | foreach name [array names prefs] {
156 | if {[lsearch -exact $pseudoprefs $name] != -1} {
157 | continue
158 | }
159 | puts $f [list prefs set $name $prefs($name)]
160 | }
161 | puts $f "# End of preferences"
162 | close $f
163 | } on error errmsg {
164 | msg "Could not save user preferences to [PrefFileName]: $errmsg"
165 | }
166 |
167 | $self NotifyObservers
168 | }
169 |
170 | # Pop up the preferences dialog; create it if it hasn't yet been
171 | # seen.
172 | method dialog {} {
173 | # Create the dialog, if one doesn't exist.
174 | if {"" == [info commands .prefsdialog]} {
175 | ::app_notebook::prefsdialog .prefsdialog
176 | }
177 |
178 | # Make sure it's visible.
179 | .prefsdialog show
180 | }
181 |
182 | # Return a list of monospace fonts defined by the system.
183 | method monofonts {} {
184 | $self LoadFonts
185 | return $fonts(mono)
186 | }
187 |
188 | # Return a list of proportional fonts defined by the system.
189 | method propfonts {} {
190 | $self LoadFonts
191 | return $fonts(prop)
192 | }
193 |
194 | # Return a list of *all* fonts defined by the system.
195 | method fonts {} {
196 | $self LoadFonts
197 | return $fonts(all)
198 | }
199 |
200 | #-----------------------------------------------------------------------
201 | # Private methods and procs
202 |
203 | # Determine the preference file name based on the platform
204 | proc PrefFileName {} {
205 | global tcl_platform
206 | global env
207 |
208 | # This is the only way to reference Tcl/Tk Aqua as opposed to
209 | # the X11 version
210 | if {[tk windowingsystem] eq "aqua"} {
211 | return [file join $env(HOME) "Library/Preferences/NotebookPrefs"]
212 | }
213 |
214 | switch $tcl_platform(platform) {
215 | "macintosh" {
216 | # This is classic Mac only
217 | return [file join $env(PREF_FOLDER) "Notebook Preferences"]
218 | }
219 | "windows" {
220 | if {[info exists env(HOME)]} {
221 | return [file join $env(HOME) "notebook.cfg"]
222 | } else {
223 | return [file join "C:/" "notebook.cfg"]
224 | }
225 | }
226 | "unix" -
227 | default {
228 | if {[info exists env(DOTDIR)]} {
229 | return "$env(DOTDIR)/.notebookrc"
230 | } else {
231 | return "$env(HOME)/.notebookrc"
232 | }
233 | }
234 | }
235 | }
236 |
237 | # Notify all registered observers that preferences have changed.
238 | method NotifyObservers {} {
239 | foreach name [array names observers] {
240 | uplevel #0 $observers($name)
241 | }
242 | }
243 |
244 | # Load system fonts, if they've not already been loaded.
245 | method LoadFonts {} {
246 | if {[llength $fonts(all)] != 0} {
247 | return
248 | }
249 |
250 | # Get all fonts.
251 | set fontnames [font families]
252 |
253 | # Tcl defines these names on all platforms, so add them to list
254 | # if they aren't already there.
255 | foreach name {Courier Times Helvetica} {
256 | if {[lsearch $fontnames $name] == -1} {
257 | lappend fontnames $name
258 | }
259 | }
260 |
261 | # On Tcl/Tk Aqua there are some problematic font names;
262 | # they all begin with non-alpha characters.
263 | foreach font $fontnames {
264 | set initial [string index $font 0]
265 | if {![string is alpha $initial]} {
266 | continue
267 | }
268 |
269 | lappend fonts(all) $font
270 | }
271 |
272 | set fonts(all) [lsort $fonts(all)]
273 |
274 | # Create lists of monospace and proportional fonts.
275 | foreach font $fonts(all) {
276 | if {[font metrics [list $font] -fixed]} {
277 | lappend fonts(mono) $font
278 | } else {
279 | lappend fonts(prop) $font
280 | }
281 | }
282 | }
283 | }
284 |
285 | # Create one instance of this object.
286 | ::app_notebook::prefsmanager create ::app_notebook::prefs
287 |
288 | namespace eval ::app_notebook:: {
289 | namespace export prefs
290 | }
291 |
292 |
293 |
--------------------------------------------------------------------------------
/lib/app_notebook/welcomer.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # welcomer.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # This component is created if Notebook is invoked
10 | # with no file name. It welcomes the user to Notebook and allows
11 | # them to open or create a notebook file. As such, it's a baby
12 | # version of a notebookbrowser. I'll duplicate the action and
13 | # menu code for now; but ultimately that will need to be fixed.
14 | #
15 | # LICENSE:
16 | # Copyright (C) 2003 by William H. Duquette. This file may
17 | # be used subject to the terms in license.txt.
18 | #
19 | #-----------------------------------------------------------------------
20 |
21 | snit::widget welcomer {
22 | # This is a toplevel window
23 | hulltype toplevel
24 | delegate option * to hull
25 |
26 | #-------------------------------------------------------------------
27 | # Options
28 |
29 | # An error stating why the welcomer was used.
30 | option -errormsg ""
31 |
32 | #-------------------------------------------------------------------
33 | # Instance Variables
34 |
35 | variable greeting {
36 | |Click on the highlighted text to:
37 | |
38 | |* [%Open|open-notebook%] an existing notebook.
39 | |* [%Create|new-notebook%] a new notebook
40 | |* [%Browse|help-introduction%] the on-line help.
41 | |
42 | |If you've never used Notebook before, then you'll want to
43 | |[%create|new-notebook%] a new notebook. It will be created
44 | |with an initial set of pages that will tell you
45 | |the things you need to know to get started.
46 | }
47 |
48 | #-------------------------------------------------------------------
49 | # Components
50 |
51 | variable am ;# The actionmanager
52 | variable status ;# The statusentry
53 | variable render ;# The renderpane
54 |
55 | #-------------------------------------------------------------------
56 | # Constructor
57 |
58 | constructor {args} {
59 | #---------------------------------------------------------------
60 | # Preliminaries
61 |
62 | # FIRST, withdraw the window, so they don't see it building.
63 | wm withdraw $win
64 |
65 | # NEXT, set the window title
66 | wm title $win "Welcome to Notebook"
67 |
68 | # NEXT, Go ahead and configure the widget options, if any; none are
69 | # delegated to anything but the hull.
70 | $self configurelist $args
71 |
72 | # NEXT, prepare for window closing
73 | windowmanager register $win
74 |
75 | #---------------------------------------------------------------
76 | # Create Components
77 |
78 | # FIRST, create the actionmanager and define the actions.
79 | install am using nbactionmanager %AUTO% \
80 | -toplevel $win \
81 | -windowtype welcomer \
82 | -errorcommand [mymethod ErrorHandler]
83 |
84 | # NEXT, create the statusentry. It provides a GUI for displaying
85 | # status and entering arguments.
86 | install status using statusentry $win.status \
87 | -errorcommand [mymethod ErrorHandler] \
88 | -messagecommand [list messagelog logmessage]
89 |
90 | # NEXT, create the renderpane for the welcome message
91 | install render using renderpane $win.render \
92 | -buttoncommand [mymethod ButtonHandler] \
93 | -width 45 \
94 | -height 20
95 |
96 | # Next, pack the components
97 | pack $status -side bottom -fill x -expand false
98 | pack $render -side top -fill both -expand true
99 |
100 | #---------------------------------------------------------------
101 | # Render the welcome message
102 |
103 | regsub -all -line {^\s*\|} [string trim $greeting] {} greeting
104 | $render render "Welcome to Notebook!" $greeting
105 |
106 | #---------------------------------------------------------------
107 | # Final Preparations
108 |
109 | # NEXT, update the state of all actions.
110 | $am updatestate
111 |
112 | # NEXT, The GUI is fully created; display it!
113 | #
114 | # We call "update" to make sure that everything has taken its final
115 | # size before we deiconify.
116 | update
117 | wm deiconify $win
118 |
119 | # NEXT, if there's an error message, display it.
120 | if {$options(-errormsg) ne ""} {
121 | $status msg $options(-errormsg)
122 | }
123 | }
124 |
125 | #-------------------------------------------------------------------
126 | # Private Methods
127 |
128 | method ButtonHandler {action} {
129 | $am invoke $action
130 | }
131 |
132 | # Called when the welcomer's work is done.
133 | method Withdraw {} {
134 | wm withdraw $win
135 |
136 | # TBD: Is the "after 1" really necessary?
137 | after 1 [list windowmanager destroy $win]
138 | }
139 |
140 | # Handles errors from the statusentry and actionmanager components.
141 | method ErrorHandler {msg einfo ecode} {
142 | if {$ecode eq "USER"} {
143 | $status msg $msg
144 | bell
145 | } else {
146 | messagelog logerror $msg $einfo $ecode
147 |
148 | $status msg "$msg -- go to Message Log for more."
149 | }
150 | }
151 |
152 |
153 | #-------------------------------------------------------------------
154 | # Delegate Action Handlers
155 |
156 | delegate method about-notebook to am
157 | delegate method close-window to am
158 | delegate method copy-string to am
159 | delegate method cut-string to am
160 | delegate method edit-preferences to am
161 | delegate method help-on to am
162 | delegate method help-introduction to am
163 | delegate method help-index to am
164 | delegate method help-on-actions to am
165 | delegate method help-on-commands to am
166 | delegate method help-on-markup to am
167 | delegate method notebook-license to am
168 | delegate method notebook-release-notes to am
169 | delegate method paste-string to am
170 | delegate method redo-change to am
171 | delegate method request-action to am
172 | delegate method undo-change to am
173 | delegate method show-version to am
174 |
175 | #-------------------------------------------------------------------
176 | # Action Handlers
177 | #
178 | # These methods are registered as actions with the actionmanager
179 | # component. Actions can be invoked by typing their names into the
180 | # statusentry widget, or programmatically; they can get input
181 | # from the user via the statusentry widget.
182 | #
183 | # When actions are invoked programmatically, none or all of their
184 | # arguments can be specified programmatically; the action will prompt
185 | # for the remaining arguments.
186 | #
187 | # When called programmatically, the action's state is NOT checked.
188 | # Thus, every action must explicitly check the same conditions as
189 | # its -statecommand, giving a good USER error if they are not met.
190 | #
191 | # Every action has a handler with the same name. In some cases,
192 | # this handler implements the entire action. For actions that have
193 | # arguments, it's usual to implement the handler as two methods.
194 | # The first has the usual name, and will do the following:
195 | #
196 | # * Require any conditions for execution of the action that do not
197 | # depend on the argument values.
198 | #
199 | # * Request the arguments, passing control to the second command when
200 | # they've been entered.
201 | #
202 | # * The second method simply takes the arguments and does what's
203 | # necessary. The second method is not intended to be called by
204 | # anyone but the first method; it's called "Do-",
205 | # and should follow immediately after the first method.
206 |
207 |
208 | # Action: new-notebook
209 | #
210 | # Creates a new notebook file and opens it, prompting for the file
211 | # name
212 | method new-notebook {} {
213 | $am new-notebook
214 |
215 | # On success the welcomer isn't needed anymore.
216 | $self Withdraw
217 | }
218 |
219 | # Action: open-notebook
220 | #
221 | # Opens a notebook file in the page browser, replacing the
222 | # existing notebook.
223 |
224 | method open-notebook {} {
225 | $am open-notebook
226 |
227 | # On success the welcomer isn't needed anymore.
228 | $self Withdraw
229 | }
230 | }
231 |
--------------------------------------------------------------------------------
/lib/combobox/ANNOUNCE.txt:
--------------------------------------------------------------------------------
1 | Combobox 2.3 release announcement
2 | September 30, 2003
3 |
4 | This is to announce version 2.3 of my pure Tcl combobox widget. This
5 | version includes the following new features from version 2.2
6 |
7 | * added -buttonbackground option
8 | * added -listvar option
9 | * tweaked packing order of internal widgets, which improves the
10 | resize behavior a bit (thanks to Oliver Bienert for the suggestion)
11 | * exposed "subwidget" command (eg: .combobox subwidget entry)
12 |
13 | Where to get it:
14 |
15 | You can download combobox version 2.3 from the following URL:
16 |
17 | http://www.purl.org/net/oakley/tcl/combobox/index.html
18 |
19 |
20 | Basic features:
21 |
22 | * written in pure tcl; no megawidget or OO extensions required
23 |
24 | * platform independent, and works for all versions of tk >= 8.0
25 |
26 | * self-contained and portable; all the code is in one file
27 |
28 | * API is similar to standard Tk widgets, with subcommands
29 | such as configure, cget, insert, etc.
30 |
31 | * keyboard navigation
32 |
33 | * emulates the look and feel of a Windows combobox
34 |
35 | * completely, totally, free. I retain copyright but you are
36 | free to use the code however you see fit. Don't be mean.
37 |
38 |
--------------------------------------------------------------------------------
/lib/combobox/CHANGES.txt:
--------------------------------------------------------------------------------
1 | Changes to combobox.tcl and related files:
2 |
3 | ### version 2.3:
4 |
5 | * added -buttonbackground options
6 | * added -listvar option
7 | * tweaked packing order of internal widgets, which improves the
8 | resize behavior a bit (thanks to Oliver Bienert for the suggestion)
9 | * exposed "subwidget" command (eg: .combobox subwidget entry)
10 | * made code which is called when the widget is destroyed a bit more
11 | robust; someone reported that their wish process would sometimes
12 | crash while trying to destroy a combobox widget and this fix made
13 | that crash
14 |
15 | ### version 2.2.2:
16 |
17 | * fixed bug where dropdown list would appear behind the main
18 | window on some window managers.
19 |
20 | ### version 2.2.1:
21 |
22 | * fixed case where mousewheel binding caused problems with tk 8.0
23 | * fixed bug when pressing return with dropdown list visible but
24 | nothing is selected
25 |
26 | ### version 2.2:
27 |
28 | * added support for tk 8.4 (changed use of tk private commands)
29 | * new option -dropdownwidth to control the width of the dropdown menu
30 | * new options -disabledforeground, -disabledbackground
31 | * added support for using the mousewheel in the dropdown list
32 | * finally added documentation for the selection subcommand. For four
33 | years now I've been saying "to be added later". It's later.
34 |
35 | ### version 2.1:
36 |
37 | * added -opencommand
38 | * included documentation for the open and close commands
39 | * fixed problem for tk 8.2 where the dropdown list was always behind
40 | the parent window.
41 |
42 | ### version 2.0:
43 |
44 | * fixed bug when attempting to get the value of the option -value
45 | before a value has been set.
46 |
47 | ### version 2.0b2:
48 |
49 | * fixed bug with non-editable comboboxes. Sometimes (or was it
50 | all the time?), if you selected a value from the dropdown list
51 | of a non-editable combobox the value wasn't being set properly.
52 |
53 |
54 | ### version 2.0b1:
55 |
56 | * option shorthand is now supported (eg: -val instead of -value)
57 | * option synonyms are now supported (eg: -bd instead of -borderwidth)
58 | * added the commands select and curselection
59 | * added option database support
60 | * handling of -textvariable is much more straight-forward. Instead of
61 | lots of internal wrangling, I merely assign the variable to the
62 | -textvariable attribute of the entry widget
63 | * lots of comments, and a wee bit more conformance to Scriptics'
64 | style guidelines
65 |
66 |
67 | ### version 1.07:
68 |
69 | * any pre-existing grab is now restored when the
70 | dropdown listbox is closed.
71 | * it should now be possible to set your own bindings
72 | on the combobox widget and have it work the way
73 | you expect. However, the default bindtags for the
74 | widget probably *aren't* what you expect.
75 | * keyboard traversal / focus management is much better
76 | now. Shift-tab seems to do the right thing without
77 | resorting to any hackery.
78 | * fixed bug where the down arrow wouldn't cause the a
79 | dropdown list to display.
80 | * added support for -highlightcolor
81 | * added the "subwidget" command, to allow you to get at some
82 | of the internal widget paths. I would prefer not to have
83 | to expose the underpinnings of this widget, but I think
84 | some advanced users may need this.
85 | * modified the example to show how one can add a list of items
86 | at once, and to include -highlightthickness
87 | * added support for -xscrollcommand, and added a test case in
88 | test.tcl for this option
89 | * man page has been changed to more accurately describe when
90 | the -command is called. These rules have changed slightly
91 | from previous versions.
92 | * modified how and where the dropdown lists pops up. In
93 | theory it should handle virtual desktops better. Also,
94 | for obscenely large lists (ie: bigger than will fit on
95 | the screen) we try to fit it the best we can. It will
96 | either pop up above or below the entry widget depending
97 | on which side gives us the largest list, and will be
98 | trimmed to start or stop at the edges of the screen.
99 | * added the list command to the man page
100 |
101 | Thanks to John Jackson and Todd Helfter of the Purdue University
102 | Computer Center for the patch to handle virtual window managers
103 |
104 | ### version 1.06:
105 |
106 | * dropdown list scrollbar is now "smart", and will only appear if the
107 | number of elements in the list is larger than the -height (or -maxheight,
108 | if -height is zero) of the widget
109 | * slightly different bitmap for the button, courtesy of Martin M. Hunt
110 | * slight modification to the computation of the height of the dropdown
111 | list. The computation now takes into consideration the borderwidth
112 | of the dropdown list
113 | * added option -commandstate. If "disabled", the value of -command will
114 | *not* be called when the value changes. Useful for setting the value
115 | programatically when you don't want to run the associated command.
116 | NB: I really like this concept (of a -commandstate); I sure wish all
117 | tk widgets had such an option...
118 | * added value checks when setting -state and -commandstate (prior to
119 | 1.06 we would attempt to set the state to whatever you passed in)
120 | * fixed bug in error reporting of some listbox manipulation commands
121 | (like ".foo list insert" and friends)
122 | * the -command is called whenever something is chosen from the list or
123 | the user presses return with focus in the entry, even if the value
124 | hasn't changed. The reasoning is that some people might actually
125 | want this behavior, and for those that don't they can easily do the
126 | check for a changed value themselves.
127 | * went back to putting all procs _outside_ the initial namespace eval,
128 | as per suggestions in the style guide published by scriptics.
129 | * focus is better handled when the dropdown listbox is hidden -- focus
130 | should now be restored to whatever widget had it last.
131 | * added a keyboard widget traversal hack in the README.txt file; this
132 | hack also appears in test.tcl
133 |
134 | ### version 1.05:
135 |
136 | * removed a bunch of the "namespace eval" nonsense, in favor of a more
137 | straight-forward technique using upvar. I still use namespaces, but
138 | I think the implementation is a bit more sensible now.
139 | * put braces around a few expressions that didn't have them.
140 | * put all procs within a single "namespace eval" command, rather
141 | than defining them at the global level, with the namespace used
142 | as part of the proc name. A net effect of zero, but this method
143 | just feels more "right".
144 |
145 | ### version 1.04:
146 |
147 | Thanks for Martin M. Hunt (hunt@cygnus.com) for some of these fixes, or
148 | the inspiration thereof
149 |
150 | * fixed bug when calling the -command proc when the value that was
151 | selected contained spaces
152 | * selecting an item from the listbox when -editable is false no
153 | longer sets the selection in the entry widget
154 | * fixed bug where the entry widget of a non-editable combobox
155 | would become enabled under certain circumstances
156 | * added a bit of code to set the button width to mimic the width
157 | of a standard scrollbar
158 | * added -height option, to set the height of the listbox
159 | * added -maxheight option, to support the combobox autosizing up to
160 | some maximum size
161 | * poping up a list when the list would go past the bottom of the
162 | screen will cause the list to pop above the entry widget instead
163 | of below
164 | * fixed bug in cget routine
165 |
166 | ### version 1.03:
167 |
168 | * scanning the list works. You can click on the button (but not release)
169 | and drag over the list. If you drag above or below the list it should
170 | scroll appropriately
171 | * if you have a textvariable defined, it is no longer set to "" initially
172 | * tab completion has changed slightly..if you type in something that
173 | doesn't match it will try to find something that does (for example,
174 | typing "apx" when "append" is a valid value will highlight append).
175 | * changed the "insert" and "delete" commands to "listinsert" and
176 | "listdelete"
177 | * added the commands "listindex", "listget", "listsize", which are passed
178 | to the listbox as index, get and size, respectively. This gives you what
179 | I think is sufficient access to the listbox (but see more about this
180 | below...)
181 | * added the commands "bbox", "insert", "delete", "icursor", "scan",
182 | "xview", and "selection", which are passed directly to the entry
183 | widget. I haven't tested them all much, but in theory if one works
184 | they all should work... (or conversely, if one is broken...)
185 | * in the entry closes the list if it is open
186 | * added configuration option -selectcommand. It is a command that gets
187 | executed whenever something from the dropdown list is selected.
188 | It *doesn't* get called if you just type in the box. I wasn't sure
189 | when to call it in the latter case -- after each keypress? After a
190 | ? When focus changes? So for the time being it is only called
191 | when you select from the list, and it will append to the command the
192 | name of the widget and the index of the item selected. This works
193 | very well for -editable false. If you want a command to trigger for
194 | -editable true, just put a trace on a -textvariable.
195 |
196 |
197 | ### version 1.02:
198 |
199 | * the namespace for the widget has moved below the ::Combobox namespace
200 | * interaction of pageup/pagedown and up/down has been fixed
201 | * new method for mapping window
202 | * fixed double-click behavior when widget is disabled
203 | * fixed case where you could pop up the list even if the widget was disabled
204 | * tweaked testing routine to use rgb values instead of color names
205 | * clicking Button 1 in the entry widget will pop up the list if the widget
206 | is enabled but not editable
207 | * clicking Button 1 anywhere in the app when the list is showing will
208 | close the list
209 | * closing the listbox will cause the data in the entry widget to be selected
210 | * added options -selectbackground, selectforeground and -selectborderwidth
211 | * added option -cursor
212 | * added check for unknown option in configure, cget
213 | * added package require Tk 8.0
214 | * changed behavior of tab key in the entry widget; it still trys to match
215 | what is there with something in the list, but the way it chooses to
216 | display the data in the entry widget has changed slightly.
217 |
--------------------------------------------------------------------------------
/lib/combobox/README.txt:
--------------------------------------------------------------------------------
1 | Combobox version 2.3
2 | Copyright (c) 1998-2003, Bryan Douglas Oakley
3 | All Rights Reserved.
4 |
5 | http://www.purl.org/net/oakley/tcl/combobox/index.html
6 | mailto:oakley@bardo.clearlight.com
7 |
8 | This software is provided AS-IS with no waranty expressed or
9 | implied. This software may be used free of charge, though I would
10 | appreciate it if you give credit where credit is due and mention my
11 | name when you use it.
12 |
13 | To use: place combobox.tcl where your programs can get at it either
14 | via autoloading or from a "source" command. To create a combobox widget
15 | use the command "::combobox::combobox", or import the combobox command
16 | with "import ::combobox::*" to use it as simply "combobox".
17 |
18 | To see a quick example, start up a wish process and cd to the directory
19 | where combobox.tcl is located. Then do "source example.tcl".
20 |
21 | #####################################################################
22 |
--------------------------------------------------------------------------------
/lib/combobox/example.tcl:
--------------------------------------------------------------------------------
1 | # A simple font display utility.
2 | #
3 | # This program uses two variations of the combobox. One, for the font
4 | # family, is non-editable (ie: the user can only pick from the list).
5 | # The other, for font size, is editable. The user can pick from the list
6 | # or enter their own size
7 |
8 | # substitute your favorite method here...
9 | source combobox.tcl
10 | package require combobox 2.3
11 | catch {namespace import combobox::*}
12 |
13 | proc main {} {
14 | # this lets us be reentrant...
15 | destroy .fontpicker .msg
16 |
17 | # default values
18 | set ::size 12
19 | set ::family [lindex [lsort [font families]] 0]
20 | set ::slant roman
21 | set ::weight normal
22 | set ::overstrike 0
23 | set ::underline 0
24 |
25 | wm title . "Combobox Example"
26 |
27 | # the main two areas: a frame to hold the font picker widgets
28 | # and a label to display a sample from the font
29 | set fp [frame .fontpicker]
30 | set msg [label .msg -borderwidth 2 -relief groove -width 30 -height 4]
31 |
32 | pack $fp -side top -fill x
33 | pack $msg -side top -fill both -expand y -pady 2
34 |
35 | $msg configure -text [join [list \
36 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ" \
37 | "abcdefghijklmnopqrstuvwxyz" \
38 | "0123456789~`!@#$%^&*()_-+=" \
39 | "{}[]:;\"'<>,.?/"] "\n"]
40 |
41 | # this will set the font of the message according to our defaults
42 | changeFont $msg
43 |
44 | # font family...
45 | label $fp.famLabel -text "Font Family:"
46 | combobox $fp.famCombo \
47 | -borderwidth 1 \
48 | -textvariable family \
49 | -editable false \
50 | -highlightthickness 1 \
51 | -command [list changeFont $msg]
52 |
53 |
54 | grid $fp.famLabel -row 0 -column 0 -sticky e
55 | grid $fp.famCombo -row 0 -column 1 -sticky ew
56 | grid columnconfigure $fp 1 -weight 1
57 |
58 | # we'll do these one at a time so we can find the widest one and
59 | # set the width of the combobox accordingly (hmmm... wonder if this
60 | # sort of thing should be done by the combobox itself...?)
61 | set widest 0
62 | foreach family [lsort [font families]] {
63 | if {[set length [string length $family]] > $widest} {
64 | set widest $length
65 | }
66 | $fp.famCombo list insert end $family
67 | }
68 | $fp.famCombo configure -width $widest
69 |
70 | # the font size. We know we are puting a fairly small, finite
71 | # number of items in this combobox, so we'll set its maxheight
72 | # to zero so it will grow to fit the number of items
73 | label $fp.sizeLabel -text "Font Size:"
74 | combobox $fp.sizeCombo \
75 | -borderwidth 1 \
76 | -highlightthickness 1 \
77 | -maxheight 0 \
78 | -width 3 \
79 | -textvariable size \
80 | -editable true \
81 | -command [list changeFont $msg]
82 |
83 | grid $fp.sizeLabel -row 0 -column 2 -sticky e -padx 2
84 | grid $fp.sizeCombo -row 0 -column 3 -sticky new
85 | grid columnconfigure $fp 3 -weight 1
86 | eval $fp.sizeCombo list insert end [list 8 9 10 12 14 16 18 20 24 28 32 36]
87 |
88 | # a dummy frame to give a little spacing...
89 | frame $fp.dummy -width 5
90 | grid $fp.dummy -row 0 -column 4
91 |
92 | # bold
93 | set bold "bold"
94 | checkbutton $fp.bold -variable weight -indicatoron false \
95 | -onvalue bold -offvalue normal \
96 | -text "B" -width 2 -height 1 \
97 | -font {-weight bold -family Times -size 12} \
98 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
99 | -command [list changeFont $msg]
100 | grid $fp.bold -row 0 -column 5 -sticky nsew
101 |
102 | # underline
103 | checkbutton $fp.underline -variable underline -indicatoron false \
104 | -onvalue 1 -offvalue 0 \
105 | -text "U" -width 2 -height 1 \
106 | -font {-underline 1 -family Times -size 12} \
107 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
108 | -command [list changeFont $msg]
109 | grid $fp.underline -row 0 -column 6 -sticky nsew
110 |
111 | # italic
112 | checkbutton $fp.italic -variable slant -indicatoron false \
113 | -onvalue italic -offvalue roman \
114 | -text "I" -width 2 -height 1 \
115 | -font {-slant italic -family Times -size 12} \
116 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
117 | -command [list changeFont $msg]
118 | grid $fp.italic -row 0 -column 7 -sticky nsew
119 |
120 | # overstrike
121 | checkbutton $fp.overstrike -variable overstrike -indicatoron false \
122 | -onvalue 1 -offvalue 0 \
123 | -text "O" -width 2 -height 1 \
124 | -font {-overstrike 1 -family Times -size 12} \
125 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
126 | -command [list changeFont $msg]
127 | grid $fp.overstrike -row 0 -column 8 -sticky nsew
128 |
129 | # this gives us relatively square buttons that fill the frame
130 | # in the Y direction
131 | bind $fp {
132 | grid columnconfigure %W 5 -minsize %h
133 | grid columnconfigure %W 6 -minsize %h
134 | grid columnconfigure %W 7 -minsize %h
135 | grid columnconfigure %W 8 -minsize %h
136 | }
137 | # put focus on the first widget
138 | catch {focus $fp.famCombo}
139 |
140 | return ""
141 | }
142 |
143 | # this proc changes the font. It is called by various methods, so
144 | # the only parameter we are guaranteed is the first one since
145 | # we supply it ourselves...
146 | proc ::changeFont {w args} {
147 | foreach foo [list family size weight underline slant overstrike] {
148 | if {[set ::$foo] == ""} {
149 | return
150 | }
151 | }
152 | set ::fontspec [list \
153 | -family $::family \
154 | -size $::size \
155 | -weight $::weight \
156 | -underline $::underline \
157 | -slant $::slant \
158 | -overstrike $::overstrike \
159 | ]
160 | $w configure -font $::fontspec
161 | }
162 |
163 | main
164 |
--------------------------------------------------------------------------------
/lib/combobox/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 |
2 | package ifneeded combobox 2.3 \
3 | [list tclPkgSetup $dir combobox 2.3 {{combobox.tcl source ::combobox::combobox}}]
4 |
5 |
--------------------------------------------------------------------------------
/lib/gui/actionmanager.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # actionmanager.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A manager for user actions.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | snit::type ::gui::actionmanager {
14 | #-------------------------------------------------------------------
15 | # Options
16 |
17 | # A command to call if an error is thrown on invocation of an action.
18 | # The command will be passed three arguments, the error message,
19 | # error code, and error info.
20 | option -errorcommand {}
21 |
22 | # A command to call to check the state (normal or disabled) of an
23 | # action.
24 | option -statecommand {}
25 |
26 | #-------------------------------------------------------------------
27 | # Instance Variables
28 |
29 | # A list of action names:
30 | variable actions {}
31 |
32 | # The following variables constitute the action database. Each
33 | # is an array, keyed on the action name.
34 |
35 | variable command ;# The Tcl command to execute when invoked.
36 | variable state ;# 1 or 0; enabled or disabled.
37 | variable label ;# The label, for menus and buttons.
38 | variable requires ;# List of condition tags.
39 | variable options ;# List of options and values
40 | variable keycodes ;# list: key-sequence menu-accelerator
41 | variable widgets ;# list: widget names
42 |
43 | #-------------------------------------------------------------------
44 | # Constructor
45 |
46 | # At present, no constructor is needed.
47 |
48 | #-------------------------------------------------------------------
49 | # Public Methods
50 |
51 | # Creates a new action with the specified name and options.
52 | method add {action args} {
53 | if {![regexp {^\S+$} $action]} {
54 | error "action name '$action' contains whitespace"
55 | }
56 |
57 | if {[info exists command($action)]} {
58 | error "action '$action' is already defined"
59 | }
60 |
61 | # Initialize the database.
62 | lappend actions $action
63 |
64 | set command($action) {}
65 | set label($action) {}
66 | set state($action) normal
67 | set requires($action) {}
68 | set options($action) {}
69 | set keycodes($action) {}
70 | set widgets($action) {}
71 |
72 | # Handle the options
73 | foreach {opt value} $args {
74 | switch -exact -- $opt {
75 | -command {
76 | set command($action) $value
77 | }
78 | -requires {
79 | set requires($action) $value
80 | }
81 | -label {
82 | # Figure out the underline index and update the label
83 | set underline [string first "&" $value]
84 |
85 | if {$underline < 0} {
86 | set underline 0
87 | set lbl $value
88 | } else {
89 | set lbl [string replace $value $underline $underline]
90 | }
91 |
92 | lappend options($action) -underline $underline
93 | set label($action) $lbl
94 | }
95 | -image -
96 | -tooltip {
97 | lappend options($action) $opt $value
98 | }
99 | -state {
100 | $self setstate $action $value
101 | }
102 | -keycodes {
103 | if {([llength $value] % 2) != 0} {
104 | error "invalid -keycodes: '$value'"
105 | }
106 | set gui [tk windowingsystem]
107 |
108 | array set codes $value
109 |
110 | if {[info exists codes($gui)]} {
111 | set keycodes($action) $codes($gui)
112 | } elseif {[info exists codes(any)]} {
113 | set keycodes($action) $codes(any)
114 | }
115 | }
116 | -keytag {
117 | $self bindkey $value $action
118 | }
119 | default {
120 | error "unknown option '$opt'"
121 | }
122 | }
123 | }
124 | }
125 |
126 | # Returns a list of all existing actions. If the state is given,
127 | # (normal | disabled) then it returns a list of all actions
128 | # that have that state. Note that updatestate is *NOT* called.
129 | # Call it explicitly if you want it.
130 | method list {{whichstate ""}} {
131 | if {$whichstate eq ""} {
132 | return $actions
133 | }
134 |
135 | set result {}
136 | foreach action $actions {
137 | if {$state($action) eq $whichstate} {
138 | lappend result $action
139 | }
140 | }
141 |
142 | return $result
143 | }
144 |
145 | # Invokes the action, e.g., calls its -command. This is done whether
146 | # the action is enabled or not, as it allows the command to present
147 | # a suitable error message.
148 | method invoke {action args} {
149 | # FIRST, if no error handler just let nature take its course.
150 | if {$options(-errorcommand) eq {}} {
151 | uplevel \#0 $command($action) $args
152 | return
153 | }
154 |
155 | # OTHERWISE, catch any error and pass it to the error handler.
156 | # If the error handler throws an error, then again let nature
157 | # take its course.
158 | if {[catch {uplevel \#0 $command($action) $args} msg]} {
159 | global errorCode
160 | global errorInfo
161 |
162 | uplevel \#0 $options(-errorcommand) \
163 | [list $msg $errorInfo $errorCode]
164 | }
165 |
166 | return
167 | }
168 |
169 | # Sets the state of the named action to normal or disabled.
170 | method setstate {action newstate} {
171 | if {$newstate ne "normal" && $newstate ne "disabled"} {
172 | error "Invalid state: '$newstate'"
173 | }
174 |
175 | set state($action) $newstate
176 |
177 | foreach {type widget} $widgets($action) {
178 | switch -exact $type {
179 | button {
180 | $widget configure -state $newstate
181 | }
182 | menu {
183 | set ndx [$widget index $label($action)]
184 |
185 | $widget entryconfigure $ndx -state $newstate
186 | }
187 | default {
188 | error "Invalid widget type: $type"
189 | }
190 | }
191 | }
192 | }
193 |
194 | # Update state: For every action that has a -requires value,
195 | # run the state command, passing it the action's name and its requirements.
196 | # The state command must return the new state.
197 | method updatestate {} {
198 | if {[llength $options(-statecommand)] == 0} {
199 | return
200 | }
201 |
202 | foreach action $actions {
203 | if {$requires($action) ne ""} {
204 | set cmd $options(-statecommand)
205 | lappend cmd $action $requires($action)
206 |
207 | $self setstate $action [uplevel \#0 $cmd]
208 | }
209 | }
210 |
211 | # Without this, sometimes widget states aren't updated promptly
212 | # on Aqua.
213 | update idletasks
214 | }
215 |
216 | # bindkey tag action ?break?
217 | #
218 | # If a keysequence exists for the action,
219 | # binds the action to the tag (usually a window).
220 | # break is included, the binding will "break".
221 | #
222 | # If there's no keysequence defined, then no binding is done.
223 |
224 | method bindkey {tag action {break ""}} {
225 | # Get the binding for this GUI. If none found, we're done.
226 | set seq [lindex $keycodes($action) 0]
227 |
228 | if {$seq eq ""} {
229 | return
230 | }
231 |
232 | # Do the binding, adding "break" as requested.
233 | set cmd [mymethod invoke $action]
234 |
235 | if {$break eq "break"} {
236 | append cmd "; break"
237 | }
238 |
239 | # If the binding is a modified letter key, do both upper and
240 | # lower case.
241 | if {[regexp {^<(.*)-([a-z])>$} $seq dummy root letter]} {
242 | set upper [string toupper $letter]
243 | set lower [string tolower $letter]
244 |
245 | bind $tag <$root-$upper> $cmd
246 | bind $tag <$root-$lower> $cmd
247 | } else {
248 | bind $tag $seq $cmd
249 | }
250 | }
251 |
252 | # Configures a button to invoke this action; also sets the button's
253 | # label or icon, etc.
254 |
255 | method addbutton {button action args} {
256 | array set opt $options($action)
257 |
258 | button $button \
259 | -command [mymethod invoke $action] \
260 | -state $state($action)
261 |
262 | if {[info exists opt(-image)]} {
263 | $button configure -image $opt(-image)
264 | } else {
265 | $button configure -text $label($action) -underline $opt(-underline)
266 | }
267 |
268 | eval $button configure $args
269 |
270 | # Enable tool tips--except with aqua on Mac OS X, because it
271 | # causes the focus to go away.
272 | if {[info exists opt(-tooltip)]} {
273 | tooltip register $button $opt(-tooltip)
274 | }
275 |
276 | lappend widgets($action) button $button
277 |
278 | return $button
279 | }
280 |
281 |
282 | # Adds a command item for the action to the named menu, and configures
283 | # additional options if desired.
284 |
285 | method addmenuitem {menu action args} {
286 | array set opt $options($action)
287 |
288 | $menu add command \
289 | -command [mymethod invoke $action] \
290 | -label $label($action) \
291 | -underline $opt(-underline) \
292 | -state $state($action) \
293 | -accelerator [lindex $keycodes($action) 1]
294 |
295 | set ndx [$menu index $label($action)]
296 |
297 | foreach {option value} $args {
298 | $menu entryconfigure $ndx $option $value
299 | }
300 |
301 | lappend widgets($action) menu $menu
302 |
303 | # Add a post command to the menu to update the state.
304 | # TBD: Consider making this explicit.
305 | $menu configure -postcommand [mymethod updatestate]
306 | }
307 | }
308 |
309 |
--------------------------------------------------------------------------------
/lib/gui/bullet1.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet1.gif
--------------------------------------------------------------------------------
/lib/gui/bullet2.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet2.gif
--------------------------------------------------------------------------------
/lib/gui/bullet3.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet3.gif
--------------------------------------------------------------------------------
/lib/gui/gui.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # gui.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Main file for the gui package. This package contains
10 | # reusable GUI components written for the Notebook application.
11 | #
12 | #-----------------------------------------------------------------------
13 |
14 | package provide gui 1.0
15 |
16 | package require BWidget 1.9
17 |
18 | namespace eval ::gui:: {
19 | variable library [file dirname [info script]]
20 | variable defaultBackground [. cget -background]
21 |
22 | namespace export actionmanager
23 | namespace export assert
24 | namespace export hasbinding
25 | namespace export require
26 | namespace export rotext
27 | namespace export searchentry
28 | namespace export statusentry
29 | namespace export tooltip
30 | namespace export windowmanager
31 | namespace export windowmenu
32 | }
33 |
34 | #-----------------------------------------------------------------------
35 | # Widget Tweaks for all windowing systems
36 |
37 | # Menu widget
38 | option add *Menu.tearOff no
39 |
40 | #-----------------------------------------------------------------------
41 | # Widget Tweaks for X11
42 |
43 | if {[tk windowingsystem] eq "x11"} {
44 | # On X11, there are quite a few widget option tweaks we'd like to
45 | # do.
46 |
47 | # Text widgets
48 | option add *Text.background white
49 | option add *Text.foreground black
50 | option add *Text.selectBorderWidth 0
51 |
52 | # Scrollbar widgets
53 | option add *Scrollbar.activeBackground $::gui::defaultBackground
54 |
55 | # Button widgets
56 | option add *Button.activeBackground $::gui::defaultBackground
57 | option add *Button.borderWidth 1
58 |
59 | # Menu widgets
60 | option add *Menu.activeBackground "dark blue"
61 | option add *Menu.activeForeground white
62 | option add *Menu.activeBorderWidth 0
63 | option add *Menu.borderWidth 1
64 |
65 | # Entry widgets
66 | option add *Entry.background white
67 | option add *Entry.foreground black
68 | option add *Entry.selectBorderWidth 0
69 | }
70 |
71 | #-----------------------------------------------------------------------
72 | # Widget Tweaks for Mac OS X
73 |
74 | if {[tk windowingsystem] eq "aqua"} {
75 | bind Listbox [bind Listbox ]
76 | }
77 |
78 |
79 |
80 | #-----------------------------------------------------------------------
81 | # Virtual Event Definitions
82 |
83 | # Cut, Copy, Paste, Undo, Redo
84 |
85 | if {[tk windowingsystem] eq "x11"} {
86 | # On X11, we want the standard win32 keybindings for cut, copy, paste,
87 | # undo, and redo to work throughout. So make those keybindings generate
88 | # the relevant virtual events.
89 | #
90 | # 4/28/05: Make sure both upper and lower case work the same.
91 |
92 | event add <>
93 | event add <>
94 | event add <>
95 | event add <>
96 | event add <>
97 | event add <>
98 | event add <>
99 | event add <>
100 |
101 | # Note that is already defined as <>,
102 | # mean ; I need to get rid of that, or
103 | # won't work for <>
104 | event delete <>
105 |
106 | # On X11, <> should be . Provide it in
107 | # both flavors.
108 | event add <>
109 | event add <>
110 |
111 | # In text widgets, the Control-v key can be bound to something else on
112 | # X11. So explicitly unbind it.
113 | bind Text ""
114 | } elseif {[tk windowingsystem] eq "win32"} {
115 | # On Windows, we want the uppercase version of control keys to
116 | # work just like the lower case. So add them all. Include
117 | # the regular ones, just to be explicit.
118 |
119 | event add <>
120 | event add <>
121 | event add <>
122 | event add <>
123 | event add <>
124 | event add <>
125 | event add <>
126 | event add <>
127 | event add <>
128 | event add <>
129 | } elseif {[tk windowingsystem] eq "aqua"} {
130 | # On Mac OS X, we want the uppercase version of control keys to
131 | # work just like the lower case. So add them.
132 |
133 | event add <>
134 | event add <>
135 | event add <>
136 | event add <>
137 | event add <>
138 | event add <>
139 | event add <>
140 | event add <>
141 |
142 | # Tk.tcl erroneously adds Command-y for <>;
143 | # get rid of it before adding the correct keys.
144 | event delete <>
145 |
146 | event add <>
147 | event add <>
148 | }
149 |
150 |
151 | #-----------------------------------------------------------------------
152 | # GUI Component Definitions
153 |
154 | source [file join $::gui::library misc.tcl]
155 | source [file join $::gui::library icon.tcl]
156 | source [file join $::gui::library actionmanager.tcl]
157 | source [file join $::gui::library windowmanager.tcl]
158 | source [file join $::gui::library statusentry.tcl]
159 | source [file join $::gui::library searchentry.tcl]
160 | source [file join $::gui::library rotext.tcl]
161 | source [file join $::gui::library tooltip.tcl]
162 |
163 |
--------------------------------------------------------------------------------
/lib/gui/misc.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # misc.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # GUI Helper Functions for notebook's gui package.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | # Does window $win have a binding for the event in any of its
14 | # bind tags?
15 | proc ::gui::hasbinding {win event} {
16 | if {$win eq ""} {
17 | return 0
18 | }
19 |
20 | foreach tag [bindtags $win] {
21 | if {[bind $tag $event] ne ""} {
22 | return 1
23 | }
24 | }
25 |
26 | return 0
27 | }
28 |
29 | # require expression message
30 | #
31 | # GUIs often have to do a lot of checking to see whether a given
32 | # user-requested action is valid or not, both in terms of program state
33 | # and in terms of the user's input. Procs that implement these actions
34 | # consequently usually begin with a series of if statements; each statement
35 | # checks a condition, emits some appropriate error message to the user, and
36 | # returns. In many cases, this is the bulk of the command.
37 | #
38 | # require streamlines this kind of code, and makes it work better when nested.
39 | # require evaluates the expression. If it's true, require returns
40 | # silently. But if it's false, require throws an error using the
41 | # given message and an errorcode of "USER". This has a number of
42 | # effects on procs written using require:
43 | #
44 | # * They are useful programmatically.
45 | # * They don't need to know how errors are reported to the user.
46 | # * They allow the caller to distinguish between user input errors
47 | # and unexpected programming errors.
48 | # * They can't be attached directly to menu items, buttons, etc.,
49 | # because they need a mediator to catch and present the error.
50 | #
51 | # Thus, using require necessitates some kind of glue mechanism, like
52 | # an action manager of some kind.
53 |
54 | proc ::gui::require {expression message} {
55 | if {[uplevel [list expr $expression]]} {
56 | return
57 | }
58 |
59 | return -code error -errorcode USER $message
60 | }
61 |
62 | # assert expression
63 | #
64 | # Assert is like require, but is used for checking invariants--in
65 | # correctly written code, the expression should invariably be true.
66 | # If the assertion fails an error is thrown indicating
67 | # that an assertion failed and what the condition was.
68 |
69 | proc ::gui::assert {expression} {
70 | if {[uplevel [list expr $expression]]} {
71 | return
72 | }
73 |
74 | return -code error -errorcode ASSERT "Assertion failed: $expression"
75 |
76 | }
--------------------------------------------------------------------------------
/lib/gui/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 | # Tcl package index file
2 |
3 | package ifneeded gui 1.0 \
4 | [list source [file join $dir gui.tcl]]
5 |
6 |
--------------------------------------------------------------------------------
/lib/gui/rotext.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # rotext.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A read-only text widget. A rotext behaves in all ways identical
10 | # to a normal text widget, except that text cannot be inserted or
11 | # deleted by the user.
12 | #
13 | # The widget was made read-only by overriding the "insert" and
14 | # "delete" widget subcommands. They have been replaced by
15 | # "ins" and "del" which do the same thing, but which aren't
16 | # available to the standard mouse and keyboard bindings.
17 | #
18 | # This sneaky trick is due to Donal K. Fellows at the
19 | # Tcler's Wiki; the widget is implemented using snit.
20 | #
21 | # LICENSE:
22 | # Copyright (C) 2003 by William H. Duquette. This file may
23 | # be used subject to the terms in license.txt.
24 | #
25 | #-----------------------------------------------------------------------
26 |
27 | #-----------------------------------------------------------------------
28 | # Public methods
29 |
30 | snit::widgetadaptor ::gui::rotext {
31 | constructor {args} {
32 | # First, create the real text widget.
33 | installhull [text $self -insertwidth 0]
34 | $self configurelist $args
35 |
36 | # Next, copy the default Text bindings to the renderpane,
37 | # and adjust the bindtags so that the Text bindings no longer
38 | # matter. This will allow us to override them.
39 |
40 | foreach sym [bind Text] {
41 | bind $win $sym [bind Text $sym]
42 | }
43 |
44 | set bt [bindtags $win]
45 | set ndx [lsearch -exact $bt Text]
46 | bindtags $win [lreplace $bt $ndx $ndx]
47 |
48 | # Next, remove the <> and <> tags, etc., since renderpanes
49 | # aren't editable.
50 | bind $win <> ""
51 | bind $win <> ""
52 | bind $win <> ""
53 | bind $win <> ""
54 | }
55 |
56 | # Disable the insert and delete methods, to make this readonly.
57 | method insert {args} {}
58 | method delete {args} {}
59 |
60 | # Enable ins and del as synonyms, so the program can insert and
61 | # delete.
62 | delegate method ins to hull as insert
63 | delegate method del to hull as delete
64 |
65 | # Pass all other methods and options to the real text widget, so
66 | # that the remaining behavior is as expected.
67 | delegate method * to hull
68 | delegate option * to hull
69 | }
70 |
71 |
72 |
73 |
--------------------------------------------------------------------------------
/lib/gui/searchentry.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # searchentry.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A searchentry is an ornamented entry field. The entry is flanked
10 | # on the left by a pulldown that lets the user select one of a number
11 | # search modes, and on the right by a clear button. All three
12 | # components are contained in a single visible border.
13 | #
14 | # The pulldown entries are determined by a widget option.
15 | # The active pulldown selection is also an option.
16 | # The searchentry supports incremental and non-incremental search.
17 | # When the search text is ready, a user-supplied command is called;
18 | # it is passed the search text and the current pulldown option.
19 | #
20 | #-----------------------------------------------------------------------
21 |
22 | snit::widget ::gui::searchentry {
23 | #-------------------------------------------------------------------
24 | # Components
25 |
26 | # The arrow button
27 | variable arrow
28 |
29 | # The entry
30 | delegate option -width to entry
31 |
32 | # The clear button
33 | variable clear
34 |
35 | # The mode menu
36 | variable modemenu
37 |
38 | #-------------------------------------------------------------------
39 | # Variables
40 |
41 | # TBD
42 |
43 | #-------------------------------------------------------------------
44 | # Creation Time Options
45 | #
46 | # These options should only be set at creation time. Note that
47 | # at present there's no error checking to prevent them from being
48 | # set later.
49 |
50 | # A list of mutually exclusive search modes and labels, e.g.,
51 | # -modelist {title "Title Only" all "Title and Contents"}
52 | option -modelist {}
53 |
54 | #--------------------------------------------------------------------
55 | # Other Options
56 |
57 | # The selected search mode: defaults to the first mode in the
58 | # -modelist, or "default" if there is no -modelist.
59 | #
60 | # WARNING: If there's a -modelist, this should only be set to one
61 | # of the modes defined in it. Note that there's no error checking
62 | # on this at present.
63 | option -mode default
64 |
65 | # The user's callback command. It should take two arguments,
66 | # the search mode and the search text. If {}, no command is called.
67 | option -searchcmd {}
68 |
69 | # 1 if we're to do incremental search, and 0 otherwise.
70 | option -incremental 1
71 |
72 | # The search text; maps to the entry's contents. Setting initiates
73 | # a search.
74 | option -searchtext -configuremethod CfgSearchText
75 |
76 | method CfgSearchText {opt value} {
77 | set options($opt) $value
78 |
79 | $self UpdateClear
80 | $self DoSearch complete
81 | }
82 |
83 | #-------------------------------------------------------------------
84 | # Constructor
85 |
86 | constructor {args} {
87 | # FIRST, set the hull's border
88 | $hull configure -relief solid -borderwidth 1 -background white
89 |
90 | # NEXT, get the modelist, since we need it early
91 | set options(-modelist) [from args -modelist]
92 |
93 | # NEXT, identify the search box
94 | label $win.search \
95 | -relief flat \
96 | -borderwidth 0 \
97 | -background white \
98 | -foreground black \
99 | -image ::gui::search
100 |
101 | # NEXT, create the pulldown's arrow button
102 | install arrow using label $win.arrow \
103 | -relief flat \
104 | -borderwidth 0 \
105 | -background white \
106 | -foreground black \
107 | -image ::gui::downarrow
108 |
109 | # Next, create the popup.
110 | install modemenu using menu $win.modemenu \
111 | -tearoff no
112 | bind $arrow <1> [mymethod PostModeMenu]
113 |
114 | $modemenu add radiobutton \
115 | -variable [myvar options(-incremental)] \
116 | -value 1 \
117 | -label "Incremental Search"
118 |
119 | $modemenu add radiobutton \
120 | -variable [myvar options(-incremental)] \
121 | -value 0 \
122 | -label "Non-Incremental Search"
123 |
124 | # If we have modes, add them.
125 | if {[llength $options(-modelist)] > 1} {
126 |
127 | set options(-mode) [lindex $options(-modelist) 0]
128 |
129 | $modemenu add separator
130 |
131 | foreach {mode label} $options(-modelist) {
132 | $modemenu add radiobutton \
133 | -variable [myvar options(-mode)] \
134 | -value $mode \
135 | -label $label \
136 | -command [mymethod DoSearch]
137 | }
138 | }
139 |
140 | # NEXT, create the entry
141 | install entry using entry $win.entry \
142 | -width 20 \
143 | -background white \
144 | -foreground black \
145 | -borderwidth 0 \
146 | -relief flat \
147 | -highlightthickness 0 \
148 | -textvariable [myvar options(-searchtext)]
149 |
150 | bindtags $entry [concat [bindtags $entry] $win]
151 |
152 | bind $win [mymethod KeyPress]
153 | bind $win [mymethod Return]
154 | bind $win [mymethod Clear]
155 |
156 | # NEXT, if the megawidget gets the focus, it should go to the entry.
157 | bind $win [mymethod FocusIn]
158 |
159 | # NEXT, create the clear button
160 | install clear using label $win.clear \
161 | -relief flat \
162 | -borderwidth 0 \
163 | -background white \
164 | -foreground black \
165 | -image ::gui::closex \
166 | -state disabled
167 | bind $clear <1> [mymethod Clear]
168 |
169 | # Pack all of the components into the hull
170 | pack $win.search -side left -fill y -padx 2 -pady 2
171 | pack $arrow -side left -fill y -padx 2 -pady 2
172 | pack $clear -side right -fill y -padx 2 -pady 2
173 | pack $entry -side left -fill both -pady 2 -expand 1
174 |
175 | # Apply the arguments
176 | $self configurelist $args
177 | }
178 |
179 | #-------------------------------------------------------------------
180 | # Private methods
181 |
182 | method FocusIn {} {
183 | focus $entry
184 | $entry selection range 0 end
185 | }
186 |
187 | method KeyPress {} {
188 | $self UpdateClear
189 |
190 | if {!$options(-incremental)} {
191 | return
192 | }
193 |
194 | $self DoSearch incremental
195 |
196 | # We must have had the focus before, since this call only comes
197 | # because of a KeyPress. So put the focus back in the entry
198 | # widget in case the search callback changed it.
199 | focus $entry
200 | }
201 |
202 | method UpdateClear {} {
203 | if {[string length $options(-searchtext)] > 0} {
204 | $clear configure -state normal
205 | } else {
206 | $clear configure -state disabled
207 | }
208 | }
209 |
210 | method Return {} {
211 | $self DoSearch complete
212 |
213 | # We don't want to call KeyRelease, so break the event.
214 | return -code break
215 | }
216 |
217 | method DoSearch {searchtype} {
218 | # Call the search command
219 | set command $options(-searchcmd)
220 | lappend command $options(-mode) $searchtype $options(-searchtext)
221 | uplevel \#0 $command
222 | }
223 |
224 | method Clear {} {
225 | set options(-searchtext) ""
226 | $clear configure -state disabled
227 | $self DoSearch complete
228 | }
229 |
230 | method PostModeMenu {} {
231 | set x [winfo rootx $arrow]
232 | set y [expr {[winfo rooty $arrow] + [winfo height $arrow]}]
233 |
234 | tk_popup $modemenu $x $y
235 | }
236 | }
237 |
238 |
--------------------------------------------------------------------------------
/lib/gui/tooltip.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # tooltip.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Tool tips for notebook's gui package.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | #-----------------------------------------------------------------------
14 | # Tooltip type
15 | #
16 | # The tooltip command is an instance of TooltipType, so that we can
17 | # have options.
18 |
19 | snit::type ::gui::TooltipType {
20 | #-------------------------------------------------------------------
21 | # Options
22 |
23 | option -font {Helvetica 12}
24 | option -background "#FFFFC0"
25 | option -topbackground black
26 | option -foreground black
27 | option -delay 800
28 |
29 | #-------------------------------------------------------------------
30 | # Variables
31 |
32 | # Tool tip text. An array, indexed by window name
33 | variable tiptext
34 |
35 | # Tool tip timeout, or {}
36 | variable timeout {}
37 |
38 | # Tool tip window, or {}
39 | variable tipwin {}
40 |
41 | #-------------------------------------------------------------------
42 | # Constructor
43 |
44 | # Implicit
45 |
46 | #-------------------------------------------------------------------
47 | # Public methods
48 |
49 | method register {window text} {
50 | set tiptext($window) $text
51 |
52 | bind $window [mymethod Enter $window]
53 | bind $window [mymethod Leave $window]
54 | }
55 |
56 | method unregister {window} {
57 | unset tiptext($window)
58 | }
59 |
60 | #-------------------------------------------------------------------
61 | # Private Methods
62 |
63 | # When the mouse pointer enters the window, set the timer.
64 | method Enter {window} {
65 | set timeout [after $options(-delay) [mymethod Popup $window]]
66 | }
67 |
68 | # Pop up the tooltip.
69 | method Popup {window} {
70 | # FIRST, the timeout has fired, so we can forget it.
71 | set timeout {}
72 |
73 | # NEXT, the tooltip will be a child of the window's toplevel.
74 | set top [winfo toplevel $window]
75 |
76 | # NEXT, the tooltip's name depends on which toplevel it is.
77 | set tipwin ".gui_tooltip_window"
78 |
79 | if {$top ne "."} {
80 | set tipwin "$top$tipwin"
81 | }
82 |
83 | # NEXT, create the tooltip window.
84 | frame $tipwin \
85 | -background $options(-topbackground)
86 |
87 | label $tipwin.label \
88 | -text $tiptext($window) \
89 | -foreground $options(-foreground) \
90 | -background $options(-background) \
91 | -font $options(-font)
92 |
93 | # Pack the label with a 1 pixel gap, so that there's a box
94 | # around it.
95 | pack $tipwin.label -padx 1 -pady 1
96 |
97 | # NEXT, the tipwin will be placed in the toplevel relative to
98 | # the position of the registered window. We'll figure this out
99 | # by getting the position of both relative to the root window.
100 |
101 | set tx [winfo rootx $top]
102 | set ty [winfo rooty $top]
103 |
104 | set wx [winfo rootx $window]
105 | set wy [winfo rooty $window]
106 |
107 | # We want to the tip to appear below and to the right of the
108 | # registered window.
109 | set offset [expr {[winfo width $window]/2}]
110 |
111 | # Compute the final position.
112 | set x [expr {($wx - $tx) + $offset}]
113 | set y [expr {($wy - $ty) + [winfo height $window] + 2}]
114 |
115 | # Finally, place the tipwin in its position.
116 | place $tipwin -anchor nw -x $x -y $y
117 |
118 | # If the tipwin runs off the right edge, we slide it left; if
119 | # it sticks off the bottom edge, we put it above the button instead.
120 | # If it still can't be seen, that's too bad.
121 | #
122 | # NOTE: I don't know of any way to determine the size of the
123 | # tipwin without letting it pop up, which causes an ugly
124 | # jump when it has to be moved.
125 | update idletasks
126 |
127 | set nx $x
128 | set ny $y
129 |
130 | set rightEdge [expr {$x + [winfo width $tipwin]}]
131 | set topWid [winfo width $top]
132 |
133 | if {$rightEdge >= $topWid} {
134 | set nx [expr {$x - ($rightEdge - $topWid + 2)}]
135 | }
136 |
137 | set bottomEdge [expr {$y + [winfo height $tipwin] + 2}]
138 | set topHt [winfo height $top]
139 |
140 | if {$bottomEdge >= $topHt} {
141 | set ny [expr {($wy - $ty) - [winfo height $tipwin] - 2}]
142 | }
143 |
144 | if {$nx != $x || $ny != $y} {
145 | place $tipwin -anchor nw -x $nx -y $ny
146 | }
147 | }
148 |
149 | # When the mouse pointer leaves the window, cancel the timer or
150 | # popdown the window, as needed.
151 | method Leave {window} {
152 | if {$timeout ne ""} {
153 | after cancel $timeout
154 | set timeout ""
155 | return
156 | }
157 |
158 | if {$tipwin ne ""} {
159 | destroy $tipwin
160 | set tipwin ""
161 | }
162 | }
163 | }
164 |
165 | #-----------------------------------------------------------------------
166 | # The tooltip command
167 |
168 | ::gui::TooltipType ::gui::tooltip
169 |
--------------------------------------------------------------------------------
/lib/gui/windowmanager.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # windowmanager.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # notebook-gui component: manages multiple toplevel windows so that
10 | # the when the last one is destroyed, the application termiantes.
11 | #
12 | # To participate, toplevel windows register with the windowmanager
13 | # on creation. A WM_DELETE_WINDOW handler is created automatically.
14 | # If a registered toplevel window wishes to destroy itself, it must
15 | # call "windowmanager destroy $win", which will in turn destroy the
16 | # window.
17 | #
18 | # windowmanager doesn't withdraw "."; the application must do that
19 | # for itself.
20 | #
21 | #-----------------------------------------------------------------------
22 |
23 | # windowmanager is a snit::type used as a singleton.
24 |
25 | snit::type ::gui::windowmanager {
26 | pragma -hasinstances no
27 | pragma -hastypedestroy no
28 |
29 | #-------------------------------------------------------------------
30 | # Type Variables
31 |
32 | # Tracks the open windows. When all are closed, the
33 | # program is terminated.
34 | typevariable windowList
35 |
36 | #-------------------------------------------------------------------
37 | # typemethods
38 |
39 | # Shadow the default create method
40 | typemethod create {args} {
41 | error "invalid method"
42 | }
43 |
44 | # register a new window
45 | typemethod register {window} {
46 | lappend windowList $window
47 |
48 | wm protocol $window WM_DELETE_WINDOW [list $type destroy $window]
49 | }
50 |
51 | # destroy a window
52 | typemethod destroy {window} {
53 | set ndx [lsearch -exact $windowList $window]
54 |
55 | if {$ndx == -1} {
56 | error "can't destroy '$window': not registered with windowmanager"
57 | }
58 |
59 | set windowList [lreplace $windowList $ndx $ndx]
60 |
61 | destroy $window
62 |
63 | if {[llength $windowList] == 0} {
64 | exit 0
65 | }
66 | }
67 |
68 | # Return the list of windows
69 | typemethod windows {} {
70 | return $windowList
71 | }
72 |
73 | # Raise the named window
74 | typemethod raise {window} {
75 | raise $window
76 | wm deiconify $window
77 | }
78 | }
79 |
80 |
--------------------------------------------------------------------------------
/lib/markupparser/README.txt:
--------------------------------------------------------------------------------
1 | markupparser 2.0
2 | -----------------------------------------------------------------
3 |
4 | markupparser parses Notebook markup into an intermediary form,
5 | a flat list of tag/value pairs. The parsing proceeds by first
6 | breaking the input into chunk, where each chunk consists
7 | of one or more full lines of text. There are (at present)
8 | four kinds of chunk:
9 |
10 | Directives
11 | A directive is a line beginning with a hash "#" character;
12 | the specific directive is determined by the text that follows
13 | the hash character. Unless otherwise indicated, any
14 | subsequent text on the line is ignored. Unrecognized
15 | directives are permitted. The existing directives are as
16 | follows:
17 |
18 | #---
19 | Rendered as a horizontal line, e.g.,
.
20 |
21 | #pre
22 | Begins a chunk of preformatted text.
23 |
24 | #unpre
25 | Ends a chunk of preformatted text.
26 |
27 | #Tcl
28 | Begins a chunk of Tcl Code
29 |
30 | #unTcl
31 | Ends a chunk of Tcl Code
32 |
33 | #meta
34 | Defines a named value associated with the pages. It will be
35 | possible to query a page for its metadata.
36 |
37 | #data
38 | Begins a data chunk. A data chunk is just like a Tcl Code or
39 | preformatted text chunk in terms of how it's handled; however,
40 | it will allow other code to easily extract data of a specific
41 | type from a page. Eventually, it might be possible to add
42 | rendering plugins for specific data types.
43 |
44 | #undata
45 | Ends a data chunk.
46 |
47 | Preformatted
48 | A preformatted chunk is to be rendered verbatim in a
49 | fixed-width font. Performatted chunks are found in two
50 | ways: either a paragraph whose first line begins with
51 | a whitespace character, or a group of lines beginning with
52 | a "#pre" directive and ending with a "#unpre" directive
53 | (or the end of the input). (The directives are not
54 | part of the chunk.)
55 |
56 | Tcl Code
57 | A Tcl code chunk is usually rendered Preformatted; it is
58 | a group of lines bracketed by "#Tcl" and "#unTcl".
59 |
60 | Wrapped Text
61 | A wrapped text paragraph consists of one or more lines of
62 | possibly styled text. Wrapped text paragraphs can be
63 | indented; if indented they can have a bullet. Wrapped
64 | text can also contain links, magic buttons, and embedded
65 | macros.
66 |
67 | Note: embedded macros are usually expanded *before* parsing
68 | the markup, so usually there won't be any in the input. If
69 | there are any, they could be anywhere, in any kind of text.
70 | However, the parser will only recognize them in wrapped text.
71 |
72 | Pass-through Text
73 | Sometimes it's desirable to include text in a page that will be
74 | passed through the parser unchanged, e.g., when using macros
75 | to generate HTML in a page that will be exported as HTML.
76 | There are two ways to specify pass-through text.
77 |
78 | #data thru
79 | Text to be passed through.
80 | #undata
81 |
82 | Text wrapped by #data thru/#undata will go through the parser
83 | unchanged, and will be handled by output processors as a single
84 | paragraph.
85 |
86 | This text has some HTML markup.
87 |
88 | Within a paragraph of wrapped text, the ...
89 | tags can be used to quote a section of text to pass
90 | through unchanged. If the example above were exported
91 | as HTML without the ... tags, the angle
92 | brackets on and would be escaped as
93 | < and >.
94 |
95 |
96 | Intermediate Form
97 | -----------------------------------------------------------------
98 |
99 | The parser parses the input and produces the intermediate form,
100 | a flat list of tag/value pairs. The tags and their values are
101 | defined as follows:
102 |
103 |
104 | META
105 | The value of META is a dict of the #meta values defined in
106 | this page. If the same keyword appears multiple times, the
107 | final value is retained. If no #meta directives appear in
108 | this page, META appears with an empty list as its value.
109 |
110 | META is always the first tag in the list.
111 |
112 | HASH
113 | One of these pairs is produced for each directive; the value is
114 | the complete line of text, including the newline at the end.
115 |
116 | PRE
117 | This is usually Preformatted text, to be displayed verbatim. The
118 | value is the exact set of lines from the input. If the chunk was
119 | delimited by "#pre" and "#unpre" directives, then this tag/value
120 | will be preceded and followed by the appropriate HASH tag/values.
121 |
122 | TCL
123 | The is a chunk of Tcl code. This tag/value will be preceded
124 | and followed by the "#Tcl" and "#unTcl" HASH tag/values.
125 |
126 | DATA { }
127 | The value of DATA is a list of two elements; the data name from
128 | the #data line and the chunk of data that appeared between the
129 | #data and #undata.
130 |
131 | When the is "thru", the is to be passed through
132 | the parser unchanged.
133 |
134 | P {:|* }
135 | Begins a paragraph of wrapped text. The value is a list of three
136 | items: the paragraph type (":" or "*"), the indent level (0 or
137 | higher) and (for indented and bulleted paragraphs) the leading
138 | string, which is the whitespace between the initial "*" or ":"
139 | and the paragraph text. (It's used to reconstruct a parsed page
140 | just exactly as it was.)
141 |
142 | A normal, non-indented non-bulleted paragraph will begin with
143 |
144 | P {: 0 {}}
145 |
146 | A paragraph with an indent level of 1 will begin with this
147 | (where the length of the leading string depends on the actual
148 | input):
149 |
150 | P {: 1 { }}
151 |
152 | A bulleted paragraph with an indent level of 1 will begin with
153 | this:
154 |
155 | P {* 1 { }}
156 |
157 | For bulleted paragraphs, the indent level must be 1 or more.
158 | Note that a normal paragraph is simply an indented paragraph
159 | with an indent level of zero.
160 |
161 | /P
162 | Terminates a paragraph of wrapped text, of whatever kind.
163 |
164 | The following tags represent components of a paragraph of wrapped
165 | text; they will always appear between P and /P.
166 |
167 | TXT
168 | The value is plain text to be wrapped and rendered.
169 |
170 | THRU
171 | The value is text in the current output format; it
172 | was passed through the parser unchanged.
173 |
174 | STY { }
175 | Notebook markup defines a number of HTML-like style codes,
176 | e.g., ... and .... When one is found in a
177 | wrapped paragraph, this tag is generated. The tag's value is
178 | a list of three elements: the raw style code (), the
179 | style letter (b), and a flag: 1 when the style turns on and
180 | 0 when the style turns off. Note that all styles are
181 | cancelled at the end of the paragraph.
182 |
183 | A renderer is free to render the styles as it prefers.
184 |
185 | LINK
186 | The value is a page link, not including the [ and ].
187 |
188 | BTN
201 | # tags.
202 | incr lev
203 |
204 | append result "[AddEscapes $htext] \n"
205 | }
206 | /P {
207 | set this(inpara) 0
208 | foreach letter [array names sty] {
209 | if {$sty($letter)} {
210 | append result $htmlStyles(${letter}0)
211 | }
212 | }
213 | array set last [array get this]
214 |
215 | if {$this(indent) == 0} {
216 | # Then this is the end of a normal paragraph, which
217 | # needs to be closed.
218 | append result ""
219 | }
220 | }
221 | P {
222 | set this(inpara) 1
223 |
224 | # FIRST, reset all text styles.
225 | array set sty {
226 | m 0 i 0 b 0
227 | h 0 s 0 x 0
228 | }
229 |
230 | # Next, get the paragraph style.
231 | set this(para) [lindex $value 0]
232 | set this(indent) [lindex $value 1]
233 |
234 | # Next, if we're indented less than before, close
235 | # the indentation.
236 | for {set i $this(indent)} {$i < $last(indent)} {incr i} {
237 | append result "\n\n"
238 | }
239 |
240 | # Next, if we're indented more than before, open
241 | # the indentation.
242 | for {set i $last(indent)} {$i < $this(indent)} {incr i} {
243 | append result "\n\n"
244 | }
245 |
246 | # Next, if the indentation is 0, start a new
247 | # paragraph; otherwise start a list item.
248 | if {$this(indent) == 0} {
249 | append result ""
250 | } elseif {$this(para) eq "*"} {
251 | append result "
- "
252 | } elseif {$last(para) eq "*" &&
253 | $this(para) eq ":"} {
254 | append result "
\n"
255 | }
256 | }
257 | TXT {
258 | # Handle Notebook markup pseudo-escapes.
259 | set value [string map [list "&lb;" \[ "&rb;" \]] $value]
260 |
261 | append result $value
262 | }
263 | HTML {
264 | append result $value
265 | }
266 | NL {
267 | append result "\n"
268 | }
269 | STY {
270 | set code [lindex $value 0]
271 | set letter [string index $code 0]
272 | set flag [string index $code 1]
273 |
274 | set sty($letter) $flag
275 | append result $htmlStyles($code)
276 | }
277 | LINK {
278 | set value [::markupparser::normalizeSpace $value]
279 |
280 | if {![regexp {^([^|]+)\|(.*$)} $value dummy linktext name]} {
281 | set linktext $value
282 | set name $value
283 | }
284 |
285 | if {$options(-linkcmd) eq ""} {
286 | append result [AddEscapes $linktext]
287 | continue
288 | }
289 |
290 | set cmd $options(-linkcmd)
291 | lappend cmd $linktext $name
292 |
293 | append result [uplevel \#0 $cmd]
294 | }
295 | BTN {
296 | # Extract just the button text.
297 | set value [lindex [split $value |] 0]
298 |
299 | append result $value
300 | }
301 | OBJECT {
302 | set obj [getobj $value]
303 |
304 | switch -exact [lindex $obj 0] {
305 | image {
306 | set fname [lindex $obj 1]
307 | array set opts [lindex $obj 2]
308 |
309 | append result ""
321 | }
322 | error -
323 | default {
324 | append result [ErrText "
\[!$value!\]
"]
325 | }
326 | }
327 | }
328 | MACRO {
329 | # There shouldn't be any macros. Format the macro
330 | # in red.
331 | append result [ErrText "\[@$value@\]"]
332 | }
333 | }
334 | }
335 |
336 | # If last indent was > 0, close the indentation.
337 | for {set i 0} {$i < $last(indent)} {incr i} {
338 | append result "\n\n"
339 | }
340 |
341 | if {$this(inpara)} {
342 | foreach letter [array names sty] {
343 | if {$sty($letter)} {
344 | append result $htmlStyles(${letter}0)
345 | }
346 | }
347 |
348 | if {$this(indent) == 0} {
349 | # Then this is the end of a normal paragraph, which
350 | # needs to be closed.
351 | append result ""
352 | }
353 | }
354 |
355 | return $result
356 | }
357 |
358 | #-------------------------------------------------------------------
359 | # Utility Procs
360 |
361 | # ErrText text
362 | #
363 | # Wraps the text in a red font.
364 |
365 | proc ErrText {text} {
366 | return "$text"
367 | }
368 |
369 | # AddEscapes text
370 | #
371 | # text plain text to be included in HTML output.
372 | #
373 | # Converts &, <, and > to &, <, and >.
374 |
375 | proc AddEscapes {text} {
376 | regsub -all "&" $text {\&} text
377 | regsub -all "<" $text {\<} text
378 | regsub -all ">" $text {\>} text
379 |
380 | return $text
381 | }
382 | }
383 |
384 |
385 |
386 |
387 |
--------------------------------------------------------------------------------
/lib/app_notebook/nb2mediawiki.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # nb2mediawiki.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # MediaWiki markup exportation code for Notebook files. This module
10 | # knows very little about the Notebook application as a whole;
11 | # such intelligence will be provided by hooks.
12 | #
13 | # LICENSE:
14 | # Copyright (C) 2005 by William H. Duquette. This file may
15 | # be used subject to the terms in license.txt.
16 | #
17 | #-----------------------------------------------------------------------
18 |
19 | #-----------------------------------------------------------------------
20 | # Required Packages
21 |
22 | package require markupparser
23 |
24 | #-----------------------------------------------------------------------
25 | # namespace declaration
26 |
27 | namespace eval ::nb2mediawiki:: {
28 | variable wikiStyles
29 |
30 | # This table indicates the MediaWiki equivalents for each
31 | # Notebook style code.
32 | array set wikiStyles {
33 | m1
34 | m0
35 | i1 ''
36 | i0 ''
37 | b1 '''
38 | b0 '''
39 | h1 {=== }
40 | h0 { ===}
41 | s1
42 | s0
43 | x1
44 | x0
45 | }
46 | }
47 |
48 |
49 |
50 | #-----------------------------------------------------------------------
51 | # Public functions
52 |
53 |
54 | # wikitext markup args
55 | #
56 | # markup Notebook markup to translate
57 | # args Option/value pairs, as follows:
58 | #
59 | # -embeddedhtml 0|1
60 | # If 1, it's assumed that TXT can contain embedded HTML.
61 | # Otherwise, &, <, and > are quoted.
62 | #
63 | # -showhashes unknown|none|all
64 | # Indicates whether hash directives should be included
65 | # in the output. If "unknown", only unknown directives
66 | # are included. If "none", no directives are included;
67 | # if "all", all directives are included. Included
68 | # directives are rendered as preformatted text.
69 |
70 | proc nb2mediawiki::wikitext {markup args} {
71 | variable wikiStyles
72 |
73 | # Allow the options to be passed as a single argument.
74 | if {[llength $args] == 1} {
75 | set args [lindex $args 0]
76 | }
77 |
78 | # Get default option values
79 | array set opts {
80 | -embeddedhtml 0
81 | -showhashes unknown
82 | }
83 |
84 | # Get the caller's values.
85 | # TBD: check errors better.
86 | array set opts $args
87 |
88 | # Set up for processing.
89 | set result ""
90 | set gotNL 1
91 |
92 | foreach {tag value} [::markupparser::parse $markup] {
93 | switch -exact $tag {
94 | META { }
95 | BR {
96 | append result
97 | }
98 | PRE {
99 | # PRE is used to mark blank lines in the input;
100 | # these should be handled separately.
101 | # TBD: See if this statement can be removed.
102 | if {[regexp {^\s*\n\s*$} $value]} {
103 | append result "\n"
104 | continue
105 | }
106 |
107 | # Otherwise, just display the preformatted text.
108 | append result "[AddEscapes $value]
\n"
109 | }
110 | TCL {
111 | # Tcl code is always displayed as preformatted text...
112 | # for now. It would be fun to do code coloring, etc.
113 | append result "[AddEscapes $value]
\n"
114 | }
115 | DATA {
116 | array set fields $value
117 |
118 | # data is shown as PRE.
119 | append result "[AddEscapes $fields(data)]
\n"
120 | }
121 | HASH {
122 | if {[string match \#pre* $value] ||
123 | [string match \#unpre* $value] ||
124 | [string match \#Tcl* $value] ||
125 | [string match \#unTcl* $value] ||
126 | [string match \#data* $value] ||
127 | [string match \#undata* $value] ||
128 | [string match \#meta* $value] ||
129 | [string match \#rem* $value]
130 | } {
131 | if {$opts(-showhashes) eq "all"} {
132 | append result "[AddEscapes $value]
\n"
133 | }
134 | continue
135 | }
136 |
137 | if {[string match \#---* $value]} {
138 | append result "----\n"
139 | continue
140 | }
141 |
142 | # Otherwise, it's an unknown hash; display as PRE.
143 | if {$opts(-showhashes) eq "unknown"} {
144 | append result "[AddEscapes $value]
\n"
145 | }
146 | }
147 | H {
148 | set lev [lindex $value 0]
149 | set htext [lindex $value 1]
150 |
151 | set tag [string repeat "=" $lev]
152 | append result "$tag $htext $tag\n"
153 | }
154 | /P {
155 | foreach letter [array names sty] {
156 | if {$sty($letter)} {
157 | append result $wikiStyles($letter$sty($letter))
158 | }
159 | }
160 | }
161 | P {
162 | # FIRST, reset all text styles.
163 | array set sty {
164 | m 0 i 0 b 0
165 | h 0 s 0 x 0
166 | }
167 |
168 | # Next, get the paragraph style.
169 | set para [lindex $value 0]
170 | set indent [lindex $value 1]
171 |
172 | if {$para eq ":" && !$gotNL} {
173 | append result "
\n"
174 | } elseif {$para eq "*"} {
175 | append result "\n[string repeat * $indent] "
176 | }
177 |
178 | set gotNL 0
179 | }
180 | TXT {
181 | if {!$opts(-embeddedhtml)} {
182 | set value [AddEscapes $value]
183 | }
184 |
185 | set value [string map [list "\n" " " "&lb;" \[ "&rb;" \]] $value]
186 |
187 | append result $value
188 | }
189 | HTML {
190 | append result $value
191 | }
192 | NL {
193 | set gotNL 1
194 | append result "\n\n"
195 | }
196 | STY {
197 | set code [lindex $value 0]
198 | set letter [string index $code 0]
199 | set flag [string index $code 1]
200 |
201 | set sty($letter) $flag
202 | append result $wikiStyles($code)
203 | }
204 | LINK {
205 | set value [::markupparser::normalizeSpace $value]
206 |
207 | # Note: with "|" notation, MediaWiki's format
208 | # puts the page name first and the displayed
209 | # text second, so we need to swap them.
210 | set list [split $value "|"]
211 |
212 | if {[llength $list] == 2} {
213 | set value "[lindex $list 1]|[lindex $list 2]"
214 | }
215 |
216 | append result "\[\[$value\]\]"
217 | }
218 | BTN {
219 | # Extract just the button text.
220 | set value [lindex [split $value |] 0]
221 |
222 | append result $value
223 | }
224 | OBJECT {
225 | set obj [getobj $value]
226 |
227 | switch -exact [lindex $obj 0] {
228 | image {
229 | set fname [lindex $obj 1]
230 | array set opts [lindex $obj 2]
231 |
232 | append result "\[\[Image:$fname\]\]"
233 | }
234 | error -
235 | default {
236 | append result "\[!$value!\] "
237 | }
238 | }
239 | }
240 | MACRO {
241 | # There shouldn't be any macros.
242 | append result "\[@$value@\] "
243 | }
244 | }
245 | }
246 |
247 | return $result
248 | }
249 |
250 |
251 | #-----------------------------------------------------------------------
252 | # Utility Procs
253 |
254 | # AddEscapes text
255 | #
256 | # text plain text to be included in HTML output.
257 | #
258 | # Converts &, <, and > to &, <, and >.
259 |
260 | proc nb2mediawiki::AddEscapes {text} {
261 | regsub -all "&" $text {\&} text
262 | regsub -all "<" $text {\<} text
263 | regsub -all ">" $text {\>} text
264 |
265 | return $text
266 | }
267 |
268 |
269 |
270 |
--------------------------------------------------------------------------------
/lib/app_notebook/nbobjects.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # nbobjects.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # This module contains the parser for Notebook "objects", e.g.,
10 | # things found in [!...!] markup.
11 | #
12 | # At some point, this might allow some kind of plug-in
13 | # architecture.
14 | #
15 | #-----------------------------------------------------------------------
16 |
17 | # getobj objstring
18 | #
19 | # Parses objstring and returns a list. The first element is the valid
20 | # object type, or "error". The subsequent elements depend on the
21 | # object type.
22 |
23 | proc getobj {objstring} {
24 | # FIRST, it must be a valid list.
25 | if {[catch {lindex $objstring 0} objectType]} {
26 | return [list error "Invalid object: $objstring"]
27 | }
28 |
29 | # NEXT, we only have one kind of object at the moment.
30 | if {$objectType != "image"} {
31 | return [list error "Unrecognized object type: $objstring"]
32 | }
33 |
34 | return [ParseImageObject $objstring]
35 | }
36 |
37 | # ParseImageObject obj
38 | #
39 | # The first token of obj is "image". The second is the path to the
40 | # image file. The remaining elements are options and values.
41 | #
42 | # Returns a list {image path optlist}. The list contains all
43 | # options allowed for images, with values.
44 |
45 | proc ParseImageObject {obj} {
46 | set result [lrange $obj 0 1]
47 |
48 | array set opts {
49 | -width 0
50 | -height 0
51 | -padwidth 0
52 | -text ""
53 | }
54 |
55 | foreach {opt val} [lrange $obj 2 end] {
56 | if {[info exists opts($opt)]} {
57 | if {$opt eq "-text" ||
58 | [regexp {^[0-9]+[cimp]?$} $val]} {
59 | set opts($opt) $val
60 | continue
61 | }
62 | }
63 |
64 | return [list error "Invalid image option: $opt $val"]
65 | }
66 |
67 | lappend result [array get opts]
68 |
69 | return $result
70 | }
71 |
--------------------------------------------------------------------------------
/lib/app_notebook/notebook.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # notebook.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Wiki-like personal notebook
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2005 by William H. Duquette. This file may
13 | # be used subject to the terms in license.txt.
14 |
15 | #-----------------------------------------------------------------------
16 | # Catch Mac OS X open events at startup.
17 | #
18 | # We aren't really ready for open events until the end of this file;
19 | # however, we call "update" when we popup the splash screen, so we
20 | # might well receive some. The following definition of
21 | # ::tk::mac::OpenDocument just saves any file names we receive so
22 | # that they can be opened later. We will redefine OpenDocument
23 | # at the end of the file to open notebooks properly.
24 | #
25 | # If we aren't running under Aqua, then this is irrelevant.
26 |
27 | set osxDocsToOpen {}
28 |
29 | if {[tk windowingsystem] eq "aqua"} {
30 | proc ::tk::mac::OpenDocument {args} {
31 | set ::osxDocsToOpen $args
32 | }
33 | }
34 |
35 | #-----------------------------------------------------------------------
36 | # Copy Encodings
37 |
38 | set appdir [file dirname [info script]]
39 |
40 | set encodingGlob [file join $appdir .. encoding *]
41 | set encodings [encoding names]
42 |
43 | foreach encodingFile [glob -nocomplain $encodingGlob] {
44 | set encoding [file rootname [file tail $encodingFile]]
45 | if {[lsearch -exact $encodings $encoding] == -1} {
46 | file copy -force $encodingFile [file join $tcl_library encoding]
47 | }
48 | }
49 |
50 | #-----------------------------------------------------------------------
51 | # Version
52 |
53 | # FIXME
54 | set notebookVersion "V2.2.0"
55 |
56 | #-----------------------------------------------------------------------
57 | # Allow notebook to execute scripts.
58 |
59 | if {"-script" == [lindex $argv 0]} {
60 | set script [lindex $argv 1]
61 | set argv [lreplace $argv 0 1]
62 | source [lindex $script]
63 | exit
64 | }
65 |
66 | #-------------------------------------------------------------------------
67 | # Do the splash screen
68 |
69 | # Withdraw the main window; we might not need it at all. We'll pop it
70 | # back up if we do.
71 | wm withdraw .
72 |
73 | toplevel .splash -background white
74 | wm title .splash "Notebook $notebookVersion"
75 |
76 | image create photo splash.gif \
77 | -file [file join [file dirname [info script]] splash.gif]
78 |
79 | pack [label .splash.image \
80 | -foreground black \
81 | -background white \
82 | -justify center \
83 | -image splash.gif]
84 |
85 | set sw [winfo screenwidth .splash]
86 | set sh [winfo screenheight .splash]
87 | set rw [winfo reqwidth .splash]
88 | set rh [winfo reqheight .splash]
89 |
90 | set x [expr ($sw - $rw)/2]
91 | set y [expr ($sh - $rh)/2]
92 |
93 | wm geometry .splash +$x+$y
94 |
95 | update
96 |
97 | #-----------------------------------------------------------------------
98 | # Utility functions
99 |
100 | # Display a message. This should only be used for debugging.
101 | proc msg {messageText {icon "error"}} {
102 | tk_messageBox -icon $icon -parent . \
103 | -title "Notebook Message" \
104 | -message $messageText \
105 | -type ok
106 | }
107 |
108 | # Return the current version
109 | proc version {} {
110 | global notebookVersion
111 |
112 | return $notebookVersion
113 | }
114 |
115 | #-----------------------------------------------------------------------
116 | # Other required packages
117 |
118 | set appdir [file dirname [info script]]
119 |
120 | package require gui 1.0
121 | namespace import ::gui::*
122 |
123 | package require markupparser
124 | package require notebookdb
125 |
126 | # Source in the application files
127 |
128 | source [file join $appdir nb2html.tcl]
129 | source [file join $appdir nb2mediawiki.tcl]
130 | source [file join $appdir userprefs.tcl]
131 | source [file join $appdir renderpane.tcl]
132 | source [file join $appdir nbobjects.tcl]
133 | source [file join $appdir pageeditor.tcl]
134 | source [file join $appdir prefs_dialog.tcl]
135 |
136 | namespace import ::app_notebook::prefs
137 |
138 | source [file join $appdir nbactionmanager.tcl]
139 | source [file join $appdir dbmanager.tcl]
140 | source [file join $appdir messagelog.tcl]
141 | source [file join $appdir welcomer.tcl]
142 | source [file join $appdir pageviewer.tcl]
143 | source [file join $appdir helpbrowser.tcl]
144 | namespace import ::app_notebook::HelpBrowser::*
145 |
146 | source [file join $appdir notebookbrowser.tcl]
147 |
148 | # Create images
149 | image create photo ::app_notebook::missing \
150 | -file [file join $appdir missing.gif]
151 |
152 | #-----------------------------------------------------------------------
153 | # Mainline code
154 |
155 | # Check the arguments
156 | if {[llength $argv] == 0} {
157 | set notebooks {}
158 | } else {
159 | foreach name $argv {
160 | set name [file normalize $name]
161 | lappend notebooks [file join [pwd] $name]
162 | }
163 | }
164 |
165 | # Read the preferences
166 | prefs load
167 |
168 | # Initialize the help browser
169 | helpbrowser [file join $appdir help.nbk]
170 |
171 | # Initialize the message log
172 | messagelog init
173 |
174 | # Copy the extensions path to the auto_path, and
175 | # try to load the extension packages.
176 | set extpath [string trim [prefs get extpath]]
177 | if {$extpath ne ""} {
178 | lappend auto_path $extpath
179 | }
180 |
181 | if {[catch {package require Img 1.3} result]} {
182 | messagelog logmessage "Img Extension: not loaded"
183 | } else {
184 | messagelog logmessage "Img Extension: loaded"
185 | }
186 |
187 | # Add the initial OS X file names, if any
188 | set notebooks [concat $notebooks $osxDocsToOpen]
189 |
190 | # Create the initial Notebook browsers
191 | notebookbrowser appdir $appdir
192 |
193 | if {[llength $notebooks] == 0} {
194 | welcomer .%AUTO%
195 | destroy .splash
196 | } else {
197 | destroy .splash
198 | foreach notebook $notebooks {
199 | try {
200 | if {[file extension $notebook] eq ""} {
201 | append notebook ".nbk"
202 | }
203 |
204 | set db [dbmanager openfile $notebook]
205 | notebookbrowser .%AUTO% -db $db
206 | } trap notebookdb::loaderror {msg} {
207 | welcomer .%AUTO% -errormsg $msg
208 | }
209 | }
210 | }
211 |
212 | #-----------------------------------------------------------------------
213 | # Redefine ::tk::mac::OpenDocument
214 | #
215 | # See the discussion at the top of this file.
216 | #
217 | # This proc will receive OS X open events after the application has
218 | # gotten initialized, and will open new windows for the specified
219 | # notebook files.
220 |
221 | if {[tk windowingsystem] eq "aqua"} {
222 | proc ::tk::mac::OpenDocument {args} {
223 | foreach name $args {
224 | try {
225 | set newdb [dbmanager openfile $name]
226 | } trap notebookdb::loaderror {msg} {
227 | throw USER $msg
228 | }
229 |
230 | if {$newdb eq ""} {
231 | error "Cancelled." {} USER
232 | }
233 |
234 | notebookbrowser .%AUTO% -db $newdb
235 | }
236 | }
237 | }
238 |
--------------------------------------------------------------------------------
/lib/app_notebook/pageviewer.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # pageviewer.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A viewer for browsing Notebook pages.
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2005 by William H. Duquette. This file may
13 | # be used subject to the terms in license.txt.
14 | #
15 | #-----------------------------------------------------------------------
16 |
17 | snit::widget pageviewer {
18 | #-------------------------------------------------------------------
19 | # Creation Options
20 | #
21 | # These options should only be set at creation time. This isn't
22 | # enforced, so be careful
23 |
24 | # 1 if we're read-only, and 0 otherwise.
25 | option -readonly 0
26 |
27 | # A command to use for outputting messages. The message will be
28 | # appended.
29 | option -messagecommand {}
30 |
31 | # The notebook file directory, used as the root for relative paths.
32 | option -dbdir {}
33 |
34 | #-------------------------------------------------------------------
35 | # Other options
36 |
37 | # A command that's called when the displayed page changes. The
38 | # command gets one argument, the page name.
39 | option -pagecommand {}
40 |
41 | # A command that's called when we try to display a page that
42 | # doesn't exist.
43 | option -unknowncommand {}
44 |
45 | #-------------------------------------------------------------------
46 | # Components
47 |
48 | # The toplevel window (the notebookbrowser)
49 | variable top
50 |
51 | # The renderpane is the component that actually displays the
52 | # rendered page.
53 | variable rp
54 |
55 | #--------------------------------------------------------------------
56 | # Other variables
57 |
58 | # The history list is a list of {PageName PagePos} pairs.
59 | variable history {}
60 |
61 | # The histPos is the index of the currently displayed page in the
62 | # history list. It's initially -1 because there's nothing in the
63 | # list.
64 | variable histPos -1
65 |
66 | # A list of recently displayed pages. Each page appears only once,
67 | # regardless of how often (and where) it appears in the history list.
68 | # There will be ten pages listed, maximum; no more than one of them
69 | # are guaranteed to still exist.
70 | variable recentPages {}
71 |
72 | #--------------------------------------------------------------------
73 | # Constructor
74 |
75 | constructor {args} {
76 | # Get the toplevel widget
77 | set top [winfo toplevel $win]
78 |
79 | # As yet we have no option delegation, so go ahead and get the
80 | # args
81 | $self configurelist $args
82 |
83 | # Create the renderpane.
84 | install rp using renderpane $win.rp \
85 | -yscrollcommand "$win.scroll set" \
86 | -querycommand [list $top pageexists] \
87 | -titlecommand [mymethod TitleHandler] \
88 | -linkcommand [mymethod LinkHandler] \
89 | -buttoncommand [mymethod ButtonHandler] \
90 | -macroerrorcommand [mymethod MacroErrorHandler] \
91 | -messagecommand $options(-messagecommand) \
92 | -dbdir $options(-dbdir)
93 |
94 | scrollbar $win.scroll \
95 | -command "$win.rp yview"
96 |
97 | # Pack them in.
98 | pack $win.scroll -side right -fill y -expand false
99 | pack $rp -side top -fill both -expand true
100 |
101 | #---------------------------------------------------------------
102 | # User Interactions
103 |
104 | # Add the pageviewer window itself to the renderpane's bindtags,
105 | # so that keys bound to the pageviewer will take effect when the
106 | # renderpane has focus
107 | set tags [bindtags $rp]
108 | lappend tags $win
109 | bindtags $rp $tags
110 |
111 | # Go to the previous page when is pressed.
112 | bind $rp [list $self backpage]
113 |
114 | # User Menu.
115 | menu $rp.user -tearoff no -postcommand [mymethod PostUserMenu]
116 |
117 | $rp.user add command -label "User Menu"
118 | $rp.user add separator
119 | $rp.user add command -label "Dummy"
120 |
121 | bind $rp [list tk_popup $rp.user %X %Y 2]
122 | bind $rp <3> [list tk_popup $rp.user %X %Y 2]
123 |
124 | # Recent Pages Menu.
125 | menu $rp.recent -tearoff no -postcommand [mymethod PostRecent]
126 |
127 | $rp.recent add command -label "Recent Pages"
128 | $rp.recent add separator
129 | $rp.recent add command -label "Dummy"
130 |
131 | bind $rp [list tk_popup $rp.recent %X %Y 2]
132 |
133 | #---------------------------------------------------------------
134 | # Prepare to receive preferences events; unregister on
135 | # destroy.
136 | prefs register $selfns [mymethod UsePreferences]
137 | }
138 |
139 | destructor {
140 | catch {prefs unregister $selfns}
141 | }
142 |
143 | method UsePreferences {} {
144 | # Update the display when the preferences change.
145 | $self showpage
146 | }
147 |
148 | #-------------------------------------------------------------------
149 | # Public Methods
150 |
151 | delegate method searchfor to rp
152 |
153 | # Returns the name of the currently displayed page, or "" if none.
154 | # Note that during a deletion or page renaming the named page
155 | # is not guaranteed to exist.
156 | method current {} {
157 | return [lindex $history $histPos 0]
158 | }
159 |
160 | # Tells the pageviewer to take the keyboard focus.
161 | # If -friendly, we take the focus only if our toplevel already
162 | # has it (e.g., we take the focus back from the search box).
163 | method focus {{option {}}} {
164 | set focusWin [focus]
165 |
166 | if {$focusWin eq ""} {
167 | return
168 | }
169 |
170 | if {$option ne "-friendly" ||
171 | [winfo toplevel $win] eq [winfo toplevel $focusWin]} {
172 | focus $rp
173 | }
174 | }
175 |
176 | # Shows the named page. The -unknowncommand is called if the
177 | # page doesn't exist.
178 | method showpage {{name ""}} {
179 | # FIRST, remember the position for the page we're showing now.
180 | if {$histPos >= 0} {
181 | lset history $histPos 1 [$self GetPos]
182 | }
183 |
184 | # NEXT, default to the current page.
185 | if {$name eq ""} {
186 | set name [$self current]
187 |
188 | if {$name eq ""} {
189 | error "no current page."
190 | }
191 | }
192 |
193 | # NEXT, if the page doesn't exist, call the -unknowncommand.
194 | if {![$top pageexists $name]} {
195 | if {$options(-unknowncommand) ne {}} {
196 | set command $options(-unknowncommand)
197 | lappend command $name
198 | uplevel \#0 $command
199 | } else {
200 | $return -code error -errorcode USER "No such page: '$name'"
201 | }
202 |
203 | return
204 | }
205 |
206 | # NEXT, save the new page in the history list. When we show
207 | # a new page, any pages forward of our position go away.
208 | set history [lrange $history 0 $histPos]
209 | lappend history [list [$top pagename $name] 0]
210 | incr histPos
211 |
212 | # NEXT, display it.
213 | $self DisplayPage
214 | }
215 |
216 | # Steps back one page, if possible
217 | method backpage {} {
218 | # FIRST, remember the position for the page we're showing now.
219 | if {$histPos >= 0} {
220 | lset history $histPos 1 [$self GetPos]
221 | }
222 |
223 | # NEXT, Look back through the history list for a page that exists,
224 | # and is also different than the current page.
225 | set current [lindex $history $histPos 0]
226 | set pos [expr {$histPos - 1}]
227 |
228 | while {$pos >= 0} {
229 | set candidate [lindex $history $pos 0]
230 |
231 | if {[$top pageexists $candidate]} {
232 |
233 | if {![string equal -nocase $candidate $current]} {
234 | break
235 | }
236 | }
237 |
238 | incr pos -1
239 | }
240 |
241 | if {$pos < 0} {
242 | bell
243 | return
244 | }
245 |
246 | set histPos $pos
247 |
248 | $self DisplayPage
249 | }
250 |
251 | # Steps forward one page, if possible
252 | method forwardpage {} {
253 | # FIRST, remember the position for the page we're showing now.
254 | if {$histPos >= 0} {
255 | lset history $histPos 1 [$self GetPos]
256 | }
257 |
258 | # NEXT, Look forward through the history list for a page that exists,
259 | # and is also different than the current page.
260 | set current [lindex $history $histPos 0]
261 | set pos [expr {$histPos + 1}]
262 | set len [llength $history]
263 |
264 | while {$pos < $len} {
265 | set candidate [lindex $history $pos 0]
266 |
267 | if {[$top pageexists $candidate]} {
268 |
269 | if {![string equal -nocase $candidate $current]} {
270 | break
271 | }
272 | }
273 |
274 | incr pos
275 | }
276 |
277 | if {$pos >= $len} {
278 | bell
279 | return
280 | }
281 |
282 | set histPos $pos
283 |
284 | $self DisplayPage
285 | }
286 |
287 | # Shows the page from the beginning of the Recent Pages list, if it exists.
288 | method cyclerecent {} {
289 | foreach id $recentPages {
290 | if {[$top pageexists $id]} {
291 | $self showpage $id
292 | break
293 | }
294 | }
295 | }
296 |
297 | #-------------------------------------------------------------------
298 | # Private Methods
299 |
300 | # Display the current page
301 | method DisplayPage {} {
302 | # FIRST, Get the current page specs
303 | set name [$top pagename [lindex $history $histPos 0]]
304 | set ypos [lindex $history $histPos 1]
305 |
306 | # NEXT, add the name to the list of recent pages
307 | $self SaveRecentPage $name
308 |
309 | # NEXT, Expand the requested page and display it.
310 | set pagetext [$top pageexpand $name]
311 |
312 | $rp render $name $pagetext
313 | $rp searchfor [$top searchtext]
314 |
315 | # NEXT, give the renderpane the focus so that we don't
316 | # need to click in it.
317 | $self focus -friendly
318 |
319 | $self setpos $ypos
320 |
321 | # NEXT, notify those concerned.
322 | if {$options(-pagecommand) ne {}} {
323 | set command $options(-pagecommand)
324 | lappend command $name
325 | uplevel \#0 $command
326 | }
327 | }
328 |
329 | # Save the specified page to the recent pages list, removing
330 | # any previous entry with the same name. Names are stored
331 | # in lower case. No more than ten names are stored.
332 | method SaveRecentPage {name} {
333 | set name [string tolower $name]
334 |
335 | set ndx [lsearch -exact $recentPages $name]
336 |
337 | if {$ndx != -1} {
338 | set recentPages [lreplace $recentPages $ndx $ndx]
339 | }
340 |
341 | lappend recentPages $name
342 |
343 | # Cut down back to ten, if need be
344 | if {[llength $recentPages] == 11} {
345 | set recentPages [lreplace $recentPages 0 0]
346 | }
347 | }
348 |
349 |
350 | # Get the y-position of the text at the top of the window.
351 | method GetPos {} {
352 | lindex [$rp yview] 0
353 | }
354 |
355 | # Set the y-position of the text at the top of the window.
356 | method setpos {ypos} {
357 | $rp yview moveto $ypos
358 | }
359 |
360 | # Called when the user clicks on the title text.
361 | method TitleHandler {title} {
362 | $top showsearch $title
363 | }
364 |
365 | # Called when the user clicks on a link; shows the linked page.
366 | method LinkHandler {linkName} {
367 | $self showpage $linkName
368 | }
369 |
370 | # Called when the user clicks on a magic button; calls the button's script
371 | method ButtonHandler {script} {
372 | $top evaluser $script
373 | }
374 |
375 | # Finds the macro error text and displays the error message.
376 | method MacroErrorHandler {macro} {
377 | $top evaluser $macro
378 | # TBD: If macros are disabled, then clicking on this won't
379 | # display an error. We need to handle this somehow.
380 | }
381 |
382 | # Called before the Recent Pages context menu is popped up.
383 | method PostRecent {} {
384 | # FIRST, delete any existing items.
385 | $rp.recent delete 2 end
386 |
387 | # NEXT, add items for the recent items.
388 | foreach id $recentPages {
389 | if {[$top pageexists $id]} {
390 | set name [$top pagename $id]
391 | $rp.recent add command \
392 | -label $name \
393 | -command [list $self showpage $name]
394 | }
395 | }
396 | }
397 |
398 | # Called before the User Menu context menu is popped up.
399 | method PostUserMenu {} {
400 | # FIRST, delete any existing items.
401 | $rp.user delete 2 end
402 |
403 | # NEXT, retrieve the user's choices
404 | set items [$top evaluser usermenu]
405 |
406 | # NEXT, add items for the user's choices.
407 | foreach {label command} $items {
408 | if {$label eq "separator"} {
409 | $rp.user add separator
410 | } else {
411 | $rp.user add command \
412 | -label $label \
413 | -command [list $top evaluser $command]
414 | }
415 | }
416 | }
417 | }
418 |
419 |
420 |
421 |
--------------------------------------------------------------------------------
/lib/app_notebook/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # pkgIndex.tcl
4 | #
5 | # PROJECT:
6 | # notebook: Your project description
7 | #
8 | # DESCRIPTION:
9 | # app_notebook(n): pkgIndex file
10 | #
11 | # Generated by Quill
12 | #
13 | #-------------------------------------------------------------------------
14 |
15 | # -quill-ifneeded-begin DO NOT EDIT BY HAND
16 | package ifneeded app_notebook 2.2.0 [list source [file join $dir pkgModules.tcl]]
17 | # -quill-ifneeded-end
18 |
--------------------------------------------------------------------------------
/lib/app_notebook/pkgModules.tcl:
--------------------------------------------------------------------------------
1 | #-------------------------------------------------------------------------
2 | # TITLE:
3 | # pkgModules.tcl
4 | #
5 | # PROJECT:
6 | # notebook: Your project description
7 | #
8 | # DESCRIPTION:
9 | # app_notebook(n): Package Loader
10 | #
11 | # Generated by Quill
12 | #
13 | #-------------------------------------------------------------------------
14 |
15 | #-------------------------------------------------------------------------
16 | # Provide Package
17 |
18 | # -quill-provide-begin DO NOT EDIT BY HAND
19 | package provide app_notebook 2.2.0
20 | # -quill-provide-end
21 |
22 | #-------------------------------------------------------------------------
23 | # Require Packages
24 |
25 | # -quill-require-begin INSERT PACKAGE REQUIRES HERE
26 | package require snit 2.3
27 | # -quill-require-end
28 |
29 | #-------------------------------------------------------------------------
30 | # Get the library directory
31 |
32 | namespace eval ::app_notebook:: {
33 | variable library [file dirname [info script]]
34 | }
35 |
36 | source [file join $::app_notebook::library main.tcl]
37 |
--------------------------------------------------------------------------------
/lib/app_notebook/splash.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/app_notebook/splash.gif
--------------------------------------------------------------------------------
/lib/app_notebook/userprefs.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # userprefs.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Notebook application user preferences.
10 | #
11 | # LICENSE:
12 | # Copyright (C) 2002,2003,2004,2005 by William H. Duquette.
13 | # This file may be used subject to the terms in license.txt.
14 |
15 | package require Tk
16 |
17 | #-----------------------------------------------------------------------
18 | # UserPrefs
19 |
20 | # prefs could be implemented as an ensemble: a type with no instances but
21 | # only typemethods. For historical reasons, though, it's been
22 | # implemented as a normal type with just one instance.
23 | snit::type ::app_notebook::prefsmanager {
24 | # Preferences array
25 | variable prefs
26 |
27 | # Observers array. index is observer name, value is command to execute.
28 | variable observers
29 |
30 | # System font lists
31 | variable fonts
32 |
33 | # Pseudo-preferences
34 | #
35 | # Pseudo-preferences aren't saved to the preferences file.
36 | variable pseudoprefs {
37 | defaultscaling
38 | }
39 |
40 | constructor {} {
41 | # Scaling Preference
42 | set prefs(defaultscaling) [tk scaling]
43 | set prefs(scaling) [tk scaling]
44 |
45 | # Font preferences
46 | set prefs(bodytext) {Times 12}
47 | set prefs(monotext) {Courier 10}
48 | set prefs(header1text) {Helvetica 16 bold}
49 | set prefs(header2text) {Helvetica 14 bold}
50 | set prefs(header3text) {Helvetica 12 bold}
51 | set prefs(titletext) {Helvetica 20}
52 | set prefs(smalltext) {Helvetica 8}
53 |
54 | # Color preferences
55 | set prefs(editorfg) black
56 | set prefs(editorbg) white
57 | set prefs(normalfg) black
58 | set prefs(normalbg) white
59 | set prefs(prefg) black
60 | set prefs(prebg) white
61 | set prefs(tclfg) black
62 | set prefs(tclbg) white
63 | set prefs(titlefg) blue
64 | set prefs(titlebg) white
65 | set prefs(linkfg) blue
66 | set prefs(linkbg) white
67 | set prefs(buttonfg) magenta
68 | set prefs(buttonbg) white
69 | set prefs(warningfg) red
70 | set prefs(warningbg) white
71 | set prefs(searchfg) white
72 | set prefs(searchbg) red
73 |
74 | # Editor preferences
75 | set prefs(tabwidth) 4
76 | set prefs(autowrap) 1
77 | set prefs(wrapcolumn) 74
78 | set prefs(autoindent) 1
79 |
80 | # Tcl/Tk Preferences
81 | set prefs(extpath) {}
82 |
83 | # Miscellaneous Options
84 | set prefs(includetour) 1
85 | set prefs(editbottom) 0
86 | set prefs(displaydirectives) 0
87 | set prefs(silentcreation) 0
88 | set prefs(showsidebar) 0
89 | set prefs(incrementalsearch) 1
90 | set prefs(contentsearch) 1
91 |
92 | # Initialize font lists
93 | set fonts(all) {}
94 | set fonts(mono) {}
95 | set fonts(prop) {}
96 | }
97 |
98 | # Register observer. obj is the observing object; command is the
99 | # command to execute when preferences are saved.
100 | method register {obj command} {
101 | set observers($obj) $command
102 | }
103 |
104 | # Unregister observer. obj is the observing object.
105 | method unregister {obj} {
106 | unset observers($obj)
107 | }
108 |
109 | # Set a preference variable's value
110 | method set {var value} {
111 | # HACK: handle translation of "headertext" to "header[123]text"
112 | # This handles a preferences change in V2.1.1
113 | if {$var eq "headertext"} {
114 | $self set header1text $value
115 | $self set header2text $value
116 | $self set header3text $value
117 | return
118 | }
119 |
120 | # Retain and save unknown preferences; this means they can
121 | # switch between this version and a later version with more
122 | # preferences and not have any trouble.
123 | set prefs($var) $value
124 | }
125 |
126 | # Get a preference variable's value
127 | method get {var} {
128 | if {[info exists prefs($var)]} {
129 | return $prefs($var)
130 | } else {
131 | error "Unknown prefs variable: '$var'"
132 | }
133 | }
134 |
135 | # Load the preferences from disk. The file name is system-dependent.
136 | method load {} {
137 | set fname [PrefFileName]
138 |
139 | if {[file exists $fname]} {
140 | try {
141 | source [PrefFileName]
142 | tk scaling $prefs(scaling)
143 | } on error errmsg {
144 | msg "Error in user preferences file '$fname'; preferences might not be set. The error was: $errmsg"
145 | }
146 | }
147 | }
148 |
149 | # Save the preferences and notify observers.
150 | method save {} {
151 | try {
152 | set f [open [PrefFileName] w]
153 |
154 | puts $f "# Notebook [version] Preferences File"
155 | foreach name [array names prefs] {
156 | if {[lsearch -exact $pseudoprefs $name] != -1} {
157 | continue
158 | }
159 | puts $f [list prefs set $name $prefs($name)]
160 | }
161 | puts $f "# End of preferences"
162 | close $f
163 | } on error errmsg {
164 | msg "Could not save user preferences to [PrefFileName]: $errmsg"
165 | }
166 |
167 | $self NotifyObservers
168 | }
169 |
170 | # Pop up the preferences dialog; create it if it hasn't yet been
171 | # seen.
172 | method dialog {} {
173 | # Create the dialog, if one doesn't exist.
174 | if {"" == [info commands .prefsdialog]} {
175 | ::app_notebook::prefsdialog .prefsdialog
176 | }
177 |
178 | # Make sure it's visible.
179 | .prefsdialog show
180 | }
181 |
182 | # Return a list of monospace fonts defined by the system.
183 | method monofonts {} {
184 | $self LoadFonts
185 | return $fonts(mono)
186 | }
187 |
188 | # Return a list of proportional fonts defined by the system.
189 | method propfonts {} {
190 | $self LoadFonts
191 | return $fonts(prop)
192 | }
193 |
194 | # Return a list of *all* fonts defined by the system.
195 | method fonts {} {
196 | $self LoadFonts
197 | return $fonts(all)
198 | }
199 |
200 | #-----------------------------------------------------------------------
201 | # Private methods and procs
202 |
203 | # Determine the preference file name based on the platform
204 | proc PrefFileName {} {
205 | global tcl_platform
206 | global env
207 |
208 | # This is the only way to reference Tcl/Tk Aqua as opposed to
209 | # the X11 version
210 | if {[tk windowingsystem] eq "aqua"} {
211 | return [file join $env(HOME) "Library/Preferences/NotebookPrefs"]
212 | }
213 |
214 | switch $tcl_platform(platform) {
215 | "macintosh" {
216 | # This is classic Mac only
217 | return [file join $env(PREF_FOLDER) "Notebook Preferences"]
218 | }
219 | "windows" {
220 | if {[info exists env(HOME)]} {
221 | return [file join $env(HOME) "notebook.cfg"]
222 | } else {
223 | return [file join "C:/" "notebook.cfg"]
224 | }
225 | }
226 | "unix" -
227 | default {
228 | if {[info exists env(DOTDIR)]} {
229 | return "$env(DOTDIR)/.notebookrc"
230 | } else {
231 | return "$env(HOME)/.notebookrc"
232 | }
233 | }
234 | }
235 | }
236 |
237 | # Notify all registered observers that preferences have changed.
238 | method NotifyObservers {} {
239 | foreach name [array names observers] {
240 | uplevel #0 $observers($name)
241 | }
242 | }
243 |
244 | # Load system fonts, if they've not already been loaded.
245 | method LoadFonts {} {
246 | if {[llength $fonts(all)] != 0} {
247 | return
248 | }
249 |
250 | # Get all fonts.
251 | set fontnames [font families]
252 |
253 | # Tcl defines these names on all platforms, so add them to list
254 | # if they aren't already there.
255 | foreach name {Courier Times Helvetica} {
256 | if {[lsearch $fontnames $name] == -1} {
257 | lappend fontnames $name
258 | }
259 | }
260 |
261 | # On Tcl/Tk Aqua there are some problematic font names;
262 | # they all begin with non-alpha characters.
263 | foreach font $fontnames {
264 | set initial [string index $font 0]
265 | if {![string is alpha $initial]} {
266 | continue
267 | }
268 |
269 | lappend fonts(all) $font
270 | }
271 |
272 | set fonts(all) [lsort $fonts(all)]
273 |
274 | # Create lists of monospace and proportional fonts.
275 | foreach font $fonts(all) {
276 | if {[font metrics [list $font] -fixed]} {
277 | lappend fonts(mono) $font
278 | } else {
279 | lappend fonts(prop) $font
280 | }
281 | }
282 | }
283 | }
284 |
285 | # Create one instance of this object.
286 | ::app_notebook::prefsmanager create ::app_notebook::prefs
287 |
288 | namespace eval ::app_notebook:: {
289 | namespace export prefs
290 | }
291 |
292 |
293 |
--------------------------------------------------------------------------------
/lib/app_notebook/welcomer.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # welcomer.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # This component is created if Notebook is invoked
10 | # with no file name. It welcomes the user to Notebook and allows
11 | # them to open or create a notebook file. As such, it's a baby
12 | # version of a notebookbrowser. I'll duplicate the action and
13 | # menu code for now; but ultimately that will need to be fixed.
14 | #
15 | # LICENSE:
16 | # Copyright (C) 2003 by William H. Duquette. This file may
17 | # be used subject to the terms in license.txt.
18 | #
19 | #-----------------------------------------------------------------------
20 |
21 | snit::widget welcomer {
22 | # This is a toplevel window
23 | hulltype toplevel
24 | delegate option * to hull
25 |
26 | #-------------------------------------------------------------------
27 | # Options
28 |
29 | # An error stating why the welcomer was used.
30 | option -errormsg ""
31 |
32 | #-------------------------------------------------------------------
33 | # Instance Variables
34 |
35 | variable greeting {
36 | |Click on the highlighted text to:
37 | |
38 | |* [%Open|open-notebook%] an existing notebook.
39 | |* [%Create|new-notebook%] a new notebook
40 | |* [%Browse|help-introduction%] the on-line help.
41 | |
42 | |If you've never used Notebook before, then you'll want to
43 | |[%create|new-notebook%] a new notebook. It will be created
44 | |with an initial set of pages that will tell you
45 | |the things you need to know to get started.
46 | }
47 |
48 | #-------------------------------------------------------------------
49 | # Components
50 |
51 | variable am ;# The actionmanager
52 | variable status ;# The statusentry
53 | variable render ;# The renderpane
54 |
55 | #-------------------------------------------------------------------
56 | # Constructor
57 |
58 | constructor {args} {
59 | #---------------------------------------------------------------
60 | # Preliminaries
61 |
62 | # FIRST, withdraw the window, so they don't see it building.
63 | wm withdraw $win
64 |
65 | # NEXT, set the window title
66 | wm title $win "Welcome to Notebook"
67 |
68 | # NEXT, Go ahead and configure the widget options, if any; none are
69 | # delegated to anything but the hull.
70 | $self configurelist $args
71 |
72 | # NEXT, prepare for window closing
73 | windowmanager register $win
74 |
75 | #---------------------------------------------------------------
76 | # Create Components
77 |
78 | # FIRST, create the actionmanager and define the actions.
79 | install am using nbactionmanager %AUTO% \
80 | -toplevel $win \
81 | -windowtype welcomer \
82 | -errorcommand [mymethod ErrorHandler]
83 |
84 | # NEXT, create the statusentry. It provides a GUI for displaying
85 | # status and entering arguments.
86 | install status using statusentry $win.status \
87 | -errorcommand [mymethod ErrorHandler] \
88 | -messagecommand [list messagelog logmessage]
89 |
90 | # NEXT, create the renderpane for the welcome message
91 | install render using renderpane $win.render \
92 | -buttoncommand [mymethod ButtonHandler] \
93 | -width 45 \
94 | -height 20
95 |
96 | # Next, pack the components
97 | pack $status -side bottom -fill x -expand false
98 | pack $render -side top -fill both -expand true
99 |
100 | #---------------------------------------------------------------
101 | # Render the welcome message
102 |
103 | regsub -all -line {^\s*\|} [string trim $greeting] {} greeting
104 | $render render "Welcome to Notebook!" $greeting
105 |
106 | #---------------------------------------------------------------
107 | # Final Preparations
108 |
109 | # NEXT, update the state of all actions.
110 | $am updatestate
111 |
112 | # NEXT, The GUI is fully created; display it!
113 | #
114 | # We call "update" to make sure that everything has taken its final
115 | # size before we deiconify.
116 | update
117 | wm deiconify $win
118 |
119 | # NEXT, if there's an error message, display it.
120 | if {$options(-errormsg) ne ""} {
121 | $status msg $options(-errormsg)
122 | }
123 | }
124 |
125 | #-------------------------------------------------------------------
126 | # Private Methods
127 |
128 | method ButtonHandler {action} {
129 | $am invoke $action
130 | }
131 |
132 | # Called when the welcomer's work is done.
133 | method Withdraw {} {
134 | wm withdraw $win
135 |
136 | # TBD: Is the "after 1" really necessary?
137 | after 1 [list windowmanager destroy $win]
138 | }
139 |
140 | # Handles errors from the statusentry and actionmanager components.
141 | method ErrorHandler {msg einfo ecode} {
142 | if {$ecode eq "USER"} {
143 | $status msg $msg
144 | bell
145 | } else {
146 | messagelog logerror $msg $einfo $ecode
147 |
148 | $status msg "$msg -- go to Message Log for more."
149 | }
150 | }
151 |
152 |
153 | #-------------------------------------------------------------------
154 | # Delegate Action Handlers
155 |
156 | delegate method about-notebook to am
157 | delegate method close-window to am
158 | delegate method copy-string to am
159 | delegate method cut-string to am
160 | delegate method edit-preferences to am
161 | delegate method help-on to am
162 | delegate method help-introduction to am
163 | delegate method help-index to am
164 | delegate method help-on-actions to am
165 | delegate method help-on-commands to am
166 | delegate method help-on-markup to am
167 | delegate method notebook-license to am
168 | delegate method notebook-release-notes to am
169 | delegate method paste-string to am
170 | delegate method redo-change to am
171 | delegate method request-action to am
172 | delegate method undo-change to am
173 | delegate method show-version to am
174 |
175 | #-------------------------------------------------------------------
176 | # Action Handlers
177 | #
178 | # These methods are registered as actions with the actionmanager
179 | # component. Actions can be invoked by typing their names into the
180 | # statusentry widget, or programmatically; they can get input
181 | # from the user via the statusentry widget.
182 | #
183 | # When actions are invoked programmatically, none or all of their
184 | # arguments can be specified programmatically; the action will prompt
185 | # for the remaining arguments.
186 | #
187 | # When called programmatically, the action's state is NOT checked.
188 | # Thus, every action must explicitly check the same conditions as
189 | # its -statecommand, giving a good USER error if they are not met.
190 | #
191 | # Every action has a handler with the same name. In some cases,
192 | # this handler implements the entire action. For actions that have
193 | # arguments, it's usual to implement the handler as two methods.
194 | # The first has the usual name, and will do the following:
195 | #
196 | # * Require any conditions for execution of the action that do not
197 | # depend on the argument values.
198 | #
199 | # * Request the arguments, passing control to the second command when
200 | # they've been entered.
201 | #
202 | # * The second method simply takes the arguments and does what's
203 | # necessary. The second method is not intended to be called by
204 | # anyone but the first method; it's called "Do-",
205 | # and should follow immediately after the first method.
206 |
207 |
208 | # Action: new-notebook
209 | #
210 | # Creates a new notebook file and opens it, prompting for the file
211 | # name
212 | method new-notebook {} {
213 | $am new-notebook
214 |
215 | # On success the welcomer isn't needed anymore.
216 | $self Withdraw
217 | }
218 |
219 | # Action: open-notebook
220 | #
221 | # Opens a notebook file in the page browser, replacing the
222 | # existing notebook.
223 |
224 | method open-notebook {} {
225 | $am open-notebook
226 |
227 | # On success the welcomer isn't needed anymore.
228 | $self Withdraw
229 | }
230 | }
231 |
--------------------------------------------------------------------------------
/lib/combobox/ANNOUNCE.txt:
--------------------------------------------------------------------------------
1 | Combobox 2.3 release announcement
2 | September 30, 2003
3 |
4 | This is to announce version 2.3 of my pure Tcl combobox widget. This
5 | version includes the following new features from version 2.2
6 |
7 | * added -buttonbackground option
8 | * added -listvar option
9 | * tweaked packing order of internal widgets, which improves the
10 | resize behavior a bit (thanks to Oliver Bienert for the suggestion)
11 | * exposed "subwidget" command (eg: .combobox subwidget entry)
12 |
13 | Where to get it:
14 |
15 | You can download combobox version 2.3 from the following URL:
16 |
17 | http://www.purl.org/net/oakley/tcl/combobox/index.html
18 |
19 |
20 | Basic features:
21 |
22 | * written in pure tcl; no megawidget or OO extensions required
23 |
24 | * platform independent, and works for all versions of tk >= 8.0
25 |
26 | * self-contained and portable; all the code is in one file
27 |
28 | * API is similar to standard Tk widgets, with subcommands
29 | such as configure, cget, insert, etc.
30 |
31 | * keyboard navigation
32 |
33 | * emulates the look and feel of a Windows combobox
34 |
35 | * completely, totally, free. I retain copyright but you are
36 | free to use the code however you see fit. Don't be mean.
37 |
38 |
--------------------------------------------------------------------------------
/lib/combobox/CHANGES.txt:
--------------------------------------------------------------------------------
1 | Changes to combobox.tcl and related files:
2 |
3 | ### version 2.3:
4 |
5 | * added -buttonbackground options
6 | * added -listvar option
7 | * tweaked packing order of internal widgets, which improves the
8 | resize behavior a bit (thanks to Oliver Bienert for the suggestion)
9 | * exposed "subwidget" command (eg: .combobox subwidget entry)
10 | * made code which is called when the widget is destroyed a bit more
11 | robust; someone reported that their wish process would sometimes
12 | crash while trying to destroy a combobox widget and this fix made
13 | that crash
14 |
15 | ### version 2.2.2:
16 |
17 | * fixed bug where dropdown list would appear behind the main
18 | window on some window managers.
19 |
20 | ### version 2.2.1:
21 |
22 | * fixed case where mousewheel binding caused problems with tk 8.0
23 | * fixed bug when pressing return with dropdown list visible but
24 | nothing is selected
25 |
26 | ### version 2.2:
27 |
28 | * added support for tk 8.4 (changed use of tk private commands)
29 | * new option -dropdownwidth to control the width of the dropdown menu
30 | * new options -disabledforeground, -disabledbackground
31 | * added support for using the mousewheel in the dropdown list
32 | * finally added documentation for the selection subcommand. For four
33 | years now I've been saying "to be added later". It's later.
34 |
35 | ### version 2.1:
36 |
37 | * added -opencommand
38 | * included documentation for the open and close commands
39 | * fixed problem for tk 8.2 where the dropdown list was always behind
40 | the parent window.
41 |
42 | ### version 2.0:
43 |
44 | * fixed bug when attempting to get the value of the option -value
45 | before a value has been set.
46 |
47 | ### version 2.0b2:
48 |
49 | * fixed bug with non-editable comboboxes. Sometimes (or was it
50 | all the time?), if you selected a value from the dropdown list
51 | of a non-editable combobox the value wasn't being set properly.
52 |
53 |
54 | ### version 2.0b1:
55 |
56 | * option shorthand is now supported (eg: -val instead of -value)
57 | * option synonyms are now supported (eg: -bd instead of -borderwidth)
58 | * added the commands select and curselection
59 | * added option database support
60 | * handling of -textvariable is much more straight-forward. Instead of
61 | lots of internal wrangling, I merely assign the variable to the
62 | -textvariable attribute of the entry widget
63 | * lots of comments, and a wee bit more conformance to Scriptics'
64 | style guidelines
65 |
66 |
67 | ### version 1.07:
68 |
69 | * any pre-existing grab is now restored when the
70 | dropdown listbox is closed.
71 | * it should now be possible to set your own bindings
72 | on the combobox widget and have it work the way
73 | you expect. However, the default bindtags for the
74 | widget probably *aren't* what you expect.
75 | * keyboard traversal / focus management is much better
76 | now. Shift-tab seems to do the right thing without
77 | resorting to any hackery.
78 | * fixed bug where the down arrow wouldn't cause the a
79 | dropdown list to display.
80 | * added support for -highlightcolor
81 | * added the "subwidget" command, to allow you to get at some
82 | of the internal widget paths. I would prefer not to have
83 | to expose the underpinnings of this widget, but I think
84 | some advanced users may need this.
85 | * modified the example to show how one can add a list of items
86 | at once, and to include -highlightthickness
87 | * added support for -xscrollcommand, and added a test case in
88 | test.tcl for this option
89 | * man page has been changed to more accurately describe when
90 | the -command is called. These rules have changed slightly
91 | from previous versions.
92 | * modified how and where the dropdown lists pops up. In
93 | theory it should handle virtual desktops better. Also,
94 | for obscenely large lists (ie: bigger than will fit on
95 | the screen) we try to fit it the best we can. It will
96 | either pop up above or below the entry widget depending
97 | on which side gives us the largest list, and will be
98 | trimmed to start or stop at the edges of the screen.
99 | * added the list command to the man page
100 |
101 | Thanks to John Jackson and Todd Helfter of the Purdue University
102 | Computer Center for the patch to handle virtual window managers
103 |
104 | ### version 1.06:
105 |
106 | * dropdown list scrollbar is now "smart", and will only appear if the
107 | number of elements in the list is larger than the -height (or -maxheight,
108 | if -height is zero) of the widget
109 | * slightly different bitmap for the button, courtesy of Martin M. Hunt
110 | * slight modification to the computation of the height of the dropdown
111 | list. The computation now takes into consideration the borderwidth
112 | of the dropdown list
113 | * added option -commandstate. If "disabled", the value of -command will
114 | *not* be called when the value changes. Useful for setting the value
115 | programatically when you don't want to run the associated command.
116 | NB: I really like this concept (of a -commandstate); I sure wish all
117 | tk widgets had such an option...
118 | * added value checks when setting -state and -commandstate (prior to
119 | 1.06 we would attempt to set the state to whatever you passed in)
120 | * fixed bug in error reporting of some listbox manipulation commands
121 | (like ".foo list insert" and friends)
122 | * the -command is called whenever something is chosen from the list or
123 | the user presses return with focus in the entry, even if the value
124 | hasn't changed. The reasoning is that some people might actually
125 | want this behavior, and for those that don't they can easily do the
126 | check for a changed value themselves.
127 | * went back to putting all procs _outside_ the initial namespace eval,
128 | as per suggestions in the style guide published by scriptics.
129 | * focus is better handled when the dropdown listbox is hidden -- focus
130 | should now be restored to whatever widget had it last.
131 | * added a keyboard widget traversal hack in the README.txt file; this
132 | hack also appears in test.tcl
133 |
134 | ### version 1.05:
135 |
136 | * removed a bunch of the "namespace eval" nonsense, in favor of a more
137 | straight-forward technique using upvar. I still use namespaces, but
138 | I think the implementation is a bit more sensible now.
139 | * put braces around a few expressions that didn't have them.
140 | * put all procs within a single "namespace eval" command, rather
141 | than defining them at the global level, with the namespace used
142 | as part of the proc name. A net effect of zero, but this method
143 | just feels more "right".
144 |
145 | ### version 1.04:
146 |
147 | Thanks for Martin M. Hunt (hunt@cygnus.com) for some of these fixes, or
148 | the inspiration thereof
149 |
150 | * fixed bug when calling the -command proc when the value that was
151 | selected contained spaces
152 | * selecting an item from the listbox when -editable is false no
153 | longer sets the selection in the entry widget
154 | * fixed bug where the entry widget of a non-editable combobox
155 | would become enabled under certain circumstances
156 | * added a bit of code to set the button width to mimic the width
157 | of a standard scrollbar
158 | * added -height option, to set the height of the listbox
159 | * added -maxheight option, to support the combobox autosizing up to
160 | some maximum size
161 | * poping up a list when the list would go past the bottom of the
162 | screen will cause the list to pop above the entry widget instead
163 | of below
164 | * fixed bug in cget routine
165 |
166 | ### version 1.03:
167 |
168 | * scanning the list works. You can click on the button (but not release)
169 | and drag over the list. If you drag above or below the list it should
170 | scroll appropriately
171 | * if you have a textvariable defined, it is no longer set to "" initially
172 | * tab completion has changed slightly..if you type in something that
173 | doesn't match it will try to find something that does (for example,
174 | typing "apx" when "append" is a valid value will highlight append).
175 | * changed the "insert" and "delete" commands to "listinsert" and
176 | "listdelete"
177 | * added the commands "listindex", "listget", "listsize", which are passed
178 | to the listbox as index, get and size, respectively. This gives you what
179 | I think is sufficient access to the listbox (but see more about this
180 | below...)
181 | * added the commands "bbox", "insert", "delete", "icursor", "scan",
182 | "xview", and "selection", which are passed directly to the entry
183 | widget. I haven't tested them all much, but in theory if one works
184 | they all should work... (or conversely, if one is broken...)
185 | * in the entry closes the list if it is open
186 | * added configuration option -selectcommand. It is a command that gets
187 | executed whenever something from the dropdown list is selected.
188 | It *doesn't* get called if you just type in the box. I wasn't sure
189 | when to call it in the latter case -- after each keypress? After a
190 | ? When focus changes? So for the time being it is only called
191 | when you select from the list, and it will append to the command the
192 | name of the widget and the index of the item selected. This works
193 | very well for -editable false. If you want a command to trigger for
194 | -editable true, just put a trace on a -textvariable.
195 |
196 |
197 | ### version 1.02:
198 |
199 | * the namespace for the widget has moved below the ::Combobox namespace
200 | * interaction of pageup/pagedown and up/down has been fixed
201 | * new method for mapping window
202 | * fixed double-click behavior when widget is disabled
203 | * fixed case where you could pop up the list even if the widget was disabled
204 | * tweaked testing routine to use rgb values instead of color names
205 | * clicking Button 1 in the entry widget will pop up the list if the widget
206 | is enabled but not editable
207 | * clicking Button 1 anywhere in the app when the list is showing will
208 | close the list
209 | * closing the listbox will cause the data in the entry widget to be selected
210 | * added options -selectbackground, selectforeground and -selectborderwidth
211 | * added option -cursor
212 | * added check for unknown option in configure, cget
213 | * added package require Tk 8.0
214 | * changed behavior of tab key in the entry widget; it still trys to match
215 | what is there with something in the list, but the way it chooses to
216 | display the data in the entry widget has changed slightly.
217 |
--------------------------------------------------------------------------------
/lib/combobox/README.txt:
--------------------------------------------------------------------------------
1 | Combobox version 2.3
2 | Copyright (c) 1998-2003, Bryan Douglas Oakley
3 | All Rights Reserved.
4 |
5 | http://www.purl.org/net/oakley/tcl/combobox/index.html
6 | mailto:oakley@bardo.clearlight.com
7 |
8 | This software is provided AS-IS with no waranty expressed or
9 | implied. This software may be used free of charge, though I would
10 | appreciate it if you give credit where credit is due and mention my
11 | name when you use it.
12 |
13 | To use: place combobox.tcl where your programs can get at it either
14 | via autoloading or from a "source" command. To create a combobox widget
15 | use the command "::combobox::combobox", or import the combobox command
16 | with "import ::combobox::*" to use it as simply "combobox".
17 |
18 | To see a quick example, start up a wish process and cd to the directory
19 | where combobox.tcl is located. Then do "source example.tcl".
20 |
21 | #####################################################################
22 |
--------------------------------------------------------------------------------
/lib/combobox/example.tcl:
--------------------------------------------------------------------------------
1 | # A simple font display utility.
2 | #
3 | # This program uses two variations of the combobox. One, for the font
4 | # family, is non-editable (ie: the user can only pick from the list).
5 | # The other, for font size, is editable. The user can pick from the list
6 | # or enter their own size
7 |
8 | # substitute your favorite method here...
9 | source combobox.tcl
10 | package require combobox 2.3
11 | catch {namespace import combobox::*}
12 |
13 | proc main {} {
14 | # this lets us be reentrant...
15 | destroy .fontpicker .msg
16 |
17 | # default values
18 | set ::size 12
19 | set ::family [lindex [lsort [font families]] 0]
20 | set ::slant roman
21 | set ::weight normal
22 | set ::overstrike 0
23 | set ::underline 0
24 |
25 | wm title . "Combobox Example"
26 |
27 | # the main two areas: a frame to hold the font picker widgets
28 | # and a label to display a sample from the font
29 | set fp [frame .fontpicker]
30 | set msg [label .msg -borderwidth 2 -relief groove -width 30 -height 4]
31 |
32 | pack $fp -side top -fill x
33 | pack $msg -side top -fill both -expand y -pady 2
34 |
35 | $msg configure -text [join [list \
36 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ" \
37 | "abcdefghijklmnopqrstuvwxyz" \
38 | "0123456789~`!@#$%^&*()_-+=" \
39 | "{}[]:;\"'<>,.?/"] "\n"]
40 |
41 | # this will set the font of the message according to our defaults
42 | changeFont $msg
43 |
44 | # font family...
45 | label $fp.famLabel -text "Font Family:"
46 | combobox $fp.famCombo \
47 | -borderwidth 1 \
48 | -textvariable family \
49 | -editable false \
50 | -highlightthickness 1 \
51 | -command [list changeFont $msg]
52 |
53 |
54 | grid $fp.famLabel -row 0 -column 0 -sticky e
55 | grid $fp.famCombo -row 0 -column 1 -sticky ew
56 | grid columnconfigure $fp 1 -weight 1
57 |
58 | # we'll do these one at a time so we can find the widest one and
59 | # set the width of the combobox accordingly (hmmm... wonder if this
60 | # sort of thing should be done by the combobox itself...?)
61 | set widest 0
62 | foreach family [lsort [font families]] {
63 | if {[set length [string length $family]] > $widest} {
64 | set widest $length
65 | }
66 | $fp.famCombo list insert end $family
67 | }
68 | $fp.famCombo configure -width $widest
69 |
70 | # the font size. We know we are puting a fairly small, finite
71 | # number of items in this combobox, so we'll set its maxheight
72 | # to zero so it will grow to fit the number of items
73 | label $fp.sizeLabel -text "Font Size:"
74 | combobox $fp.sizeCombo \
75 | -borderwidth 1 \
76 | -highlightthickness 1 \
77 | -maxheight 0 \
78 | -width 3 \
79 | -textvariable size \
80 | -editable true \
81 | -command [list changeFont $msg]
82 |
83 | grid $fp.sizeLabel -row 0 -column 2 -sticky e -padx 2
84 | grid $fp.sizeCombo -row 0 -column 3 -sticky new
85 | grid columnconfigure $fp 3 -weight 1
86 | eval $fp.sizeCombo list insert end [list 8 9 10 12 14 16 18 20 24 28 32 36]
87 |
88 | # a dummy frame to give a little spacing...
89 | frame $fp.dummy -width 5
90 | grid $fp.dummy -row 0 -column 4
91 |
92 | # bold
93 | set bold "bold"
94 | checkbutton $fp.bold -variable weight -indicatoron false \
95 | -onvalue bold -offvalue normal \
96 | -text "B" -width 2 -height 1 \
97 | -font {-weight bold -family Times -size 12} \
98 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
99 | -command [list changeFont $msg]
100 | grid $fp.bold -row 0 -column 5 -sticky nsew
101 |
102 | # underline
103 | checkbutton $fp.underline -variable underline -indicatoron false \
104 | -onvalue 1 -offvalue 0 \
105 | -text "U" -width 2 -height 1 \
106 | -font {-underline 1 -family Times -size 12} \
107 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
108 | -command [list changeFont $msg]
109 | grid $fp.underline -row 0 -column 6 -sticky nsew
110 |
111 | # italic
112 | checkbutton $fp.italic -variable slant -indicatoron false \
113 | -onvalue italic -offvalue roman \
114 | -text "I" -width 2 -height 1 \
115 | -font {-slant italic -family Times -size 12} \
116 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
117 | -command [list changeFont $msg]
118 | grid $fp.italic -row 0 -column 7 -sticky nsew
119 |
120 | # overstrike
121 | checkbutton $fp.overstrike -variable overstrike -indicatoron false \
122 | -onvalue 1 -offvalue 0 \
123 | -text "O" -width 2 -height 1 \
124 | -font {-overstrike 1 -family Times -size 12} \
125 | -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
126 | -command [list changeFont $msg]
127 | grid $fp.overstrike -row 0 -column 8 -sticky nsew
128 |
129 | # this gives us relatively square buttons that fill the frame
130 | # in the Y direction
131 | bind $fp {
132 | grid columnconfigure %W 5 -minsize %h
133 | grid columnconfigure %W 6 -minsize %h
134 | grid columnconfigure %W 7 -minsize %h
135 | grid columnconfigure %W 8 -minsize %h
136 | }
137 | # put focus on the first widget
138 | catch {focus $fp.famCombo}
139 |
140 | return ""
141 | }
142 |
143 | # this proc changes the font. It is called by various methods, so
144 | # the only parameter we are guaranteed is the first one since
145 | # we supply it ourselves...
146 | proc ::changeFont {w args} {
147 | foreach foo [list family size weight underline slant overstrike] {
148 | if {[set ::$foo] == ""} {
149 | return
150 | }
151 | }
152 | set ::fontspec [list \
153 | -family $::family \
154 | -size $::size \
155 | -weight $::weight \
156 | -underline $::underline \
157 | -slant $::slant \
158 | -overstrike $::overstrike \
159 | ]
160 | $w configure -font $::fontspec
161 | }
162 |
163 | main
164 |
--------------------------------------------------------------------------------
/lib/combobox/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 |
2 | package ifneeded combobox 2.3 \
3 | [list tclPkgSetup $dir combobox 2.3 {{combobox.tcl source ::combobox::combobox}}]
4 |
5 |
--------------------------------------------------------------------------------
/lib/gui/actionmanager.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # actionmanager.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A manager for user actions.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | snit::type ::gui::actionmanager {
14 | #-------------------------------------------------------------------
15 | # Options
16 |
17 | # A command to call if an error is thrown on invocation of an action.
18 | # The command will be passed three arguments, the error message,
19 | # error code, and error info.
20 | option -errorcommand {}
21 |
22 | # A command to call to check the state (normal or disabled) of an
23 | # action.
24 | option -statecommand {}
25 |
26 | #-------------------------------------------------------------------
27 | # Instance Variables
28 |
29 | # A list of action names:
30 | variable actions {}
31 |
32 | # The following variables constitute the action database. Each
33 | # is an array, keyed on the action name.
34 |
35 | variable command ;# The Tcl command to execute when invoked.
36 | variable state ;# 1 or 0; enabled or disabled.
37 | variable label ;# The label, for menus and buttons.
38 | variable requires ;# List of condition tags.
39 | variable options ;# List of options and values
40 | variable keycodes ;# list: key-sequence menu-accelerator
41 | variable widgets ;# list: widget names
42 |
43 | #-------------------------------------------------------------------
44 | # Constructor
45 |
46 | # At present, no constructor is needed.
47 |
48 | #-------------------------------------------------------------------
49 | # Public Methods
50 |
51 | # Creates a new action with the specified name and options.
52 | method add {action args} {
53 | if {![regexp {^\S+$} $action]} {
54 | error "action name '$action' contains whitespace"
55 | }
56 |
57 | if {[info exists command($action)]} {
58 | error "action '$action' is already defined"
59 | }
60 |
61 | # Initialize the database.
62 | lappend actions $action
63 |
64 | set command($action) {}
65 | set label($action) {}
66 | set state($action) normal
67 | set requires($action) {}
68 | set options($action) {}
69 | set keycodes($action) {}
70 | set widgets($action) {}
71 |
72 | # Handle the options
73 | foreach {opt value} $args {
74 | switch -exact -- $opt {
75 | -command {
76 | set command($action) $value
77 | }
78 | -requires {
79 | set requires($action) $value
80 | }
81 | -label {
82 | # Figure out the underline index and update the label
83 | set underline [string first "&" $value]
84 |
85 | if {$underline < 0} {
86 | set underline 0
87 | set lbl $value
88 | } else {
89 | set lbl [string replace $value $underline $underline]
90 | }
91 |
92 | lappend options($action) -underline $underline
93 | set label($action) $lbl
94 | }
95 | -image -
96 | -tooltip {
97 | lappend options($action) $opt $value
98 | }
99 | -state {
100 | $self setstate $action $value
101 | }
102 | -keycodes {
103 | if {([llength $value] % 2) != 0} {
104 | error "invalid -keycodes: '$value'"
105 | }
106 | set gui [tk windowingsystem]
107 |
108 | array set codes $value
109 |
110 | if {[info exists codes($gui)]} {
111 | set keycodes($action) $codes($gui)
112 | } elseif {[info exists codes(any)]} {
113 | set keycodes($action) $codes(any)
114 | }
115 | }
116 | -keytag {
117 | $self bindkey $value $action
118 | }
119 | default {
120 | error "unknown option '$opt'"
121 | }
122 | }
123 | }
124 | }
125 |
126 | # Returns a list of all existing actions. If the state is given,
127 | # (normal | disabled) then it returns a list of all actions
128 | # that have that state. Note that updatestate is *NOT* called.
129 | # Call it explicitly if you want it.
130 | method list {{whichstate ""}} {
131 | if {$whichstate eq ""} {
132 | return $actions
133 | }
134 |
135 | set result {}
136 | foreach action $actions {
137 | if {$state($action) eq $whichstate} {
138 | lappend result $action
139 | }
140 | }
141 |
142 | return $result
143 | }
144 |
145 | # Invokes the action, e.g., calls its -command. This is done whether
146 | # the action is enabled or not, as it allows the command to present
147 | # a suitable error message.
148 | method invoke {action args} {
149 | # FIRST, if no error handler just let nature take its course.
150 | if {$options(-errorcommand) eq {}} {
151 | uplevel \#0 $command($action) $args
152 | return
153 | }
154 |
155 | # OTHERWISE, catch any error and pass it to the error handler.
156 | # If the error handler throws an error, then again let nature
157 | # take its course.
158 | if {[catch {uplevel \#0 $command($action) $args} msg]} {
159 | global errorCode
160 | global errorInfo
161 |
162 | uplevel \#0 $options(-errorcommand) \
163 | [list $msg $errorInfo $errorCode]
164 | }
165 |
166 | return
167 | }
168 |
169 | # Sets the state of the named action to normal or disabled.
170 | method setstate {action newstate} {
171 | if {$newstate ne "normal" && $newstate ne "disabled"} {
172 | error "Invalid state: '$newstate'"
173 | }
174 |
175 | set state($action) $newstate
176 |
177 | foreach {type widget} $widgets($action) {
178 | switch -exact $type {
179 | button {
180 | $widget configure -state $newstate
181 | }
182 | menu {
183 | set ndx [$widget index $label($action)]
184 |
185 | $widget entryconfigure $ndx -state $newstate
186 | }
187 | default {
188 | error "Invalid widget type: $type"
189 | }
190 | }
191 | }
192 | }
193 |
194 | # Update state: For every action that has a -requires value,
195 | # run the state command, passing it the action's name and its requirements.
196 | # The state command must return the new state.
197 | method updatestate {} {
198 | if {[llength $options(-statecommand)] == 0} {
199 | return
200 | }
201 |
202 | foreach action $actions {
203 | if {$requires($action) ne ""} {
204 | set cmd $options(-statecommand)
205 | lappend cmd $action $requires($action)
206 |
207 | $self setstate $action [uplevel \#0 $cmd]
208 | }
209 | }
210 |
211 | # Without this, sometimes widget states aren't updated promptly
212 | # on Aqua.
213 | update idletasks
214 | }
215 |
216 | # bindkey tag action ?break?
217 | #
218 | # If a keysequence exists for the action,
219 | # binds the action to the tag (usually a window).
220 | # break is included, the binding will "break".
221 | #
222 | # If there's no keysequence defined, then no binding is done.
223 |
224 | method bindkey {tag action {break ""}} {
225 | # Get the binding for this GUI. If none found, we're done.
226 | set seq [lindex $keycodes($action) 0]
227 |
228 | if {$seq eq ""} {
229 | return
230 | }
231 |
232 | # Do the binding, adding "break" as requested.
233 | set cmd [mymethod invoke $action]
234 |
235 | if {$break eq "break"} {
236 | append cmd "; break"
237 | }
238 |
239 | # If the binding is a modified letter key, do both upper and
240 | # lower case.
241 | if {[regexp {^<(.*)-([a-z])>$} $seq dummy root letter]} {
242 | set upper [string toupper $letter]
243 | set lower [string tolower $letter]
244 |
245 | bind $tag <$root-$upper> $cmd
246 | bind $tag <$root-$lower> $cmd
247 | } else {
248 | bind $tag $seq $cmd
249 | }
250 | }
251 |
252 | # Configures a button to invoke this action; also sets the button's
253 | # label or icon, etc.
254 |
255 | method addbutton {button action args} {
256 | array set opt $options($action)
257 |
258 | button $button \
259 | -command [mymethod invoke $action] \
260 | -state $state($action)
261 |
262 | if {[info exists opt(-image)]} {
263 | $button configure -image $opt(-image)
264 | } else {
265 | $button configure -text $label($action) -underline $opt(-underline)
266 | }
267 |
268 | eval $button configure $args
269 |
270 | # Enable tool tips--except with aqua on Mac OS X, because it
271 | # causes the focus to go away.
272 | if {[info exists opt(-tooltip)]} {
273 | tooltip register $button $opt(-tooltip)
274 | }
275 |
276 | lappend widgets($action) button $button
277 |
278 | return $button
279 | }
280 |
281 |
282 | # Adds a command item for the action to the named menu, and configures
283 | # additional options if desired.
284 |
285 | method addmenuitem {menu action args} {
286 | array set opt $options($action)
287 |
288 | $menu add command \
289 | -command [mymethod invoke $action] \
290 | -label $label($action) \
291 | -underline $opt(-underline) \
292 | -state $state($action) \
293 | -accelerator [lindex $keycodes($action) 1]
294 |
295 | set ndx [$menu index $label($action)]
296 |
297 | foreach {option value} $args {
298 | $menu entryconfigure $ndx $option $value
299 | }
300 |
301 | lappend widgets($action) menu $menu
302 |
303 | # Add a post command to the menu to update the state.
304 | # TBD: Consider making this explicit.
305 | $menu configure -postcommand [mymethod updatestate]
306 | }
307 | }
308 |
309 |
--------------------------------------------------------------------------------
/lib/gui/bullet1.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet1.gif
--------------------------------------------------------------------------------
/lib/gui/bullet2.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet2.gif
--------------------------------------------------------------------------------
/lib/gui/bullet3.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wduquette/notebook/2a9e80cec650ff7899cb9fb1ece68811ebf3fc6a/lib/gui/bullet3.gif
--------------------------------------------------------------------------------
/lib/gui/gui.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # gui.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Main file for the gui package. This package contains
10 | # reusable GUI components written for the Notebook application.
11 | #
12 | #-----------------------------------------------------------------------
13 |
14 | package provide gui 1.0
15 |
16 | package require BWidget 1.9
17 |
18 | namespace eval ::gui:: {
19 | variable library [file dirname [info script]]
20 | variable defaultBackground [. cget -background]
21 |
22 | namespace export actionmanager
23 | namespace export assert
24 | namespace export hasbinding
25 | namespace export require
26 | namespace export rotext
27 | namespace export searchentry
28 | namespace export statusentry
29 | namespace export tooltip
30 | namespace export windowmanager
31 | namespace export windowmenu
32 | }
33 |
34 | #-----------------------------------------------------------------------
35 | # Widget Tweaks for all windowing systems
36 |
37 | # Menu widget
38 | option add *Menu.tearOff no
39 |
40 | #-----------------------------------------------------------------------
41 | # Widget Tweaks for X11
42 |
43 | if {[tk windowingsystem] eq "x11"} {
44 | # On X11, there are quite a few widget option tweaks we'd like to
45 | # do.
46 |
47 | # Text widgets
48 | option add *Text.background white
49 | option add *Text.foreground black
50 | option add *Text.selectBorderWidth 0
51 |
52 | # Scrollbar widgets
53 | option add *Scrollbar.activeBackground $::gui::defaultBackground
54 |
55 | # Button widgets
56 | option add *Button.activeBackground $::gui::defaultBackground
57 | option add *Button.borderWidth 1
58 |
59 | # Menu widgets
60 | option add *Menu.activeBackground "dark blue"
61 | option add *Menu.activeForeground white
62 | option add *Menu.activeBorderWidth 0
63 | option add *Menu.borderWidth 1
64 |
65 | # Entry widgets
66 | option add *Entry.background white
67 | option add *Entry.foreground black
68 | option add *Entry.selectBorderWidth 0
69 | }
70 |
71 | #-----------------------------------------------------------------------
72 | # Widget Tweaks for Mac OS X
73 |
74 | if {[tk windowingsystem] eq "aqua"} {
75 | bind Listbox [bind Listbox ]
76 | }
77 |
78 |
79 |
80 | #-----------------------------------------------------------------------
81 | # Virtual Event Definitions
82 |
83 | # Cut, Copy, Paste, Undo, Redo
84 |
85 | if {[tk windowingsystem] eq "x11"} {
86 | # On X11, we want the standard win32 keybindings for cut, copy, paste,
87 | # undo, and redo to work throughout. So make those keybindings generate
88 | # the relevant virtual events.
89 | #
90 | # 4/28/05: Make sure both upper and lower case work the same.
91 |
92 | event add <>
93 | event add <>
94 | event add <>
95 | event add <>
96 | event add <>
97 | event add <>
98 | event add <>
99 | event add <>
100 |
101 | # Note that is already defined as <>,
102 | # mean ; I need to get rid of that, or
103 | # won't work for <>
104 | event delete <>
105 |
106 | # On X11, <> should be . Provide it in
107 | # both flavors.
108 | event add <>
109 | event add <>
110 |
111 | # In text widgets, the Control-v key can be bound to something else on
112 | # X11. So explicitly unbind it.
113 | bind Text ""
114 | } elseif {[tk windowingsystem] eq "win32"} {
115 | # On Windows, we want the uppercase version of control keys to
116 | # work just like the lower case. So add them all. Include
117 | # the regular ones, just to be explicit.
118 |
119 | event add <>
120 | event add <>
121 | event add <>
122 | event add <>
123 | event add <>
124 | event add <>
125 | event add <>
126 | event add <>
127 | event add <>
128 | event add <>
129 | } elseif {[tk windowingsystem] eq "aqua"} {
130 | # On Mac OS X, we want the uppercase version of control keys to
131 | # work just like the lower case. So add them.
132 |
133 | event add <>
134 | event add <>
135 | event add <>
136 | event add <>
137 | event add <>
138 | event add <>
139 | event add <>
140 | event add <>
141 |
142 | # Tk.tcl erroneously adds Command-y for <>;
143 | # get rid of it before adding the correct keys.
144 | event delete <>
145 |
146 | event add <>
147 | event add <>
148 | }
149 |
150 |
151 | #-----------------------------------------------------------------------
152 | # GUI Component Definitions
153 |
154 | source [file join $::gui::library misc.tcl]
155 | source [file join $::gui::library icon.tcl]
156 | source [file join $::gui::library actionmanager.tcl]
157 | source [file join $::gui::library windowmanager.tcl]
158 | source [file join $::gui::library statusentry.tcl]
159 | source [file join $::gui::library searchentry.tcl]
160 | source [file join $::gui::library rotext.tcl]
161 | source [file join $::gui::library tooltip.tcl]
162 |
163 |
--------------------------------------------------------------------------------
/lib/gui/misc.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # misc.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # GUI Helper Functions for notebook's gui package.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | # Does window $win have a binding for the event in any of its
14 | # bind tags?
15 | proc ::gui::hasbinding {win event} {
16 | if {$win eq ""} {
17 | return 0
18 | }
19 |
20 | foreach tag [bindtags $win] {
21 | if {[bind $tag $event] ne ""} {
22 | return 1
23 | }
24 | }
25 |
26 | return 0
27 | }
28 |
29 | # require expression message
30 | #
31 | # GUIs often have to do a lot of checking to see whether a given
32 | # user-requested action is valid or not, both in terms of program state
33 | # and in terms of the user's input. Procs that implement these actions
34 | # consequently usually begin with a series of if statements; each statement
35 | # checks a condition, emits some appropriate error message to the user, and
36 | # returns. In many cases, this is the bulk of the command.
37 | #
38 | # require streamlines this kind of code, and makes it work better when nested.
39 | # require evaluates the expression. If it's true, require returns
40 | # silently. But if it's false, require throws an error using the
41 | # given message and an errorcode of "USER". This has a number of
42 | # effects on procs written using require:
43 | #
44 | # * They are useful programmatically.
45 | # * They don't need to know how errors are reported to the user.
46 | # * They allow the caller to distinguish between user input errors
47 | # and unexpected programming errors.
48 | # * They can't be attached directly to menu items, buttons, etc.,
49 | # because they need a mediator to catch and present the error.
50 | #
51 | # Thus, using require necessitates some kind of glue mechanism, like
52 | # an action manager of some kind.
53 |
54 | proc ::gui::require {expression message} {
55 | if {[uplevel [list expr $expression]]} {
56 | return
57 | }
58 |
59 | return -code error -errorcode USER $message
60 | }
61 |
62 | # assert expression
63 | #
64 | # Assert is like require, but is used for checking invariants--in
65 | # correctly written code, the expression should invariably be true.
66 | # If the assertion fails an error is thrown indicating
67 | # that an assertion failed and what the condition was.
68 |
69 | proc ::gui::assert {expression} {
70 | if {[uplevel [list expr $expression]]} {
71 | return
72 | }
73 |
74 | return -code error -errorcode ASSERT "Assertion failed: $expression"
75 |
76 | }
--------------------------------------------------------------------------------
/lib/gui/pkgIndex.tcl:
--------------------------------------------------------------------------------
1 | # Tcl package index file
2 |
3 | package ifneeded gui 1.0 \
4 | [list source [file join $dir gui.tcl]]
5 |
6 |
--------------------------------------------------------------------------------
/lib/gui/rotext.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # rotext.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A read-only text widget. A rotext behaves in all ways identical
10 | # to a normal text widget, except that text cannot be inserted or
11 | # deleted by the user.
12 | #
13 | # The widget was made read-only by overriding the "insert" and
14 | # "delete" widget subcommands. They have been replaced by
15 | # "ins" and "del" which do the same thing, but which aren't
16 | # available to the standard mouse and keyboard bindings.
17 | #
18 | # This sneaky trick is due to Donal K. Fellows at the
19 | # Tcler's Wiki; the widget is implemented using snit.
20 | #
21 | # LICENSE:
22 | # Copyright (C) 2003 by William H. Duquette. This file may
23 | # be used subject to the terms in license.txt.
24 | #
25 | #-----------------------------------------------------------------------
26 |
27 | #-----------------------------------------------------------------------
28 | # Public methods
29 |
30 | snit::widgetadaptor ::gui::rotext {
31 | constructor {args} {
32 | # First, create the real text widget.
33 | installhull [text $self -insertwidth 0]
34 | $self configurelist $args
35 |
36 | # Next, copy the default Text bindings to the renderpane,
37 | # and adjust the bindtags so that the Text bindings no longer
38 | # matter. This will allow us to override them.
39 |
40 | foreach sym [bind Text] {
41 | bind $win $sym [bind Text $sym]
42 | }
43 |
44 | set bt [bindtags $win]
45 | set ndx [lsearch -exact $bt Text]
46 | bindtags $win [lreplace $bt $ndx $ndx]
47 |
48 | # Next, remove the <> and <> tags, etc., since renderpanes
49 | # aren't editable.
50 | bind $win <> ""
51 | bind $win <> ""
52 | bind $win <> ""
53 | bind $win <> ""
54 | }
55 |
56 | # Disable the insert and delete methods, to make this readonly.
57 | method insert {args} {}
58 | method delete {args} {}
59 |
60 | # Enable ins and del as synonyms, so the program can insert and
61 | # delete.
62 | delegate method ins to hull as insert
63 | delegate method del to hull as delete
64 |
65 | # Pass all other methods and options to the real text widget, so
66 | # that the remaining behavior is as expected.
67 | delegate method * to hull
68 | delegate option * to hull
69 | }
70 |
71 |
72 |
73 |
--------------------------------------------------------------------------------
/lib/gui/searchentry.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # searchentry.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # A searchentry is an ornamented entry field. The entry is flanked
10 | # on the left by a pulldown that lets the user select one of a number
11 | # search modes, and on the right by a clear button. All three
12 | # components are contained in a single visible border.
13 | #
14 | # The pulldown entries are determined by a widget option.
15 | # The active pulldown selection is also an option.
16 | # The searchentry supports incremental and non-incremental search.
17 | # When the search text is ready, a user-supplied command is called;
18 | # it is passed the search text and the current pulldown option.
19 | #
20 | #-----------------------------------------------------------------------
21 |
22 | snit::widget ::gui::searchentry {
23 | #-------------------------------------------------------------------
24 | # Components
25 |
26 | # The arrow button
27 | variable arrow
28 |
29 | # The entry
30 | delegate option -width to entry
31 |
32 | # The clear button
33 | variable clear
34 |
35 | # The mode menu
36 | variable modemenu
37 |
38 | #-------------------------------------------------------------------
39 | # Variables
40 |
41 | # TBD
42 |
43 | #-------------------------------------------------------------------
44 | # Creation Time Options
45 | #
46 | # These options should only be set at creation time. Note that
47 | # at present there's no error checking to prevent them from being
48 | # set later.
49 |
50 | # A list of mutually exclusive search modes and labels, e.g.,
51 | # -modelist {title "Title Only" all "Title and Contents"}
52 | option -modelist {}
53 |
54 | #--------------------------------------------------------------------
55 | # Other Options
56 |
57 | # The selected search mode: defaults to the first mode in the
58 | # -modelist, or "default" if there is no -modelist.
59 | #
60 | # WARNING: If there's a -modelist, this should only be set to one
61 | # of the modes defined in it. Note that there's no error checking
62 | # on this at present.
63 | option -mode default
64 |
65 | # The user's callback command. It should take two arguments,
66 | # the search mode and the search text. If {}, no command is called.
67 | option -searchcmd {}
68 |
69 | # 1 if we're to do incremental search, and 0 otherwise.
70 | option -incremental 1
71 |
72 | # The search text; maps to the entry's contents. Setting initiates
73 | # a search.
74 | option -searchtext -configuremethod CfgSearchText
75 |
76 | method CfgSearchText {opt value} {
77 | set options($opt) $value
78 |
79 | $self UpdateClear
80 | $self DoSearch complete
81 | }
82 |
83 | #-------------------------------------------------------------------
84 | # Constructor
85 |
86 | constructor {args} {
87 | # FIRST, set the hull's border
88 | $hull configure -relief solid -borderwidth 1 -background white
89 |
90 | # NEXT, get the modelist, since we need it early
91 | set options(-modelist) [from args -modelist]
92 |
93 | # NEXT, identify the search box
94 | label $win.search \
95 | -relief flat \
96 | -borderwidth 0 \
97 | -background white \
98 | -foreground black \
99 | -image ::gui::search
100 |
101 | # NEXT, create the pulldown's arrow button
102 | install arrow using label $win.arrow \
103 | -relief flat \
104 | -borderwidth 0 \
105 | -background white \
106 | -foreground black \
107 | -image ::gui::downarrow
108 |
109 | # Next, create the popup.
110 | install modemenu using menu $win.modemenu \
111 | -tearoff no
112 | bind $arrow <1> [mymethod PostModeMenu]
113 |
114 | $modemenu add radiobutton \
115 | -variable [myvar options(-incremental)] \
116 | -value 1 \
117 | -label "Incremental Search"
118 |
119 | $modemenu add radiobutton \
120 | -variable [myvar options(-incremental)] \
121 | -value 0 \
122 | -label "Non-Incremental Search"
123 |
124 | # If we have modes, add them.
125 | if {[llength $options(-modelist)] > 1} {
126 |
127 | set options(-mode) [lindex $options(-modelist) 0]
128 |
129 | $modemenu add separator
130 |
131 | foreach {mode label} $options(-modelist) {
132 | $modemenu add radiobutton \
133 | -variable [myvar options(-mode)] \
134 | -value $mode \
135 | -label $label \
136 | -command [mymethod DoSearch]
137 | }
138 | }
139 |
140 | # NEXT, create the entry
141 | install entry using entry $win.entry \
142 | -width 20 \
143 | -background white \
144 | -foreground black \
145 | -borderwidth 0 \
146 | -relief flat \
147 | -highlightthickness 0 \
148 | -textvariable [myvar options(-searchtext)]
149 |
150 | bindtags $entry [concat [bindtags $entry] $win]
151 |
152 | bind $win [mymethod KeyPress]
153 | bind $win [mymethod Return]
154 | bind $win [mymethod Clear]
155 |
156 | # NEXT, if the megawidget gets the focus, it should go to the entry.
157 | bind $win [mymethod FocusIn]
158 |
159 | # NEXT, create the clear button
160 | install clear using label $win.clear \
161 | -relief flat \
162 | -borderwidth 0 \
163 | -background white \
164 | -foreground black \
165 | -image ::gui::closex \
166 | -state disabled
167 | bind $clear <1> [mymethod Clear]
168 |
169 | # Pack all of the components into the hull
170 | pack $win.search -side left -fill y -padx 2 -pady 2
171 | pack $arrow -side left -fill y -padx 2 -pady 2
172 | pack $clear -side right -fill y -padx 2 -pady 2
173 | pack $entry -side left -fill both -pady 2 -expand 1
174 |
175 | # Apply the arguments
176 | $self configurelist $args
177 | }
178 |
179 | #-------------------------------------------------------------------
180 | # Private methods
181 |
182 | method FocusIn {} {
183 | focus $entry
184 | $entry selection range 0 end
185 | }
186 |
187 | method KeyPress {} {
188 | $self UpdateClear
189 |
190 | if {!$options(-incremental)} {
191 | return
192 | }
193 |
194 | $self DoSearch incremental
195 |
196 | # We must have had the focus before, since this call only comes
197 | # because of a KeyPress. So put the focus back in the entry
198 | # widget in case the search callback changed it.
199 | focus $entry
200 | }
201 |
202 | method UpdateClear {} {
203 | if {[string length $options(-searchtext)] > 0} {
204 | $clear configure -state normal
205 | } else {
206 | $clear configure -state disabled
207 | }
208 | }
209 |
210 | method Return {} {
211 | $self DoSearch complete
212 |
213 | # We don't want to call KeyRelease, so break the event.
214 | return -code break
215 | }
216 |
217 | method DoSearch {searchtype} {
218 | # Call the search command
219 | set command $options(-searchcmd)
220 | lappend command $options(-mode) $searchtype $options(-searchtext)
221 | uplevel \#0 $command
222 | }
223 |
224 | method Clear {} {
225 | set options(-searchtext) ""
226 | $clear configure -state disabled
227 | $self DoSearch complete
228 | }
229 |
230 | method PostModeMenu {} {
231 | set x [winfo rootx $arrow]
232 | set y [expr {[winfo rooty $arrow] + [winfo height $arrow]}]
233 |
234 | tk_popup $modemenu $x $y
235 | }
236 | }
237 |
238 |
--------------------------------------------------------------------------------
/lib/gui/tooltip.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # tooltip.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # Tool tips for notebook's gui package.
10 | #
11 | #-----------------------------------------------------------------------
12 |
13 | #-----------------------------------------------------------------------
14 | # Tooltip type
15 | #
16 | # The tooltip command is an instance of TooltipType, so that we can
17 | # have options.
18 |
19 | snit::type ::gui::TooltipType {
20 | #-------------------------------------------------------------------
21 | # Options
22 |
23 | option -font {Helvetica 12}
24 | option -background "#FFFFC0"
25 | option -topbackground black
26 | option -foreground black
27 | option -delay 800
28 |
29 | #-------------------------------------------------------------------
30 | # Variables
31 |
32 | # Tool tip text. An array, indexed by window name
33 | variable tiptext
34 |
35 | # Tool tip timeout, or {}
36 | variable timeout {}
37 |
38 | # Tool tip window, or {}
39 | variable tipwin {}
40 |
41 | #-------------------------------------------------------------------
42 | # Constructor
43 |
44 | # Implicit
45 |
46 | #-------------------------------------------------------------------
47 | # Public methods
48 |
49 | method register {window text} {
50 | set tiptext($window) $text
51 |
52 | bind $window [mymethod Enter $window]
53 | bind $window [mymethod Leave $window]
54 | }
55 |
56 | method unregister {window} {
57 | unset tiptext($window)
58 | }
59 |
60 | #-------------------------------------------------------------------
61 | # Private Methods
62 |
63 | # When the mouse pointer enters the window, set the timer.
64 | method Enter {window} {
65 | set timeout [after $options(-delay) [mymethod Popup $window]]
66 | }
67 |
68 | # Pop up the tooltip.
69 | method Popup {window} {
70 | # FIRST, the timeout has fired, so we can forget it.
71 | set timeout {}
72 |
73 | # NEXT, the tooltip will be a child of the window's toplevel.
74 | set top [winfo toplevel $window]
75 |
76 | # NEXT, the tooltip's name depends on which toplevel it is.
77 | set tipwin ".gui_tooltip_window"
78 |
79 | if {$top ne "."} {
80 | set tipwin "$top$tipwin"
81 | }
82 |
83 | # NEXT, create the tooltip window.
84 | frame $tipwin \
85 | -background $options(-topbackground)
86 |
87 | label $tipwin.label \
88 | -text $tiptext($window) \
89 | -foreground $options(-foreground) \
90 | -background $options(-background) \
91 | -font $options(-font)
92 |
93 | # Pack the label with a 1 pixel gap, so that there's a box
94 | # around it.
95 | pack $tipwin.label -padx 1 -pady 1
96 |
97 | # NEXT, the tipwin will be placed in the toplevel relative to
98 | # the position of the registered window. We'll figure this out
99 | # by getting the position of both relative to the root window.
100 |
101 | set tx [winfo rootx $top]
102 | set ty [winfo rooty $top]
103 |
104 | set wx [winfo rootx $window]
105 | set wy [winfo rooty $window]
106 |
107 | # We want to the tip to appear below and to the right of the
108 | # registered window.
109 | set offset [expr {[winfo width $window]/2}]
110 |
111 | # Compute the final position.
112 | set x [expr {($wx - $tx) + $offset}]
113 | set y [expr {($wy - $ty) + [winfo height $window] + 2}]
114 |
115 | # Finally, place the tipwin in its position.
116 | place $tipwin -anchor nw -x $x -y $y
117 |
118 | # If the tipwin runs off the right edge, we slide it left; if
119 | # it sticks off the bottom edge, we put it above the button instead.
120 | # If it still can't be seen, that's too bad.
121 | #
122 | # NOTE: I don't know of any way to determine the size of the
123 | # tipwin without letting it pop up, which causes an ugly
124 | # jump when it has to be moved.
125 | update idletasks
126 |
127 | set nx $x
128 | set ny $y
129 |
130 | set rightEdge [expr {$x + [winfo width $tipwin]}]
131 | set topWid [winfo width $top]
132 |
133 | if {$rightEdge >= $topWid} {
134 | set nx [expr {$x - ($rightEdge - $topWid + 2)}]
135 | }
136 |
137 | set bottomEdge [expr {$y + [winfo height $tipwin] + 2}]
138 | set topHt [winfo height $top]
139 |
140 | if {$bottomEdge >= $topHt} {
141 | set ny [expr {($wy - $ty) - [winfo height $tipwin] - 2}]
142 | }
143 |
144 | if {$nx != $x || $ny != $y} {
145 | place $tipwin -anchor nw -x $nx -y $ny
146 | }
147 | }
148 |
149 | # When the mouse pointer leaves the window, cancel the timer or
150 | # popdown the window, as needed.
151 | method Leave {window} {
152 | if {$timeout ne ""} {
153 | after cancel $timeout
154 | set timeout ""
155 | return
156 | }
157 |
158 | if {$tipwin ne ""} {
159 | destroy $tipwin
160 | set tipwin ""
161 | }
162 | }
163 | }
164 |
165 | #-----------------------------------------------------------------------
166 | # The tooltip command
167 |
168 | ::gui::TooltipType ::gui::tooltip
169 |
--------------------------------------------------------------------------------
/lib/gui/windowmanager.tcl:
--------------------------------------------------------------------------------
1 | #-----------------------------------------------------------------------
2 | # TITLE:
3 | # windowmanager.tcl
4 | #
5 | # AUTHOR:
6 | # Will Duquette
7 | #
8 | # DESCRIPTION:
9 | # notebook-gui component: manages multiple toplevel windows so that
10 | # the when the last one is destroyed, the application termiantes.
11 | #
12 | # To participate, toplevel windows register with the windowmanager
13 | # on creation. A WM_DELETE_WINDOW handler is created automatically.
14 | # If a registered toplevel window wishes to destroy itself, it must
15 | # call "windowmanager destroy $win", which will in turn destroy the
16 | # window.
17 | #
18 | # windowmanager doesn't withdraw "."; the application must do that
19 | # for itself.
20 | #
21 | #-----------------------------------------------------------------------
22 |
23 | # windowmanager is a snit::type used as a singleton.
24 |
25 | snit::type ::gui::windowmanager {
26 | pragma -hasinstances no
27 | pragma -hastypedestroy no
28 |
29 | #-------------------------------------------------------------------
30 | # Type Variables
31 |
32 | # Tracks the open windows. When all are closed, the
33 | # program is terminated.
34 | typevariable windowList
35 |
36 | #-------------------------------------------------------------------
37 | # typemethods
38 |
39 | # Shadow the default create method
40 | typemethod create {args} {
41 | error "invalid method"
42 | }
43 |
44 | # register a new window
45 | typemethod register {window} {
46 | lappend windowList $window
47 |
48 | wm protocol $window WM_DELETE_WINDOW [list $type destroy $window]
49 | }
50 |
51 | # destroy a window
52 | typemethod destroy {window} {
53 | set ndx [lsearch -exact $windowList $window]
54 |
55 | if {$ndx == -1} {
56 | error "can't destroy '$window': not registered with windowmanager"
57 | }
58 |
59 | set windowList [lreplace $windowList $ndx $ndx]
60 |
61 | destroy $window
62 |
63 | if {[llength $windowList] == 0} {
64 | exit 0
65 | }
66 | }
67 |
68 | # Return the list of windows
69 | typemethod windows {} {
70 | return $windowList
71 | }
72 |
73 | # Raise the named window
74 | typemethod raise {window} {
75 | raise $window
76 | wm deiconify $window
77 | }
78 | }
79 |
80 |
--------------------------------------------------------------------------------
/lib/markupparser/README.txt:
--------------------------------------------------------------------------------
1 | markupparser 2.0
2 | -----------------------------------------------------------------
3 |
4 | markupparser parses Notebook markup into an intermediary form,
5 | a flat list of tag/value pairs. The parsing proceeds by first
6 | breaking the input into chunk, where each chunk consists
7 | of one or more full lines of text. There are (at present)
8 | four kinds of chunk:
9 |
10 | Directives
11 | A directive is a line beginning with a hash "#" character;
12 | the specific directive is determined by the text that follows
13 | the hash character. Unless otherwise indicated, any
14 | subsequent text on the line is ignored. Unrecognized
15 | directives are permitted. The existing directives are as
16 | follows:
17 |
18 | #---
19 | Rendered as a horizontal line, e.g.,
.
20 |
21 | #pre
22 | Begins a chunk of preformatted text.
23 |
24 | #unpre
25 | Ends a chunk of preformatted text.
26 |
27 | #Tcl
28 | Begins a chunk of Tcl Code
29 |
30 | #unTcl
31 | Ends a chunk of Tcl Code
32 |
33 | #meta
34 | Defines a named value associated with the pages. It will be
35 | possible to query a page for its metadata.
36 |
37 | #data
38 | Begins a data chunk. A data chunk is just like a Tcl Code or
39 | preformatted text chunk in terms of how it's handled; however,
40 | it will allow other code to easily extract data of a specific
41 | type from a page. Eventually, it might be possible to add
42 | rendering plugins for specific data types.
43 |
44 | #undata
45 | Ends a data chunk.
46 |
47 | Preformatted
48 | A preformatted chunk is to be rendered verbatim in a
49 | fixed-width font. Performatted chunks are found in two
50 | ways: either a paragraph whose first line begins with
51 | a whitespace character, or a group of lines beginning with
52 | a "#pre" directive and ending with a "#unpre" directive
53 | (or the end of the input). (The directives are not
54 | part of the chunk.)
55 |
56 | Tcl Code
57 | A Tcl code chunk is usually rendered Preformatted; it is
58 | a group of lines bracketed by "#Tcl" and "#unTcl".
59 |
60 | Wrapped Text
61 | A wrapped text paragraph consists of one or more lines of
62 | possibly styled text. Wrapped text paragraphs can be
63 | indented; if indented they can have a bullet. Wrapped
64 | text can also contain links, magic buttons, and embedded
65 | macros.
66 |
67 | Note: embedded macros are usually expanded *before* parsing
68 | the markup, so usually there won't be any in the input. If
69 | there are any, they could be anywhere, in any kind of text.
70 | However, the parser will only recognize them in wrapped text.
71 |
72 | Pass-through Text
73 | Sometimes it's desirable to include text in a page that will be
74 | passed through the parser unchanged, e.g., when using macros
75 | to generate HTML in a page that will be exported as HTML.
76 | There are two ways to specify pass-through text.
77 |
78 | #data thru
79 | Text to be passed through.
80 | #undata
81 |
82 | Text wrapped by #data thru/#undata will go through the parser
83 | unchanged, and will be handled by output processors as a single
84 | paragraph.
85 |
86 | This text has some HTML markup.
87 |
88 | Within a paragraph of wrapped text, the ...
89 | tags can be used to quote a section of text to pass
90 | through unchanged. If the example above were exported
91 | as HTML without the ... tags, the angle
92 | brackets on and would be escaped as
93 | < and >.
94 |
95 |
96 | Intermediate Form
97 | -----------------------------------------------------------------
98 |
99 | The parser parses the input and produces the intermediate form,
100 | a flat list of tag/value pairs. The tags and their values are
101 | defined as follows:
102 |
103 |
104 | META
105 | The value of META is a dict of the #meta values defined in
106 | this page. If the same keyword appears multiple times, the
107 | final value is retained. If no #meta directives appear in
108 | this page, META appears with an empty list as its value.
109 |
110 | META is always the first tag in the list.
111 |
112 | HASH
113 | One of these pairs is produced for each directive; the value is
114 | the complete line of text, including the newline at the end.
115 |
116 | PRE
117 | This is usually Preformatted text, to be displayed verbatim. The
118 | value is the exact set of lines from the input. If the chunk was
119 | delimited by "#pre" and "#unpre" directives, then this tag/value
120 | will be preceded and followed by the appropriate HASH tag/values.
121 |
122 | TCL
123 | The is a chunk of Tcl code. This tag/value will be preceded
124 | and followed by the "#Tcl" and "#unTcl" HASH tag/values.
125 |
126 | DATA { }
127 | The value of DATA is a list of two elements; the data name from
128 | the #data line and the chunk of data that appeared between the
129 | #data and #undata.
130 |
131 | When the is "thru", the is to be passed through
132 | the parser unchanged.
133 |
134 | P {:|* }
135 | Begins a paragraph of wrapped text. The value is a list of three
136 | items: the paragraph type (":" or "*"), the indent level (0 or
137 | higher) and (for indented and bulleted paragraphs) the leading
138 | string, which is the whitespace between the initial "*" or ":"
139 | and the paragraph text. (It's used to reconstruct a parsed page
140 | just exactly as it was.)
141 |
142 | A normal, non-indented non-bulleted paragraph will begin with
143 |
144 | P {: 0 {}}
145 |
146 | A paragraph with an indent level of 1 will begin with this
147 | (where the length of the leading string depends on the actual
148 | input):
149 |
150 | P {: 1 { }}
151 |
152 | A bulleted paragraph with an indent level of 1 will begin with
153 | this:
154 |
155 | P {* 1 { }}
156 |
157 | For bulleted paragraphs, the indent level must be 1 or more.
158 | Note that a normal paragraph is simply an indented paragraph
159 | with an indent level of zero.
160 |
161 | /P
162 | Terminates a paragraph of wrapped text, of whatever kind.
163 |
164 | The following tags represent components of a paragraph of wrapped
165 | text; they will always appear between P and /P.
166 |
167 | TXT
168 | The value is plain text to be wrapped and rendered.
169 |
170 | THRU
171 | The value is text in the current output format; it
172 | was passed through the parser unchanged.
173 |
174 | STY { }
175 | Notebook markup defines a number of HTML-like style codes,
176 | e.g., ... and .... When one is found in a
177 | wrapped paragraph, this tag is generated. The tag's value is
178 | a list of three elements: the raw style code (), the
179 | style letter (b), and a flag: 1 when the style turns on and
180 | 0 when the style turns off. Note that all styles are
181 | cancelled at the end of the paragraph.
182 |
183 | A renderer is free to render the styles as it prefers.
184 |
185 | LINK
186 | The value is a page link, not including the [ and ].
187 |
188 | BTN
" 250 | } elseif {$this(para) eq "*"} { 251 | append result "
. 20 | 21 | #pre 22 | Begins a chunk of preformatted text. 23 | 24 | #unpre 25 | Ends a chunk of preformatted text. 26 | 27 | #Tcl 28 | Begins a chunk of Tcl Code 29 | 30 | #unTcl 31 | Ends a chunk of Tcl Code 32 | 33 | #meta