/
pdtk_canvas.tcl
588 lines (517 loc) · 23.5 KB
/
pdtk_canvas.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
package provide pdtk_canvas 0.1
package require pd_bindings
namespace eval ::pdtk_canvas:: {
# the untitled name prefix pd checks for using a macro in g_canvas.h,
# a saveas panel is shown when saving a file with this name
variable untitled_name "PDUNTITLED"
variable untitled_len 10
namespace export pdtk_canvas_popup
namespace export pdtk_canvas_editmode
namespace export pdtk_canvas_getscroll
namespace export pdtk_canvas_setparents
namespace export pdtk_canvas_reflecttitle
namespace export pdtk_canvas_menuclose
}
# store the filename associated with this window,
# so we can use it during menuclose
array set ::pdtk_canvas::::window_fullname {}
array set ::pdtk_canvas::geometry_needs_init {}
# One thing that is tricky to understand is the difference between a Tk
# 'canvas' and a 'canvas' in terms of Pd's implementation. They are similar,
# but not the same thing. In Pd code, a 'canvas' is basically a patch, while
# the Tk 'canvas' is the backdrop for drawing everything that is in a patch.
# The Tk 'canvas' is contained in a 'toplevel' window. That window has a Tk
# class of 'PatchWindow'.
# TODO figure out weird frameless window when you open a graph
#TODO: http://wiki.tcl.tk/11502
# MS Windows
#wm geometry . returns contentswidthxcontentsheight+decorationTop+decorationLeftEdge.
#and
#winfo rooty . returns contentsTop
#winfo rootx . returns contentsLeftEdge
if {[tk windowingsystem] eq "win32" || \
$::tcl_version < 8.5 || \
($::tcl_version == 8.5 && \
[tk windowingsystem] eq "aqua" && \
[lindex [split [info patchlevel] "."] 2] < 13) } {
# fit the geometry onto screen for Tk 8.4 or win32,
# also check for Tk Cocoa backend on macOS which is only stable in 8.5.13+;
# newer versions of Tk can handle multiple monitors so allow negative pos
proc pdtk_canvas_wrap_window {x y w h} {
foreach {width height} [wm maxsize .] {break}
if {$w > $width} {
set w $width
set x 0
}
if {$h > $height} {
# 30 for window framing
set h [expr $height - $::menubarsize]
set y $::menubarsize
}
set xmin [winfo vrootx .]
set ymin [winfo vrooty .]
set x [expr ($x - $xmin) % $width + $xmin]
set y [expr ($y - $ymin) % $height + $ymin]
return [list ${x} ${y} ${w} ${h}]
}
} {
proc pdtk_canvas_wrap_window {x y w h} {
return [list ${x} ${y} ${w} ${h}]
}
}
# this proc is split out on its own to make it easy to override. This makes it
# easy for people to customize these calculations based on their Window
# Manager, desires, etc.
proc pdtk_canvas_place_window {width height geometry} {
# read back the current geometry +posx+posy into variables
set w $width
set h $height
set xypos ""
if { "" != ${geometry} } {
scan $geometry {%[+]%d%[+]%d} - x - y
foreach {x y w h} [pdtk_canvas_wrap_window $x $y $width $height] {break}
set xypos +${x}+${y}
}
return [list ${w} ${h} ${w}x${h}${xypos}]
}
#------------------------------------------------------------------------------#
# canvas new/saveas
proc pdtk_canvas_new {mytoplevel width height geometry editable} {
if { "" eq $geometry } {
# no position set: this is a new window (rather than one loaded from file)
# we set a flag here, so we can query (and report) the actual geometry,
# once the window is fully created
set ::pdtk_canvas::geometry_needs_init($mytoplevel) 1
}
foreach {width height geometry} [pdtk_canvas_place_window $width $height $geometry] {break;}
set ::undo_actions($mytoplevel) no
set ::redo_actions($mytoplevel) no
# release the window grab here so that the new window will
# properly get the Map and FocusIn events when its created
::pdwindow::busyrelease
# set the loaded array for this new window so things can track state
set ::loaded($mytoplevel) 0
toplevel $mytoplevel -width $width -height $height -class PatchWindow
wm group $mytoplevel .
$mytoplevel configure -menu $::patch_menubar
# we have to wait until $mytoplevel exists before we can generate
# a <<Loading>> event for it, that's why this is here and not in the
# started_loading_file proc. Perhaps this doesn't make sense tho
event generate $mytoplevel <<Loading>>
if { "" != ${geometry} } {
wm geometry $mytoplevel $geometry
}
wm minsize $mytoplevel $::canvas_minwidth $::canvas_minheight
set tkcanvas [tkcanvas_name $mytoplevel]
canvas $tkcanvas -width $width -height $height \
-highlightthickness 0 -scrollregion [list 0 0 $width $height] \
-xscrollcommand "$mytoplevel.xscroll set" \
-yscrollcommand "$mytoplevel.yscroll set" \
-background white
scrollbar $mytoplevel.xscroll -orient horizontal -command "$tkcanvas xview"
scrollbar $mytoplevel.yscroll -orient vertical -command "$tkcanvas yview"
pack $tkcanvas -side left -expand 1 -fill both
# for some crazy reason, win32 mousewheel scrolling is in units of
# 120, and this forces Tk to interpret 120 to mean 1 scroll unit
if {$::windowingsystem eq "win32"} {
$tkcanvas configure -xscrollincrement 1 -yscrollincrement 1
}
::pd_bindings::patch_bindings $mytoplevel
# give focus to the canvas so it gets the events rather than the window
focus $tkcanvas
# let the scrollbar logic determine if it should make things scrollable
set ::xscrollable($tkcanvas) 0
set ::yscrollable($tkcanvas) 0
# init patch properties arrays
set ::editingtext($mytoplevel) 0
set ::childwindows($mytoplevel) {}
# this should be at the end so that the window and canvas are all ready
# before this variable changes.
set ::editmode($mytoplevel) $editable
}
# if the patch canvas window already exists, then make it come to the front
proc pdtk_canvas_raise {mytoplevel} {
wm deiconify $mytoplevel
raise $mytoplevel
set mycanvas $mytoplevel.c
focus $mycanvas
}
proc pdtk_canvas_saveas {mytoplevel initialfile initialdir destroyflag} {
if { ! [file isdirectory $initialdir]} {set initialdir $::filenewdir}
set filename [tk_getSaveFile -initialdir $initialdir \
-initialfile [::pdtk_canvas::cleanname "$initialfile"] \
-defaultextension .pd -filetypes $::filetypes]
if {$filename eq ""} return; # they clicked cancel
set extension [file extension $filename]
set oldfilename $filename
set filename [regsub -- "$extension$" $filename [string tolower $extension]]
if { ! [regexp -- "\.(pd|pat|mxt)$" $filename]} {
# we need the file extension even on Mac OS X
set filename $filename.pd
}
# test again after downcasing and maybe adding a ".pd" on the end
if {$filename ne $oldfilename && [file exists $filename]} {
set answer [tk_messageBox -type okcancel -icon question -default cancel\
-message [_ "\"$filename\" already exists. Do you want to replace it?"]]
if {$answer eq "cancel"} return; # they clicked cancel
}
set dirname [file dirname $filename]
set basename [file tail $filename]
pdsend "$mytoplevel savetofile [enquote_path $basename] [enquote_path \
$dirname] $destroyflag"
set ::filenewdir $dirname
# add to recentfiles
::pd_guiprefs::update_recentfiles $filename
}
##### ask user Save? Discard? Cancel?, and if so, send a message on to Pd ######
proc ::pdtk_canvas::pdtk_canvas_menuclose {mytoplevel reply_to_pd} {
raise $mytoplevel
set filename [lindex [array get ::pdtk_canvas::::window_fullname $mytoplevel] 1]
set message [format [_ "Do you want to save the changes you made in '%s'?"] $filename]
set answer [tk_messageBox -message $message -type yesnocancel -default "yes" \
-parent $mytoplevel -icon question]
switch -- $answer {
yes {pdsend "$mytoplevel menusave 1"}
no {pdsend $reply_to_pd}
cancel {}
}
}
#------------------------------------------------------------------------------#
# mouse usage
# TODO put these procs into the pdtk_canvas namespace
proc pdtk_canvas_motion {tkcanvas x y mods} {
set mytoplevel [winfo toplevel $tkcanvas]
pdsend "$mytoplevel motion [$tkcanvas canvasx $x] [$tkcanvas canvasy $y] $mods"
}
proc pdtk_canvas_mouse {tkcanvas x y b f} {
set mytoplevel [winfo toplevel $tkcanvas]
pdsend "$mytoplevel mouse [$tkcanvas canvasx $x] [$tkcanvas canvasy $y] $b $f"
}
proc pdtk_canvas_mouseup {tkcanvas x y b {f 0}} {
set mytoplevel [winfo toplevel $tkcanvas]
pdsend "$mytoplevel mouseup [$tkcanvas canvasx $x] [$tkcanvas canvasy $y] $b $f"
}
proc pdtk_canvas_rightclick {tkcanvas x y b} {
set mytoplevel [winfo toplevel $tkcanvas]
pdsend "$mytoplevel mouse [$tkcanvas canvasx $x] [$tkcanvas canvasy $y] $b 8"
}
# on X11, button 2 pastes from X11 clipboard, so simulate normal paste actions
proc pdtk_canvas_clickpaste {tkcanvas x y b} {
pdtk_canvas_mouse $tkcanvas $x $y $b 0
pdtk_canvas_mouseup $tkcanvas $x $y $b 0
if { [catch {set pdtk_pastebuffer [selection get]}] } {
# no selection... do nothing
} else {
for {set i 0} {$i < [string length $pdtk_pastebuffer]} {incr i 1} {
set cha [string index $pdtk_pastebuffer $i]
scan $cha %c keynum
pdsend "[winfo toplevel $tkcanvas] key 1 $keynum 0"
}
}
}
proc ::pdtk_canvas::pdtk_get_clipboard_text {tkcanvas} {
set CLIPBOARD_PATCH_TEXT_START 0;
set CLIPBOARD_PATCH_TEXT_LINE_END 1;
set CLIPBOARD_PATCH_TEXT_END 2;
set CLIPBOARD_PATCH_TEXT_LINE_PARTIAL 3;
set MAX_CHUNK_SIZE 960;
set clipboard_data [clipboard get]
# TODO: better validation of PD patch clipboard data
if {[string index $clipboard_data 0] != "#"} {
::pdwindow::post "Warning: Clipboard content does not seem to be valid PD patch: \n"
::pdwindow::post $clipboard_data
return
}
pdsend "[winfo toplevel $tkcanvas] got-clipboard-contents $CLIPBOARD_PATCH_TEXT_START NONE"
foreach line [split $clipboard_data \n] {
if {[string length $line] > 0} {
set escaped_line [string range $line 0 end-1]
set escaped_line [string map {" " {\ } ";" {\\;} "," {\\,} "\$" "\\$"} $escaped_line]
# split each line into chunks, and make sure atoms don't get split
while {[string length $escaped_line] > $MAX_CHUNK_SIZE} {
set boundary [string last { } [string range $escaped_line 0 [expr $MAX_CHUNK_SIZE - 1]]]
set chunk [string range $escaped_line 0 $boundary]
pdsend "[winfo toplevel $tkcanvas] got-clipboard-contents $CLIPBOARD_PATCH_TEXT_LINE_PARTIAL $chunk"
set escaped_line [string range $escaped_line [expr $boundary + 1] end]
}
# FIXME: the atoms can have width property, i.e. , f 12 - this last comma is not escaped
# and causing lot of trouble, so discarding it for now
# fix by adding new flag and appending comma manually to binbuf
set escaped_line [regsub {\,\\\sf\\\s\d+$} $escaped_line ""]
pdsend "[winfo toplevel $tkcanvas] got-clipboard-contents $CLIPBOARD_PATCH_TEXT_LINE_END $escaped_line"
}
}
pdsend "[winfo toplevel $tkcanvas] got-clipboard-contents $CLIPBOARD_PATCH_TEXT_END NONE"
}
proc pdtk_copy_to_clipboard_as_text {tkcanvas args} {
clipboard clear
set clipboard_content ""
set atom_line ""
set obj_type ""
for {set i 0} {$i < [llength $args]} {incr i} {
set prev_atom [lindex $args [expr $i - 1]]
set atom [lindex $args $i]
set next_atom [lindex $args [expr $i + 1]]
set next_next_atom [lindex $args [expr $i + 2]]
# Check for beginning of new line (#) but discard hex colors
if {[string first "#" $atom] == 0 && ![regexp {^#[0-9a-fA-F]{6}$} $atom]} {
append clipboard_content [string trim $atom_line]
append clipboard_content "\n"
set atom_line "$atom "
set obj_type $next_atom
} else {
if {$atom == ";" && ([string first "#" $next_atom] == 0 || $next_atom == "")} {
set atom_line [string trimright $atom_line]
append atom_line ";"
} elseif {$atom == ";"} {
append atom_line "\\; "
} elseif {[string first "\$" $atom] == 0} {
append atom_line "\\$" [string range $atom 1 end] " "
} elseif {$atom == ","} {
# text items can have unescaped comma delimiting the width attribute
if {$obj_type == "text"} {
append atom_line [expr {$next_atom != "f" ? "\\, " : ", "}]
} else {
append atom_line "\\, "
}
} else {
set delimiter [expr {$obj_type == "text" && $next_next_atom == "f" ? "" : " "}]
append atom_line $atom $delimiter
}
}
}
append clipboard_content "$atom_line\n"
set processed_content $clipboard_content
clipboard append [string trimleft $processed_content]
}
#------------------------------------------------------------------------------#
# canvas popup menu
# since there is one popup that is used for all canvas windows, the menu
# -commands use {} quotes so that $::focused_window is interpreted when the
# menu item is called, not when the command is mapped to the menu item. This
# is the same as the menubar in pd_menus.tcl but the opposite of the 'bind'
# commands in pd_bindings.tcl
proc ::pdtk_canvas::create_popup {popupid actionwindow x y} {
if { ! [winfo exists $popupid]} {
# the popup menu for the canvas
menu $popupid -tearoff false
$popupid add command -label [_ "Properties"] \
-command "::pdtk_canvas::done_popup $actionwindow 0 $x $y"
$popupid add command -label [_ "Open"] \
-command "::pdtk_canvas::done_popup $actionwindow 1 $x $y"
$popupid add command -label [_ "Help"] \
-command "::pdtk_canvas::done_popup $actionwindow 2 $x $y"
}
}
proc ::pdtk_canvas::done_popup {mytoplevel action x y} {
pdsend "$mytoplevel done-popup $action $x $y"
}
proc ::pdtk_canvas::pdtk_canvas_popup {mytoplevel xcanvas ycanvas hasproperties hasopen} {
set toplevel [winfo toplevel $mytoplevel]
set tkcanvas [tkcanvas_name $toplevel]
set popup ${toplevel}.popup
destroy $popup
::pdtk_canvas::create_popup ${popup} ${toplevel} ${xcanvas} ${ycanvas}
if {$hasproperties} {
${popup} entryconfigure [_ "Properties"] -state normal
} else {
${popup} entryconfigure [_ "Properties"] -state disabled
}
if {$hasopen} {
${popup} entryconfigure [_ "Open"] -state normal
} else {
${popup} entryconfigure [_ "Open"] -state disabled
}
set scrollregion [$tkcanvas cget -scrollregion]
# get the canvas location that is currently the top left corner in the window
set left_xview_pix [expr [lindex [$tkcanvas xview] 0] * [lindex $scrollregion 2]]
set top_yview_pix [expr [lindex [$tkcanvas yview] 0] * [lindex $scrollregion 3]]
# take the mouse clicks in canvas coords, add the root of the canvas
# window, and subtract the area that is obscured by scrolling
set xpopup [expr int($xcanvas + [winfo rootx $tkcanvas] - $left_xview_pix)]
set ypopup [expr int($ycanvas + [winfo rooty $tkcanvas] - $top_yview_pix)]
tk_popup ${popup} ${xpopup} ${ypopup} 0
}
if {[tk windowingsystem] eq "aqua" } {
# I don't know how to move the mouse on OSX, so skip it
proc ::pdtk_canvas::setmouse {tkcanvas x y} { }
} else {
proc ::pdtk_canvas::setmouse {tkcanvas x y} {
# set the mouse to the given position
# (same coordinate system as reported by pdtk_canvas_motion)
event generate $tkcanvas <Motion> -warp 1 -x $x -y $y
}
}
#------------------------------------------------------------------------------#
# procs for when file loading starts/finishes
proc ::pdtk_canvas::started_loading_file {patchname} {
::pdwindow::busygrab
}
# things to run when a patch is finished loading. This is called when
# the OS sends the "Map" event for this window.
proc ::pdtk_canvas::finished_loading_file {mytoplevel} {
# ::pdwindow::busyrelease is in pdtk_canvas_new so that the grab
# is released before the new toplevel window gets created.
# Otherwise the grab blocks the new window from getting the
# FocusIn event on creation.
# set editmode to make sure the menu item is in the right state
pdtk_canvas_editmode $mytoplevel $::editmode($mytoplevel)
set ::loaded($mytoplevel) 1
# send the virtual events now that everything is loaded
event generate $mytoplevel <<Loaded>>
# if the window was created without a position (that is: a new window),
# we have the opportunity to query the actual position now
if { "" ne [array names ::pdtk_canvas::geometry_needs_init $mytoplevel ] } {
array unset ::pdtk_canvas::geometry_needs_init $mytoplevel
scan [wm geometry $mytoplevel] {%dx%d%[+]%d%[+]%d} width height - x - y
# on X11, 'wm geometry' won't report a useful position until the window was moved
# but 'winfo geometry' does (though slightly off, but we ignore this offset
# for newly created, never moved windows)
# other windowingsystems will already report a useful position, and luckily
# they report the same for 'wm geometry' and 'winfo geometry'
if { "+$x+$y" eq "+0+0" } {
scan [winfo geometry $mytoplevel] {%dx%d%[+]%d%[+]%d} width height - x - y
pdsend "$mytoplevel setbounds $x $y [expr $x + $width] [expr $y + $height]"
}
}
}
#------------------------------------------------------------------------------#
# procs for canvas events
# check or uncheck the "edit" menu item
proc ::pdtk_canvas::pdtk_canvas_editmode {mytoplevel state} {
set ::editmode_button $state
set ::editmode($mytoplevel) $state
event generate $mytoplevel <<EditMode>>
}
# message from Pd to update the currently available undo/redo action
proc pdtk_undomenu {mytoplevel undoaction redoaction} {
set ::undo_actions($mytoplevel) $undoaction
set ::redo_actions($mytoplevel) $redoaction
if {$mytoplevel ne "nobody"} {
::pd_menus::update_undo_on_menu $mytoplevel $undoaction $redoaction
}
}
# This proc configures the scrollbars whenever anything relevant has
# been updated. It should always receive a tkcanvas, which is then
# used to generate the mytoplevel, needed to address the scrollbars.
proc ::pdtk_canvas::pdtk_canvas_getscroll {tkcanvas} {
if {! [winfo exists $tkcanvas]} {
return
}
set mytoplevel [winfo toplevel $tkcanvas]
set height [winfo height $tkcanvas]
set width [winfo width $tkcanvas]
set bbox [$tkcanvas bbox all]
if {$bbox eq "" || [llength $bbox] != 4} {return}
set xupperleft [lindex $bbox 0]
set yupperleft [lindex $bbox 1]
if {$xupperleft > 0} {set xupperleft 0}
if {$yupperleft > 0} {set yupperleft 0}
set xlowerright [lindex $bbox 2]
set ylowerright [lindex $bbox 3]
if {$xlowerright < $width} {set xlowerright $width}
if {$ylowerright < $height} {set ylowerright $height}
set scrollregion [concat $xupperleft $yupperleft $xlowerright $ylowerright]
$tkcanvas configure -scrollregion $scrollregion
# X scrollbar
if {[lindex [$tkcanvas xview] 0] == 0.0 && [lindex [$tkcanvas xview] 1] == 1.0} {
set ::xscrollable($tkcanvas) 0
pack forget $mytoplevel.xscroll
} else {
set ::xscrollable($tkcanvas) 1
pack $mytoplevel.xscroll -side bottom -fill x -before $tkcanvas
}
# Y scrollbar, it gets touchy at the limit, so say > 0.995
if {[lindex [$tkcanvas yview] 0] == 0.0 && [lindex [$tkcanvas yview] 1] > 0.995} {
set ::yscrollable($tkcanvas) 0
pack forget $mytoplevel.yscroll
} else {
set ::yscrollable($tkcanvas) 1
pack $mytoplevel.yscroll -side right -fill y -before $tkcanvas
}
}
proc ::pdtk_canvas::scroll {tkcanvas axis amount} {
if {$axis eq "x" && $::xscrollable($tkcanvas) == 1} {
$tkcanvas xview scroll [expr {- ($amount)}] units
}
if {$axis eq "y" && $::yscrollable($tkcanvas) == 1} {
$tkcanvas yview scroll [expr {- ($amount)}] units
}
}
#------------------------------------------------------------------------------#
# get patch window child/parent relationships
# add a child window ID to the list of children, if it isn't already there
proc ::pdtk_canvas::addchild {mytoplevel child} {
# if either ::childwindows($mytoplevel) does not exist, or $child does not
# exist inside of the ::childwindows($mytoplevel list
if { [lsearch -exact [array names ::childwindows $mytoplevel]] == -1 \
|| [lsearch -exact $::childwindows($mytoplevel) $child] == -1} {
set ::childwindows($mytoplevel) [lappend ::childwindows($mytoplevel) $child]
}
}
# receive a list of all my parent windows from 'pd'
proc ::pdtk_canvas::pdtk_canvas_setparents {mytoplevel args} {
# check if the user passed a list (instead of multiple arguments)
if { [llength $args] == 1 } {set args [lindex $args 0]}
set parents {}
foreach parent $args {
if { [catch {set parent [winfo toplevel $parent]}] } {
if { [file extension $parent] eq ".c" } {set parent [file rootname $parent]}
}
lappend parents $parent
addchild $parent $mytoplevel
}
set ::parentwindows($mytoplevel) $parents
}
# receive information for setting the info in the title bar of the window
proc ::pdtk_canvas::pdtk_canvas_reflecttitle {mytoplevel \
path name arguments dirty} {
set path [::pdtk_text::unescape $path]
set name [::pdtk_text::unescape $name]
set arguments [::pdtk_text::unescape $arguments]
set name [::pdtk_canvas::cleanname "$name"]
set ::windowname($mytoplevel) $name
set ::pdtk_canvas::::window_fullname($mytoplevel) "$path/$name"
if {$::windowingsystem eq "aqua"} {
wm attributes $mytoplevel -modified $dirty
if {[file exists "$path/$name"]} {
# for some reason -titlepath can still fail so just catch it
if [catch {wm attributes $mytoplevel -titlepath "$path/$name"}] {
wm title $mytoplevel "$path/$name"
}
}
wm title $mytoplevel "$name$arguments"
} else {
if {$dirty} {set dirtychar "*"} else {set dirtychar " "}
wm title $mytoplevel "$name$dirtychar$arguments - $path"
}
}
#------------------------------------------------------------------------------#
# utils
# provide a clean filename to avoid saving files with the untitled name prefix
proc ::pdtk_canvas::cleanname {name} {
variable untitled_name
variable untitled_len
if {[string compare -length $untitled_len "$name" "$untitled_name"] == 0} {
# replace untitled prefix with a display name
# TODO localize "Untitled" & make sure translations do not contain spaces
return [string replace "$name" 0 [expr $untitled_len - 1] "Untitled"]
}
return $name
}
set enable_cords_to_foreground false
proc ::pdtk_canvas::cords_to_foreground {mytoplevel {state 1}} {
global enable_cords_to_foreground
if {$enable_cords_to_foreground eq "true"} {
set col black
if { $state == 0 } {
set col lightgrey
}
foreach id [$mytoplevel find withtag {cord && !selected}] {
# don't apply backgrouding on selected (blue) lines
if { [lindex [$mytoplevel itemconfigure $id -fill] 4 ] ne "blue" } {
$mytoplevel itemconfigure $id -fill $col
}
}
}
}