228 changed files with 128781 additions and 131 deletions
@ -0,0 +1,186 @@
|
||||
2013-11-22 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Reviewed the work on the pyk-tar branch. Brought |
||||
* tar.tcl: new testsuite up to spec. Reviewed the skip fix, |
||||
* tar.test: modified it to reinstate the skip limit per round |
||||
* test-support.tcl: without getting the bug back. Bumped version |
||||
to 0.9. Thanks to PoorYorick for the initial work on the bug, |
||||
fix, and testsuite. This also fixes ticket [6b7aa0aecc]. |
||||
|
||||
2013-08-12 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man (tar::untar, contents, stat, get): Extended the |
||||
* tar.tcl: procedures to detect and properly handle @LongName |
||||
* pkgIndex.tcl: header entries as generated by GNU tar. These |
||||
entries contain the file name for the next header entry as file |
||||
data, for files whose name is longer than the 100-char field of |
||||
the regular header. Version bumped to 0.8. This is a new |
||||
feature. |
||||
|
||||
2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.15 ======================== |
||||
* |
||||
|
||||
2012-09-11 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl (seekorskip): Fixed seekorskip which prevented its use |
||||
* pkgIndex.tcl: from a non-seekable channel, like stdin. The issue |
||||
was that the original attempt to seek before skipping not just |
||||
failed, but apparently still moved the read pointer in some way |
||||
which skipped over irreplacable input, breaking the next call of |
||||
readHeader. Using [tell] to check seekability does not break in |
||||
this manner. Bumped version to 0.7.1. |
||||
|
||||
2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.14 ======================== |
||||
* |
||||
|
||||
2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.13 ======================== |
||||
* |
||||
|
||||
2011-01-20 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl: [Bug 3162548]: Applied patch by Alexandre Ferrieux, |
||||
* tar.man: extending various tar commands to be able to use |
||||
* pkgIndex.tcl: the -chan option, and channels instead of files. |
||||
Version bumped to 0.7 |
||||
|
||||
2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.12 ======================== |
||||
* |
||||
|
||||
2009-12-03 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: [Patch 2840147]. Applied. New options -prefix and |
||||
* tar.tcl: -quick for tar::add. -prefix allows specifying a |
||||
* tar.pcx: prefix for filenames in the archive, and -quick 1 |
||||
* pkgIndex.tcl: changes back to the seek-from-end algorithm for |
||||
finding the place where to add the new files. The new default |
||||
scans from start (robust). Bumped version to 0.6. |
||||
|
||||
2009-05-12 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: add support for reading pre-posix archives. |
||||
if a file isnt writable when extracting, try deleting |
||||
before giving up. |
||||
|
||||
2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.11.1 ======================== |
||||
* |
||||
|
||||
2008-11-26 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.man: add and clarify documentation |
||||
|
||||
2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.11 ======================== |
||||
* |
||||
|
||||
2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.pcx: New file. Syntax definitions for the public commands of |
||||
the tar package. |
||||
|
||||
2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.10 ======================== |
||||
* |
||||
|
||||
2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.man: Fixed all warnings due to use of now deprecated |
||||
commands. Added a section about how to give feedback. |
||||
|
||||
2007-02-08 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: bug fix in recursion algorithm that missed |
||||
some files in deep subdirs. incremented version |
||||
|
||||
2007-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.tcl: Bumped version to 0.3, for the bugfix described |
||||
* tar.man: by the last entry. |
||||
* pkgIndex.tcl: |
||||
|
||||
2006-12-20 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: fix in parseOpts which affected -file and -glob |
||||
arguments to tar::untar |
||||
* tar.man: clarifications to add, create, and untar |
||||
|
||||
2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.9 ======================== |
||||
* |
||||
|
||||
2006-29-06 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: fixed bug in parseOpts |
||||
|
||||
2005-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* pkgIndex.tcl: Corrected buggy commit, synchronized version |
||||
* tar.man: numbers across all relevant files. |
||||
|
||||
2005-11-08 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: bumped version to 0.2 because of new feature |
||||
* tar.man: tar::remove |
||||
|
||||
2005-11-07 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Fixed error, incorrect placement of [call] markup |
||||
outside of list. |
||||
|
||||
2005-11-04 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.man: added tar::remove command and documentation for it |
||||
* tar.tcl: |
||||
|
||||
2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.8 ======================== |
||||
* |
||||
|
||||
2005-09-30 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl: qualified all [open] calls with :: to ensure usag of |
||||
the builtin. Apparently mitigates conflict between this package |
||||
and the vfs::tar module. |
||||
|
||||
2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.7 ======================== |
||||
* |
||||
|
||||
2004-10-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.man: Added keywords and title/module description to the |
||||
documentation. |
||||
|
||||
2004-09-10 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: Fixed typo bug in ::tar::add |
||||
* tar.man: Added info for ::tar::stat |
||||
|
||||
2004-08-23 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Fixed problems in the documentation. |
||||
|
||||
@ -0,0 +1,5 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
# PRAGMA: returnok |
||||
return |
||||
} |
||||
package ifneeded tar 0.12 [list source [file join $dir tar.tcl]] |
||||
@ -0,0 +1,202 @@
|
||||
[comment {-*- mode: tcl ; fill-column: 80 -*- doctools manpage}] |
||||
[vset PACKAGE_VERSION 0.12] |
||||
[manpage_begin tar n [vset PACKAGE_VERSION]] |
||||
[keywords archive] |
||||
[keywords {tape archive}] |
||||
[keywords tar] |
||||
[moddesc {Tar file handling}] |
||||
[titledesc {Tar file creation, extraction & manipulation}] |
||||
[category {File formats}] |
||||
[require Tcl "8.5 9"] |
||||
[require tar [opt [vset PACKAGE_VERSION]]] |
||||
[description] |
||||
|
||||
[para] [strong Note]: Starting with version 0.8 the tar reader commands |
||||
(contents, stats, get, untar) support the GNU LongName extension (header type |
||||
'L') for large paths. |
||||
|
||||
[para] |
||||
|
||||
[section BEWARE] |
||||
|
||||
For all commands, when using [option -chan] ... |
||||
|
||||
[list_begin enumerated] |
||||
|
||||
[enum] It is assumed that the channel was opened for reading, and configured for |
||||
binary input. |
||||
|
||||
[enum] It is assumed that the channel position is at the beginning of a legal |
||||
tar file. |
||||
|
||||
[enum] The commands will [emph modify] the channel position as they perform their |
||||
task. |
||||
|
||||
[enum] The commands will [emph not] close the channel. |
||||
|
||||
[enum] In other words, the commands leave the channel in a state very likely |
||||
unsuitable for use by further [cmd tar] commands. Still doing so will |
||||
very likely results in errors, bad data, etc. pp. |
||||
|
||||
[enum] It is the responsibility of the user to seek the channel back to a |
||||
suitable position. |
||||
|
||||
[enum] When using a channel transformation which is not generally seekable, for |
||||
example [cmd gunzip], then it is the responsibility of the user to (a) |
||||
unstack the transformation before seeking the channel back to a suitable |
||||
position, and (b) for restacking it after. |
||||
|
||||
[list_end] |
||||
|
||||
[section COMMANDS] |
||||
|
||||
[list_begin definitions] |
||||
|
||||
[call [cmd ::tar::contents] [arg tarball] [opt [option -chan]]] |
||||
|
||||
Returns a list of the files contained in [arg tarball]. The order is not sorted and depends on the order |
||||
files were stored in the archive. |
||||
[para] |
||||
|
||||
If the option [option -chan] is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[call [cmd ::tar::stat] [arg tarball] [opt file] [opt [option -chan]]] |
||||
|
||||
Returns a nested dict containing information on the named [opt file] in [arg tarball], |
||||
or all files if none is specified. The top level are pairs of filename and info. The info is a dict with the keys |
||||
"[const mode] [const uid] [const gid] [const size] [const mtime] [const type] [const linkname] [const uname] [const gname] |
||||
[const devmajor] [const devminor]" |
||||
|
||||
[example { |
||||
% ::tar::stat tarball.tar |
||||
foo.jpg {mode 0644 uid 1000 gid 0 size 7580 mtime 811903867 type file linkname {} uname user gname wheel devmajor 0 devminor 0} |
||||
}] |
||||
|
||||
[para] |
||||
If the option [option -chan] is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[call [cmd ::tar::untar] [arg tarball] [arg args]] |
||||
|
||||
Extracts [arg tarball]. [arg -file] and [arg -glob] limit the extraction |
||||
to files which exactly match or pattern match the given argument. No error is |
||||
thrown if no files match. Returns a list of filenames extracted and the file |
||||
size. The size will be null for non regular files. Leading path seperators are |
||||
stripped so paths will always be relative. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dir dirName] |
||||
Directory to extract to. Uses [cmd pwd] if none is specified |
||||
[opt_def -file fileName] |
||||
Only extract the file with this name. The name is matched against the complete path |
||||
stored in the archive including directories. |
||||
[opt_def -glob pattern] |
||||
Only extract files patching this glob style pattern. The pattern is matched against the complete path |
||||
stored in the archive. |
||||
[opt_def -nooverwrite] |
||||
Dont overwrite files that already exist |
||||
[opt_def -nomtime] |
||||
Leave the file modification time as the current time instead of setting it to the value in the archive. |
||||
[opt_def -noperms] |
||||
In Unix, leave the file permissions as the current umask instead of setting them to the values in the archive. |
||||
|
||||
[opt_def -chan] |
||||
If this option is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[list_end] |
||||
[para] |
||||
|
||||
[example { |
||||
% foreach {file size} [::tar::untar tarball.tar -glob *.jpg] { |
||||
puts "Extracted $file ($size bytes)" |
||||
} |
||||
}] |
||||
|
||||
[call [cmd ::tar::get] [arg tarball] [arg fileName] [opt [option -chan]]] |
||||
|
||||
Returns the contents of [arg fileName] from the [arg tarball]. |
||||
|
||||
[para][example { |
||||
% set readme [::tar::get tarball.tar doc/README] { |
||||
% puts $readme |
||||
} |
||||
}] |
||||
|
||||
[para] If the option [option -chan] is present [arg tarball] is |
||||
interpreted as an open channel. It is assumed that the channel was |
||||
opened for reading, and configured for binary input. The command will |
||||
[emph not] close the channel. |
||||
|
||||
[para] An error is thrown when [arg fileName] is not found in the tar |
||||
archive. |
||||
|
||||
[call [cmd ::tar::create] [arg tarball] [arg files] [arg args]] |
||||
|
||||
Creates a new tar file containing the [arg files]. [arg files] must be specified |
||||
as a single argument which is a proper list of filenames. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dereference] |
||||
Normally [cmd create] will store links as an actual link pointing at a file that may |
||||
or may not exist in the archive. Specifying this option will cause the actual file point to |
||||
by the link to be stored instead. |
||||
|
||||
[opt_def -chan] |
||||
If this option is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for writing, and configured for binary output. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[list_end] |
||||
[para] |
||||
|
||||
[example { |
||||
% ::tar::create new.tar [glob -nocomplain file*] |
||||
% ::tar::contents new.tar |
||||
file1 file2 file3 |
||||
}] |
||||
|
||||
[call [cmd ::tar::add] [arg tarball] [arg files] [arg args]] |
||||
|
||||
Appends [arg files] to the end of the existing [arg tarball]. [arg files] must be specified |
||||
as a single argument which is a proper list of filenames. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dereference] |
||||
Normally [cmd add] will store links as an actual link pointing at a file that may |
||||
or may not exist in the archive. Specifying this option will cause the actual file point to |
||||
by the link to be stored instead. |
||||
[opt_def -prefix string] |
||||
Normally [cmd add] will store files under exactly the name specified as |
||||
argument. Specifying a [opt -prefix] causes the [arg string] to be |
||||
prepended to every name. |
||||
[opt_def -quick] |
||||
The only sure way to find the position in the [arg tarball] where new |
||||
files can be added is to read it from start, but if [arg tarball] was |
||||
written with a "blocksize" of 1 (as this package does) then one can |
||||
alternatively find this position by seeking from the end. The |
||||
[opt -quick] option tells [cmd add] to do the latter. |
||||
[list_end] |
||||
[para] |
||||
|
||||
[call [cmd ::tar::remove] [arg tarball] [arg files]] |
||||
|
||||
Removes [arg files] from the [arg tarball]. No error will result if the file does not exist in the |
||||
tarball. Directory write permission and free disk space equivalent to at least the size of the tarball |
||||
will be needed. |
||||
|
||||
[example { |
||||
% ::tar::remove new.tar {file2 file3} |
||||
% ::tar::contents new.tar |
||||
file3 |
||||
}] |
||||
|
||||
[list_end] |
||||
|
||||
[vset CATEGORY tar] |
||||
[include ../common-text/feedback.inc] |
||||
[manpage_end] |
||||
@ -0,0 +1,83 @@
|
||||
# -*- tcl -*- tar.pcx |
||||
# Syntax of the commands provided by package tar. |
||||
# |
||||
# For use by TclDevKit's static syntax checker (v4.1+). |
||||
# See http://www.activestate.com/solutions/tcl/ |
||||
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api |
||||
# for the specification of the format of the code in this file. |
||||
# |
||||
|
||||
package require pcx |
||||
pcx::register tar |
||||
pcx::tcldep 0.4 needs tcl 8.2 |
||||
pcx::tcldep 0.5 needs tcl 8.2 |
||||
pcx::tcldep 0.6 needs tcl 8.2 |
||||
|
||||
namespace eval ::tar {} |
||||
|
||||
#pcx::message FOO {... text ...} type |
||||
#pcx::scan <VERSION> <NAME> <RULE> |
||||
|
||||
pcx::check 0.4 std ::tar::add \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-dereference checkBoolean} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.6 std ::tar::add \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-dereference checkBoolean} |
||||
{-quick checkBoolean} |
||||
{-prefix checkWord} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.4 std ::tar::contents \ |
||||
{checkSimpleArgs 1 1 { |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::create \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-chan checkChannelID} |
||||
{-dereference checkBoolean} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.4 std ::tar::get \ |
||||
{checkSimpleArgs 2 2 { |
||||
checkFileName |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::remove \ |
||||
{checkSimpleArgs 2 2 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
}} |
||||
pcx::check 0.4 std ::tar::stat \ |
||||
{checkSimpleArgs 1 2 { |
||||
checkFileName |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::untar \ |
||||
{checkSimpleArgs 1 -1 { |
||||
checkFileName |
||||
{checkSwitches 1 { |
||||
{-chan checkChannelID} |
||||
{-dir checkFileName} |
||||
{-file checkFileName} |
||||
{-glob checkPattern} |
||||
{-nomtime checkBoolean} |
||||
{-nooverwrite checkBoolean} |
||||
{-noperms checkBoolean} |
||||
} {}} |
||||
}} |
||||
|
||||
# Initialization via pcx::init. |
||||
# Use a ::tar::init procedure for non-standard initialization. |
||||
pcx::complete |
||||
@ -0,0 +1,550 @@
|
||||
# tar.tcl -- |
||||
# |
||||
# Creating, extracting, and listing posix tar archives |
||||
# |
||||
# Copyright (c) 2004 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
# Copyright (c) 2013 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# (GNU tar @LongLink support). |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: tar.tcl,v 1.17 2012/09/11 17:22:24 andreas_kupries Exp $ |
||||
|
||||
package require Tcl 8.5 9 |
||||
package provide tar 0.12 |
||||
|
||||
namespace eval ::tar {} |
||||
|
||||
proc ::tar::parseOpts {acc opts} { |
||||
array set flags $acc |
||||
foreach {x y} $acc {upvar $x $x} |
||||
|
||||
set len [llength $opts] |
||||
set i 0 |
||||
while {$i < $len} { |
||||
set name [string trimleft [lindex $opts $i] -] |
||||
if {![info exists flags($name)]} { |
||||
return -errorcode {TAR INVALID OPTION} \ |
||||
-code error "unknown option \"$name\"" |
||||
} |
||||
if {$flags($name) == 1} { |
||||
set $name [lindex $opts [expr {$i + 1}]] |
||||
incr i $flags($name) |
||||
} elseif {$flags($name) > 1} { |
||||
set $name [lrange $opts [expr {$i + 1}] [expr {$i + $flags($name)}]] |
||||
incr i $flags($name) |
||||
} else { |
||||
set $name 1 |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
proc ::tar::pad {size} { |
||||
set pad [expr {512 - ($size % 512)}] |
||||
if {$pad == 512} {return 0} |
||||
return $pad |
||||
} |
||||
|
||||
proc ::tar::seekorskip {ch off wh} { |
||||
if {[tell $ch] < 0} { |
||||
if {$wh!="current"} { |
||||
return -code error -errorcode [list TAR INVALID WHENCE $wh] \ |
||||
"WHENCE=$wh not supported on non-seekable channel $ch" |
||||
} |
||||
skip $ch $off |
||||
return |
||||
} |
||||
seek $ch $off $wh |
||||
return |
||||
} |
||||
|
||||
proc ::tar::skip {ch skipover} { |
||||
while {$skipover > 0} { |
||||
set requested $skipover |
||||
|
||||
# Limit individual skips to 64K, as a compromise between speed |
||||
# of skipping (Number of read requests), and memory usage |
||||
# (Note how skipped block is read into memory!). While the |
||||
# read data is immediately discarded it still generates memory |
||||
# allocation traffic, gets copied, etc. Trying to skip the |
||||
# block in one go without the limit may cause us to run out of |
||||
# (virtual) memory, or just induce swapping, for nothing. |
||||
|
||||
if {$requested > 65536} { |
||||
set requested 65536 |
||||
} |
||||
|
||||
set skipped [string length [read $ch $requested]] |
||||
|
||||
# Stop in short read into the end of the file. |
||||
if {!$skipped && [eof $ch]} break |
||||
|
||||
# Keep track of how much is (not) skipped yet. |
||||
incr skipover -$skipped |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::tar::readHeader {data} { |
||||
binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \ |
||||
name mode uid gid size mtime cksum type \ |
||||
linkname magic version uname gname devmajor devminor prefix |
||||
|
||||
foreach x {name type linkname} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {uid gid size mtime cksum} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
set mode [string trim $mode " \x00"] |
||||
|
||||
if {$magic == "ustar "} { |
||||
# gnu tar |
||||
# not fully supported |
||||
foreach x {uname gname prefix} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {devmajor devminor} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
} elseif {$magic == "ustar\x00"} { |
||||
# posix tar |
||||
foreach x {uname gname prefix} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {devmajor devminor} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
} else { |
||||
# old style tar |
||||
foreach x {uname gname devmajor devminor prefix} { set $x {} } |
||||
if {$type == ""} { |
||||
if {[string match */ $name]} { |
||||
set type 5 |
||||
} else { |
||||
set type 0 |
||||
} |
||||
} |
||||
} |
||||
|
||||
return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \ |
||||
cksum $cksum type $type linkname $linkname magic $magic \ |
||||
version $version uname $uname gname $gname devmajor $devmajor \ |
||||
devminor $devminor prefix $prefix] |
||||
} |
||||
|
||||
proc ::tar::contents {file args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $file |
||||
} else { |
||||
set fh [::open $file] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
set ret {} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
lappend ret $header(prefix)$header(name) |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
proc ::tar::stat {tar {file {}} args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
set ret {} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
if {$file != "" && "$header(prefix)$header(name)" != $file} {continue} |
||||
set header(type) [string map {0 file 5 directory 3 characterSpecial 4 blockSpecial 6 fifo 2 link} $header(type)] |
||||
set header(mode) [string range $header(mode) 2 end] |
||||
lappend ret $header(prefix)$header(name) [list mode $header(mode) uid $header(uid) gid $header(gid) \ |
||||
size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \ |
||||
uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)] |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
proc ::tar::get {tar file args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
while {![eof $fh]} { |
||||
set data [read $fh 512] |
||||
array set header [readHeader $data] |
||||
HandleLongLink $fh header |
||||
if {$header(name) eq ""} break |
||||
if {$header(prefix) ne ""} {append header(prefix) /} |
||||
set name [string trimleft $header(prefix)$header(name) /] |
||||
if {$name eq $file} { |
||||
set file [read $fh $header(size)] |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $file |
||||
} |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return -code error -errorcode {TAR MISSING FILE} \ |
||||
"Tar \"$tar\": File \"$file\" not found" |
||||
} |
||||
|
||||
proc ::tar::untar {tar args} { |
||||
set nooverwrite 0 |
||||
set data 0 |
||||
set nomtime 0 |
||||
set noperms 0 |
||||
set chan 0 |
||||
parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0 chan 0} $args |
||||
if {![info exists dir]} {set dir [pwd]} |
||||
set pattern * |
||||
if {[info exists file]} { |
||||
set pattern [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $file] |
||||
} elseif {[info exists glob]} { |
||||
set pattern $glob |
||||
} |
||||
|
||||
set ret {} |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
set name [string trimleft $header(prefix)$header(name) /] |
||||
if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} { |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
continue |
||||
} |
||||
|
||||
set name [file join $dir $name] |
||||
if {![file isdirectory [file dirname $name]]} { |
||||
file mkdir [file dirname $name] |
||||
lappend ret [file dirname $name] {} |
||||
} |
||||
if {[string match {[0346]} $header(type)]} { |
||||
if {[catch {::open $name w+} new]} { |
||||
# sometimes if we dont have write permission we can still delete |
||||
catch {file delete -force $name} |
||||
set new [::open $name w+] |
||||
} |
||||
fconfigure $new -encoding binary -translation lf -eofchar {} |
||||
fcopy $fh $new -size $header(size) |
||||
close $new |
||||
lappend ret $name $header(size) |
||||
} elseif {$header(type) == 5} { |
||||
file mkdir $name |
||||
lappend ret $name {} |
||||
} elseif {[string match {[12]} $header(type)] && $::tcl_platform(platform) == "unix"} { |
||||
catch {file delete $name} |
||||
if {![catch {file link [string map {1 -hard 2 -symbolic} $header(type)] $name $header(linkname)}]} { |
||||
lappend ret $name {} |
||||
} |
||||
} |
||||
seekorskip $fh [pad $header(size)] current |
||||
if {![file exists $name]} continue |
||||
|
||||
if {$::tcl_platform(platform) == "unix"} { |
||||
if {!$noperms} { |
||||
catch {file attributes $name -permissions 0o[string range $header(mode) 2 end]} |
||||
} |
||||
catch {file attributes $name -owner $header(uid) -group $header(gid)} |
||||
catch {file attributes $name -owner $header(uname) -group $header(gname)} |
||||
} |
||||
if {!$nomtime} { |
||||
file mtime $name $header(mtime) |
||||
} |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
## |
||||
# ::tar::statFile |
||||
# |
||||
# Returns stat info about a filesystem object, in the form of an info |
||||
# dictionary like that returned by ::tar::readHeader. |
||||
# |
||||
# The mode, uid, gid, mtime, and type entries are always present. |
||||
# The size and linkname entries are present if relevant for this type |
||||
# of object. The uname and gname entries are present if the OS supports |
||||
# them. No devmajor or devminor entry is present. |
||||
## |
||||
|
||||
proc ::tar::statFile {name followlinks} { |
||||
if {$followlinks} { |
||||
file stat $name stat |
||||
} else { |
||||
file lstat $name stat |
||||
} |
||||
|
||||
set ret {} |
||||
|
||||
if {$::tcl_platform(platform) == "unix"} { |
||||
# Tcl 9 returns the permission as 0o octal number. Since this |
||||
# is written to the tar file and the file format expects "00" |
||||
# we have to rewrite. |
||||
lappend ret mode 1[string map {o 0} [file attributes $name -permissions]] |
||||
lappend ret uname [file attributes $name -owner] |
||||
lappend ret gname [file attributes $name -group] |
||||
if {$stat(type) == "link"} { |
||||
lappend ret linkname [file link $name] |
||||
} |
||||
} else { |
||||
lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]] |
||||
} |
||||
|
||||
lappend ret uid $stat(uid) gid $stat(gid) mtime $stat(mtime) \ |
||||
type $stat(type) |
||||
|
||||
if {$stat(type) == "file"} {lappend ret size $stat(size)} |
||||
|
||||
return $ret |
||||
} |
||||
|
||||
## |
||||
# ::tar::formatHeader |
||||
# |
||||
# Opposite operation to ::tar::readHeader; takes a file name and info |
||||
# dictionary as arguments, returns a corresponding (POSIX-tar) header. |
||||
# |
||||
# The following dictionary entries must be present: |
||||
# mode |
||||
# type |
||||
# |
||||
# The following dictionary entries are used if present, otherwise |
||||
# the indicated default is used: |
||||
# uid 0 |
||||
# gid 0 |
||||
# size 0 |
||||
# mtime [clock seconds] |
||||
# linkname {} |
||||
# uname {} |
||||
# gname {} |
||||
# |
||||
# All other dictionary entries, including devmajor and devminor, are |
||||
# presently ignored. |
||||
## |
||||
|
||||
proc ::tar::formatHeader {name info} { |
||||
array set A { |
||||
linkname "" |
||||
uname "" |
||||
gname "" |
||||
size 0 |
||||
gid 0 |
||||
uid 0 |
||||
} |
||||
set A(mtime) [clock seconds] |
||||
array set A $info |
||||
array set A {devmajor "" devminor ""} |
||||
|
||||
set type [string map {file 0 directory 5 characterSpecial 3 \ |
||||
blockSpecial 4 fifo 6 link 2 socket A} $A(type)] |
||||
|
||||
set osize [format %o $A(size)] |
||||
set ogid [format %o $A(gid)] |
||||
set ouid [format %o $A(uid)] |
||||
set omtime [format %o $A(mtime)] |
||||
|
||||
set name [string trimleft $name /] |
||||
if {[string length $name] > 255} { |
||||
return -code error -errorcode {TAR BAD PATH LENGTH} \ |
||||
"path name over 255 chars" |
||||
} elseif {[string length $name] > 100} { |
||||
set common [string range $name end-99 154] |
||||
if {[set splitpoint [string first / $common]] == -1} { |
||||
return -code error -errorcode {TAR BAD PATH UNSPLITTABLE} \ |
||||
"path name cannot be split into prefix and name" |
||||
} |
||||
set prefix [string range $name 0 end-100][string range $common 0 $splitpoint-1] |
||||
set name [string range $common $splitpoint+1 end][string range $name 155 end] |
||||
} else { |
||||
set prefix "" |
||||
} |
||||
|
||||
set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \ |
||||
$name $A(mode)\x00 $ouid\x00 $ogid\x00\ |
||||
$osize\x00 $omtime\x00 {} $type \ |
||||
$A(linkname) ustar\x00 00 $A(uname) $A(gname)\ |
||||
$A(devmajor) $A(devminor) $prefix {}] |
||||
|
||||
binary scan $header c* tmp |
||||
set cksum 0 |
||||
foreach x $tmp {incr cksum $x} |
||||
|
||||
return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]] |
||||
} |
||||
|
||||
|
||||
proc ::tar::recurseDirs {files followlinks} { |
||||
foreach x $files { |
||||
if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} { |
||||
if {[set more [glob -dir $x -nocomplain *]] != ""} { |
||||
eval lappend files [recurseDirs $more $followlinks] |
||||
} else { |
||||
lappend files $x |
||||
} |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
proc ::tar::writefile {in out followlinks name} { |
||||
puts -nonewline $out [formatHeader $name [statFile $in $followlinks]] |
||||
set size 0 |
||||
if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} { |
||||
set in [::open $in] |
||||
fconfigure $in -encoding binary -translation lf -eofchar {} |
||||
set size [fcopy $in $out] |
||||
close $in |
||||
} |
||||
puts -nonewline $out [string repeat \x00 [pad $size]] |
||||
} |
||||
|
||||
proc ::tar::create {tar files args} { |
||||
set dereference 0 |
||||
set chan 0 |
||||
parseOpts {dereference 0 chan 0} $args |
||||
|
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar w+] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
foreach x [recurseDirs $files $dereference] { |
||||
writefile $x $fh $dereference $x |
||||
} |
||||
puts -nonewline $fh [string repeat \x00 1024] |
||||
|
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $tar |
||||
} |
||||
|
||||
proc ::tar::add {tar files args} { |
||||
set dereference 0 |
||||
set prefix "" |
||||
set quick 0 |
||||
parseOpts {dereference 0 prefix 1 quick 0} $args |
||||
|
||||
set fh [::open $tar r+] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
|
||||
if {$quick} then { |
||||
seek $fh -1024 end |
||||
} else { |
||||
set data [read $fh 512] |
||||
while {[regexp {[^\0]} $data]} { |
||||
array set header [readHeader $data] |
||||
seek $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
set data [read $fh 512] |
||||
} |
||||
seek $fh -512 current |
||||
} |
||||
|
||||
foreach x [recurseDirs $files $dereference] { |
||||
writefile $x $fh $dereference $prefix$x |
||||
} |
||||
puts -nonewline $fh [string repeat \x00 1024] |
||||
|
||||
close $fh |
||||
return $tar |
||||
} |
||||
|
||||
proc ::tar::remove {tar files} { |
||||
set n 0 |
||||
while {[file exists $tar$n.tmp]} {incr n} |
||||
set tfh [::open $tar$n.tmp w] |
||||
set fh [::open $tar r] |
||||
|
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
fconfigure $tfh -encoding binary -translation lf -eofchar {} |
||||
|
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
if {$header(name) == ""} { |
||||
puts -nonewline $tfh [string repeat \x00 1024] |
||||
break |
||||
} |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
set name $header(prefix)$header(name) |
||||
set len [expr {$header(size) + [pad $header(size)]}] |
||||
if {[lsearch $files $name] > -1} { |
||||
seek $fh $len current |
||||
} else { |
||||
seek $fh -512 current |
||||
fcopy $fh $tfh -size [expr {$len + 512}] |
||||
} |
||||
} |
||||
|
||||
close $fh |
||||
close $tfh |
||||
|
||||
file rename -force $tar$n.tmp $tar |
||||
} |
||||
|
||||
proc ::tar::HandleLongLink {fh hv} { |
||||
upvar 1 $hv header thelongname thelongname |
||||
|
||||
# @LongName Part I. |
||||
if {$header(type) == "L"} { |
||||
# Size == Length of name. Read it, and pad to full 512 |
||||
# size. After that is a regular header for the actual |
||||
# file, where we have to insert the name. This is handled |
||||
# by the next iteration and the part II below. |
||||
set thelongname [string trimright [read $fh $header(size)] \000] |
||||
seekorskip $fh [pad $header(size)] current |
||||
return -code continue |
||||
} |
||||
# Not supported yet: type 'K' for LongLink (long symbolic links). |
||||
|
||||
# @LongName, part II, get data from previous entry, if defined. |
||||
if {[info exists thelongname]} { |
||||
set header(name) $thelongname |
||||
# Prevent leakage to further entries. |
||||
unset thelongname |
||||
} |
||||
|
||||
return |
||||
} |
||||
@ -0,0 +1,139 @@
|
||||
# -*- tcl -*- |
||||
# These tests are in the public domain |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
source [file join \ |
||||
[file dirname [file dirname [file normalize [info script]]]] \ |
||||
devtools testutilities.tcl] |
||||
|
||||
testsNeedTcl 8.5 ; # Virt channel support! |
||||
testsNeedTcltest 1.0 |
||||
|
||||
# Check if we have TclOO available. |
||||
tcltest::testConstraint tcloo [expr {![catch {package require TclOO}]}] |
||||
|
||||
support { |
||||
if {[tcltest::testConstraint tcloo]} { |
||||
use virtchannel_base/memchan.tcl tcl::chan::memchan |
||||
} |
||||
useLocalFile tests/support.tcl |
||||
} |
||||
testing { |
||||
useLocal tar.tcl tar |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
test tar-stream {stream} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
string length [read $chan1] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result 128000 |
||||
|
||||
test tar-pad {pad} -body { |
||||
tar::pad 230 |
||||
} -result {282} |
||||
|
||||
test tar-skip {skip} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
tar::skip $chan1 10 |
||||
lappend res [read $chan1 10] |
||||
tar::skip $chan1 72313 |
||||
lappend res [read $chan1 10] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result {{6 7 8 9 10} {07 13908 1}} |
||||
|
||||
test tar-seekorskip-backwards {seekorskip} -constraints tcl8.6plus -setup setup1 -body { |
||||
# The zlib push stuff is Tcl 8.6+. Properly restrict the test. |
||||
zlib push gzip $chan1 |
||||
catch {tar::seekorskip $chan1 -10 start} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 10 start} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 -10 end} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 10 end} cres |
||||
lappend res $cres |
||||
lappend res [read $chan1 10] |
||||
} -cleanup cleanup1 -match glob \ |
||||
-result [list \ |
||||
{WHENCE=start not supported*} \ |
||||
{WHENCE=start not supported*} \ |
||||
{WHENCE=end not supported*} \ |
||||
{WHENCE=end not supported*} \ |
||||
{1 2 3 4 5 } \ |
||||
] |
||||
|
||||
test tar-header {header} -body { |
||||
set file1 [dict get $filesys Dir1 File1] |
||||
dict set file1 path /Dir1/File1 |
||||
set header [header_posix $file1] |
||||
set parsed [string trim [tar::readHeader $header]] |
||||
set golden "name /Dir1/File1 mode 755 uid 13103 gid 18103 size 100 mtime 5706756101 cksum 3676 type 0 linkname {} magic ustar\0 version 00 uname {} gname {} devmajor 0 devminor 0 prefix {}" |
||||
set len [string length $parsed] |
||||
foreach {key value} $golden { |
||||
if {[set value1 [dict get $parsed $key]] ne $value } { |
||||
lappend res [list $key $value $value1] |
||||
} |
||||
} |
||||
} -result {} |
||||
|
||||
test tar-add {add} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
tar::create $chan1 [list $tmpdir/one/a $tmpdir/one/two/a $tmpdir/one/three/a] -chan |
||||
seek $chan1 0 |
||||
lappend res {*}[tar::contents $chan1 -chan] |
||||
seek $chan1 0 |
||||
lappend res [string trim [tar::get $chan1 $tmpdir/one/two/a -chan]] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result {tartest/one/a tartest/one/two/a tartest/one/three/a hello2} |
||||
|
||||
|
||||
test tar-bug-2840180 {Ticket 2840180} -setup { |
||||
setup2 |
||||
} -body { |
||||
tar::create $chan1 [list $tmpdir/[large-path]/a] -chan |
||||
seek $chan1 0 |
||||
|
||||
# What the package sees. |
||||
lappend res {*}[tar::contents $chan1 -chan] |
||||
close $chan1 |
||||
|
||||
# What a regular tar package sees. |
||||
lappend res [exec 2> $tmpfile.err tar tvf $tmpfile] |
||||
join $res \n |
||||
} -cleanup { |
||||
cleanup2 |
||||
} -match glob -result [join [list \ |
||||
tartest/[large-path]/a \ |
||||
"* tartest/[large-path]/a" \ |
||||
] \n] |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
test tar-tkt-9f4c0e3e95-1.0 {Ticket 9f4c0e3e95, A} -setup { |
||||
set tarfile [setup-tkt-9f4c0e3e95] |
||||
} -body { |
||||
string trim [tar::get $tarfile 02] |
||||
} -cleanup { |
||||
cleanup-tkt-9f4c0e3e95 |
||||
unset tarfile |
||||
} -result {zero-two} |
||||
|
||||
test tar-tkt-9f4c0e3e95-1.1 {Ticket 9f4c0e3e95, B, } -setup { |
||||
set tarfile [setup-tkt-9f4c0e3e95] |
||||
} -body { |
||||
tar::get $tarfile 0b10 |
||||
} -cleanup { |
||||
cleanup-tkt-9f4c0e3e95 |
||||
unset tarfile |
||||
} -returnCodes error -result {Tar "tartest/t.tar": File "0b10" not found} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
testsuiteCleanup |
||||
@ -0,0 +1,149 @@
|
||||
|
||||
proc stream {{size 128000}} { |
||||
set chan [tcl::chan::memchan] |
||||
set line {} |
||||
while 1 { |
||||
incr i |
||||
set istring $i |
||||
set ilen [string length $istring] |
||||
if {$line ne {}} { |
||||
append line { } |
||||
incr size -1 |
||||
} |
||||
append line $istring |
||||
incr size -$ilen |
||||
if {$size < 1} { |
||||
set line [string range $line 0 end-[expr {abs(1-$size)}]] |
||||
puts $chan $line |
||||
break |
||||
} |
||||
|
||||
if {$i % 10 == 0} { |
||||
puts $chan $line |
||||
incr size -1 ;# for the [puts] newline |
||||
set line {} |
||||
} |
||||
} |
||||
|
||||
seek $chan 0 |
||||
return $chan |
||||
} |
||||
|
||||
proc header_posix {tarball} { |
||||
dict with tarball {} |
||||
tar::formatHeader $path \ |
||||
[dict create \ |
||||
mode $mode \ |
||||
type $type \ |
||||
uid $uid \ |
||||
gid $gid \ |
||||
size $size \ |
||||
mtime $mtime] |
||||
} |
||||
|
||||
proc setup1 {} { |
||||
variable chan1 |
||||
variable res {} |
||||
variable tmpdir tartest |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
|
||||
foreach directory { |
||||
one |
||||
one/two |
||||
one/three |
||||
} { |
||||
tcltest::makeDirectory $tmpdir/$directory |
||||
set chan [open $tmpdir/$directory/a w] |
||||
puts $chan hello[incr i] |
||||
close $chan |
||||
} |
||||
set chan1 [stream] |
||||
} |
||||
|
||||
proc large-path {} { |
||||
return aaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbtcllib/modules/tar |
||||
} |
||||
|
||||
proc setup2 {} { |
||||
variable chan1 |
||||
variable res {} |
||||
variable tmpdir tartest |
||||
variable tmpfile tarX |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
tcltest::makeFile {} $tmpfile |
||||
|
||||
foreach directory [list [large-path]] { |
||||
tcltest::makeDirectory $tmpdir/$directory |
||||
set chan [open $tmpdir/$directory/a w] |
||||
puts $chan hello[incr i] |
||||
close $chan |
||||
} |
||||
set chan1 [open $tmpfile w+] |
||||
} |
||||
|
||||
proc cleanup1 {} { |
||||
variable chan1 |
||||
close $chan1 |
||||
tcltest::removeDirectory tartest |
||||
return |
||||
} |
||||
|
||||
proc cleanup2 {} { |
||||
variable chan1 |
||||
variable tmpdir |
||||
variable tmpfile |
||||
catch { close $chan1 } |
||||
tcltest::removeDirectory $tmpdir |
||||
tcltest::removeFile $tmpfile |
||||
tcltest::removeFile $tmpfile.err |
||||
return |
||||
} |
||||
|
||||
variable filesys { |
||||
Dir1 { |
||||
File1 { |
||||
type 0 |
||||
mode 755 |
||||
uid 13103 |
||||
gid 18103 |
||||
size 100 |
||||
mtime 5706756101 |
||||
} |
||||
} |
||||
|
||||
Dir2 { |
||||
File1 { |
||||
type 0 |
||||
mode 644 |
||||
uid 15103 |
||||
gid 19103 |
||||
size 100 |
||||
mtime 5706776103 |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc setup-tkt-9f4c0e3e95 {} { |
||||
variable tmpdir tartest |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
tcltest::makeFile {zero-two} $tmpdir/02 |
||||
tcltest::makeFile {number two} $tmpdir/2 |
||||
|
||||
set here [pwd] |
||||
cd $tmpdir |
||||
tar::create t.tar {2 02} |
||||
cd $here |
||||
|
||||
return $tmpdir/t.tar |
||||
} |
||||
|
||||
proc cleanup-tkt-9f4c0e3e95 {} { |
||||
variable tmpdir |
||||
tcltest::removeFile $tmpdir/2 |
||||
tcltest::removeFile $tmpdir/02 |
||||
tcltest::removeDirectory $tmpdir |
||||
return |
||||
} |
||||
@ -0,0 +1,238 @@
|
||||
# autoscroll.tcl -- |
||||
# |
||||
# Package to create scroll bars that automatically appear when |
||||
# a window is too small to display its content. |
||||
# |
||||
# Copyright (c) 2003 Kevin B Kenny <kennykb@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: autoscroll.tcl,v 1.8 2005/06/01 02:37:51 andreas_kupries Exp $ |
||||
|
||||
package require Tk |
||||
package provide autoscroll 1.1 |
||||
|
||||
namespace eval ::autoscroll { |
||||
namespace export autoscroll unautoscroll |
||||
bind Autoscroll <Destroy> [namespace code [list destroyed %W]] |
||||
bind Autoscroll <Map> [namespace code [list map %W]] |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::autoscroll -- |
||||
# |
||||
# Create a scroll bar that disappears when it is not needed, and |
||||
# reappears when it is. |
||||
# |
||||
# Parameters: |
||||
# w -- Path name of the scroll bar, which should already exist |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The widget command is renamed, so that the 'set' command can |
||||
# be intercepted and determine whether the widget should appear. |
||||
# In addition, the 'Autoscroll' bind tag is added to the widget, |
||||
# so that the <Destroy> event can be intercepted. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::autoscroll { w } { |
||||
if { [info commands ::autoscroll::renamed$w] != "" } { return $w } |
||||
rename $w ::autoscroll::renamed$w |
||||
interp alias {} ::$w {} ::autoscroll::widgetCommand $w |
||||
bindtags $w [linsert [bindtags $w] 1 Autoscroll] |
||||
eval [list ::$w set] [renamed$w get] |
||||
return $w |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::unautoscroll -- |
||||
# |
||||
# Return a scrollbar to its normal static behavior by removing |
||||
# it from the control of this package. |
||||
# |
||||
# Parameters: |
||||
# w -- Path name of the scroll bar, which must have previously |
||||
# had ::autoscroll::autoscroll called on it. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The widget command is renamed to its original name. The widget |
||||
# is mapped if it was not currently displayed. The widgets |
||||
# bindtags are returned to their original state. Internal memory |
||||
# is cleaned up. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::unautoscroll { w } { |
||||
if { [info commands ::autoscroll::renamed$w] != "" } { |
||||
variable grid |
||||
rename ::$w {} |
||||
rename ::autoscroll::renamed$w ::$w |
||||
if { [set i [lsearch -exact [bindtags $w] Autoscroll]] > -1 } { |
||||
bindtags $w [lreplace [bindtags $w] $i $i] |
||||
} |
||||
if { [info exists grid($w)] } { |
||||
eval [join $grid($w) \;] |
||||
unset grid($w) |
||||
} |
||||
} |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::widgetCommand -- |
||||
# |
||||
# Widget command on an 'autoscroll' scrollbar |
||||
# |
||||
# Parameters: |
||||
# w -- Path name of the scroll bar |
||||
# command -- Widget command being executed |
||||
# args -- Arguments to the commane |
||||
# |
||||
# Results: |
||||
# Returns whatever the widget command returns |
||||
# |
||||
# Side effects: |
||||
# Has whatever side effects the widget command has. In |
||||
# addition, the 'set' widget command is handled specially, |
||||
# by gridding/packing the scroll bar according to whether |
||||
# it is required. |
||||
# |
||||
#------------------------------------------------------------ |
||||
|
||||
proc ::autoscroll::widgetCommand { w command args } { |
||||
variable grid |
||||
if { $command == "set" } { |
||||
foreach { min max } $args {} |
||||
if { $min <= 0 && $max >= 1 } { |
||||
switch -exact -- [winfo manager $w] { |
||||
grid { |
||||
lappend grid($w) "[list grid $w] [grid info $w]" |
||||
grid forget $w |
||||
} |
||||
pack { |
||||
foreach x [pack slaves [winfo parent $w]] { |
||||
lappend grid($w) "[list pack $x] [pack info $x]" |
||||
} |
||||
pack forget $w |
||||
} |
||||
} |
||||
} elseif { [info exists grid($w)] } { |
||||
eval [join $grid($w) \;] |
||||
unset grid($w) |
||||
} |
||||
} |
||||
return [eval [list renamed$w $command] $args] |
||||
} |
||||
|
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::destroyed -- |
||||
# |
||||
# Callback executed when an automatic scroll bar is destroyed. |
||||
# |
||||
# Parameters: |
||||
# w -- Path name of the scroll bar |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Cleans up internal memory. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::destroyed { w } { |
||||
variable grid |
||||
catch { unset grid($w) } |
||||
rename ::$w {} |
||||
} |
||||
|
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::map -- |
||||
# |
||||
# Callback executed when an automatic scroll bar is mapped. |
||||
# |
||||
# Parameters: |
||||
# w -- Path name of the scroll bar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Geometry of the scroll bar's top-level window is constrained. |
||||
# |
||||
# This procedure keeps the top-level window associated with an |
||||
# automatic scroll bar from being resized automatically after the |
||||
# scroll bar is mapped. This effect avoids a potential endless loop |
||||
# in the case where the resize of the top-level window resizes the |
||||
# widget being scrolled, causing the scroll bar no longer to be needed. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::map { w } { |
||||
wm geometry [winfo toplevel $w] [wm geometry [winfo toplevel $w]] |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::wrap -- |
||||
# |
||||
# Arrange for all new scrollbars to be automatically autoscrolled |
||||
# |
||||
# Parameters: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# ::scrollbar is overloaded to automatically autoscroll any new |
||||
# scrollbars. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::wrap {} { |
||||
if {[info commands ::autoscroll::_scrollbar] != ""} {return} |
||||
rename ::scrollbar ::autoscroll::_scrollbar |
||||
proc ::scrollbar {w args} { |
||||
eval ::autoscroll::_scrollbar [list $w] $args |
||||
::autoscroll::autoscroll $w |
||||
return $w |
||||
} |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::autoscroll::unwrap -- |
||||
# |
||||
# Turns off automatic autoscrolling of new scrollbars. Does not |
||||
# effect existing scrollbars. |
||||
# |
||||
# Parameters: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# ::scrollbar is returned to its original state |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::autoscroll::unwrap {} { |
||||
if {[info commands ::autoscroll::_scrollbar] == ""} {return} |
||||
rename ::scrollbar {} |
||||
rename ::autoscroll::_scrollbar ::scrollbar |
||||
} |
||||
@ -0,0 +1,13 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
if { ![package vsatisfies [package provide Tcl] 8.2] } { return } |
||||
package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]] |
||||
|
||||
@ -0,0 +1,278 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Canvas Behavior Module. Dragging items and groups of items. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
namespace eval ::canvas::drag { |
||||
namespace export \ |
||||
item group on off |
||||
namespace ensemble create |
||||
} |
||||
|
||||
proc ::canvas::drag::item {c tag args} { |
||||
# Set up dragging of single items identified by the <tag> |
||||
on $c $tag [namespace code Item1] {*}$args |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::drag::group {c tag cmdprefix args} { |
||||
# Set up dragging a group of items, with each group's drag |
||||
# handle(s) identified by <tag>, and the <cmdprefix> taking the |
||||
# handle item which triggered the drag and returning a tag which |
||||
# identifies the whole group to move. |
||||
|
||||
on $c $tag [namespace code [list ItemGroup $cmdprefix]] {*}$args |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::drag::on {c tag cmdprefix args} { |
||||
# Setting up a general drag, with the drag handles identified by |
||||
# <tag> and <cmdprefix> providing start/move methods invoked to |
||||
# initialize and perform the drag. The cmdprefix is fully |
||||
# responsible for how the dragging of a particular handle is |
||||
# handled. |
||||
|
||||
variable attached |
||||
|
||||
# Process options (-event) |
||||
set events [dict get [Options {*}$args] event] |
||||
|
||||
# Save the (canvas, tag) combination for use by 'off'. |
||||
set k [list $c $tag] |
||||
set attached($k) $events |
||||
|
||||
# Install the bindings doing the drag |
||||
lassign $events trigger motion untrigger |
||||
$c bind $tag $trigger [namespace code [list Start $c $cmdprefix %x %y]] |
||||
$c bind $tag $motion [namespace code [list Move $c $cmdprefix %x %y]] |
||||
$c bind $tag $untrigger [namespace code [list Done $c $cmdprefix %x %y]] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::drag::off {c tag} { |
||||
# Remove a drag identified by canvas and tag. |
||||
|
||||
variable attached |
||||
|
||||
# Find and remove the bindings for this particular canvas,tag |
||||
# combination. |
||||
set k [list $c $tag] |
||||
foreach event $attached($k) { |
||||
$c bind $tag $event {} |
||||
} |
||||
|
||||
# Update our database |
||||
unset attached($k) |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Option processing. |
||||
|
||||
proc ::canvas::drag::Options {args} { |
||||
# Button 3 is default for dragging. |
||||
set config [list event [Validate 3]] |
||||
|
||||
foreach {option value} $args { |
||||
switch -exact -- $option { |
||||
-event { |
||||
dict set config event [Validate $value] |
||||
} |
||||
default { |
||||
return -code error "Unknown option \"$option\", expected -event" |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $config |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Event parsing and transformation |
||||
|
||||
proc ::canvas::drag::Validate {event} { |
||||
# Assumes that events are specified in the forms |
||||
# <modifier>-<button> and <button>, where <modifier> is in the set |
||||
# {Control, Shift, Alt, ... } and <button> a number. Returns |
||||
# button-press and related motion event, or throws an error. |
||||
|
||||
set xevent [split $event -] |
||||
if {[llength $xevent] > 2} { |
||||
return -code error "Bad event \"$event\"" |
||||
} elseif {[llength $xevent] == 2} { |
||||
lassign $xevent modifier button |
||||
|
||||
set trigger <${event}> |
||||
set motion <${modifier}-B${button}-Motion> |
||||
set untrigger <${modifier}-ButtonRelease-${button}> |
||||
|
||||
} else { |
||||
lassign $xevent button |
||||
set modifier {} |
||||
|
||||
set trigger <${button}> |
||||
set motion <B${button}-Motion> |
||||
set untrigger <ButtonRelease-${button}> |
||||
} |
||||
|
||||
return [list $trigger $motion $untrigger] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Drag execution. |
||||
|
||||
proc ::canvas::drag::Start {c cmdprefix x y} { |
||||
# Start a drag operation. |
||||
variable attached |
||||
variable active |
||||
variable clientdata |
||||
variable lastx |
||||
variable lasty |
||||
|
||||
# Clear drag state |
||||
unset -nocomplain active clientdata lastx lasty |
||||
|
||||
# Get item under mouse, if any. |
||||
set item [$c find withtag current] |
||||
if {$item eq {}} return |
||||
|
||||
# Initialize the drag state, run the command to initialize |
||||
# anything external to us. We remember the current location to |
||||
# enable the delta calculations in 'Move'. |
||||
|
||||
set active $cmdprefix |
||||
set lastx [$c canvasx $x] |
||||
set lasty [$c canvasy $y] |
||||
set clientdata [{*}$active start $c $item] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::drag::Move {c cmdprefix x y} { |
||||
# Check for active drag. |
||||
variable active |
||||
if {![info exists active]} return |
||||
|
||||
# Import remainder of the drag state |
||||
variable clientdata |
||||
variable lastx |
||||
variable lasty |
||||
|
||||
# Get current location and compute delta. |
||||
set x [$c canvasx $x] |
||||
set y [$c canvasy $y] |
||||
|
||||
set dx [expr {$x - $lastx}] |
||||
set dy [expr {$y - $lasty}] |
||||
|
||||
# Let the command process the movement as it sees fit. |
||||
# This may include updated client data. |
||||
set clientdata [{*}$active move $c $clientdata $dx $dy] |
||||
|
||||
# Save the new location , for the next movement and delta. |
||||
set lastx $x |
||||
set lasty $y |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::drag::Done {c cmdprefix x y} { |
||||
# Check for active drag. |
||||
variable active |
||||
if {![info exists active]} return |
||||
|
||||
# Import remainder of the drag state |
||||
variable clientdata |
||||
|
||||
# Let the command process the end of the drag operation as it sees |
||||
# fit. |
||||
{*}$active done $c $clientdata |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Convenience. Dragging a single item. |
||||
|
||||
# This is trivial. We remember the item to be dragged, and forward |
||||
# move requests directly to the canvas. |
||||
|
||||
namespace eval ::canvas::drag::Item1 { |
||||
namespace export start move done |
||||
namespace ensemble create |
||||
} |
||||
|
||||
proc ::canvas::drag::Item1::start {c item} { |
||||
return $item |
||||
} |
||||
|
||||
proc ::canvas::drag::Item1::move {c item dx dy} { |
||||
$c move $item $dx $dy |
||||
return $item |
||||
} |
||||
|
||||
proc ::canvas::drag::Item1::done {c item} { |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Convenience. Dragging an item group. |
||||
|
||||
# Also mostly trivial. The move requests are still simply forwarded to |
||||
# the canvas, using the tag identifying the group. The main point is |
||||
# during start, using the external callback to transform the handle |
||||
# item into the group tag. |
||||
|
||||
proc ::canvas::drag::ItemGroup {cmd method c args} { |
||||
return [ItemGroup::$method $cmd $c {*}$args] |
||||
} |
||||
|
||||
namespace eval ::canvas::drag::ItemGroup {} |
||||
|
||||
proc ::canvas::drag::ItemGroup::start {cmd c item} { |
||||
return [{*}$cmd start $c $item] |
||||
} |
||||
|
||||
proc ::canvas::drag::ItemGroup::move {cmd c grouptag dx dy} { |
||||
$c move $grouptag $dx $dy |
||||
return $grouptag |
||||
} |
||||
|
||||
proc ::canvas::drag::ItemGroup::done {cmd c grouptag} { |
||||
{*}$cmd done $c $grouptag |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State. |
||||
|
||||
namespace eval ::canvas::drag { |
||||
# Database of canvas,tag combinations with active bindings |
||||
# (allowing their removal, see --> 'off'). Value are the |
||||
# events which have bindings. |
||||
|
||||
variable attached |
||||
array set attached {} |
||||
|
||||
# State of a drag in progress |
||||
|
||||
variable active ; # command prefix to invoke for 'start' / 'move'. |
||||
variable clientdata ; # Result of invoking 'start', data for 'move'. |
||||
variable lastx ; # x coord of last position the drag was at. |
||||
variable lasty ; # y coord of last position the drag was at. |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::drag 0.1 |
||||
return |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Scrap yard. |
||||
@ -0,0 +1,383 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
# Canvas Behavior Module. Editing 2 points describing an axis-aligned circle. |
||||
|
||||
# Core interaction behaviour inherited from canvas::edit::points |
||||
|
||||
# Configurable: |
||||
# - Tag used to mark/identify the points of this cloud. |
||||
# Default: CIRCLE |
||||
# |
||||
# - Callback used to create the item (group) representing the point. |
||||
# Default: <Inherited from the subordinate point cloud editor> |
||||
# |
||||
# - Callback used to report on circle editing activity. |
||||
# Default: NONE. |
||||
# |
||||
# - Callback used to report enter/leave events for the circle and its points. |
||||
# Default: NONE. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
package require snit |
||||
package require canvas::edit::points |
||||
|
||||
namespace eval ::canvas::edit { |
||||
namespace export circle |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::edit::circle { |
||||
|
||||
# See canvas::edit::points |
||||
option -tag -default CIRCLE -readonly 1 |
||||
option -create-cmd -default {} \ |
||||
-configuremethod Chain \ |
||||
-cgetmethod UnChain |
||||
|
||||
# Callback reporting the circle after changes (add, remove, drag) |
||||
option -data-cmd -default {} |
||||
|
||||
# Callback reporting when the circle or any of the points have the mouse over it |
||||
option -active-cmd -default {} |
||||
|
||||
# See canvas::edit::points, also base config for circle |
||||
option -color -default SkyBlue2 -configuremethod Pass |
||||
option -hilit-color -default red -configuremethod Pass |
||||
|
||||
# See canvas::edit::points |
||||
option -radius -default 3 -configuremethod Pass |
||||
option -kind -default oval -configuremethod Pass |
||||
|
||||
# See canvas::edit::points, -add-remove also for click on circle |
||||
option -add-remove-point -default {} -readonly 1 |
||||
option -drag-point -default 3 -readonly 1 |
||||
|
||||
# Additional circle configuration |
||||
# NOTE: __Cannot__ supercede -color/-hilit-color |
||||
option -circle-config -default {} |
||||
|
||||
method Pass {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
$myeditor configure $o $v |
||||
return 1 |
||||
} |
||||
|
||||
method Chain {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
|
||||
# Reconfigure the editor with our behaviour still in the chain |
||||
$myeditor configure -create-cmd [mymethod Deny $v] |
||||
return 1 |
||||
} |
||||
|
||||
method Unchain {o} { |
||||
# Hide the internal -create-cmd chaining from the user |
||||
return [$myeditor cget -create-cmd] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
constructor {c args} { |
||||
set mycanvas $c |
||||
set mystate {} |
||||
set myops base |
||||
|
||||
$self configurelist $args |
||||
|
||||
# Generate an internal point cloud editor, which will handle |
||||
# the basic tasks regarding the circles's vertices. |
||||
|
||||
lappend cmd canvas::edit points ${selfns}::P $c |
||||
lappend cmd -tag $options(-tag) |
||||
lappend cmd -data-cmd [mymethod Point] |
||||
lappend cmd -active-cmd [mymethod PointActive] |
||||
|
||||
# Pass point options/configuration to the subordinate editor |
||||
foreach o { |
||||
-create-cmd |
||||
-color |
||||
-hilit-color |
||||
-radius |
||||
-kind |
||||
-add-remove-point |
||||
-drag-point |
||||
} { |
||||
set c $options($o) |
||||
if {$c ne {}} { lappend cmd $o $c } |
||||
} |
||||
|
||||
set myeditor [{*}$cmd] |
||||
|
||||
$myeditor configure -create-cmd \ |
||||
[mymethod Deny [$myeditor cget -create-cmd]] |
||||
|
||||
$mycanvas bind [SegmentTag] <Enter> [mymethod Active circle] |
||||
$mycanvas bind [SegmentTag] <Leave> [mymethod Active {} ] |
||||
return |
||||
} |
||||
|
||||
component myeditor |
||||
|
||||
delegate method enable to myeditor |
||||
delegate method disable to myeditor |
||||
delegate method active to myeditor |
||||
|
||||
method clear {} { |
||||
set myops shunt |
||||
$myeditor clear |
||||
|
||||
set myops base |
||||
set mystate {} |
||||
set mycoords {} |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method set {center radius} { |
||||
$self clear |
||||
|
||||
lassign $center x y |
||||
set edge [list [expr {$x + $radius} $y]] |
||||
|
||||
$myeditor add {*}$center |
||||
$myeditor add {*}$edge |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Actions bound to events, as reported by the point cloud editor. |
||||
|
||||
method Deny {chain c x y} { |
||||
#puts deny/$myops/$mystate/ |
||||
# Deny more points when we have the complete set. |
||||
if {$myops eq "complete"} return |
||||
|
||||
# Continue to actual marker creation. |
||||
return [{*}$chain $c $x $y] |
||||
} |
||||
|
||||
method PointActive {_ corner} { |
||||
if {$myops ne "complete"} return |
||||
if {$corner ne {}} { set corner [dict get $mystate $corner] } |
||||
$self Active $corner |
||||
return |
||||
} |
||||
|
||||
method Active {kind} { |
||||
# puts /$kind/ |
||||
if {![llength $options(-active-cmd)]} return |
||||
{*}$options(-active-cmd) $self $kind |
||||
return |
||||
} |
||||
|
||||
method {Point add} {pe id x y} { |
||||
switch -exact -- $myops { |
||||
shunt {} |
||||
base { |
||||
Save $id center $x $y |
||||
set myops partial |
||||
return |
||||
} |
||||
partial { |
||||
Save $id edge $x $y |
||||
set myops complete |
||||
|
||||
$self Regenerate |
||||
Note |
||||
} |
||||
complete { |
||||
return -code error "Should have been rejected by `Deny`" |
||||
} |
||||
} |
||||
} |
||||
|
||||
method {Point remove} {pe id} { |
||||
switch -exact -- $myops { |
||||
shunt {} |
||||
base { |
||||
# no points known. nothing to do |
||||
return |
||||
} |
||||
partial { |
||||
# first point known, no second point. drop memory of first point |
||||
set mystate {} |
||||
set myops base |
||||
return |
||||
} |
||||
complete { |
||||
# removing even one point of the circle removes the entire circle! |
||||
# Disable point callbacks invoked due to this automatic task. |
||||
set myops shunt |
||||
|
||||
# Find the corner removed by the user and drop it from the state. |
||||
# Then remove the remaining corners |
||||
set corner [dict get $mystate $id] |
||||
dict unset mystate $id |
||||
dict unset mystate $corner |
||||
|
||||
foreach corner $ourcorners { |
||||
if {![dict exists $mystate $corner]} continue |
||||
$pe remove [dict get $mystate $corner] |
||||
} |
||||
|
||||
# enter base state waiting for a new first point |
||||
set myops base |
||||
set mystate {} |
||||
set mycoords {} |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
method {Point move start} {pe id} { |
||||
# Initialize local drag state. |
||||
set mydid $id |
||||
set corner [dict get $mystate $id] |
||||
set mydloc [dict get $mycoords $corner] |
||||
return |
||||
} |
||||
|
||||
method {Point move delta} {pe id nx ny dx dy} { |
||||
# Track the movement. |
||||
set mydloc [list $nx $ny] |
||||
return |
||||
} |
||||
|
||||
method {Point move done} {pe id} { |
||||
set corner [dict get $mystate $id] |
||||
Save $id $corner {*}$mydloc |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return 1 |
||||
} |
||||
|
||||
method Regenerate {} { |
||||
if {$mycircle ne {}} { |
||||
$mycanvas delete $mycircle |
||||
set mycircle {} |
||||
} |
||||
|
||||
if {$myops ne "complete"} return |
||||
|
||||
lassign [dict get $mycoords center] cx cy |
||||
lassign [dict get $mycoords edge ] ex ey |
||||
|
||||
set radius [expr { hypot ($ex - $cx, $ey - $cy) }] |
||||
set w [expr {$cx - $radius}] |
||||
set n [expr {$cy - $radius}] |
||||
set e [expr {$cx + $radius}] |
||||
set s [expr {$cy + $radius}] |
||||
|
||||
set mycircle [$mycanvas create oval $w $n $e $s \ |
||||
-fill {} \ |
||||
-width 2 \ |
||||
{*}$options(-circle-config) \ |
||||
-activeoutline $options(-hilit-color) \ |
||||
-outline $options(-color)] |
||||
|
||||
canvas::tag append $mycanvas $mycircle [SegmentTag] |
||||
$mycanvas lower $mycircle $options(-tag) |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Corner management |
||||
|
||||
proc Save {id corner x y} { |
||||
upvar 1 mystate mystate mycoords mycoords |
||||
|
||||
dict set mycoords $corner [list $x $y] |
||||
dict set mystate $corner $id |
||||
dict set mystate $id $corner |
||||
return |
||||
} |
||||
|
||||
proc SegmentTag {} { |
||||
upvar 1 options options |
||||
return $options(-tag)/Circle |
||||
} |
||||
|
||||
#### Generate notification about changes to the point cloud. |
||||
|
||||
proc Note {} { |
||||
upvar 1 options options self self myops myops mycoords mycoords |
||||
if {![llength $options(-data-cmd)]} return |
||||
|
||||
switch -exact -- $myops { |
||||
shunt - base - partial { |
||||
set details {} |
||||
} |
||||
complete { |
||||
set center [dict get $mycoords center] |
||||
lassign $center cx cy |
||||
lassign [dict get $mycoords edge] ex ey |
||||
|
||||
set radius [expr { hypot ($ex - $cx, $ey - $cy) }] |
||||
set details [list $center $radius] |
||||
} |
||||
} |
||||
|
||||
return [{*}$options(-data-cmd) $self $details] |
||||
} |
||||
|
||||
# debug support ... |
||||
proc X {p} { return [lindex [split $p /] 0] } |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## STATE |
||||
# - Saved handle of the canvas operated on. |
||||
# - Counter for the generation of point identifiers |
||||
# - List of the points managed by the object, conveying their |
||||
# order. |
||||
# - Canvas items for the actual circle |
||||
|
||||
typevariable ourcorners {center edge} |
||||
|
||||
variable mycanvas {} ;# The canvas we are working with. |
||||
variable myeditor {} ;# point editor instance managing the circle corners |
||||
variable mystate {} ;# dict, general state |
||||
variable myops {} ;# system state controlling callback processing |
||||
# states |
||||
# - base No points present, accept base point |
||||
# - shunt Ignore point editor callback, automatic task in progress |
||||
# - partial Single point known, wait for the second corner |
||||
# - complete Circle is complete, deny more points |
||||
|
||||
variable mycoords {} ;# corner -> pair (x y) |
||||
variable mycircle {} ;# circle item |
||||
|
||||
variable mydid ; # Drag state. id of the moving point. |
||||
variable mydloc ; # Drag state. Uncommitted location of the moving point. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::edit::circle 0.1 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,453 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
# Canvas Behavior Module. Editing a point cloud. |
||||
|
||||
# - Create point - B1 (canvas global) |
||||
# - Remove point - B2 (linked to -tag, current item) |
||||
# - Drag/Move point - B3 (linked to -tag, current item) |
||||
# - Auto-highlight points, to show ability of drag/move. |
||||
|
||||
# Configurable: |
||||
# - Tag used to mark/identify the points of this cloud. |
||||
# Default: POINT. |
||||
# |
||||
# - Callback used to create the item (group) representing the point. |
||||
# Default: Single blue circle of radius 3 with center at point location. |
||||
# Active color red. |
||||
# |
||||
# - Callback used to record editing activity (add, remove, move point) |
||||
# Default: Do nothing, accept all moves |
||||
# |
||||
# - Callback used to report enter/leave editing activity on the points |
||||
# Default: Do nothing. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
package require snit |
||||
package require canvas::drag |
||||
package require canvas::tag |
||||
|
||||
namespace eval ::canvas::edit { |
||||
namespace export points |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::edit::points { |
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Life cycle, and configuration |
||||
|
||||
option -tag -default POINT -readonly 1 ;# Tag identifying our points |
||||
option -create-cmd -default {} ;# Callback invoked to create new points. |
||||
option -data-cmd -default {} ;# Callback for point edit operations |
||||
option -active-cmd -default {} ;# Callback to report point with mouse over it |
||||
|
||||
# data-cmd signatures ... |
||||
# DC add (canvas group x y ) :: VOID |
||||
# DC remove (canvas group ) :: VOID |
||||
# DC move start (canvas group ) :: VOID |
||||
# DC move delta (canvas group x y dx dy) :: VOID |
||||
# DC move done (canvas group ) :: boolean |
||||
|
||||
# Options to tweak the default marker style without having to go for full-custom callback |
||||
# Blue filled circle of radius 3, with a black border. See `DefaultCreate`. |
||||
option -color -default SkyBlue2 |
||||
option -hilit-color -default red |
||||
option -radius -default 3 |
||||
option -kind -default oval |
||||
|
||||
# Event options ... |
||||
option -add-remove-point -default {} -readonly 1 ; # Event to add/remove a point |
||||
option -drag-point -default 3 -readonly 1 ; # Event to drag a point |
||||
|
||||
constructor {c args} { |
||||
set options(-data-cmd) [mymethod DefaultData] |
||||
set options(-create-cmd) [mymethod DefaultCreate] |
||||
|
||||
$self configurelist $args |
||||
|
||||
set mycanvas $c |
||||
|
||||
# TODO :: Connect this to the option processing to allow me to |
||||
# drop -readonly 1 from their definition. Note that this also |
||||
# requires code to re-tag all the items on the fly. |
||||
#$self Bindings Add {} |
||||
|
||||
$mycanvas bind $options(-tag) <Enter> [mymethod Active 1 $mycanvas %x %y] |
||||
$mycanvas bind $options(-tag) <Leave> [mymethod Active 0 $mycanvas %x %y] |
||||
return |
||||
} |
||||
|
||||
destructor { |
||||
if {![winfo exists $mycanvas]} return |
||||
$self Bindings Remove {} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API. |
||||
|
||||
method disable {args} { |
||||
$self Bindings Remove $args |
||||
return |
||||
} |
||||
|
||||
method enable {args} { |
||||
$self Bindings Add $args |
||||
return |
||||
} |
||||
|
||||
method active {} { |
||||
return $myactive |
||||
} |
||||
|
||||
method add {x y} { |
||||
# Create a point marker programmatically. This enables users |
||||
# to load an editor instance with existing point locations. |
||||
return [$self AddCore $mycanvas $x $y] |
||||
} |
||||
|
||||
method remove {id} { |
||||
$self RemoveByTag $id |
||||
return |
||||
} |
||||
|
||||
method move-to {id x y} { |
||||
$self MoveTo $id $x $y |
||||
return |
||||
} |
||||
|
||||
method move-by {id dx dy} { |
||||
$self MoveBy $id $dx $dy |
||||
return |
||||
} |
||||
|
||||
method current {} { |
||||
return [GetId $mycanvas [$mycanvas find withtag current]] |
||||
} |
||||
|
||||
###### Destroy an existing point |
||||
method clear {} { |
||||
set grouptags {} |
||||
foreach item [$mycanvas find withtag $options(-tag)] { |
||||
lappend grouptags [GetId $mycanvas $item] |
||||
} |
||||
foreach grouptag [lsort -unique $grouptags] { |
||||
$mycanvas delete $grouptag |
||||
#puts "Remove|$x $y|$grouptag" |
||||
unset myloc($grouptag) |
||||
Note remove $grouptag |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Manage the canvas bindings (point creation and removal, dragging). |
||||
|
||||
method {Bindings Add} {parts} { |
||||
if {![llength $parts]} { lappend parts drag edit } |
||||
foreach part $parts { |
||||
switch -exact -- $part { |
||||
drag { |
||||
canvas::drag on $mycanvas $options(-tag) \ |
||||
[mymethod Drag] \ |
||||
-event $options(-drag-point) |
||||
} |
||||
edit { |
||||
if {$myactive} return |
||||
set myactive 1 |
||||
|
||||
# NOTES: |
||||
# 1. Is there a way to make 'Add' not canvas global ? |
||||
# 2. If not, is there a way to ensure that 'Add' is not triggered when a |
||||
# 'Remove' is done, even if the events for the 2 actions basically overlap |
||||
# (B1=Add, Shift-B1=Remove, for example) ? |
||||
# |
||||
# We know that Remove, as item binding, is run before the global Add. |
||||
|
||||
if {$options(-add-remove-point) ne {}} { |
||||
set event <$options(-add-remove-point)> |
||||
$mycanvas bind $options(-tag) $event [mymethod Remove $mycanvas %x %y 1] |
||||
bind $mycanvas $event [mymethod Add $mycanvas %x %y 1] |
||||
} else { |
||||
$mycanvas bind $options(-tag) <2> [mymethod Remove $mycanvas %x %y 0] |
||||
bind $mycanvas <1> [mymethod Add $mycanvas %x %y 0] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
method {Bindings Remove} {parts} { |
||||
if {![llength $parts]} { lappend parts drag edit } |
||||
foreach part $parts { |
||||
switch -exact -- $part { |
||||
drag { |
||||
canvas::drag off $mycanvas $options(-tag) |
||||
} |
||||
edit { |
||||
if {!$myactive} return |
||||
set myactive 0 |
||||
|
||||
if {$options(-add-remove-point) ne {}} { |
||||
set event <$options(-add-remove-point)> |
||||
$mycanvas bind $options(-tag) $event {} |
||||
bind $mycanvas $event {} |
||||
} else { |
||||
$mycanvas bind $options(-tag) <2> {} |
||||
bind $mycanvas <1> {} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## The actions invoked by the bindings managed in the previous |
||||
## section. |
||||
|
||||
###### Place new point |
||||
method Add {c x y skip} { |
||||
# x, y are relative to the viewport |
||||
|
||||
if {$skip && $myskip} { set myskip 0 ; return } |
||||
|
||||
$self CheckCanvas $c |
||||
|
||||
# Translate into actual canvas coordinates |
||||
set x [$c canvasx $x] |
||||
set y [$c canvasy $y] |
||||
|
||||
$self AddCore $c $x $y |
||||
} |
||||
|
||||
method AddCore {c x y} { |
||||
# x, y are absolute canvas coordinates |
||||
|
||||
set grouptag [NewId] |
||||
|
||||
set items [{*}$options(-create-cmd) $c $x $y] |
||||
# No visual representation of the point, no point. Vetoed. |
||||
if {![llength $items]} return |
||||
|
||||
Tag $c $items $grouptag |
||||
set myloc($grouptag) [list $x $y] |
||||
#puts "Add|$x $y|$items" |
||||
Note add $grouptag $x $y |
||||
return $grouptag |
||||
} |
||||
|
||||
###### Destroy an existing point |
||||
method Remove {c x y skip} { |
||||
$self CheckCanvas $c |
||||
#puts "Remove|$x $y|[$c find withtag current]" |
||||
$self RemoveByTag [GetId $c [$c find withtag current]] |
||||
set myskip $skip |
||||
return |
||||
} |
||||
|
||||
method RemoveByTag {grouptag} { |
||||
$mycanvas delete $grouptag |
||||
#puts "RemoveTag|$grouptag" |
||||
unset myloc($grouptag) |
||||
Note remove $grouptag |
||||
return |
||||
} |
||||
|
||||
###### Move existing point programmatically, absolute or relative |
||||
method MoveTo {grouptag x y} { |
||||
set myloc($grouptag) [list $x $y] |
||||
$mycanvas moveto $grouptag $x $y |
||||
return |
||||
} |
||||
|
||||
method MoveBy {grouptag dx dy} { |
||||
lassign $myloc($grouptag) x y |
||||
set x [expr {$x + $dx}] |
||||
set y [expr {$y + $dy}] |
||||
set myloc($grouptag) [list $x $y] |
||||
|
||||
$mycanvas move $grouptag $dx $dy |
||||
return |
||||
} |
||||
|
||||
###### Drag management. On start of a drag ... Identify the group of items to move. |
||||
method {Drag start} {c item} { |
||||
$self CheckCanvas $c |
||||
#puts "Drag Start|$item|" |
||||
set grouptag [GetId $c $item] |
||||
set mydbox [$c bbox $grouptag] |
||||
Note {move start} $grouptag |
||||
return $grouptag |
||||
} |
||||
|
||||
###### Drag management. During a drag ... Move the grouped items. |
||||
method {Drag move} {c grouptag dx dy} { |
||||
$self CheckCanvas $c |
||||
#puts "Drag Move|$grouptag|$dx $dy|" |
||||
$c move $grouptag $dx $dy |
||||
lassign [Delta] px py dx dy |
||||
Note {move delta} $grouptag $px $py $dx $dy |
||||
return $grouptag |
||||
} |
||||
|
||||
###### Drag management. After a drag ... |
||||
method {Drag done} {c grouptag} { |
||||
$self CheckCanvas $c |
||||
#puts "Drag Done|$grouptag|" |
||||
set ok [Note {move done} $grouptag] |
||||
lassign [Delta] px py dx dy |
||||
if {$ok} { |
||||
# Commit to new location. |
||||
set myloc($grouptag) [list $px $py] |
||||
} else { |
||||
# Vetoed. Undo the move. |
||||
set dx [expr {- $dx}] |
||||
set dy [expr {- $dy}] |
||||
$c move $grouptag $dx $dy |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Class global commands for the actions in the previous section. |
||||
|
||||
#### Generate notification about changes to the point cloud. |
||||
|
||||
proc Note {cmd args} { |
||||
upvar 1 options options self self |
||||
if {![llength $options(-data-cmd)]} return |
||||
return [{*}$options(-data-cmd) {*}$cmd $self {*}$args] |
||||
} |
||||
|
||||
#### Generate a unique tag for a new point. |
||||
#### The tag references editor instance and type |
||||
|
||||
proc NewId {} { |
||||
upvar 1 mycounter mycounter self self type type |
||||
return P[incr mycounter]/$self/$type |
||||
} |
||||
|
||||
#### Link both the unique tag for a point marker and the overall |
||||
#### tag identifying the markers managed by an editor to the |
||||
#### canvas items visually representing the marker. |
||||
|
||||
proc Tag {c items grouptag} { |
||||
upvar 1 options options |
||||
foreach i $items { |
||||
canvas::tag append $c $i \ |
||||
$grouptag \ |
||||
$options(-tag) |
||||
} |
||||
return |
||||
} |
||||
|
||||
#### Retrieve the tag of the point marker from any item which is |
||||
#### part of its visual representation. |
||||
|
||||
proc GetId {c item} { |
||||
upvar 1 self self type type |
||||
return [lindex [canvas::tag match $c $item */$self/$type] 0] |
||||
} |
||||
|
||||
#### Compute absolute location and full delta from current and |
||||
#### saved bounding boxes for the items of the point. |
||||
proc Delta {} { |
||||
upvar 1 grouptag grouptag c c |
||||
upvar 1 mydbox obox myloc($grouptag) p |
||||
|
||||
set nbox [$c bbox $grouptag] |
||||
#puts |$myloc($grouptag)|$mydbox|$nbox| |
||||
|
||||
lassign $p px py |
||||
lassign $obox ox oy _ _ |
||||
lassign $nbox nx ny _ _ |
||||
|
||||
# Full delta based between old and current location. |
||||
set dx [expr {$nx - $ox}] |
||||
set dy [expr {$ny - $oy}] |
||||
|
||||
# New absolute location based on the full delta. |
||||
set px [expr {$px + $dx}] |
||||
set py [expr {$py + $dy}] |
||||
|
||||
return [list $px $py $dx $dy] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Instance state |
||||
|
||||
variable myskip 0 ; # Remove/Add communication flag |
||||
variable mycanvas {} ; # Instance command of the canvas widget |
||||
# the editor works with. |
||||
variable mycounter 0 ; # Counter for NewId to generate |
||||
# identifiers for point markers. |
||||
variable mydbox {} ; # The bounding box of the items dragged |
||||
# around, to compute full deltas and |
||||
# absolute location during the drag. |
||||
variable myactive 0 ; # Flag, true when the editor bindings are |
||||
# set on the canvas, enabling editing. |
||||
variable myloc -array {} ; # Internal data base mapping from point |
||||
# id to point location, for the |
||||
# calculation of absolute coordinates |
||||
# during dragging. |
||||
|
||||
method Active {on c x y} { |
||||
# puts "$on $c\t($x $y)" |
||||
if {![llength $options(-active-cmd)]} return |
||||
if {$on} { set on [$self current] } else { set on {} } |
||||
{*}$options(-active-cmd) $self $on |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Default implementations for the configurable callbacks to |
||||
## create the edited points. |
||||
|
||||
method DefaultCreate {c x y} { |
||||
$self CheckCanvas $c |
||||
|
||||
# Create a circle marker in the default style |
||||
set r $options(-radius) |
||||
set w [expr {$x - $r}] |
||||
set n [expr {$y - $r}] |
||||
set e [expr {$x + $r}] |
||||
set s [expr {$y + $r}] |
||||
lappend items [$c create $options(-kind) $w $n $e $s \ |
||||
-width 1 \ |
||||
-outline black \ |
||||
-activefill $options(-hilit-color) \ |
||||
-fill $options(-color)] |
||||
return $items |
||||
} |
||||
|
||||
method {DefaultData add} {c group x y} {} |
||||
method {DefaultData remove} {c group} {} |
||||
method {DefaultData move start} {c group} {} |
||||
method {DefaultData move delta} {c group x y dx dy} {} |
||||
method {DefaultData move done} {c group} { return yes } ;# accept always |
||||
|
||||
method CheckCanvas {c} { |
||||
if {$c eq $mycanvas} return |
||||
return -code error "Canvas mismatch, ours is $mycanvas, called with $c" |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::edit::points 0.3 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,660 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
# Canvas Behavior Module. Editing a point cloud representing a poly-line. I.e. |
||||
# we have two designated points which are start and end of the line, and points |
||||
# have an order, with a line-segment drawn between each adjacent pair of points |
||||
# in this order. |
||||
|
||||
# Default events |
||||
# - Inherited from canvas::edit::points |
||||
# |
||||
# Configurable: |
||||
# - Tag used to mark/identify the points of this cloud. |
||||
# Default: POLYLINE. |
||||
# |
||||
# The tag used for the line segment item is "(tag)/Segment". |
||||
# |
||||
# - Callback used to create the item (group) representing the point. |
||||
# Default: <Inherited from the subordinate point cloud editor> |
||||
# |
||||
# - Callback used to report on line editing activity. |
||||
# Default: NONE. |
||||
# |
||||
# - Callback used to report enter/leave editing activity on the points |
||||
# Default: Do nothing. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
# Notes: |
||||
# |
||||
# - New points are added per the following three rules (See NEW): |
||||
# |
||||
# 1. Points added on a specific segment split that segment, and can |
||||
# then be dragged to their final location. |
||||
# |
||||
# 2. Points not lying an a segment are attached to the nearest |
||||
# endpoint of the line |
||||
# |
||||
# 3. For a closed line which is not yet a line simply extend the |
||||
# line until we have 3 points and can close it as triangle. |
||||
# |
||||
# 4. For a closed line, i.e. loop, we do not have endpoints to |
||||
# attach to. For them rule 3 is disabled, and points can only be |
||||
# added as per rules 1 and 2. |
||||
# |
||||
# - Removal of a point P either removes the single line-segment it is |
||||
# part of (happens if P is the current start or end of the line), or |
||||
# replaces the two segments adjacent to P with a single segment |
||||
# joining the neighbours of P. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 |
||||
package require Tk |
||||
package require snit |
||||
package require canvas::edit::points |
||||
package require canvas::track::lines |
||||
|
||||
namespace eval ::canvas::edit { |
||||
namespace export polyline |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::edit::polyline { |
||||
|
||||
# Major edit mode: line (open) / polygon (closed) |
||||
option -closed -type snit::boolean -default 0 -readonly 1 |
||||
# Minor edit mode: Convex polygon (ignored for -closed 0) |
||||
option -convex -type snit::boolean -default 0 -readonly 1 |
||||
|
||||
# Callback reporting the line/polygon coordinates after changes (add, remove, drag) |
||||
option -data-cmd -default {} |
||||
|
||||
# Callback reporting when the line/polygon or any of the points have the mouse over it |
||||
option -active-cmd -default {} |
||||
|
||||
# See canvas::edit::points |
||||
option -tag -default POLYLINE -readonly 1 |
||||
option -create-cmd -default {} \ |
||||
-configuremethod Chain \ |
||||
-cgetmethod UnChain |
||||
|
||||
# See canvas::edit::points, also base config for line/polygon |
||||
option -color -default SkyBlue2 -configuremethod Pass |
||||
option -hilit-color -default red -configuremethod Pass |
||||
|
||||
# See canvas::edit::points |
||||
option -radius -default 3 -configuremethod Pass |
||||
option -kind -default oval -configuremethod Pass |
||||
|
||||
# See canvas::edit::points, -add-remove also for click on line/polygon |
||||
option -add-remove-point -default {} -readonly 1 |
||||
option -drag-point -default 3 -readonly 1 |
||||
|
||||
# Additional line/polygon configuration |
||||
# NOTE: __Cannot__ supercede -color/-hilit-color |
||||
option -line-config -default {} |
||||
|
||||
method Pass {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
$myeditor configure $o $v |
||||
return 1 |
||||
} |
||||
|
||||
method Chain {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
|
||||
# Reconfigure the editor with our behaviour still in the chain |
||||
$myeditor configure -create-cmd [mymethod Deny $v] |
||||
return 1 |
||||
} |
||||
|
||||
method Unchain {o} { |
||||
# Hide the internal -create-cmd chaining from the user |
||||
return [$myeditor cget -create-cmd] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
constructor {c args} { |
||||
set mycanvas $c |
||||
|
||||
$self configurelist $args |
||||
|
||||
# Generate an internal point cloud editor, which will handle |
||||
# the basic tasks regarding the line's vertices. |
||||
|
||||
lappend cmd canvas::edit points ${selfns}::P $c |
||||
lappend cmd -tag $options(-tag) |
||||
lappend cmd -data-cmd [mymethod Point] |
||||
lappend cmd -active-cmd [mymethod PointActive] |
||||
|
||||
# Pass point options/configuration to the subordinate editor |
||||
foreach o { |
||||
-create-cmd |
||||
-color |
||||
-hilit-color |
||||
-radius |
||||
-kind |
||||
-add-remove-point |
||||
-drag-point |
||||
} { |
||||
set c $options($o) |
||||
if {$c ne {}} { lappend cmd $o $c } |
||||
} |
||||
|
||||
set myeditor [{*}$cmd] |
||||
set mytracker [canvas::track lines ${selfns}::TRACK $mycanvas] |
||||
|
||||
if {$options(-closed)} { |
||||
# Intercept point creation for early rejection of new points |
||||
# not placed on an existing segment of the loop. |
||||
$myeditor configure -create-cmd \ |
||||
[mymethod DenyOutsideOfSegment [$myeditor cget -create-cmd]] |
||||
} |
||||
|
||||
$mycanvas bind [SegmentTag] <Enter> [mymethod Active line] |
||||
$mycanvas bind [SegmentTag] <Leave> [mymethod Active {} ] |
||||
return |
||||
} |
||||
|
||||
component mytracker |
||||
component myeditor |
||||
|
||||
delegate method active to myeditor |
||||
|
||||
method enable {args} { |
||||
Parts |
||||
$myeditor enable {*}$args |
||||
|
||||
foreach part $args { |
||||
switch -exact $part { |
||||
drag {} |
||||
edit { |
||||
$mycanvas bind [SegmentTag] [Event] [mymethod FindSegment $mycanvas %x %y] |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
method disable {args} { |
||||
Parts |
||||
$myeditor disable {*}$args |
||||
|
||||
foreach part $args { |
||||
switch -exact $part { |
||||
drag {} |
||||
edit { |
||||
$mycanvas bind [SegmentTag] [Event] {} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# This is not a straight-forward delegation. Because we have to |
||||
# remove than just the points of the line. |
||||
method clear {} { |
||||
# Drop points - Prevent slow incremental removal of line segments |
||||
set myrskip 1 |
||||
$myeditor clear |
||||
set myrskip 0 |
||||
|
||||
set mypoints {} |
||||
|
||||
# ... and the coordinates |
||||
array unset mycoords * |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
# This is not a straight-forward delegation. Because we have to |
||||
# force 'appending the point' instead of using the heuristics. |
||||
method add {x y} { |
||||
set mydoappend 1 |
||||
$myeditor add $x $y |
||||
set mydoappend 0 |
||||
|
||||
$self Regenerate |
||||
return |
||||
} |
||||
|
||||
method set-line {points} { |
||||
# points :: list ((x0 y0) (x1 y1) ...) |
||||
$self clear |
||||
set mydoappend 1 |
||||
foreach p $points { |
||||
$myeditor add {*}$p |
||||
} |
||||
set mydoappend 0 |
||||
|
||||
$self Regenerate |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Actions bound to events, as reported by the point cloud editor. |
||||
|
||||
method PointActive {_ point} { |
||||
if {$point ne {}} { |
||||
set point [lsearch -exact $mypoints $point] |
||||
# if {$point < 0} { set point {} } |
||||
} |
||||
$self Active $point |
||||
return |
||||
} |
||||
|
||||
method Active {kind} { |
||||
# puts /$kind/ |
||||
if {![llength $options(-active-cmd)]} return |
||||
{*}$options(-active-cmd) $self $kind |
||||
return |
||||
} |
||||
|
||||
method FindSegment {c x y} { |
||||
# We know that we clicked on the line/polygon going through the known points. |
||||
# This means that (x,y) is on one of the segments of that line. |
||||
# Locate that segment. |
||||
# We look for the segment A-B where the direction of A-B best matches the direction of A-P, |
||||
# for the new point P. |
||||
|
||||
set x [$c canvasx $x] |
||||
set y [$c canvasy $y] |
||||
|
||||
# OPTIMIZE: keep last |
||||
|
||||
if {$options(-closed)} { |
||||
set pas $mypoints |
||||
set pbs [lrange $mypoints 1 end] |
||||
lappend pbs [lindex $mypoints 0] |
||||
} else { |
||||
set pas [lrange $mypoints 0 end-1] |
||||
set pbs [lrange $mypoints 1 end] |
||||
} |
||||
|
||||
set min Inf |
||||
set pos 0 |
||||
foreach pa $pas pb $pbs { |
||||
incr pos ;# pos -- pb |
||||
lassign $mycoords($pa) xa ya |
||||
lassign $mycoords($pb) xb yb |
||||
# puts -nonewline \nB@$pos\t[X $pa]-[X $pb] |
||||
|
||||
# vectors A-P and A-B |
||||
set dax [expr {$x - $xa}] |
||||
set day [expr {$y - $ya}] |
||||
set dbx [expr {$xb - $xa}] |
||||
set dby [expr {$yb - $ya}] |
||||
|
||||
# normalized scalar product = cos (angle) |
||||
set mag [expr {hypot($dax,$day)}] |
||||
set sp [expr {(($dax*$dbx) + ($day*$dby))/($mag*hypot($dbx,$dby))}] |
||||
# puts -nonewline \t|$mag|\tcphi\t$sp |
||||
|
||||
# -1 ==> vectors are anti collinear |
||||
# 0 ==> vectors are orthogonal |
||||
# 1 ==> vectors are collinear |
||||
|
||||
# ignore directions which do not match to a minimum standard |
||||
if {$sp < 0.9} continue |
||||
# puts -nonewline \tGOOD |
||||
|
||||
# ... and take the nearest of the remainder |
||||
if {$mag > $min} continue |
||||
# puts -nonewline \tREMEMBER |
||||
|
||||
set min $mag |
||||
set mysplit [list $pa $pb] |
||||
} |
||||
|
||||
#puts "" |
||||
if {[llength $mysplit]} return |
||||
# puts "/FAIL" |
||||
|
||||
# With mysplit not set the system falls back to attaching to the nearest endpoint |
||||
# Or, for a polygon, denies the new point |
||||
return |
||||
} |
||||
|
||||
method DenyOutsideOfSegment {chain c x y} { |
||||
# Accept all points during programmatic load |
||||
if {$mydoappend} { |
||||
return [{*}$chain $c $x $y] |
||||
} |
||||
# Interaction, Rule 4. |
||||
## |
||||
# We know here that we are working on a closed line/loop. |
||||
# Deny any attempts to add points not sitting on a segment of the line. |
||||
# Exception is when we have no loop at all yet (needs 3 points and segments). |
||||
set len [llength $mypoints] |
||||
if {$len >= 3} { |
||||
if {![llength $mysplit]} return ;# deny point not on segment |
||||
} |
||||
# Continue to actual marker creation. |
||||
return [{*}$chain $c $x $y] |
||||
} |
||||
|
||||
method {Point add} {pe id x y} { |
||||
set mycoords($id) [list $x $y] |
||||
|
||||
if {$mydoappend} { |
||||
set end [lindex $mypoints end] |
||||
lappend mypoints $id |
||||
|
||||
if {[llength $mypoints] < 2} return |
||||
|
||||
# Reject loading of closed non-convex line into convex editor |
||||
if {$options(-closed) && $options(-convex) && ![$self Convex]} { |
||||
return -code error "Polygon is not convex" |
||||
} |
||||
|
||||
# Regenerate is handled by caller (enables deferal until complete line is loaded) |
||||
return |
||||
} |
||||
|
||||
$self ExtendLine $id $x $y |
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method {Point remove} {pe id} { |
||||
if {$myrskip} return |
||||
|
||||
$self ShrinkLine $id |
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method {Point move start} {pe id} { |
||||
set mydloc $mycoords($id) |
||||
set mydstart $mydloc |
||||
|
||||
set len [llength $mypoints] |
||||
set pos [lsearch -exact $mypoints $id] |
||||
if {$pos < 0} return |
||||
|
||||
set fix {} |
||||
|
||||
set prev $pos ; incr prev -1 |
||||
set next $pos ; incr next |
||||
|
||||
if {$options(-closed) && ($prev < 0)} { |
||||
lappend fix $mycoords([lindex $mypoints end]) |
||||
} elseif {$prev >= 0} { |
||||
lappend fix $mycoords([lindex $mypoints $prev]) |
||||
} |
||||
|
||||
if {$options(-closed) && ($next >= $len)} { |
||||
lappend fix $mycoords([lindex $mypoints 0]) |
||||
} elseif {$next < $len} { |
||||
lappend fix $mycoords([lindex $mypoints $next]) |
||||
} |
||||
|
||||
$mytracker start $mydloc {*}$fix |
||||
return |
||||
} |
||||
|
||||
method {Point move delta} {pe id nx ny dx dy} { |
||||
set mydloc [list $nx $ny] |
||||
$mytracker move $mydloc |
||||
return |
||||
} |
||||
|
||||
method {Point move done} {pe id} { |
||||
$mytracker done |
||||
$self MoveVertex $id $mydloc |
||||
|
||||
if {$options(-closed) && $options(-convex) && ![$self Convex]} { |
||||
# Undo the move when it makes the closed convex line non-convex. |
||||
$self MoveVertex $id $mydstart |
||||
return 0 |
||||
} |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return 1 |
||||
} |
||||
|
||||
method MoveVertex {p new} { |
||||
# Move the reference location of the point, and ... |
||||
set mycoords($p) $new |
||||
return |
||||
} |
||||
|
||||
method Convex {} { |
||||
# Anything up to a triangle is always considered convex. |
||||
if {[llength $mypoints] < 4} { return 1 } |
||||
foreach triple [Triples] { |
||||
lassign $triple a b c |
||||
# Corner a --> b --> c |
||||
# Convex if the turn is right-hand |
||||
set o [Cross [Delta $b $a] [Delta $c $b]] |
||||
if {$o < 0} { return 0 } |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
proc Cross {a b} { |
||||
lassign $a xa ya |
||||
lassign $b xb yb |
||||
return [expr {$xa*$yb - $ya*$xb}] |
||||
} |
||||
|
||||
proc Delta {a b} { |
||||
lassign $a xa ya |
||||
lassign $b xb yb |
||||
return [list [expr {$xb - $xa}] [expr {$yb - $ya}]] |
||||
} |
||||
|
||||
proc Triples {} { |
||||
upvar 1 mypoints mypoints mycoords mycoords |
||||
|
||||
set plist $mypoints |
||||
lappend plist {*}[lrange $mypoints 0 1] |
||||
|
||||
set plist [lmap p $plist { set mycoords($p) }] |
||||
set triples {} |
||||
foreach \ |
||||
a [lrange $plist 0 end-2] \ |
||||
b [lrange $plist 1 end-1] \ |
||||
c [lrange $plist 2 end] { |
||||
lappend triples [list $a $b $c] |
||||
} |
||||
return $triples |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Line management |
||||
|
||||
method Regenerate {} { |
||||
if {$mytrack ne {}} { |
||||
$mycanvas delete $mytrack |
||||
set mytrack {} |
||||
} |
||||
|
||||
set len [llength $mypoints] |
||||
if {$len < 2} return ;# line needs 2 points |
||||
|
||||
set coordinates [concat {*}[lmap p $mypoints { |
||||
set mycoords($p) |
||||
}]] |
||||
|
||||
if {$options(-closed) && ($len > 2)} { |
||||
set mytrack [$mycanvas create polygon {*}$coordinates \ |
||||
-fill {} \ |
||||
-width 2 \ |
||||
{*}$options(-line-config) \ |
||||
-activeoutline $options(-hilit-color) \ |
||||
-outline $options(-color)] |
||||
} else { |
||||
set mytrack [$mycanvas create line {*}$coordinates \ |
||||
-width 2 \ |
||||
{*}$options(-line-config) \ |
||||
-activefill $options(-hilit-color) \ |
||||
-fill $options(-color)] |
||||
} |
||||
|
||||
canvas::tag append $mycanvas $mytrack [SegmentTag] |
||||
$mycanvas lower $mytrack $options(-tag) |
||||
return |
||||
} |
||||
|
||||
method ExtendLine {p x y} { |
||||
# Add point, with attached segments, drop superseded segments |
||||
set len [llength $mypoints] |
||||
|
||||
switch -exact -- $len { |
||||
0 - 1 { |
||||
lappend mypoints $p |
||||
} |
||||
default { |
||||
# 2 or more points ... (NEW) ... Rules at top of file |
||||
## |
||||
|
||||
# Rule 1. |
||||
|
||||
if {[llength $mysplit]} { |
||||
lassign $mysplit pa pb |
||||
set mysplit {} |
||||
|
||||
set pos [lsearch -exact $mypoints $pb] |
||||
set mypoints [linsert $mypoints $pos $p] |
||||
return |
||||
} |
||||
|
||||
# Rule 4. |
||||
|
||||
if {$options(-closed) && ($len >= 3)} { |
||||
return -code error \ |
||||
"Failed to be rejected by DenyOutsideOfSegment" |
||||
} |
||||
|
||||
# Rule 3. Extend at end and close |
||||
|
||||
if {$options(-closed) && ($len == 2)} { |
||||
lappend mypoints $p |
||||
return |
||||
} |
||||
|
||||
# Rule 2. Attach to the nearer of the two endpoints. |
||||
|
||||
set first [lindex $mypoints 0] |
||||
set last [lindex $mypoints end] |
||||
|
||||
if {[Distance $p $first] < [Distance $p $last]} { |
||||
set mypoints [linsert $mypoints 0 $p] |
||||
return |
||||
} |
||||
|
||||
lappend mypoints $p |
||||
return |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
method ShrinkLine {p} { |
||||
set pos [lsearch -exact $mypoints $p] |
||||
if {$pos < 0} return |
||||
set mypoints [lreplace $mypoints $pos $pos] |
||||
|
||||
unset mycoords($p) |
||||
return |
||||
} |
||||
|
||||
proc Distance {pa pb} { |
||||
upvar 1 mycoords mycoords |
||||
lassign $mycoords($pa) xa ya |
||||
lassign $mycoords($pb) xb yb |
||||
return [expr {hypot($xa-$xb,$ya-$yb)}] |
||||
} |
||||
|
||||
#### #### #### #### #### #### #### #### #### #### #### #### |
||||
|
||||
proc SegmentTag {{suffix {}}} { |
||||
upvar 1 options options |
||||
if {$suffix ne {}} { set suffix ,$suffix } |
||||
return $options(-tag)/Segment$suffix |
||||
} |
||||
|
||||
proc Parts {} { |
||||
upvar 1 args args |
||||
if {![llength $args]} { set args {edit} } |
||||
lappend args drag |
||||
set args [lsort -unique $args] |
||||
return |
||||
} |
||||
|
||||
proc Event {} { |
||||
upvar 1 options options |
||||
if {$options(-add-remove-point) ne {}} { |
||||
return <$options(-add-remove-point)> |
||||
} else { |
||||
return <1> |
||||
} |
||||
} |
||||
|
||||
#### Generate notification about changes to the point cloud. |
||||
|
||||
proc Note {} { |
||||
upvar 1 options options |
||||
if {![llength $options(-data-cmd)]} return |
||||
upvar 1 mypoints mypoints mycoords mycoords self self |
||||
set coords {} |
||||
foreach p $mypoints { |
||||
lappend coords $mycoords($p) |
||||
} |
||||
return [{*}$options(-data-cmd) $self $coords] |
||||
} |
||||
|
||||
# debug support ... |
||||
proc X {p} { return [lindex [split $p /] 0] } |
||||
proc XX {} { upvar 1 mypoints ps ; lmap p $ps { X $p } } |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## STATE |
||||
# - Saved handle of the canvas operated on. |
||||
# - List of the points managed by the object, conveying their |
||||
# order. |
||||
# - Canvas items for the line segments the poly line consists of. |
||||
|
||||
variable mycanvas {} ;# canvas the editor is attached to |
||||
variable mytrack {} ;# line/polygon item for the entire track |
||||
|
||||
# mypoints :: list (id...) |
||||
# mycoords :: array (id -> pixel) |
||||
# myline :: array (pair (a b) -> item) |
||||
|
||||
variable mypoints {} ; # list of the ids for the line's points. |
||||
variable mysplit {} ; # Segment clicked on (pair (point-id-a point-id-b)) |
||||
variable mycoords -array {} ; # Reference coordinates of the points. Keyed by point id. |
||||
variable mydloc {} ; # Drag state. Location of the moving vertex. |
||||
variable mydstart {} ; # Drag state. Original location of the moving vertex. |
||||
variable mydoappend 0 ; # Flag. When set new points are always |
||||
# appended at the end of the line. |
||||
variable myrskip 0 ; # Flag. Skip complex point removal when set. |
||||
# |
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::edit::polyline 0.2 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,400 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
## TODO : Optimize the use of AddLine/DropAdjacent to reduce the amount |
||||
## TODO : of item churn. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
# Canvas Behavior Module. Editing 4 points/vertices describing a |
||||
# (convex) quadrilateral. |
||||
|
||||
# - Create point - B1 (canvas global) |
||||
# - Remove point - B2 (linked to -tag, current item) |
||||
# - Drag/Move point - B3 (linked to -tag, current item) |
||||
# - Auto-highlight points, to show ability of drag/move. |
||||
|
||||
# Configurable: |
||||
# - Tag used to mark/identify the points of this cloud. |
||||
# Default: QUADRILATERAL. |
||||
# |
||||
# - Callback used to create the item (group) representing the point. |
||||
# Default: <Inherited from the subordinate point cloud editor> |
||||
# |
||||
# - Callback used to (un)highlight the item (group) of a point. |
||||
# Default: <Inherited from the subordinate point cloud editor> |
||||
# |
||||
# - Callback used to report on quadrilateral editing activity. |
||||
# Default: NONE. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
package require snit |
||||
package require canvas::edit::points |
||||
package require canvas::track::lines |
||||
|
||||
namespace eval ::canvas::edit { |
||||
namespace export quadrilateral |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::edit::quadrilateral { |
||||
option -tag -default QUADRILATERAL -readonly 1 |
||||
option -create-cmd -default {} -readonly 1 |
||||
option -highlight-cmd -default {} -readonly 1 |
||||
option -data-cmd -default {} -readonly 1 |
||||
|
||||
option -convex -type snit::boolean -default 0 -readonly 1 |
||||
|
||||
constructor {c args} { |
||||
set mycanvas $c |
||||
set myfreeref $ourrefs |
||||
|
||||
# Generate an internal point cloud editor, which will handle |
||||
# the basic tasks regarding the quadrilaterals's vertices. |
||||
|
||||
lappend cmd canvas::edit points ${selfns}::P $c |
||||
lappend cmd -tag [from args -tag QUADRILATERAL] |
||||
lappend cmd -data-cmd [mymethod Point] |
||||
lappend cmd -create-cmd [mymethod Create] |
||||
|
||||
set c [from args -highlight-cmd {}] |
||||
if {$c ne {}} { lappend cmd -highlight-cmd $c } |
||||
|
||||
set myeditor [{*}$cmd] |
||||
set mytracker [canvas::track lines ${selfns}::TRACK $mycanvas] |
||||
|
||||
set c [from args -create-cmd [mymethod DefaultCreate]] |
||||
set options(-create-cmd) $c |
||||
|
||||
$self configurelist $args |
||||
|
||||
# TODO :: Connect this to the option processing to alow me to |
||||
# drop -readonly 1 from their definition. Note that this also |
||||
# requires code to re-tag all the items on the fly. |
||||
|
||||
return |
||||
} |
||||
|
||||
component mytracker |
||||
component myeditor |
||||
|
||||
delegate method enable to myeditor |
||||
delegate method disable to myeditor |
||||
delegate method active to myeditor |
||||
delegate method clear to myeditor |
||||
delegate method add to myeditor |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Actions bound to events, as reported by the point cloud editor. |
||||
|
||||
method DefaultCreate {c x y} { |
||||
# No vetoing, just item creation. The vertices of the |
||||
# quadrilateral are uniquely colored and shaped, ensuring that |
||||
# we not only see the shape of the quad, but its exact |
||||
# orientation as well. |
||||
|
||||
set items {} |
||||
set radius 5 |
||||
switch -exact -- [lindex $myfreeref 0] { |
||||
0 { |
||||
# First vertex, top left. |
||||
# A circle centered on the chosen location, blue |
||||
# filled with black border. |
||||
set w [expr {$x - $radius}] |
||||
set n [expr {$y - $radius}] |
||||
set e [expr {$x + $radius}] |
||||
set s [expr {$y + $radius}] |
||||
lappend items [$c create oval $w $n $e $s \ |
||||
-width 1 \ |
||||
-outline black \ |
||||
-fill SkyBlue2] |
||||
} |
||||
1 { |
||||
# Second vertex, clock-wise, top right |
||||
# A circle centered on the chosen location, green |
||||
# filled with black border. |
||||
set w [expr {$x - $radius}] |
||||
set n [expr {$y - $radius}] |
||||
set e [expr {$x + $radius}] |
||||
set s [expr {$y + $radius}] |
||||
lappend items [$c create oval $w $n $e $s \ |
||||
-width 1 \ |
||||
-outline black \ |
||||
-fill Green] |
||||
} |
||||
2 { |
||||
# Third vertex, clock-wise, bottom right |
||||
# A square centered on the chosen location, blue |
||||
# filled with black border. |
||||
set w [expr {$x - $radius}] |
||||
set n [expr {$y - $radius}] |
||||
set e [expr {$x + $radius}] |
||||
set s [expr {$y + $radius}] |
||||
lappend items [$c create rect $w $n $e $s \ |
||||
-width 1 \ |
||||
-outline black \ |
||||
-fill SkyBlue2] |
||||
} |
||||
3 { |
||||
# Fourth vertex, clock-wise, bottom left |
||||
# A square centered on the chosen location, green |
||||
# filled with black border. |
||||
set w [expr {$x - $radius}] |
||||
set n [expr {$y - $radius}] |
||||
set e [expr {$x + $radius}] |
||||
set s [expr {$y + $radius}] |
||||
lappend items [$c create rect $w $n $e $s \ |
||||
-width 1 \ |
||||
-outline black \ |
||||
-fill Green] |
||||
} |
||||
} |
||||
return $items |
||||
} |
||||
|
||||
method Create {c x y} { |
||||
if {![llength $myfreeref]} { return {} } |
||||
|
||||
if {$options(-convex)} { |
||||
set next [lindex $myfreeref 0] |
||||
set mydactive 1 |
||||
set mydvertex $next |
||||
set mydloc [list $x $y] |
||||
set convex [$self Convex] |
||||
set mydactive 0 |
||||
if {!$convex} { return {} } |
||||
} |
||||
# XXX Might be useful to have our own standard create method. |
||||
# XXX To make the vertices of the quad visually unique |
||||
# XXX (color, shape). |
||||
return [{*}$options(-create-cmd) $c $x $y] |
||||
} |
||||
|
||||
method {Point add} {pe id x y} { |
||||
set ref [lindex $myfreeref 0] |
||||
set myfreeref [lrange $myfreeref 1 end] |
||||
set myvertex($ref) [list $x $y] |
||||
set myvertex($id) $ref |
||||
|
||||
$self AddLine [expr {($ref-1)%4}] $ref |
||||
$self AddLine $ref [expr {($ref+1)%4}] |
||||
|
||||
# Report only when the quad has become complete. |
||||
if {[llength $myfreeref]} return |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method {Point remove} {pe id} { |
||||
set ref $myvertex($id) |
||||
unset myvertex($id) myvertex($ref) |
||||
lappend myfreeref $ref |
||||
|
||||
$self DropAdjacent $ref |
||||
|
||||
# Report only when the quad just lost a vertex |
||||
if {[llength $myfreeref] > 1} return |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method {Point move start} {pe id} { |
||||
# Initialize local drag state. |
||||
set ref $myvertex($id) |
||||
set mydactive 1 |
||||
set mydid $id |
||||
set mydvertex $ref |
||||
set mydloc $myvertex($ref) |
||||
|
||||
$mytracker start $mydloc {*}[$self Trackpoints] |
||||
return |
||||
} |
||||
|
||||
method {Point move delta} {pe id nx ny dx dy} { |
||||
# Track the movement. |
||||
set mydloc [list $nx $ny] |
||||
$mytracker move $mydloc |
||||
return |
||||
} |
||||
|
||||
method {Point move done} {pe id} { |
||||
# Accept any move if the quad is not restrained. |
||||
# Otherwise reject locations causing non-convexity. |
||||
$mytracker done |
||||
set ok [expr {!$options(-convex) || [$self Convex]}] |
||||
set mydactive 0 |
||||
if {$ok} { |
||||
# Commit to the new location. |
||||
set myvertex($mydvertex) $mydloc |
||||
$self DropAdjacent $mydvertex |
||||
$self AddLine [expr {($mydvertex-1)%4}] $mydvertex |
||||
$self AddLine $mydvertex [expr {($mydvertex+1)%4}] |
||||
|
||||
# Report only if the quad is complete. |
||||
if {![llength $myfreeref]} Note |
||||
} |
||||
return $ok |
||||
} |
||||
|
||||
method Convex {} { |
||||
# An incomplete quad is at most a triangle, and always convex. |
||||
if {[llength $myfreeref] > 1} { return 1 } |
||||
foreach triple [$self Triples] { |
||||
lassign $triple a b c |
||||
# Corner a --> b --> c |
||||
# Convex if the turn is right-hand |
||||
set o [Cross [Delta $b $a] [Delta $c $b]] |
||||
if {$o < 0} { return 0 } |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
proc Cross {a b} { |
||||
lassign $a xa ya |
||||
lassign $b xb yb |
||||
return [expr {$xa*$yb - $ya*$xb}] |
||||
} |
||||
|
||||
proc Delta {a b} { |
||||
lassign $a xa ya |
||||
lassign $b xb yb |
||||
return [list [expr {$xb - $xa}] [expr {$yb - $ya}]] |
||||
} |
||||
|
||||
method Triples {} { |
||||
set plist [$self GetQuad 1] |
||||
set triples {} |
||||
foreach \ |
||||
a [lrange $plist 0 end-2] \ |
||||
b [lrange $plist 1 end-1] \ |
||||
c [lrange $plist 2 end] { |
||||
lappend triples [list $a $b $c] |
||||
} |
||||
return $triples |
||||
} |
||||
|
||||
method GetQuad {{extended 0}} { |
||||
set res {} |
||||
if {$extended} { |
||||
set idlist $ourerefs |
||||
} else { |
||||
set idlist $ourrefs |
||||
} |
||||
foreach ref $idlist { |
||||
if {$mydactive && ($ref == $mydvertex)} { |
||||
set p $mydloc |
||||
} else { |
||||
if {![info exists myvertex($ref)]} continue |
||||
set p $myvertex($ref) |
||||
} |
||||
lappend res $p |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Line management |
||||
|
||||
method Trackpoints {} { |
||||
set prev [expr {($mydvertex-1)%4}] |
||||
set next [expr {($mydvertex+1)%4}] |
||||
set res {} |
||||
if {[info exists myvertex($prev)]} { |
||||
lappend res $myvertex($prev) |
||||
} |
||||
if {[info exists myvertex($next)]} { |
||||
lappend res $myvertex($next) |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
method AddLine {aref bref} { |
||||
set key $aref$bref |
||||
if {[info exists myline($key)]} { error "present already" } |
||||
|
||||
if {![info exists myvertex($aref)] || |
||||
![info exists myvertex($bref)] |
||||
} return |
||||
|
||||
set a $myvertex($aref) |
||||
set b $myvertex($bref) |
||||
|
||||
# TODO :: Add a callback/create command prefix for the helper |
||||
# lines. At which point the 'line' may consist of multiple |
||||
# items. |
||||
|
||||
set segment [$mycanvas create line {*}$a {*}$b -width 1 -fill black] |
||||
$mycanvas lower $segment $options(-tag) |
||||
|
||||
set myline($key) $segment |
||||
|
||||
# NOTE :: Should we tag the segment ? |
||||
return |
||||
} |
||||
|
||||
method DropAdjacent {pref} { |
||||
foreach key [array names myline *${pref}*] { |
||||
set segment $myline($key) |
||||
$mycanvas delete $segment |
||||
unset myline($key) |
||||
} |
||||
return |
||||
} |
||||
|
||||
#### Generate notification about changes to the point cloud. |
||||
|
||||
proc Note {} { |
||||
upvar 1 options options myfreeref myfreeref myvertex myvertex self self |
||||
if {![llength $options(-data-cmd)]} return |
||||
if {[llength $myfreeref]} { |
||||
# Incomplete quad. Report as 'no quad'. |
||||
set coords {} |
||||
} else { |
||||
set coords [$self GetQuad] |
||||
} |
||||
return [{*}$options(-data-cmd) $self $coords] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## STATE |
||||
# - Saved handle of the canvas operated on. |
||||
# - Counter for the generation of point identifiers |
||||
# - List of the points managed by the object, conveying their |
||||
# order. |
||||
# - Canvas items for the actual polyline |
||||
|
||||
typevariable ourrefs {0 1 2 3} |
||||
typevariable ourerefs {0 1 2 3 0 1} |
||||
|
||||
variable mycanvas {} ; # The canvas we are working with. |
||||
variable myfreeref ; # Vertex ids which are free to fill. |
||||
variable myvertex -array {} ; # Vertex information |
||||
# editor id -> vertex id |
||||
# vertex id -> vertex coordinates |
||||
variable myline -array {} ; # Canvas items for the quad helper lines connecting the points. |
||||
# Keyed by the pair if vertex ids connected by the line. |
||||
|
||||
variable mydactive 0 ; # Drag state. Boolean flag. True when drag in progress. |
||||
variable mydid ; # Drag state. Editor point id of moving point. |
||||
variable mydvertex ; # Drag state. Vertex id of moving point. |
||||
variable mydloc ; # Drag state. Uncommitted location of the moving point. |
||||
variable mydcrosshair ; # Drag state. Crosshair / rubber band lines shown during dragging. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::edit::quadrilateral 0.1 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,452 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
# Canvas Behavior Module. Editing 2-4 points/vertices describing an axis-aligned rectangle, |
||||
# i.e. bounding box. |
||||
|
||||
# Core interaction behaviour inherited from canvas::edit::points |
||||
|
||||
# Configurable: |
||||
# - Tag used to mark/identify the points of this cloud. |
||||
# Default: RECTANGLE |
||||
# |
||||
# - Callback used to create the item (group) representing the point. |
||||
# Default: <Inherited from the subordinate point cloud editor> |
||||
# |
||||
# - Callback used to report on rectangle editing activity. |
||||
# Default: NONE. |
||||
# |
||||
# - Callback used to report enter/leave events for the rectangle and its points. |
||||
# Default: NONE. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
package require snit |
||||
package require canvas::edit::points |
||||
|
||||
namespace eval ::canvas::edit { |
||||
namespace export rectangle |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::edit::rectangle { |
||||
|
||||
# See canvas::edit::points |
||||
option -tag -default RECTANGLE -readonly 1 |
||||
option -create-cmd -default {} \ |
||||
-configuremethod Chain \ |
||||
-cgetmethod UnChain |
||||
|
||||
# Callback reporting the rectangle after changes (add, remove, drag) |
||||
option -data-cmd -default {} |
||||
|
||||
# Callback reporting when the rectangle or any of the points have the mouse over it |
||||
option -active-cmd -default {} |
||||
|
||||
# See canvas::edit::points, also base config for rectangle |
||||
option -color -default SkyBlue2 -configuremethod Pass |
||||
option -hilit-color -default red -configuremethod Pass |
||||
|
||||
# See canvas::edit::points |
||||
option -radius -default 3 -configuremethod Pass |
||||
option -kind -default oval -configuremethod Pass |
||||
|
||||
# See canvas::edit::points, -add-remove also for click on rectangle |
||||
option -add-remove-point -default {} -readonly 1 |
||||
option -drag-point -default 3 -readonly 1 |
||||
|
||||
# Additional rectangle configuration |
||||
# NOTE: __Cannot__ supercede -color/-hilit-color |
||||
option -rect-config -default {} |
||||
|
||||
method Pass {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
$myeditor configure $o $v |
||||
return 1 |
||||
} |
||||
|
||||
method Chain {o v} { |
||||
if {$v eq $options($o)} { return 0 } |
||||
set options($o) $v |
||||
if {$myeditor eq {}} { return 1 } |
||||
|
||||
# Reconfigure the editor with our behaviour still in the chain |
||||
$myeditor configure -create-cmd [mymethod Deny $v] |
||||
return 1 |
||||
} |
||||
|
||||
method Unchain {o} { |
||||
# Hide the internal -create-cmd chaining from the user |
||||
return [$myeditor cget -create-cmd] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
constructor {c args} { |
||||
set mycanvas $c |
||||
set mystate {} |
||||
set myops base |
||||
|
||||
$self configurelist $args |
||||
|
||||
# Generate an internal point cloud editor, which will handle |
||||
# the basic tasks regarding the rectangles's vertices. |
||||
|
||||
lappend cmd canvas::edit points ${selfns}::P $c |
||||
lappend cmd -tag $options(-tag) |
||||
lappend cmd -data-cmd [mymethod Point] |
||||
lappend cmd -active-cmd [mymethod PointActive] |
||||
|
||||
# Pass point options/configuration to the subordinate editor |
||||
foreach o { |
||||
-create-cmd |
||||
-color |
||||
-hilit-color |
||||
-radius |
||||
-kind |
||||
-add-remove-point |
||||
-drag-point |
||||
} { |
||||
set c $options($o) |
||||
if {$c ne {}} { lappend cmd $o $c } |
||||
} |
||||
|
||||
set myeditor [{*}$cmd] |
||||
|
||||
$myeditor configure -create-cmd \ |
||||
[mymethod Deny [$myeditor cget -create-cmd]] |
||||
|
||||
$mycanvas bind [SegmentTag] <Enter> [mymethod Active rect] |
||||
$mycanvas bind [SegmentTag] <Leave> [mymethod Active {} ] |
||||
return |
||||
} |
||||
|
||||
component myeditor |
||||
|
||||
delegate method enable to myeditor |
||||
delegate method disable to myeditor |
||||
delegate method active to myeditor |
||||
|
||||
method clear {} { |
||||
set myops shunt |
||||
$myeditor clear |
||||
|
||||
set myops base |
||||
set mystate {} |
||||
set mycoords {} |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method set {minx miny maxx maxy} { |
||||
$self clear |
||||
$self Complete $myeditor $minx $miny $maxx $maxy |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Actions bound to events, as reported by the point cloud editor. |
||||
|
||||
method Complete {pe minx miny maxx maxy} { |
||||
set myops shunt |
||||
|
||||
# Corners |
||||
# |
||||
# tl *--* tr |
||||
# | | |
||||
# bl *--* br |
||||
|
||||
# Create the proper corner points and remember their associations (id <-> corner) |
||||
Def $pe tl $minx $miny |
||||
Def $pe bl $minx $maxy |
||||
Def $pe tr $maxx $miny |
||||
Def $pe br $maxx $maxy |
||||
|
||||
# enter completion, where the rectangle can be dragged (by its corners), and removed |
||||
set myops complete |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
|
||||
method Deny {chain c x y} { |
||||
#puts deny/$myops/$mystate/ |
||||
# Deny more points when we have the complete set. |
||||
if {$myops eq "complete"} return |
||||
|
||||
# Continue to actual marker creation. |
||||
return [{*}$chain $c $x $y] |
||||
} |
||||
|
||||
method PointActive {_ corner} { |
||||
if {$myops ne "complete"} return |
||||
if {$corner ne {}} { set corner [dict get $mystate $corner] } |
||||
$self Active $corner |
||||
return |
||||
} |
||||
|
||||
method Active {kind} { |
||||
# puts /$kind/ |
||||
if {![llength $options(-active-cmd)]} return |
||||
{*}$options(-active-cmd) $self $kind |
||||
return |
||||
} |
||||
|
||||
method {Point add} {pe id x y} { |
||||
switch -exact -- $myops { |
||||
shunt {} |
||||
base { |
||||
# Base point arrived, remember, now wait for second corner |
||||
set mystate [list $id $x $y] |
||||
set myops partial |
||||
return |
||||
} |
||||
partial { |
||||
# Second corner has arrived. Complete the rectangle. |
||||
# Disable point callbacks invoked due to this automatic task. |
||||
set myops shunt |
||||
|
||||
# Get saved first corner |
||||
lassign $mystate id0 x0 y0 |
||||
set mystate {} |
||||
|
||||
# Compute all corners from it and the current, second, corner |
||||
set minx [expr { min ($x0, $x) }] |
||||
set miny [expr { min ($y0, $y) }] |
||||
set maxx [expr { max ($x0, $x) }] |
||||
set maxy [expr { max ($y0, $y) }] |
||||
|
||||
# Drop old points (base, and current) |
||||
$pe remove $id |
||||
$pe remove $id0 |
||||
|
||||
# And generate the rectangle |
||||
$self Complete $pe $minx $miny $maxx $maxy |
||||
} |
||||
complete { |
||||
return -code error "Should have been rejected by `Deny`" |
||||
} |
||||
} |
||||
} |
||||
|
||||
method {Point remove} {pe id} { |
||||
switch -exact -- $myops { |
||||
shunt {} |
||||
base { |
||||
# no points known. nothing to do |
||||
return |
||||
} |
||||
partial { |
||||
# first point known, no second point. drop memory of first point |
||||
set mystate {} |
||||
set myops base |
||||
return |
||||
} |
||||
complete { |
||||
# removing even one point of the rectangle removes the entire rectangle! |
||||
# Disable point callbacks invoked due to this automatic task. |
||||
set myops shunt |
||||
|
||||
# Find the corner removed by the user and drop it from the state. |
||||
# Then remove the remaining corners |
||||
set corner [dict get $mystate $id] |
||||
dict unset mystate $id |
||||
dict unset mystate $corner |
||||
|
||||
foreach corner $ourcorners { |
||||
if {![dict exists $mystate $corner]} continue |
||||
$pe remove [dict get $mystate $corner] |
||||
} |
||||
|
||||
# enter base state waiting for a new first point |
||||
set myops base |
||||
set mystate {} |
||||
set mycoords {} |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return |
||||
} |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
method {Point move start} {pe id} { |
||||
# Initialize local drag state. |
||||
set mydid $id |
||||
set corner [dict get $mystate $id] |
||||
set mydloc [dict get $mycoords $corner] |
||||
return |
||||
} |
||||
|
||||
method {Point move delta} {pe id nx ny dx dy} { |
||||
# Track the movement. |
||||
set mydloc [list $nx $ny] |
||||
return |
||||
} |
||||
|
||||
method {Point move done} {pe id} { |
||||
set corner [dict get $mystate $id] |
||||
|
||||
# Get the rectangle data from moving an opposite corner |
||||
lassign [dict get $mycoords [dict get { |
||||
tl br tr bl |
||||
bl tr br tl |
||||
} $corner]] x1 y1 |
||||
lassign $mydloc x0 y0 |
||||
|
||||
# Update state of the moved point, for proper relative |
||||
# movement after the coming recalculation |
||||
Save $id $corner $x0 $y0 |
||||
|
||||
# Recompute all corner locations ... |
||||
set minx [expr { min ($x0, $x1) }] |
||||
set miny [expr { min ($y0, $y1) }] |
||||
set maxx [expr { max ($x0, $x1) }] |
||||
set maxy [expr { max ($y0, $y1) }] |
||||
|
||||
# and move the points for the corners to the new locations |
||||
# One of the points, the current moved may not move again |
||||
Move $pe tl $minx $miny |
||||
Move $pe bl $minx $maxy |
||||
Move $pe tr $maxx $miny |
||||
Move $pe br $maxx $maxy |
||||
|
||||
$self Regenerate |
||||
Note |
||||
return 1 |
||||
} |
||||
|
||||
method Regenerate {} { |
||||
if {$myrect ne {}} { |
||||
$mycanvas delete $myrect |
||||
set myrect {} |
||||
} |
||||
|
||||
if {$myops ne "complete"} return |
||||
|
||||
lassign [dict get $mycoords tl] minx miny |
||||
lassign [dict get $mycoords br] maxx maxy |
||||
|
||||
set myrect [$mycanvas create rectangle $minx $miny $maxx $maxy \ |
||||
-fill {} \ |
||||
-width 2 \ |
||||
{*}$options(-rect-config) \ |
||||
-activeoutline $options(-hilit-color) \ |
||||
-outline $options(-color)] |
||||
|
||||
canvas::tag append $mycanvas $myrect [SegmentTag] |
||||
$mycanvas lower $myrect $options(-tag) |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Corner management |
||||
|
||||
proc Move {pe corner nx ny} { |
||||
upvar 1 mystate mystate mycoords mycoords |
||||
|
||||
lassign [dict get $mycoords $corner] ox oy |
||||
set dx [expr {$nx - $ox}] |
||||
set dy [expr {$ny - $oy}] |
||||
|
||||
set id [dict get $mystate $corner] |
||||
$pe move-by $id $dx $dy |
||||
|
||||
Save $id $corner $nx $ny |
||||
return |
||||
} |
||||
|
||||
proc Def {pe corner x y} { |
||||
upvar 1 mystate mystate mycoords mycoords |
||||
|
||||
Save [$pe add $x $y] $corner $x $y |
||||
return |
||||
} |
||||
|
||||
proc Save {id corner x y} { |
||||
upvar 1 mystate mystate mycoords mycoords |
||||
|
||||
dict set mycoords $corner [list $x $y] |
||||
dict set mystate $corner $id |
||||
dict set mystate $id $corner |
||||
return |
||||
} |
||||
|
||||
proc SegmentTag {} { |
||||
upvar 1 options options |
||||
return $options(-tag)/Rect |
||||
} |
||||
|
||||
#### Generate notification about changes to the point cloud. |
||||
|
||||
proc Note {} { |
||||
upvar 1 options options self self myops myops mycoords mycoords |
||||
if {![llength $options(-data-cmd)]} return |
||||
|
||||
switch -exact -- $myops { |
||||
shunt - base - partial { |
||||
set coords {} |
||||
} |
||||
complete { |
||||
lassign [dict get $mycoords tl] minx miny |
||||
lassign [dict get $mycoords br] maxx maxy |
||||
set coords [list $minx $miny $maxx $maxy] |
||||
} |
||||
} |
||||
|
||||
return [{*}$options(-data-cmd) $self $coords] |
||||
} |
||||
|
||||
# debug support ... |
||||
proc X {p} { return [lindex [split $p /] 0] } |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## STATE |
||||
# - Saved handle of the canvas operated on. |
||||
# - Counter for the generation of point identifiers |
||||
# - List of the points managed by the object, conveying their |
||||
# order. |
||||
# - Canvas items for the actual rectangle |
||||
|
||||
typevariable ourcorners {tl tr bl br} |
||||
|
||||
variable mycanvas {} ;# The canvas we are working with. |
||||
variable myeditor {} ;# point editor instance managing the rectangle corners |
||||
variable mystate {} ;# dict, general state |
||||
variable myops {} ;# system state controlling callback processing |
||||
# states |
||||
# - base No points present, accept base point |
||||
# - shunt Ignore point editor callback, automatic task in progress |
||||
# - partial Single point known, wait for the second corner |
||||
# - complete Rectangle is complete, deny more points |
||||
|
||||
variable mycoords {} ;# corner -> pair (x y) |
||||
variable myrect {} ;# rectangle item |
||||
|
||||
variable mydid ; # Drag state. id of the moving point. |
||||
variable mydloc ; # Drag state. Uncommitted location of the moving point. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::edit::rectangle 0.1 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,278 @@
|
||||
# *- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Copyright (c) 2013 Jarek Lewandowski (MaxJarek) |
||||
# Origin http://wiki.tcl.tk/6100 |
||||
# Origin http://wiki.tcl.tk/37242 |
||||
# Origin http://wiki.tcl.tk/9079 |
||||
# OLL licensed (http://wiki.tcl.tk/10892) |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk 8.5- |
||||
|
||||
namespace eval ::canvas {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation. |
||||
|
||||
proc ::canvas::gradient {canvas args} { |
||||
gradient::DrawGradient $canvas {*}$args |
||||
bind $canvas <Configure> [list ::canvas::gradient::DrawGradient %W {*}$args] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Helper commands. Internal. |
||||
|
||||
namespace eval ::canvas::gradient {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Helper commands. |
||||
## Recreate the entire gradient from scratch, as a series of (nested) |
||||
## items each filled with a piece of it. This command is called on |
||||
## *every* change to the canvas's geometry. |
||||
|
||||
## TODO: Force redraw only on changes to width and height, not |
||||
## position. |
||||
|
||||
proc ::canvas::gradient::DrawGradient {canvas args} { |
||||
|
||||
# Fill any holes in the user's specification with the defaults. |
||||
set args [dict merge { |
||||
-direction x |
||||
-color1 red |
||||
-color2 green |
||||
-type linear |
||||
} $args] |
||||
|
||||
set color1 [dict get $args -color1] |
||||
set color2 [dict get $args -color2] |
||||
set direction [dict get $args -direction] |
||||
|
||||
## Clear gradient. Destroys all canvas items the old gradient |
||||
## consisted of. |
||||
$canvas delete canvas::gradient |
||||
|
||||
## Get current canvas width and height. |
||||
set canWidthPx [winfo width $canvas] |
||||
set canHeightPx [winfo height $canvas] |
||||
|
||||
## No gradient if the canvas' area is too small |
||||
if {($canWidthPx < 10) || |
||||
($canHeightPx < 10)} return |
||||
|
||||
## Get the distance 'distPx' (in pixels) over which |
||||
## the 2 colors are to be gradiated. |
||||
|
||||
switch -exact -- $direction { |
||||
x { |
||||
set distPx $canWidthPx |
||||
} |
||||
y { |
||||
set distPx $canHeightPx |
||||
} |
||||
r { |
||||
set halfWidthPx [expr {int($canWidthPx / 2)}] |
||||
set halfHeightPx [expr {int($canHeightPx / 2)}] |
||||
set distPx [expr {max($halfHeightPx,$halfWidthPx)}] |
||||
|
||||
# Even with the radial gradient stopping at the farthest |
||||
# canvas border (see dist calculation above, max), we may |
||||
# have undefined pixels in the corners. The rectangle |
||||
# added below ensures that these have a defined color as |
||||
# well (the end color). |
||||
$canvas create rectangle 0 0 $canWidthPx $canHeightPx \ |
||||
-tags canvas::gradient -fill $color2 |
||||
} |
||||
d1 - |
||||
d2 { |
||||
# Hm. I wonder if that should be the length of the |
||||
# diagonal instead (hypot). |
||||
set distPx [expr {$canWidthPx + $canHeightPx}] |
||||
} |
||||
default { |
||||
return -code error "Invalid direction $direction" |
||||
} |
||||
} |
||||
|
||||
## Translate whatever color specification came in into RGB triples |
||||
## we can then interpolate between. |
||||
if {[catch { |
||||
lassign [winfo rgb $canvas $color1] r1 g1 b1 |
||||
lassign [winfo rgb $canvas $color2] r2 g2 b2 |
||||
} err]} { |
||||
return -code error $err |
||||
} |
||||
|
||||
## Calculate the data needed for the interpolation, i.e. color |
||||
## range and slope of the line (The ratio of RGB-color-ranges to |
||||
## distance 'across' the canvas). |
||||
|
||||
set rRange [expr {$r2 - $r1 + 0.0}] |
||||
set gRange [expr {$g2 - $g1 + 0.0}] |
||||
set bRange [expr {$b2 - $b1 + 0.0}] |
||||
|
||||
set rRatio [expr {$rRange / $distPx}] |
||||
set gRatio [expr {$gRange / $distPx}] |
||||
set bRatio [expr {$bRange / $distPx}] |
||||
|
||||
## Increment 'across' the canvas, drawing colored lines, or ovals |
||||
## with canvas-'create line', 'create oval'. Computed jump to the |
||||
## actual drawing command. |
||||
|
||||
Draw_$direction |
||||
|
||||
## Lower the newly created gradient items into the background |
||||
$canvas lower canvas::gradient |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Draw helpers, one per direction. |
||||
|
||||
proc ::canvas::gradient::Draw_d1 {} { |
||||
upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
upvar 1 canHeightPx canHeightPx canWidthPx canWidthPx |
||||
|
||||
# Drawing for diagonal direction, left+top to bottom+right |
||||
|
||||
# Two stages: |
||||
# - First along y-axis (canHeightPx), top to bottom, |
||||
# - Then along x-axis (canWidthPx), left to right. |
||||
|
||||
# i 0 --> canHeight |
||||
|
||||
for {set i 0} {$i <= $canHeightPx} {incr i} { |
||||
catch { |
||||
$canvas create line $i 0 0 $i \ |
||||
-tags canvas::gradient -fill [GetNextColor $i] |
||||
} |
||||
} |
||||
|
||||
# x canHeight --> canWidth + canHeight |
||||
# i 0 --> canWidth |
||||
|
||||
for { |
||||
set x $canHeightPx |
||||
set i 0 |
||||
} {$i <= $canWidthPx} { |
||||
incr i |
||||
incr x |
||||
} { |
||||
catch { |
||||
$canvas create line $i $canHeightPx $x 0 \ |
||||
-tags canvas::gradient -fill [GetNextColor $x] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::gradient::Draw_d2 {} { |
||||
upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
upvar 1 canHeightPx canHeightPx canWidthPx canWidthPx |
||||
|
||||
# Drawing for diagonal direction, bottom+left to top+right |
||||
|
||||
# Two stages: |
||||
# - First along y-axis (canHeightPx), bottom to top. |
||||
# - Then along x-axis (canWidthPx), left to right. |
||||
|
||||
# x 0 --> canHeight |
||||
# i canHeight --> 0 |
||||
|
||||
for { |
||||
set x 0 |
||||
set i $canHeightPx |
||||
} {$i >= 0} { |
||||
incr i -1 |
||||
incr x |
||||
} { |
||||
catch { |
||||
$canvas create line $x $canHeightPx 0 $i \ |
||||
-tags canvas::gradient -fill [GetNextColor $x] |
||||
} |
||||
} |
||||
|
||||
# x canHeight --> canWidth + canHeight |
||||
# i 0 --> canWidth |
||||
|
||||
for { |
||||
set x $canHeightPx |
||||
set i 0 |
||||
} {$i <= $canWidthPx} { |
||||
incr i |
||||
incr x |
||||
} { |
||||
catch { |
||||
$canvas create line $i 0 $x $canHeightPx \ |
||||
-tags canvas::gradient -fill [GetNextColor $x] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::gradient::Draw_x {} { |
||||
upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
upvar 1 canHeightPx canHeightPx distPx distPx |
||||
|
||||
for {set i $distPx} {$i >= 0} {incr i -1} { |
||||
catch { |
||||
$canvas create line $i 0 $i $canHeightPx \ |
||||
-tags canvas::gradient -fill [GetNextColor $i] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::gradient::Draw_y {} { |
||||
upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
upvar 1 canWidthPx canWidthPx distPx distPx |
||||
|
||||
for {set i $distPx} {$i >= 0} {incr i -1} { |
||||
catch { |
||||
$canvas create line 0 $i $canWidthPx $i \ |
||||
-tags canvas::gradient -fill [GetNextColor $i] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::gradient::Draw_r {} { |
||||
upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
upvar 1 halfWidthPx halfWidthPx halfHeightPx halfHeightPx distPx distPx |
||||
|
||||
for {set i $distPx} {$i >= 0} {incr i -1} { |
||||
set xx1 [expr {$halfWidthPx + $i}] |
||||
set xx2 [expr {$halfHeightPx + $i}] |
||||
set xx3 [expr {$halfWidthPx - $i}] |
||||
set xx4 [expr {$halfHeightPx - $i}] |
||||
catch { |
||||
$canvas create oval $xx1 $xx2 $xx3 $xx4 \ |
||||
-outline {} -tags canvas::gradient -fill [GetNextColor $i] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Helper command. Compute the color for step i of the gradient. |
||||
## Linear interpolation from the start color. |
||||
|
||||
proc ::canvas::gradient::GetNextColor {i} { |
||||
upvar 1 r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio |
||||
|
||||
set nR [expr {int ($r1 + ($rRatio * $i))}] |
||||
set nG [expr {int ($g1 + ($gRatio * $i))}] |
||||
set nB [expr {int ($b1 + ($bRatio * $i))}] |
||||
|
||||
return [format "#%04X%04X%04X" $nR $nG $nB] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::gradient 0.2 |
||||
return |
||||
@ -0,0 +1,106 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Canvas Behavior Module. Highlighting items and groups of items. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
namespace eval ::canvas::highlight { |
||||
namespace export \ |
||||
on off |
||||
namespace ensemble create |
||||
} |
||||
|
||||
proc ::canvas::highlight::on {c tagOrId cmdprefix} { |
||||
# Setting up a general highlight, with the items to highlight |
||||
# identified by <tagOrId> and <cmdprefix> providing the 'on' and 'off' |
||||
# methods invoked to (de)activate highlight. The cmdprefix is |
||||
# fully responsible for how the highlightging of a particular |
||||
# handle is handled. |
||||
|
||||
# Install the bindings doing the highlight |
||||
$c bind $tagOrId <Any-Enter> [namespace code [list Highlight $c $cmdprefix %x %y]] |
||||
$c bind $tagOrId <Any-Leave> [namespace code [list Unhighlight $c $cmdprefix %x %y]] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::highlight::off {c tagOrId} { |
||||
# Remove a highlight identified by canvas <c> and <tagOrId>. |
||||
|
||||
# Find and remove the bindings for this particular combination of |
||||
# canvas and tagOrId. |
||||
|
||||
$c bind $tagOrId <Any-Enter> {} |
||||
$c bind $tagOrId <Any-Leave> {} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Highlight execution. |
||||
|
||||
proc ::canvas::highlight::Highlight {c cmdprefix x y} { |
||||
# Check that highlight is not active |
||||
variable active |
||||
if {[info exists active]} return |
||||
|
||||
# Start a highlight operation, import remainder of state |
||||
variable clientdata |
||||
|
||||
# Get item under mouse, if any. |
||||
set item [$c find withtag current] |
||||
if {$item eq {}} return |
||||
|
||||
# Initialize the highlight state, run the command to initialize |
||||
# anything external to us. We remember the current location to |
||||
# enable the delta calculations in 'Move'. |
||||
|
||||
set active $cmdprefix |
||||
set clientdata [{*}$active on $c $item] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::highlight::Unhighlight {c cmdprefix x y} { |
||||
# Check for active highlight. |
||||
variable active |
||||
if {![info exists active]} return |
||||
|
||||
# Import remainder of the highlight state |
||||
variable clientdata |
||||
|
||||
# Let the commnand process the movement as it sees fit. |
||||
# Must return a boolean. False vetos the unhighlight. |
||||
if {![{*}$active off $c $clientdata]} return |
||||
|
||||
# Clear highlight state |
||||
unset -nocomplain active clientdata |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Convenience. Highlightging via ... |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State. |
||||
|
||||
namespace eval ::canvas::highlight { |
||||
# State of a highlight in progress |
||||
|
||||
variable active ; # command prefix to invoke for 'on' / 'off'. |
||||
variable clientdata ; # Result of invoking 'on', data for 'off'. |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::highlight 0.1 |
||||
return |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Scrap yard. |
||||
@ -0,0 +1,392 @@
|
||||
# *- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Copyright (c) 2010 Wolf-Dieter Busch |
||||
# Origin http://wiki.tcl.tk/26859 [23-08-2010] |
||||
# OLL licensed (http://wiki.tcl.tk/10892). |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk 8.5- |
||||
|
||||
namespace eval ::canvas {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation. |
||||
|
||||
proc ::canvas::mvg {canvas} { |
||||
|
||||
#raise [winfo toplevel $canvas] |
||||
#update |
||||
|
||||
# Initialize drawing state... This array is keyed by the MVG |
||||
# commands for the attribute, not by the canvas options, and not |
||||
# by something third. |
||||
array set mode { |
||||
fill {} |
||||
stroke {} |
||||
stroke-width {} |
||||
stroke-linejoin {} |
||||
stroke-linecap {} |
||||
font {} |
||||
font-size {} |
||||
} |
||||
|
||||
# Get the bounding box of all item, and compute the translation |
||||
# required to put the lower-left corner at the origin. |
||||
set dx 0 |
||||
set dy 0 |
||||
set box [$canvas bbox {*}[$canvas find all]] |
||||
lassign $box zx zy ex ey |
||||
if {$zx < 0} { set dx [expr {- $zx}] ; set ex [expr {$ex + $dx}] } |
||||
if {$zy < 0} { set dy [expr {- $zy}] ; set ey [expr {$ey + $dy}] } |
||||
set box [list 0 0 $ex $ey] |
||||
|
||||
# Standard prelude... |
||||
mvg::Emit [list viewbox {*}$box] |
||||
mvg::EmitChanged stroke none |
||||
mvg::EmitChanged fill [mvg::Col2Hex $canvas] |
||||
mvg::Emit [list rectangle {*}$box] |
||||
|
||||
# Introspect the canvas, i.e. convert each item to MVG |
||||
foreach item [$canvas find all] { |
||||
set type [$canvas type $item] |
||||
|
||||
# Info to help debugging... |
||||
mvg::Emit "# $type ... [$canvas gettags $item]" |
||||
|
||||
# Dump the item's attributes, as they are supported by it. |
||||
# Note how the code is not sliced by item type which then |
||||
# handles each of its attributes, but by attribute name, which |
||||
# then checks if the type of the current item supports it. |
||||
|
||||
# Further note that the current attribute state is stored in |
||||
# the mode array and actually emitted if and only if it is |
||||
# different from the previously drawn state. This optimizes |
||||
# the number of commands needed to set the drawing state for a |
||||
# particular item. |
||||
|
||||
# outline width |
||||
if {$type in {polygon oval arc rectangle line}} then { |
||||
mvg::EmitValue $item -width stroke-width |
||||
} |
||||
|
||||
# fill, stroke |
||||
if {$type in {polygon oval arc rectangle}} { |
||||
mvg::EmitColor $item -fill fill |
||||
mvg::EmitColor $item -outline stroke |
||||
} |
||||
|
||||
# joinstyle |
||||
if {$type in {polygon}} then { |
||||
mvg::EmitValue $item -joinstyle stroke-linejoin |
||||
} |
||||
|
||||
# line color, capstyle |
||||
if {$type in {line}} then { |
||||
mvg::EmitChanged fill none |
||||
mvg::EmitColor $item -fill stroke |
||||
mvg::EmitCap $item -capstyle stroke-linecap |
||||
} |
||||
|
||||
# text color, font, size |
||||
if {$type in {text}} then { |
||||
# Compute font-family, font-size |
||||
set font [$canvas itemcget $item -font] |
||||
if {$font in [font names]} { |
||||
set fontsize [font configure $font -size] |
||||
set fontfamily [font configure $font -family] |
||||
} else { |
||||
if {[llength $font] == 1} then { |
||||
set fontsize 12 |
||||
} else { |
||||
set fontsize [lindex $font 1] |
||||
} |
||||
set fontfamily [lindex $font 0] |
||||
} |
||||
if {$fontsize < 0} { |
||||
set fontsize [expr {int(-$fontsize / [tk scaling])}] |
||||
} |
||||
|
||||
mvg::EmitChanged stroke none |
||||
mvg::EmitColor $item -fill fill |
||||
mvg::EmitChanged font-size $fontsize |
||||
mvg::EmitChanged font $fontfamily |
||||
|
||||
# |
||||
# Attention! In some cases ImageMagick assumes 72dpi where |
||||
# 90dpi is necessary. If that happens use the switch |
||||
# -density to force the correct dpi setting, like % |
||||
# convert -density 90 test.mvg test.png |
||||
# |
||||
# Attention! Make sure that ImageMagick has access to the |
||||
# used fonts. If it has not, an error msg will be shown, |
||||
# and then switches silently to the default font. |
||||
# |
||||
} |
||||
|
||||
# After the attributes we can emit the command actually |
||||
# drawing the item, in the its place. |
||||
|
||||
set line {} |
||||
set coords [mvg::Translate [$canvas coords $item]] |
||||
|
||||
switch -exact -- $type { |
||||
line { |
||||
# start of path |
||||
lappend line path 'M |
||||
|
||||
# smooth can be any boolean value, plus the name of a |
||||
# line smoothing method. Core supports only 'raw'. |
||||
# This however is extensible through packages. |
||||
|
||||
switch -exact -- [mvg::Smooth $item] { |
||||
0 { |
||||
lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end] |
||||
} |
||||
1 { |
||||
if {[$canvas itemcget $item -arrow] eq "none"} { |
||||
lappend line {*}[mvg::Spline2MVG $coords] |
||||
} else { |
||||
lappend line {*}[mvg::Spline2MVG $coords false] |
||||
} |
||||
} |
||||
2 { |
||||
lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end] |
||||
} |
||||
} |
||||
|
||||
append line ' |
||||
mvg::Emit $line |
||||
} |
||||
polygon { |
||||
# start of path. |
||||
lappend line path 'M |
||||
|
||||
switch -exact -- [mvg::Smooth $item] { |
||||
0 { |
||||
lassign $coords x0 y0 |
||||
lassign [lrange $coords end-1 end] x1 y1 |
||||
set x [expr {($x0+$x1)/2.0}] |
||||
set y [expr {($y0+$y1)/2.0}] |
||||
lappend line $x $y L {*}$coords $x $y Z |
||||
} |
||||
1 { |
||||
lassign $coords x0 y0 |
||||
lassign [lrange $coords end-1 end] x1 y1 |
||||
if {($x0 != $x1) || ($y0 != $y1)} { |
||||
lappend coords {*}[lrange $coords 0 1] |
||||
} |
||||
lappend line {*}[mvg::Spline2MVG $coords] |
||||
} |
||||
2 { |
||||
lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end] |
||||
} |
||||
} |
||||
|
||||
append line ' |
||||
mvg::Emit $line |
||||
} |
||||
oval { |
||||
lassign $coords x0 y0 x1 y1 |
||||
set xc [expr {($x0+$x1)/2.0}] |
||||
set yc [expr {($y0+$y1)/2.0}] |
||||
|
||||
mvg::Emit [list ellipse $xc $yc [expr {$x1-$xc}] [expr {$y1-$yc}] 0 360] |
||||
} |
||||
arc { |
||||
lassign $coords x0 y0 x1 y1 |
||||
|
||||
set rx [expr {($x1-$x0)/2.0}] |
||||
set ry [expr {($y1-$y0)/2.0}] |
||||
set x [expr {($x0+$x1)/2.0}] |
||||
set y [expr {($y0+$y1)/2.0}] |
||||
set f [expr {acos(0)/90}] |
||||
|
||||
set start [$canvas itemcget $item -start] |
||||
set startx [expr {cos($start*$f)*$rx+$x}] |
||||
set starty [expr {sin(-$start*$f)*$ry+$y}] |
||||
set angle [expr {$start+[$canvas itemcget $item -extent]}] |
||||
set endx [expr {cos($angle*$f)*$rx+$x}] |
||||
set endy [expr {sin(-$angle*$f)*$ry+$y}] |
||||
|
||||
# start path |
||||
lappend line path 'M |
||||
# start point |
||||
lappend line $startx $starty |
||||
lappend line A |
||||
# radiusx, radiusy |
||||
lappend line $rx $ry |
||||
# angle -- always 0 |
||||
lappend line 0 |
||||
# "big" or "small"? |
||||
lappend line [expr {($angle-$start) > 180}] |
||||
# right side (always) |
||||
lappend line 0 |
||||
# end point |
||||
lappend line $endx $endy |
||||
# close path |
||||
lappend line L $x $y Z |
||||
append line ' |
||||
|
||||
mvg::Emit $line |
||||
} |
||||
rectangle { |
||||
mvg::Emit [list rectangle {*}$coords] |
||||
} |
||||
text { |
||||
lassign [mvg::Translate [$canvas bbox $item]] x0 y0 x1 y1 |
||||
mvg::Emit "text $x0 $y1 '[$canvas itemcget $item -text]'" |
||||
} |
||||
image - bitmap { |
||||
set img [$canvas itemcget $item -image] |
||||
set file [$img cget -file] |
||||
lassign [mvg::Translate [$canvas bbox $item]] x0 y0 |
||||
mvg::Emit "image over $x0 $y0 0 0 '$file'" |
||||
} |
||||
default { |
||||
set line "# not yet done:" |
||||
append line " " [$canvas type $item] |
||||
append line " " [mvg::Translate [$canvas coords $item]] |
||||
append line " (" [$canvas gettags $item] ")" |
||||
mvg::Emit $line |
||||
} |
||||
} |
||||
} |
||||
|
||||
# At last, return the fully assembled snapshot |
||||
return [join $result \n] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Helper commands. Internal. |
||||
|
||||
namespace eval ::canvas::mvg {} |
||||
|
||||
proc ::canvas::mvg::Translate {coords} { |
||||
upvar 1 dx dx dy dy |
||||
set tmp {} |
||||
foreach {x y} $coords { |
||||
lappend tmp [expr {$x + $dx}] [expr {$y + $dy}] |
||||
} |
||||
return $tmp |
||||
} |
||||
|
||||
|
||||
proc ::canvas::mvg::Smooth {item} { |
||||
upvar 1 canvas canvas |
||||
|
||||
# Force smooth to canonical values we can then switch on. |
||||
set smooth [$canvas itemcget $item -smooth] |
||||
if {[string is boolean $smooth]} { |
||||
if {$smooth} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 2 |
||||
} |
||||
} |
||||
|
||||
proc ::canvas::mvg::EmitValue {item option cmd} { |
||||
upvar 1 mode mode result result canvas canvas |
||||
|
||||
EmitChanged $cmd \ |
||||
[$canvas itemcget $item $option] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::mvg::EmitColor {item option cmd} { |
||||
upvar 1 mode mode result result canvas canvas |
||||
|
||||
EmitChanged $cmd \ |
||||
[Col2Hex [$canvas itemcget $item $option]] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::mvg::EmitCap {item option cmd} { |
||||
upvar 1 mode mode result result canvas canvas |
||||
|
||||
EmitChanged $cmd \ |
||||
[dict get { |
||||
butt butt |
||||
projecting square |
||||
round round |
||||
} [$canvas itemcget $item $option]] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::mvg::EmitChanged {cmd value} { |
||||
upvar 1 mode mode result result |
||||
|
||||
if {$mode($cmd) eq $value} return |
||||
set mode($cmd) $value |
||||
Emit [list $cmd $value] |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::mvg::Emit {command} { |
||||
upvar 1 result result |
||||
lappend result $command |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::mvg::Col2Hex {color} { |
||||
# This command or similar functionality we might have somewhere |
||||
# in tklib already ... |
||||
|
||||
# Special handling of canvas widgets, use their background color. |
||||
if {[winfo exists $color] && [winfo class $color] eq "Canvas"} { |
||||
set color [$color cget -bg] |
||||
} |
||||
if {$color eq ""} { |
||||
return none |
||||
} |
||||
set result # |
||||
foreach x [winfo rgb . $color] { |
||||
append result [format %02x [expr {int($x / 256)}]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::canvas::mvg::Spline2MVG {coords {canBeClosed yes}} { |
||||
set closed [expr {$canBeClosed && |
||||
[lindex $coords 0] == [lindex $coords end-1] && |
||||
[lindex $coords 1] == [lindex $coords end]}] |
||||
|
||||
if {$closed} { |
||||
lassign [lrange $coords end-3 end] x0 y0 x1 y1 |
||||
|
||||
set x [expr {($x0+$x1)/2.0}] |
||||
set y [expr {($y0+$y1)/2.0}] |
||||
|
||||
lset coords end-1 $x |
||||
lset coords end $y |
||||
|
||||
set coords [linsert $coords 0 $x $y] |
||||
} |
||||
|
||||
if {[llength $coords] != 6} { |
||||
lappend tmp {*}[lrange $coords 0 1] |
||||
|
||||
set co1 [lrange $coords 2 end-4] |
||||
set co2 [lrange $coords 4 end-2] |
||||
|
||||
foreach {x1 y1} $co1 {x2 y2} $co2 { |
||||
lappend tmp $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}] |
||||
} |
||||
lappend tmp {*}[lrange $coords end-3 end] |
||||
set coords $tmp |
||||
} |
||||
|
||||
return [lreplace $coords 2 1 Q] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::mvg 1 |
||||
return |
||||
@ -0,0 +1,111 @@
|
||||
# *- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Copyright (c) 2004 George Petasis |
||||
# Origin http://wiki.tcl.tk/1404 [24-10-2004] |
||||
# BSD licensed. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk 8.5- |
||||
package require img::window |
||||
|
||||
namespace eval ::canvas {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation. |
||||
|
||||
proc ::canvas::snap {canvas} { |
||||
|
||||
# Ensure that the window is on top of everything else, so as not |
||||
# to get white ranges in the image, due to overlapped portions of |
||||
# the window with other windows... |
||||
|
||||
raise [winfo toplevel $canvas] |
||||
update |
||||
|
||||
# XXX: Undo the raise at the end ?! |
||||
|
||||
set border [expr {[$canvas cget -borderwidth] + |
||||
[$canvas cget -highlightthickness]}] |
||||
|
||||
set view_height [expr {[winfo height $canvas]-2*$border}] |
||||
set view_width [expr {[winfo width $canvas]-2*$border}] |
||||
|
||||
lassign [$canvas bbox all] x1 y1 x2 y2 |
||||
#foreach {x1 y1 x2 y2} [$canvas bbox all] break |
||||
|
||||
set x1 [expr {int($x1-10)}] |
||||
set y1 [expr {int($y1-10)}] |
||||
set x2 [expr {int($x2+10)}] |
||||
set y2 [expr {int($y2+10)}] |
||||
|
||||
set width [expr {$x2-$x1}] |
||||
set height [expr {$y2-$y1}] |
||||
|
||||
set image [image create photo -height $height -width $width] |
||||
|
||||
# Arrange the scrollregion of the canvas to get the whole window |
||||
# visible, so as to grab it into an image... |
||||
|
||||
# Save the scrolling state, as this will be overidden in short order. |
||||
set scrollregion [$canvas cget -scrollregion] |
||||
set xscrollcommand [$canvas cget -xscrollcommand] |
||||
set yscrollcommand [$canvas cget -yscrollcommand] |
||||
|
||||
$canvas configure -xscrollcommand {} |
||||
$canvas configure -yscrollcommand {} |
||||
|
||||
set grabbed_x $x1 |
||||
set grabbed_y $y1 |
||||
set image_x 0 |
||||
set image_y 0 |
||||
|
||||
while {$grabbed_y < $y2} { |
||||
while {$grabbed_x < $x2} { |
||||
set newregion [list \ |
||||
$grabbed_x \ |
||||
$grabbed_y \ |
||||
[expr {$grabbed_x + $view_width}] \ |
||||
[expr {$grabbed_y + $view_height}]] |
||||
|
||||
$canvas configure -scrollregion $newregion |
||||
update |
||||
|
||||
# Take a screenshot of the visible canvas part... |
||||
set tmp [image create photo -format window -data $canvas] |
||||
|
||||
# Copy the screenshot to the target image... |
||||
$image copy $tmp -to $image_x $image_y -from $border $border |
||||
|
||||
# And delete the temporary image (leak in original code) |
||||
image delete $tmp |
||||
|
||||
incr grabbed_x $view_width |
||||
incr image_x $view_width |
||||
} |
||||
|
||||
set grabbed_x $x1 |
||||
set image_x 0 |
||||
|
||||
incr grabbed_y $view_height |
||||
incr image_y $view_height |
||||
} |
||||
|
||||
# Restore the previous scrolling state of the canvas. |
||||
|
||||
$canvas configure -scrollregion $scrollregion |
||||
$canvas configure -xscrollcommand $xscrollcommand |
||||
$canvas configure -yscrollcommand $yscrollcommand |
||||
|
||||
# At last, return the fully assembled snapshot |
||||
return $image |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::snap 1.0.1 |
||||
return |
||||
@ -0,0 +1,667 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Known issue :: It is unspecified who is responsible for the images |
||||
# after they are used in the canvas. The canvas |
||||
# currently doesn't delete them. Meaning, this is |
||||
# likely leaking memory like mad when switching between |
||||
# sources, and dragging around. |
||||
|
||||
# sqmap = square map. |
||||
|
||||
# Ideas to work on ... |
||||
|
||||
# -- Factor the low-level viewport tracking and viewport stabilization |
||||
# across scroll-region changes out into its own canvas class. |
||||
|
||||
# -- Factor the grid layer handling into its own class. That is a |
||||
# requisite for the handling of multiple layers, |
||||
|
||||
# -- Create a hexmap, i.e. hexagonal tiling. This can be done with |
||||
# images as well, with parts properly transparent and then |
||||
# positioned to overlap. Regarding coordinates this can be seen |
||||
# as a skewed cartesian system, so only 2 coordinates required |
||||
|
||||
# -- Consider viewport stabilization for when the canvas is resized. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.4- ; # No {*}-expansion! :( |
||||
package require Tk |
||||
package require snit ; # |
||||
package require uevent::onidle ; # Some defered actions. |
||||
package require cache::async 0.3 ; # Internal tile cache. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
snit::widgetadaptor canvas::sqmap { |
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
# All canvas options, except for -scrollregion are accepted by |
||||
# this widget(adaptor), and propagated to the embedded canvas. The |
||||
# region is always implicitly (0,0,w,h), with w and h computed |
||||
# from the number of grid rows, columns and the cell dimensions. |
||||
|
||||
delegate option * to hull except -scrollregion |
||||
|
||||
# All canvas methods are accepted and propagated to the embedded |
||||
# canvas. Some of them we intercept however, to either impose |
||||
# restrictions (*), or get information we need and not available |
||||
# otherwise (**). |
||||
|
||||
# (*) The images used as background have to stay lower than all |
||||
# user-created items, to be that background. We cannot allow |
||||
# them to be raised, nor must others go below them. |
||||
|
||||
# If we were extremely rigourous we would have to intercept |
||||
# all methods and filter out our internal tags and items ids, |
||||
# to make them completely invisible to the user. The last 5% |
||||
# needing 90% of the effort. *** Defered *** |
||||
|
||||
# (**) Dragging changes the viewport, we do not see this without |
||||
# interception. |
||||
|
||||
delegate method * to hull except {lower raise scan xview yview} |
||||
delegate method {scan mark} to hull as {scan mark} |
||||
|
||||
# New options: Information about the grid, and where to get the |
||||
# images. |
||||
# rows = number of rows the grid consists of. <0 <=> unlimited |
||||
# columns = s.a., columns |
||||
# cell-width = width of a cell in the grid, in pixels |
||||
# cell-height = s.a., height |
||||
# cell-source = command prefix called to get the image for a cell in the grid. |
||||
|
||||
option -grid-cell-width -default 0 -configuremethod O-ReconfigureNum -type {snit::integer -min 0} |
||||
option -grid-cell-height -default 0 -configuremethod O-ReconfigureNum -type {snit::integer -min 0} |
||||
option -grid-cell-command -default {} -configuremethod O-ReconfigureStr |
||||
option -scrollregion -default {} -configuremethod O-ReconfigureStr |
||||
|
||||
# NOTE AK, maybe, for the future. |
||||
# rows/columns - we may wish to have min/max values, if any to represent |
||||
# - grid boundaries. |
||||
#option -grid-rows -default 0 -configuremethod O-ReconfigureNum |
||||
#option -grid-columns -default 0 -configuremethod O-ReconfigureNum |
||||
|
||||
# NOTE !!! Use -grid-show-borders only for short-term debugging. |
||||
# NOTE !!! The items created when true are never deleted, i.e. leaking memory |
||||
|
||||
option -grid-show-borders -default 0 -type snit::boolean |
||||
|
||||
option -viewport-command -default {} -configuremethod O-vp-command |
||||
|
||||
option -image-on-load -default {} |
||||
option -image-on-unset -default {} |
||||
|
||||
constructor {args} { |
||||
installhull using canvas |
||||
|
||||
install reconfigure using uevent::onidle ${selfns}::reconfigure \ |
||||
[mymethod Reconfigure] |
||||
|
||||
install redraw using uevent::onidle ${selfns}::redraw \ |
||||
[mymethod Redraw] |
||||
|
||||
install tilecache using cache::async ${selfns}::tilecache \ |
||||
[mymethod Tile] -full-async-results 0 |
||||
# Configuration means synchronous return of in-cache results. |
||||
# This is needed to get proper use and disposal of -> |
||||
# myfreeitems. |
||||
|
||||
bind $win <Configure> [mymethod Configure] |
||||
|
||||
$self configurelist $args |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Define/Remove images from grid cells. These are the main |
||||
## commands to control grid appearance. The -grid-cell-command should |
||||
## use these commands as well to provide its results to the |
||||
## widget. |
||||
|
||||
method {image set} {at image} { |
||||
$tilecache set $at $image |
||||
|
||||
# Nothing more is required for an invisible cell. |
||||
if {![info exists myvisible($at)]} return |
||||
|
||||
# For empty cells we create proper items now. |
||||
set theitem $myvisible($at) |
||||
if {$theitem eq ""} { |
||||
set theitem [$self GetItem [GridToPixel $at]] |
||||
set myvisible($at) $theitem |
||||
} |
||||
|
||||
# Show the chosen image |
||||
$hull itemconfigure $theitem -image $image |
||||
return |
||||
} |
||||
|
||||
method {image unset} {at} { |
||||
# Show an image signaling that 'this tile is not valid/found' ... |
||||
if {$options(-image-on-unset) ne {}} { |
||||
$self image set $at $options(-image-on-unset) |
||||
return |
||||
} |
||||
|
||||
$tilecache unset $at |
||||
|
||||
# Nothing more is required for an invisible cell. |
||||
if {![info exists myvisible($at)]} return |
||||
|
||||
# Nothing more is required for an empty cell. |
||||
set theitem $myvisible($at) |
||||
if {$theitem eq ""} return |
||||
|
||||
# Mark the cell as empty and drop the associated item. |
||||
set myvisible($at) "" |
||||
$hull delete $theitem |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Force a full reload of all (visible) cells. |
||||
|
||||
method flush {} { |
||||
$tilecache clear |
||||
set mypixelview {} |
||||
#puts REDRAW-RQ/flush |
||||
$redraw request |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Intercepting the methods changing the display order, to ensure |
||||
## that our grid is kept at the bottom. It is the background after |
||||
## all. |
||||
|
||||
method raise {args} { |
||||
eval [linsert $args 0 $hull raise] |
||||
# Ensure that our cells stay at the bottom. |
||||
$hull lower $ourtag |
||||
return |
||||
} |
||||
|
||||
method lower {args} { |
||||
eval [linsert $args 0 $hull lower] |
||||
# Ensure that our cells stay at the bottom. |
||||
$hull lower $ourtag |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Intercepting the dragto command to keep track of the |
||||
## viewport. See the scroll method interception below too. |
||||
|
||||
# NOTE: 'scan mark' interception will be needed if we wish to |
||||
# allow items to float in place regardless of dragging (i.e. as UI |
||||
# elements, for example a zoom-scale). |
||||
|
||||
method {scan dragto} {x y {gain 1}} { |
||||
# Regular handling of dragging ... |
||||
$hull scan dragto $x $y $gain |
||||
|
||||
# ... then compute and record the changed viewport, and |
||||
# request a redraw to be done when the system has time for it |
||||
$self SetPixelView |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Intercepting the scroll methods to keep track of the viewport. |
||||
## The canvas has no way to report changes on its own. No |
||||
## callbacks, nothing. See the dragto interception above too. |
||||
|
||||
method xview {args} { |
||||
# Regular handling of scrolling ... |
||||
set res [eval [linsert $args 0 $hull xview]] |
||||
# Keep track of the viewport in case of changes. |
||||
if {[llength $args]} { $self SetPixelView } |
||||
return $res |
||||
} |
||||
|
||||
method yview {args} { |
||||
# Regular handling of scrolling ... |
||||
set res [eval [linsert $args 0 $hull yview]] |
||||
# Keep track of the viewport in case of changes. |
||||
if {[llength $args]} { $self SetPixelView } |
||||
return $res |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Intercept <Configure> events on the canvas. This changes the |
||||
## viewport. At the time the event happens the new viewport is not |
||||
## yet known, as this is done in a canvas-internal idle-handler. We |
||||
## simply trigger our redraw in our idle-handler, and force it to |
||||
## recompute the viewport. |
||||
|
||||
method Configure {} { |
||||
set mypixelview {} ; # Force full recalculation. |
||||
#puts REDRAW-RQ/configure |
||||
$redraw request |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
method O-vp-command {o v} { |
||||
#puts $o=$v |
||||
if {$options($o) eq $v} return |
||||
set options($o) $v |
||||
set myhasvpcommand [expr {!![llength $v]}] |
||||
if {!$myhasvpcommand} return |
||||
# Callback changed and ok, request first call with current |
||||
# settings. |
||||
$self PixelViewExport |
||||
return |
||||
} |
||||
|
||||
variable myhasvpcommand 0 ; # Track use of viewport-command callback |
||||
|
||||
method PixelViewExport {} { |
||||
if {!$myhasvpcommand} return |
||||
if {![llength $mypixelview]} return |
||||
foreach {xl yt xr yb} $mypixelview break |
||||
uplevel \#0 [linsert $options(-viewport-command) end $xl $yt $xr $yb] |
||||
return |
||||
} |
||||
|
||||
method SetPixelView {} { |
||||
set mypixelview [PV] |
||||
$self PixelViewExport |
||||
# Viewport changes imply redraws |
||||
#puts REDRAW-RQ/set-pixel-view |
||||
$redraw request |
||||
return |
||||
} |
||||
|
||||
proc PV {} { |
||||
upvar 1 hull hull win win |
||||
return [list \ |
||||
[$hull canvasx 0] \ |
||||
[$hull canvasy 0] \ |
||||
[$hull canvasx [winfo width $win]] \ |
||||
[$hull canvasy [winfo height $win]]] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Option processing. Any changes force a refresh of the grid |
||||
## information, and then a redraw. |
||||
|
||||
method O-ReconfigureNum {o v} { |
||||
#puts $o=$v |
||||
if {$options($o) == $v} return |
||||
set options($o) $v |
||||
$reconfigure request |
||||
return |
||||
} |
||||
|
||||
method O-ReconfigureStr {o v} { |
||||
#puts $o=$v |
||||
if {$options($o) eq $v} return |
||||
set options($o) $v |
||||
$reconfigure request |
||||
return |
||||
} |
||||
|
||||
component reconfigure |
||||
method Reconfigure {} { |
||||
#puts /reconfigure |
||||
|
||||
# The grid definition has changed, in parts, or all. We have |
||||
# to redraw the background, even if nothing else was changed. |
||||
# Here we commit all changed option values to the engine. |
||||
# This is the only place accessing the options array. |
||||
|
||||
set oldsr $myscrollregion |
||||
|
||||
set mygridwidth $options(-grid-cell-width) |
||||
set mygridheight $options(-grid-cell-height) |
||||
set mygridcmd $options(-grid-cell-command) |
||||
set myscrollregion $options(-scrollregion) |
||||
|
||||
# Commit region change to the canvas itself |
||||
|
||||
$hull configure -scrollregion $myscrollregion |
||||
|
||||
# Flush the cache to force a reload of the entire visible |
||||
# area now, and of the invisible part later when scrolling. |
||||
$tilecache clear |
||||
|
||||
# Now save and restore the view, keeping the center of the |
||||
# view as stable as possible across the transition. Note, the |
||||
# scrapyard at the end of this file contains the same |
||||
# calculations in long form, i.e. all steps written out. Here |
||||
# the various expressions are inlined and simplified. |
||||
|
||||
foreach { sxl syt sxr syb} $oldsr break |
||||
if {[llength $oldsr] && (($sxr - $sxl) > 0) && (($syb - $syt) > 0)} { |
||||
# Old and new scroll regions. |
||||
foreach {nsxl nsyt nsxr nsyb} $myscrollregion break |
||||
|
||||
#puts OSR=($oldsr) |
||||
#puts NSR=($myscrollregion) |
||||
|
||||
# Get current pixel view, and limit it to the old |
||||
# scrollregion (as the canvas may show more than the |
||||
# scrollregion). |
||||
foreach {xl yt xr yb} $mypixelview break |
||||
if {$xl < $sxl} { set xl $sxl } |
||||
if {$xr > $sxr} { set xr $sxr } |
||||
if {$yt < $syt} { set yt $syt } |
||||
if {$yb > $syb} { set yb $syb } |
||||
|
||||
# Determine the center of the pixel view, as fractions |
||||
# relative to old scroll origin. |
||||
set xcfrac [expr {double((($xr + $xl)/2) - $sxl) / ($sxr - $sxl)}] |
||||
set ycfrac [expr {double((($yt + $yb)/2) - $syt) / ($syb - $syt)}] |
||||
|
||||
# The fractions for the topleft corner are the fractions |
||||
# of the center less the (fractional manhattan radii |
||||
# around the center, relative to the new region). |
||||
set nxlfrac [expr {$xcfrac - double(($xr - $xl)/2) / ($nsxr - $nsxl)}] |
||||
set nytfrac [expr {$ycfrac - double(($yb - $yt)/2) / ($nsyb - $nsyt)}] |
||||
|
||||
# Limit the fractions to the scroll origin (>= 0). |
||||
if {$nxlfrac < 0} { set nxlfrac 0 } |
||||
if {$nytfrac < 0} { set nytfrac 0 } |
||||
|
||||
# Adjust canvas view to keep the center as stable as |
||||
# possible across the transition. Note that this goes |
||||
# through our own xview/yview method, calls SetPixelView, |
||||
# and through that requests a redraw. No need to have the |
||||
# redraw done by this method. |
||||
|
||||
#puts MOVETO\t$nxlfrac,$nytfrac |
||||
$self xview moveto $nxlfrac |
||||
$self yview moveto $nytfrac |
||||
|
||||
# Note however that we still have to force the redraw to |
||||
# be fully done. |
||||
set mypixelview {} |
||||
} else { |
||||
# Nearly last, redraw full. This happens only because no |
||||
# view adjustments were done which would have forced it |
||||
# (see above), so in this cause we have to do it |
||||
# ourselves. |
||||
$self Redraw 1 |
||||
} |
||||
#puts reconfigure/done |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Grid redraw. This is done after changes to the viewport, |
||||
## and when the system is idle. |
||||
|
||||
component redraw |
||||
method Redraw {{forced 0}} { |
||||
#puts /redraw/$forced |
||||
|
||||
# Compute viewport in tile coordinates and compare to last. |
||||
# This will tell us where to update and how, if any. |
||||
|
||||
if {![llength $mypixelview]} { |
||||
# Undefined viewport, generate baseline, and force |
||||
# redraw. Scheduling another redraw is however not needed, |
||||
# so we are inlining only parts of SetPixelView. |
||||
set mypixelview [PV] |
||||
$self PixelViewExport |
||||
#puts \tforce-due-undefined-viewport |
||||
set forced 1 |
||||
} |
||||
|
||||
set gridview [PixelToGrid $mypixelview] |
||||
foreach {xl yt xr yb} $gridview break |
||||
foreach {ll lt lr lb} $myshowngridview break |
||||
|
||||
#puts \tVP=($mypixelview) |
||||
#puts \tVG=($gridview) |
||||
#puts \tVL=($myshowngridview) |
||||
#puts \tF'=$forced |
||||
|
||||
if {!$forced} { |
||||
# Viewport unchanged, nothing to do. |
||||
if {($xl == $ll) && ($xr == $lr) && |
||||
($yt == $lt) && ($yb == $lb)} { |
||||
#puts \tunchanged,ignore |
||||
return |
||||
} |
||||
} |
||||
|
||||
set myfreeitems {} |
||||
|
||||
# NOTE. The code below is suboptimal. While already better |
||||
# than dropping and recreating all items, we could optimize by |
||||
# using the structure of the viewport (rectangles) to |
||||
# determine directly which grid cells became (in)visible, from |
||||
# the viewport boundary coordinates. This will however be also |
||||
# quite more complex, with all the possible cases of |
||||
# overlapping old and new views. |
||||
|
||||
if {$forced} { |
||||
# Forced redraw, simply make all items available |
||||
# for the upcoming fill. |
||||
|
||||
foreach at [array names myvisible] { |
||||
$self FreeCell $at |
||||
} |
||||
} elseif {[llength $myshowngridview]} { |
||||
# Scan through the grid cells of the view used at the last |
||||
# redraw, and check which of them have become |
||||
# invisible. Put these on the list of items we can reuse |
||||
# for the cells which just became visible and thus in need |
||||
# of items. |
||||
|
||||
for {set r $lt} {$r <= $lb} {incr r} { |
||||
for {set c $ll} {$c <= $lr} {incr c} { |
||||
if {($r < $yt) || ($yb < $r) || ($c < $xl) || ($xr < $c)} { |
||||
# The grid cell dropped out of the viewport. |
||||
$self FreeCell [list $r $c] |
||||
#puts /drop/$idx |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Remember location for next redraw. |
||||
set myshowngridview $gridview |
||||
|
||||
for {set r $yt} {$r <= $yb} {incr r} { |
||||
for {set c $xl} {$c <= $xr} {incr c} { |
||||
# Now scan through the cells of the new viewport. |
||||
# Ignore those which are still visible, and create the |
||||
# remainder. |
||||
set at [list $r $c] |
||||
if {[info exists myvisible($at)]} continue |
||||
#puts /make/$idx |
||||
set myvisible($at) "" ; # placeholder |
||||
|
||||
# Show an image signaling that 'we are loading this tile' ... |
||||
if {$options(-image-on-load) ne {}} { |
||||
set theitem [$self GetItem [GridToPixel $at]] |
||||
set myvisible($at) $theitem |
||||
$hull itemconfigure $theitem \ |
||||
-image $options(-image-on-load) |
||||
} |
||||
|
||||
after 0 [list $tilecache get $at [mymethod image]] |
||||
# This cache access re-uses the items in myfreeitems |
||||
# as images already in the cache are delivered |
||||
# synchronously, going through 'image set' and |
||||
# GetItem. Only unknown cells will come later. |
||||
} |
||||
} |
||||
|
||||
# Delete all items which were not reused. |
||||
|
||||
# No, no need. Canvas image items without an image configured |
||||
# for display are effectively invisible, regardless of |
||||
# location. Keep them around for late coming provider results. |
||||
#$self DropFreeItems |
||||
#puts redraw/done |
||||
return |
||||
} |
||||
|
||||
method FreeCell {at} { |
||||
# Ignore already invisible cells |
||||
if {![info exists myvisible($at)]} return |
||||
|
||||
# Clear empty cells, nothing more |
||||
set theitem $myvisible($at) |
||||
unset myvisible($at) |
||||
if {$theitem eq ""} return |
||||
|
||||
# Record re-usable item and clear the image it used. Note that |
||||
# this doesn't delete the image! |
||||
lappend myfreeitems $theitem |
||||
$hull itemconfigure $theitem -image {} |
||||
return |
||||
} |
||||
|
||||
method {Tile get} {at donecmd} { |
||||
# Tile cache provider callback. The request is routed to the |
||||
# canvas's own tile provider. Responses go to the cache. The |
||||
# cache is set up that its responses go to the 'image ...' |
||||
# methods. |
||||
|
||||
if {![llength $mygridcmd]} return |
||||
#puts \t\t\t\tGet($at) |
||||
uplevel #0 [linsert $mygridcmd end get $at $donecmd] |
||||
return |
||||
} |
||||
|
||||
method GetItem {location} { |
||||
# location = pixel position, list (x y) |
||||
if {[llength $myfreeitems]} { |
||||
# Free items were found, reuse one of them. |
||||
|
||||
set theitem [lindex $myfreeitems end] |
||||
set myfreeitems [lreplace $myfreeitems end end] |
||||
|
||||
$hull coords $theitem $location |
||||
$hull itemconfigure $theitem -image {} |
||||
} else { |
||||
# Nothing available for reuse, create a new item. |
||||
|
||||
if {$options(-grid-show-borders)} { |
||||
# Helper markers for debugging, showing cell borders |
||||
# and coordinates. |
||||
|
||||
# NOTE !!! Use -grid-show-borders only for short-term debugging. |
||||
# NOTE !!! The items create here are never deleted, i.e. leaking memory |
||||
|
||||
foreach {x y} $location break |
||||
set x [expr {int($x)}] |
||||
set y [expr {int($y)}] |
||||
set t "<[expr {$y/$mygridheight}],[expr {$x/$mygridwidth}]>" |
||||
|
||||
incr x 2 ; incr y 2 |
||||
set x1 $x ; incr x1 $mygridwidth ; incr x1 -2 |
||||
set y1 $y ; incr y1 $mygridheight ; incr y1 -2 |
||||
|
||||
$hull create rectangle $x $y $x1 $y1 -outline red |
||||
incr x 4 ; incr y 4 |
||||
set t [$hull create text $x $y -fill red -anchor nw -text $t] |
||||
$hull raise $t |
||||
} |
||||
|
||||
set theitem [$hull create image $location -anchor nw -tags [list $ourtag]] |
||||
$hull lower $theitem |
||||
} |
||||
return $theitem |
||||
} |
||||
|
||||
method DropFreeItems {} { |
||||
if {[llength $myfreeitems]} { |
||||
eval [linsert $myfreeitems 0 $hull delete] |
||||
set myfreeitems {} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
proc PixelToGrid {pixelview} { |
||||
# Import grid definitions ... |
||||
upvar 1 mygridwidth gcw mygridheight gch |
||||
foreach {xl yt xr yb} $pixelview break |
||||
|
||||
set coll [expr {int($xl / double($gcw))}] |
||||
set colr [expr {int($xr / double($gcw))}] |
||||
set rowt [expr {int($yt / double($gch))}] |
||||
set rowb [expr {int($yb / double($gch))}] |
||||
|
||||
# NOTE AK: Maybe limit cell coordinates to boundaries, if |
||||
# NOTE AK: so requested. |
||||
|
||||
return [list $coll $rowt $colr $rowb] |
||||
} |
||||
|
||||
proc GridToPixel {at} { |
||||
# Import grid definitions ... |
||||
upvar 1 mygridwidth gcw mygridheight gch |
||||
foreach {r c} $at break |
||||
set y [expr {int($r * double($gch))}] |
||||
set x [expr {int($c * double($gcw))}] |
||||
return [list $x $y] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State |
||||
|
||||
# Active copies of various options. Their use prevents races in |
||||
# the redraw logic using new option values while other parts are |
||||
# not adapted to the changes. The 'Reconfigure' method is |
||||
# responsible for the atomic commit of external changes to the |
||||
# internal engine. |
||||
|
||||
variable mygridwidth {} ; # Grid definition used by the engine. |
||||
variable mygridheight {} ; # s.a. |
||||
variable mygridcmd {} ; # s.a. |
||||
variable myscrollregion {} ; # s.a. |
||||
|
||||
# All arrays using grid cells as keys, i.e. 'myvisible', use grid |
||||
# cell coordinates to reference grid cell, in the form |
||||
# tuple(row, col) |
||||
# |
||||
# This is the same form taken by the grid-cell-command command prefix and makes |
||||
# use of keys easier as it they are the same across the board. |
||||
|
||||
# Cache for quick lookup of images and image misses we have seen |
||||
# before, to avoid async round-trips through the |
||||
# grid-cell-command, aka image provider. |
||||
|
||||
component tilecache |
||||
|
||||
# Tracking the viewport, i.e. the visible area of the canvas |
||||
# within the scrollregion. |
||||
|
||||
variable mypixelview {} ; # Current viewport of the hull, in pixels. |
||||
variable myshowngridview {} ; # Viewport set by last Redraw, in grid cell coordinates |
||||
|
||||
# Tracking the grid cells shown in the viewport and their canvas |
||||
# items. |
||||
|
||||
variable myvisible -array {} ; # Visible grid cells, mapped to their canvas items. |
||||
|
||||
# Transient list of items available for reassignment. |
||||
|
||||
variable myfreeitems {} |
||||
|
||||
# Tag used to mark all canvas items used for the grid cell display. |
||||
|
||||
typevariable ourtag canvas::sqmap::cells |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::sqmap 0.3.1 |
||||
return |
||||
@ -0,0 +1,70 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
## Canvas Utilities. Operations on item tags. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
|
||||
namespace eval ::canvas::tag { |
||||
namespace export \ |
||||
append prepend insert remove match |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
proc ::canvas::tag::append {c tagOrId args} { |
||||
insert $c $tagOrId end {*}$args |
||||
#$c addtag $newtag withtag $tagOrId |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::tag::prepend {c tagOrId args} { |
||||
insert $c $tagOrId 0 {*}$args |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::tag::insert {c tagOrId index args} { |
||||
foreach item [$c find withtag $tagOrId] { |
||||
$c itemconfigure $item -tags [linsert [$c gettags $item] $index {*}$args] |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::tag::remove {c tagOrId args} { |
||||
foreach item [$c find withtag $tagOrId] { |
||||
set tags [$c gettags $item] |
||||
foreach tagToRemove $args { |
||||
while {1} { |
||||
set pos [lsearch -exact $tags $tagToRemove] |
||||
if {$pos < 0} break |
||||
set tags [lreplace $tags $pos $pos] |
||||
} |
||||
} |
||||
$c itemconfigure $item -tags $tags |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::canvas::tag::match {c tagOrId pattern} { |
||||
set result {} |
||||
foreach item [$c find withtag $tagOrId] { |
||||
lappend result {*}[lsearch -inline -all -glob \ |
||||
[$c gettags $item] $pattern] |
||||
} |
||||
return [lsort -unique $result] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::tag 0.1 |
||||
return |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Scrap yard. |
||||
@ -0,0 +1,95 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
## |
||||
# Canvas Behavior Module. Managing semi-crosshair rubber bands when |
||||
# dragging. Tracers are lines from fixed points to current location |
||||
# Purely visual. Driven from the outside. No bindings of its own. |
||||
## |
||||
|
||||
## TODO : Callback to customize the rubberband lines. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk |
||||
package require snit |
||||
|
||||
namespace eval ::canvas::track { |
||||
namespace export lines |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API |
||||
|
||||
snit::type ::canvas::track::lines { |
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Lifecycle management |
||||
|
||||
constructor {c} { |
||||
set mycanvas $c |
||||
return |
||||
} |
||||
|
||||
destructor { |
||||
$self done |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API. |
||||
|
||||
method start {center args} { |
||||
if {![llength $args]} return |
||||
$self done |
||||
|
||||
# args = list of pairs, each pair contains the x- and |
||||
# y-coordinates of a fixed point. |
||||
# center is current location. |
||||
|
||||
set mycoords $args |
||||
set myitems {} |
||||
|
||||
foreach p $mycoords { |
||||
lappend myitems [$mycanvas create line \ |
||||
{*}$p {*}$center \ |
||||
-width 0 -fill black -dash .] |
||||
} |
||||
return |
||||
} |
||||
|
||||
method move {center} { |
||||
if {![llength $myitems]} return |
||||
foreach p $mycoords item $myitems { |
||||
$mycanvas coords $item {*}$p {*}$center |
||||
} |
||||
return |
||||
} |
||||
|
||||
method done {} { |
||||
if {![llength $myitems]} return |
||||
$mycanvas delete {*}$myitems |
||||
set myitems {} |
||||
set mycoords {} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## STATE |
||||
|
||||
variable mycanvas {} ; # The canvas we are working with/on. |
||||
variable mycoords {} ; # List of fixed points for the rubberbands. |
||||
variable myitems {} ; # Liust of the canvas items representing the rubberbands. |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ##################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide canvas::track::lines 0.1 |
||||
return |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Scrap yard. |
||||
@ -0,0 +1,181 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
## A discrete zoom-control widget based on two buttons and label. |
||||
## The API is similar to a scale. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.4- ; # No {*}-expansion :( |
||||
package require Tk |
||||
package require snit ; # |
||||
package require uevent::onidle ; # Some defered actions. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
snit::widget ::canvas::zoom { |
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
option -orient -default vertical -configuremethod O-orient \ |
||||
-type {snit::enum -values {vertical horizontal}} |
||||
option -levels -default {0 10} -configuremethod O-levels \ |
||||
-type {snit::listtype -minlen 1 -maxlen 2 -type snit::integer} |
||||
option -variable -default {} -configuremethod O-variable |
||||
option -command -default {} -configuremethod O-command |
||||
|
||||
constructor {args} { |
||||
install reconfigure using uevent::onidle ${selfns}::reconfigure \ |
||||
[mymethod Reconfigure] |
||||
|
||||
set options(-variable) [myvar myzoomlevel] ;# Default value |
||||
$self configurelist $args |
||||
|
||||
# Force redraw if it could not be triggered by options. |
||||
if {![llength $args]} { |
||||
$reconfigure request |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Option processing. Any changes force a refresh of the grid |
||||
## information, and then a redraw. |
||||
|
||||
method O-orient {o v} { |
||||
if {$options($o) eq $v} return |
||||
set options($o) $v |
||||
$reconfigure request |
||||
return |
||||
} |
||||
|
||||
method O-levels {o v} { |
||||
# When only a single value was specified, we use it as |
||||
# our maximum, and default the minimum to zero. |
||||
if {[llength $v] == 1} { |
||||
set v [linsert $v 0 0] |
||||
} |
||||
if {$options($o) == $v} return |
||||
set options($o) $v |
||||
$reconfigure request |
||||
return |
||||
} |
||||
|
||||
method O-variable {o v} { |
||||
# The handling of an attached variable is very simple, without |
||||
# any of the trace management one would expect to be |
||||
# here. That is because we are using an unmapped aka hidden |
||||
# scale widget to do this for us, at the C level. |
||||
|
||||
if {$options($o) == $v} return |
||||
set options($o) $v |
||||
$reconfigure request |
||||
return |
||||
} |
||||
|
||||
method O-command {o v} { |
||||
if {$v eq $options(-command)} return |
||||
set options(-command) $v |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
component reconfigure |
||||
method Reconfigure {} { |
||||
# (Re)generate the user interface. |
||||
|
||||
eval [linsert [winfo children $win] 0 destroy] |
||||
|
||||
set side $options(-orient) |
||||
set var $options(-variable) |
||||
foreach {lo hi} $options(-levels) break |
||||
|
||||
set vwidth [expr {max([string length $lo], [string length $hi])}] |
||||
set pre [expr {[info commands ::ttk::button] ne "" ? "::ttk" : "::tk"}] |
||||
|
||||
${pre}::frame $win.z -relief solid -borderwidth 1 |
||||
${pre}::button $win.z.plus -image ::canvas::zoom::plus -command [mymethod ZoomIn] |
||||
${pre}::label $win.z.val -textvariable $var -justify c -anchor c -width $vwidth |
||||
${pre}::button $win.z.minus -image ::canvas::zoom::minus -command [mymethod ZoomOut] |
||||
|
||||
# Use an unmapped scale to keep var between lo and hi and |
||||
# avoid doing our own trace management |
||||
scale $win.z.sc -from $lo -to $hi -variable $var |
||||
|
||||
pack $win.z -fill both -expand 1 |
||||
if {$side eq "vertical"} { |
||||
pack $win.z.plus $win.z.val $win.z.minus -side top -fill x |
||||
} else { |
||||
pack $win.z.plus $win.z.val $win.z.minus -side left -fill y |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Events which act on the zoomlevel. |
||||
|
||||
method ZoomIn {} { |
||||
upvar #0 $options(-variable) zoomlevel |
||||
foreach {lo hi} $options(-levels) break |
||||
if {$zoomlevel >= $hi} return |
||||
incr zoomlevel |
||||
$self Callback |
||||
return |
||||
} |
||||
|
||||
method ZoomOut {} { |
||||
upvar #0 $options(-variable) zoomlevel |
||||
foreach {lo hi} $options(-levels) break |
||||
if {$zoomlevel <= $lo} return |
||||
incr zoomlevel -1 |
||||
$self Callback |
||||
return |
||||
} |
||||
|
||||
method Callback {} { |
||||
if {![llength $options(-command)]} return |
||||
|
||||
upvar #0 $options(-variable) zoomlevel |
||||
uplevel #0 [linsert $options(-command) end $win $zoomlevel] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State |
||||
|
||||
variable myzoomlevel 0 ; # The variable to use if the user |
||||
# did not supply one to -variable. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Images for the buttons |
||||
|
||||
image create bitmap ::canvas::zoom::plus -data { |
||||
#define plus_width 8 |
||||
#define plus_height 8 |
||||
static char bullet_bits = { |
||||
0x18, 0x18, 0x18, 0xff, 0xff, 0x18, 0x18, 0x18 |
||||
} |
||||
} |
||||
|
||||
image create bitmap ::canvas::zoom::minus -data { |
||||
#define minus_width 8 |
||||
#define minus_height 8 |
||||
static char bullet_bits = { |
||||
0x00, 0x00, 0x00, 0xff, 0xff, 0x00, 0x00, 0x00 |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::zoom 0.2.1 |
||||
return |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Scrap yard. |
||||
@ -0,0 +1,16 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return} |
||||
package ifneeded canvas::sqmap 0.3.1 [list source [file join $dir canvas_sqmap.tcl]] |
||||
package ifneeded canvas::zoom 0.2.1 [list source [file join $dir canvas_zoom.tcl]] |
||||
if {![package vsatisfies [package provide Tcl] 8.5]} { return } |
||||
package ifneeded canvas::drag 0.1 [list source [file join $dir canvas_drag.tcl]] |
||||
package ifneeded canvas::edit::circle 0.1 [list source [file join $dir canvas_ecircle.tcl]] |
||||
package ifneeded canvas::edit::points 0.3 [list source [file join $dir canvas_epoints.tcl]] |
||||
package ifneeded canvas::edit::polyline 0.2 [list source [file join $dir canvas_epolyline.tcl]] |
||||
package ifneeded canvas::edit::quadrilateral 0.1 [list source [file join $dir canvas_equad.tcl]] |
||||
package ifneeded canvas::edit::rectangle 0.1 [list source [file join $dir canvas_erectangle.tcl]] |
||||
package ifneeded canvas::gradient 0.2 [list source [file join $dir canvas_gradient.tcl]] |
||||
package ifneeded canvas::highlight 0.1 [list source [file join $dir canvas_highlight.tcl]] |
||||
package ifneeded canvas::mvg 1 [list source [file join $dir canvas_mvg.tcl]] |
||||
package ifneeded canvas::snap 1.0.1 [list source [file join $dir canvas_snap.tcl]] |
||||
package ifneeded canvas::tag 0.1 [list source [file join $dir canvas_tags.tcl]] |
||||
package ifneeded canvas::track::lines 0.1 [list source [file join $dir canvas_trlines.tcl]] |
||||
@ -0,0 +1,777 @@
|
||||
# chatwidget.tcl -- |
||||
# |
||||
# This package provides a composite widget suitable for use in chat |
||||
# applications. A number of panes managed by panedwidgets are available |
||||
# for displaying user names, chat text and for entering new comments. |
||||
# The main display area makes use of text widget peers to enable a split |
||||
# view for history or searching. |
||||
# |
||||
# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk 8.5- |
||||
|
||||
namespace eval chatwidget { |
||||
variable version 1.1.4 |
||||
|
||||
namespace export chatwidget |
||||
|
||||
ttk::style layout ChatwidgetFrame { |
||||
Entry.field -sticky news -border 1 -children { |
||||
ChatwidgetFrame.padding -sticky news |
||||
} |
||||
} |
||||
if {[lsearch -exact [font names] ChatwidgetFont] == -1} { |
||||
eval [list font create ChatwidgetFont] [font configure TkTextFont] |
||||
eval [list font create ChatwidgetBoldFont] \ |
||||
[font configure ChatwidgetFont] -weight bold |
||||
eval [list font create ChatwidgetItalicFont] \ |
||||
[font configure ChatwidgetFont] -slant italic |
||||
eval [list font create ChatwidgetTopicFont] \ |
||||
[font configure ChatwidgetFont] \ |
||||
-size [expr {[font configure ChatwidgetFont -size] - 0}] |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::chatwidget {w args} { |
||||
Create $w |
||||
interp hide {} $w |
||||
interp alias {} $w {} [namespace origin WidgetProc] $w |
||||
return $w |
||||
} |
||||
|
||||
proc chatwidget::WidgetProc {self cmd args} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -- $cmd { |
||||
hook { |
||||
if {[llength $args] < 2} { |
||||
return -code error "wrong \# args: should be\ |
||||
\"\$widget hook add|remove|list hook_type ?script? ?priority?\"" |
||||
} |
||||
return [uplevel 1 [list [namespace origin Hook] $self] $args] |
||||
} |
||||
cget { |
||||
return [uplevel 1 [list [namespace origin Cget] $self] $args] |
||||
} |
||||
configure { |
||||
return [uplevel 1 [list [namespace origin Configure] $self] $args] |
||||
} |
||||
insert { |
||||
return [uplevel 1 [list [namespace origin Insert] $self] $args] |
||||
} |
||||
message { |
||||
return [uplevel 1 [list [namespace origin Message] $self] $args] |
||||
} |
||||
name { |
||||
return [uplevel 1 [list [namespace origin Name] $self] $args] |
||||
} |
||||
topic { |
||||
return [uplevel 1 [list [namespace origin Topic] $self] $args] |
||||
} |
||||
names { |
||||
return [uplevel 1 [list [namespace origin Names] $self] $args] |
||||
} |
||||
entry { |
||||
return [uplevel 1 [list [namespace origin Entry] $self] $args] |
||||
} |
||||
peer { |
||||
return [uplevel 1 [list [namespace origin Peer] $self] $args] |
||||
} |
||||
chat - |
||||
default { |
||||
return [uplevel 1 [list [namespace origin Chat] $self] $args] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc chatwidget::Chat {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[llength $args] == 0} { |
||||
return $state(chat_widget) |
||||
} |
||||
return [uplevel 1 [list $state(chat_widget)] $args] |
||||
} |
||||
|
||||
proc chatwidget::Cget {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -exact -- [set what [lindex $args 0]] { |
||||
-chatstate { return $state(chatstate) } |
||||
-history { return $state(history) } |
||||
default { |
||||
return [uplevel 1 [list $state(chat_widget) cget] $args] |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Configure {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -exact -- [set option [lindex $args 0]] { |
||||
-chatstate { |
||||
if {[llength $args] > 1} { set state(chatstate) [Pop args 1] } |
||||
else { return $state(chatstate) } |
||||
} |
||||
-history { |
||||
if {[llength $args] > 1} { set state(history) [Pop args 1] } |
||||
else { return $state(history) } |
||||
} |
||||
-font { |
||||
if {[llength $args] > 1} { |
||||
set font [Pop args 1] |
||||
set family [font actual $font -family] |
||||
set size [font actual $font -size] |
||||
font configure ChatwidgetFont -family $family -size $size |
||||
font configure ChatwidgetBoldFont -family $family -size $size |
||||
font configure ChatwidgetItalicFont -family $family -size $size |
||||
} else { return [$state(chat_widget) cget -font] } |
||||
} |
||||
default { |
||||
return [uplevel 1 [list $state(chat_widget) configure] $args] |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Peer {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[llength $args] == 0} { |
||||
return $state(chat_peer_widget) |
||||
} |
||||
return [uplevel 1 [list $state(chat_peer_widget)] $args] |
||||
} |
||||
|
||||
proc chatwidget::Topic {self cmd args} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -exact -- $cmd { |
||||
show { grid $self.topic -row 0 -column 0 -sticky new } |
||||
hide { grid forget $self.topic } |
||||
set { |
||||
set state(topic) [lindex $args 0] |
||||
$self.topic.text configure -state normal |
||||
$self.topic.text delete 1.0 end |
||||
$self.topic.text insert end $state(topic) |
||||
$self.topic.text configure -state disabled |
||||
bind $self.topic.text <Map> [list [namespace origin TopicUpdate] $self] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be show, hide or set" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Set the topic widget to 2 lines with an optional scrollbar if the text |
||||
# will require more than a single line of display. |
||||
proc chatwidget::TopicUpdate {self} { |
||||
bind $self.topic.text <Map> {} |
||||
set lines [$self.topic.text count -displaylines 1.0 end] |
||||
if {$lines < 2} { |
||||
$self.topic.text configure -height 1 |
||||
} else { |
||||
$self.topic.text configure -height 2 |
||||
ttk::scrollbar $self.topic.vs -command [list $self.topic.text yview] |
||||
$self.topic.text configure -yscrollcommand \ |
||||
[list [namespace origin scroll_set] $self.topic.vs $self 0] |
||||
grid $self.topic.vs -row 0 -column 2 -sticky new -pady {2 0} -padx 1 |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Names {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
set frame [winfo parent $state(names_widget)] |
||||
set pane [winfo parent $frame] |
||||
if {[llength $args] == 0} { |
||||
return $state(names_widget) |
||||
} |
||||
if {[llength $args] == 1 && [lindex $args 0] eq "hide"} { |
||||
if {$frame in [$pane panes]} { |
||||
$pane forget $frame |
||||
} |
||||
return |
||||
} |
||||
if {[llength $args] == 1 && [lindex $args 0] eq "show"} { |
||||
if {$frame ni [$pane panes]} { |
||||
$pane add $frame |
||||
} |
||||
return |
||||
} |
||||
return [uplevel 1 [list $state(names_widget)] $args] |
||||
} |
||||
|
||||
proc chatwidget::Entry {self args} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[llength $args] == 0} { |
||||
return $state(entry_widget) |
||||
} |
||||
if {[llength $args] == 1 && [lindex $args 0] eq "text"} { |
||||
return [$state(entry_widget) get 1.0 end-1c] |
||||
} |
||||
return [uplevel 1 [list $state(entry_widget)] $args] |
||||
} |
||||
|
||||
proc chatwidget::Message {self text args} { |
||||
upvar #0 [namespace current]::$self state |
||||
set chat $state(chat_widget) |
||||
|
||||
set mark end |
||||
set type normal |
||||
set nick Unknown |
||||
set time [clock seconds] |
||||
set tags {} |
||||
|
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -exact -- $option { |
||||
-nick { set nick [Pop args 1] } |
||||
-time { set time [Pop args 1] } |
||||
-type { set type [Pop args 1] } |
||||
-mark { set mark [Pop args 1] } |
||||
-tags { set tags [Pop args 1] } |
||||
default { |
||||
return -code error "unknown option \"$option\"" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {[catch {Hook $self run message $text \ |
||||
-mark $mark -type $type -nick $nick \ |
||||
-time $time -tags $tags}] == 3} then { |
||||
return |
||||
} |
||||
|
||||
if {$type ne "system"} { lappend tags NICK-$nick } |
||||
lappend tags TYPE-$type |
||||
$chat configure -state normal |
||||
set ts [clock format $time -format "\[%H:%M\]\t"] |
||||
$chat insert $mark $ts [concat BOOKMARK STAMP $tags] |
||||
if {$type eq "action"} { |
||||
$chat insert $mark " * $nick " [concat BOOKMARK NICK $tags] |
||||
lappend tags ACTION |
||||
} elseif {$type eq "system"} { |
||||
} else { |
||||
$chat insert $mark "$nick\t" [concat BOOKMARK NICK $tags] |
||||
} |
||||
if {$type ne "system"} { lappend tags MSG NICK-$nick } |
||||
#$chat insert $mark $text $tags |
||||
Insert $self $mark $text $tags |
||||
$chat insert $mark "\n" $tags |
||||
$chat configure -state disabled |
||||
if {$state(autoscroll)} { |
||||
$chat see $mark |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc chatwidget::Insert {self mark args} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {![info exists state(urluid)]} {set state(urluid) 0} |
||||
set w $state(chat_widget) |
||||
set parts {} |
||||
foreach {s t} $args { |
||||
while {[regexp -indices {\m(https?://[^\s]+)} $s -> ndx]} { |
||||
foreach {fr bk} $ndx break |
||||
lappend parts [string range $s 0 [expr {$fr - 1}]] $t |
||||
lappend parts [string range $s $fr $bk] \ |
||||
[linsert $t end URL URL-[incr state(urluid)]] |
||||
set s [string range $s [incr bk] end] |
||||
} |
||||
lappend parts $s $t |
||||
} |
||||
set ws [$w cget -state] |
||||
$w configure -state normal |
||||
eval [list $w insert $mark] $parts |
||||
$w configure -state $ws |
||||
} |
||||
|
||||
# $w name add ericthered -group admin -color red |
||||
# state(names) {{pat -color red -group admin -thing wilf} {eric ....}} |
||||
proc chatwidget::Name {self cmd args} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -exact -- $cmd { |
||||
list { |
||||
switch -exact -- [lindex $args 0] { |
||||
-full { |
||||
return $state(names) |
||||
} |
||||
default { |
||||
set r {} |
||||
foreach item $state(names) { lappend r [lindex $item 0] } |
||||
return $r |
||||
} |
||||
} |
||||
} |
||||
add { |
||||
if {[llength $args] < 1 || ([llength $args] % 2) != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
\"add nick ?-group group ...?\"" |
||||
} |
||||
set nick [lindex $args 0] |
||||
if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] == -1} { |
||||
set fg [$state(chat_widget) cget -foreground] |
||||
array set opts [list -group {} -color $fg] |
||||
array set opts [lrange $args 1 end] |
||||
lappend state(names) [linsert [array get opts] 0 $nick] |
||||
} else { |
||||
array set opts [lrange [lindex $state(names) $ndx] 1 end] |
||||
array set opts [lrange $args 1 end] |
||||
lset state(names) $ndx [linsert [array get opts] 0 $nick] |
||||
} |
||||
UpdateNames $self |
||||
} |
||||
delete { |
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be \"delete nick\"" |
||||
} |
||||
set nick [lindex $args 0] |
||||
if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} { |
||||
set state(names) [lreplace $state(names) $ndx $ndx] |
||||
UpdateNames $self |
||||
} |
||||
} |
||||
get { |
||||
if {[llength $args] < 1} { |
||||
return -code error "wrong # args:\ |
||||
should be \"get nick\" ?option?" |
||||
} |
||||
set result {} |
||||
set nick [lindex $args 0] |
||||
if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} { |
||||
set result [lindex $state(names) $ndx] |
||||
if {[llength $args] > 1} { |
||||
if {[set ndx [lsearch $result [lindex $args 1]]] != -1} { |
||||
set result [lindex $result [incr ndx]] |
||||
} else { |
||||
set result {} |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
default { |
||||
return -code error "bad name option \"$cmd\":\ |
||||
must be list, names, add or delete" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::UpdateNames {self} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[info exists state(updatenames)]} { |
||||
after cancel $state(updatenames) |
||||
} |
||||
set state(updatenames) [after idle [list [namespace origin UpdateNamesExec] $self]] |
||||
} |
||||
|
||||
proc chatwidget::UpdateNamesExec {self} { |
||||
upvar #0 [namespace current]::$self state |
||||
unset state(updatenames) |
||||
set names $state(names_widget) |
||||
set chat $state(chat_widget) |
||||
|
||||
foreach tagname [lsearch -all -inline [$names tag names] NICK-*] { |
||||
$names tag delete $tagname |
||||
} |
||||
foreach tagname [lsearch -all -inline [$names tag names] GROUP-*] { |
||||
$names tag delete $tagname |
||||
} |
||||
|
||||
$names configure -state normal |
||||
$names delete 1.0 end |
||||
array set groups {} |
||||
foreach item $state(names) { |
||||
set group {} |
||||
if {[set ndx [lsearch $item -group]] != -1} { |
||||
set group [lindex $item [incr ndx]] |
||||
} |
||||
lappend groups($group) [lindex $item 0] |
||||
} |
||||
|
||||
foreach group [lsort [array names groups]] { |
||||
Hook $self run names_group $group |
||||
$names insert end "$group\n" [list SUBTITLE GROUP-$group] |
||||
foreach nick [lsort -dictionary $groups($group)] { |
||||
$names tag configure NICK-$nick |
||||
unset -nocomplain opts ; array set opts {} |
||||
if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} { |
||||
array set opts [lrange [lindex $state(names) $ndx] 1 end] |
||||
if {[info exists opts(-color)]} { |
||||
$names tag configure NICK-$nick -foreground $opts(-color) |
||||
$chat tag configure NICK-$nick -foreground $opts(-color) |
||||
} |
||||
eval [linsert [lindex $state(names) $ndx] 0 \ |
||||
Hook $self run names_nick] |
||||
} |
||||
$names insert end $nick\n [list NICK NICK-$nick GROUP-$group] |
||||
} |
||||
} |
||||
$names insert end "[llength $state(names)] nicks\n" [list SUBTITLE] |
||||
|
||||
$names configure -state disabled |
||||
} |
||||
|
||||
proc chatwidget::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
proc chatwidget::Hook {self do type args} { |
||||
upvar #0 [namespace current]::$self state |
||||
set valid {message post names_group names_nick chatstate url} |
||||
if {[lsearch -exact $valid $type] == -1} { |
||||
return -code error "unknown hook type \"$type\":\ |
||||
must be one of [join $valid ,]" |
||||
} |
||||
switch -exact -- $do { |
||||
add { |
||||
if {[llength $args] < 1 || [llength $args] > 2} { |
||||
return -code error "wrong # args: should be \"add hook cmd ?priority?\"" |
||||
} |
||||
foreach {cmd pri} $args break |
||||
if {$pri eq {}} { set pri 50 } |
||||
lappend state(hook,$type) [list $cmd $pri] |
||||
set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]] |
||||
} |
||||
remove { |
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be \"remove hook cmd\"" |
||||
} |
||||
if {![info exists state(hook,$type)]} { return } |
||||
for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} { |
||||
set item [lindex $state(hook,$type) $ndx] |
||||
if {[lindex $item 0] eq [lindex $args 0]} { |
||||
set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx] |
||||
break |
||||
} |
||||
} |
||||
set state(hook,$type) |
||||
} |
||||
run { |
||||
if {![info exists state(hook,$type)]} { return } |
||||
set res "" |
||||
foreach item $state(hook,$type) { |
||||
foreach {cmd pri} $item break |
||||
set code [catch {eval $cmd $args} err] |
||||
if {$code} { |
||||
::bgerror "error running \"$type\" hook: $err" |
||||
break |
||||
} else { |
||||
lappend res $err |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
list { |
||||
if {[info exists state(hook,$type)]} { |
||||
return $state(hook,$type) |
||||
} |
||||
} |
||||
default { |
||||
return -code error "unknown hook action \"$do\":\ |
||||
must be add, remove, list or run" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Grid {w {row 0} {column 0}} { |
||||
grid rowconfigure $w $row -weight 1 |
||||
grid columnconfigure $w $column -weight 1 |
||||
} |
||||
|
||||
proc chatwidget::Create {self} { |
||||
upvar #0 [set State [namespace current]::$self] state |
||||
set state(history) {} |
||||
set state(current) 0 |
||||
set state(autoscroll) 1 |
||||
set state(names) {} |
||||
set state(chatstatetimer) {} |
||||
set state(chatstate) active |
||||
|
||||
# NOTE: By using a non-ttk frame as the outermost part we are able |
||||
# to be [wm manage]d. The outermost frame should be invisible at all times. |
||||
set self [frame $self -class Chatwidget \ |
||||
-borderwidth 0 -highlightthickness 0 -relief flat] |
||||
set outer [ttk::panedwindow $self.outer -orient vertical] |
||||
set inner [ttk::panedwindow $outer.inner -orient horizontal] |
||||
|
||||
# Create a topic/subject header |
||||
set topic [ttk::frame $self.topic] |
||||
ttk::label $topic.label -anchor w -text Topic |
||||
text $topic.text -state disabled -font ChatwidgetTopicFont |
||||
$topic.text configure -state disabled -height 1 -wrap word |
||||
grid $topic.label $topic.text -sticky new -pady {2 0} -padx 1 |
||||
Grid $topic 0 1 |
||||
|
||||
# Create the usernames scrolled text |
||||
set names [ttk::frame $inner.names -style ChatwidgetFrame] |
||||
text $names.text -borderwidth 0 -relief flat -font ChatwidgetFont |
||||
ttk::scrollbar $names.vs -command [list $names.text yview] |
||||
$names.text configure -width 10 -height 10 -state disabled \ |
||||
-yscrollcommand [list [namespace origin scroll_set] $names.vs $inner 0] |
||||
bindtags $names.text [linsert [bindtags $names.text] 1 ChatwidgetNames] |
||||
grid $names.text $names.vs -sticky news -padx 1 -pady 1 |
||||
Grid $names 0 0 |
||||
set state(names_widget) $names.text |
||||
|
||||
# Create the chat display |
||||
set chatf [ttk::frame $inner.chat -style ChatwidgetFrame] |
||||
set peers [ttk::panedwindow $chatf.peers -orient vertical] |
||||
set upper [ttk::frame $peers.upper] |
||||
set lower [ttk::frame $peers.lower] |
||||
|
||||
set chat [text $lower.text -borderwidth 0 -relief flat -wrap word \ |
||||
-state disabled -font ChatwidgetFont] |
||||
set chatvs [ttk::scrollbar $lower.vs -command [list $chat yview]] |
||||
$chat configure -height 10 -state disabled \ |
||||
-yscrollcommand [list [namespace origin scroll_set] $chatvs $peers 1] |
||||
grid $chat $chatvs -sticky news |
||||
Grid $lower 0 0 |
||||
set peer [$chat peer create $upper.text -borderwidth 0 -relief flat \ |
||||
-wrap word -state disabled -font ChatwidgetFont] |
||||
set peervs [ttk::scrollbar $upper.vs -command [list $peer yview]] |
||||
$peer configure -height 0 \ |
||||
-yscrollcommand [list [namespace origin scroll_set] $peervs $peers 0] |
||||
grid $peer $peervs -sticky news |
||||
Grid $upper 0 0 |
||||
$peers add $upper |
||||
$peers add $lower -weight 1 |
||||
grid $peers -sticky news -padx 1 -pady 1 |
||||
Grid $chatf 0 0 |
||||
bindtags $chat [linsert [bindtags $chat] 1 ChatwidgetText] |
||||
set state(chat_widget) $chat |
||||
set state(chat_peer_widget) $peer |
||||
|
||||
# Create the entry widget |
||||
set entry [ttk::frame $outer.entry -style ChatwidgetFrame] |
||||
text $entry.text -borderwidth 0 -relief flat -font ChatwidgetFont |
||||
$entry.text configure -insertbackground [$entry.text cget -foreground] |
||||
|
||||
ttk::scrollbar $entry.vs -command [list $entry.text yview] |
||||
$entry.text configure -height 1 \ |
||||
-yscrollcommand [list [namespace origin scroll_set] $entry.vs $outer 0] |
||||
bindtags $entry.text [linsert [bindtags $entry.text] 1 ChatwidgetEntry] |
||||
grid $entry.text $entry.vs -sticky news -padx 1 -pady 1 |
||||
Grid $entry 0 0 |
||||
set state(entry_widget) $entry.text |
||||
|
||||
bind ChatwidgetEntry <Return> "[namespace origin Post] \[[namespace origin Self] %W\]" |
||||
bind ChatwidgetEntry <KP_Enter> "[namespace origin Post] \[[namespace origin Self] %W\]" |
||||
bind ChatwidgetEntry <Shift-Return> "#" |
||||
bind ChatwidgetEntry <Control-Return> "#" |
||||
bind ChatwidgetEntry <Key-Up> "[namespace origin History] \[[namespace origin Self] %W\] prev" |
||||
bind ChatwidgetEntry <Key-Down> "[namespace origin History] \[[namespace origin Self] %W\] next" |
||||
bind ChatwidgetEntry <Key-Tab> "[namespace origin Nickcomplete] \[[namespace origin Self] %W\]" |
||||
bind ChatwidgetEntry <Key-Prior> "\[[namespace origin Self] %W\] chat yview scroll -1 pages" |
||||
bind ChatwidgetEntry <Key-Next> "\[[namespace origin Self] %W\] chat yview scroll 1 pages" |
||||
bind ChatwidgetEntry <Key> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] composing" |
||||
bind ChatwidgetEntry <FocusIn> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] active" |
||||
bind $self <Destroy> "+unset -nocomplain [namespace current]::%W" |
||||
bind $peer <Map> [list [namespace origin PaneMap] %W $peers 0] |
||||
bind $names.text <Map> [list [namespace origin PaneMap] %W $inner -90] |
||||
bind $entry.text <Map> [list [namespace origin PaneMap] %W $outer -28] |
||||
|
||||
bind ChatwidgetText <<ThemeChanged>> { |
||||
ttk::style layout ChatwidgetFrame { |
||||
Entry.field -sticky news -border 1 -children { |
||||
ChatwidgetFrame.padding -sticky news |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Use inverted colors for the subtitles. |
||||
$names.text tag configure SUBTITLE -font ChatwidgetBoldFont \ |
||||
-foreground [$names.text cget -background] \ |
||||
-background [$names.text cget -foreground] |
||||
$chat tag configure NICK -font ChatwidgetBoldFont |
||||
$chat tag configure TYPE-system -font ChatwidgetItalicFont |
||||
$chat tag configure URL -underline 1 |
||||
|
||||
$inner add $chatf -weight 1 |
||||
$inner add $names |
||||
$outer add $inner -weight 1 |
||||
$outer add $entry |
||||
|
||||
grid $outer -row 1 -column 0 -sticky news -padx 1 -pady 1 |
||||
Grid $self 1 0 |
||||
return $self |
||||
} |
||||
|
||||
proc chatwidget::Self {widget} { |
||||
set class [winfo class [set w $widget]] |
||||
while {[winfo exists $w] && [winfo class $w] ne "Chatwidget"} { |
||||
set w [winfo parent $w] |
||||
} |
||||
if {![winfo exists $w]} { |
||||
return -code error "invalid window $widget" |
||||
} |
||||
return $w |
||||
} |
||||
|
||||
# Set initial position of sash |
||||
proc chatwidget::PaneMap {w pane offset} { |
||||
bind $w <Map> {} |
||||
if {[llength [$pane panes]] > 1} { |
||||
if {$offset < 0} { |
||||
if {[$pane cget -orient] eq "horizontal"} { |
||||
set axis width |
||||
} else { |
||||
set axis height |
||||
} |
||||
#after idle [list $pane sashpos 0 [expr {[winfo $axis $pane] + $offset}]] |
||||
after idle [namespace code [list PaneMapImpl $pane $axis $offset]] |
||||
} else { |
||||
#after idle [list $pane sashpos 0 $offset] |
||||
after idle [namespace code [list PaneMapImpl $pane {} $offset]] |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::PaneMapImpl {pane axis offset} { |
||||
if {$axis eq {}} { |
||||
set size 0 |
||||
} else { |
||||
set size [winfo $axis $pane] |
||||
} |
||||
set sashpos [expr {$size + $offset}] |
||||
#puts stderr "PaneMapImpl $pane $axis $offset : size:$size sashpos:$sashpos" |
||||
after 0 [list $pane sashpos 0 $sashpos] |
||||
} |
||||
|
||||
# Handle auto-scroll smarts. This will cause the scrollbar to be removed if |
||||
# not required and to disable autoscroll for the text widget if we are not |
||||
# tracking the bottom line. |
||||
proc chatwidget::scroll_set {scrollbar pw set f1 f2} { |
||||
$scrollbar set $f1 $f2 |
||||
if {($f1 == 0) && ($f2 == 1)} { |
||||
grid remove $scrollbar |
||||
} else { |
||||
if {[winfo manager $scrollbar] eq {}} {} |
||||
if {[llength [$pw panes]] > 1} { |
||||
set pos [$pw sashpos 0] |
||||
grid $scrollbar |
||||
after idle [list $pw sashpos 0 $pos] |
||||
} else { |
||||
grid $scrollbar |
||||
} |
||||
|
||||
} |
||||
if {$set} { |
||||
upvar #0 [namespace current]::[Self $scrollbar] state |
||||
set state(autoscroll) [expr {(1.0 - $f2) < 1.0e-6 }] |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Post {self} { |
||||
set msg [$self entry get 1.0 end-1c] |
||||
if {$msg eq ""} { return -code break "" } |
||||
if {[catch {Hook $self run post $msg}] != 3} { |
||||
$self entry delete 1.0 end |
||||
upvar #0 [namespace current]::$self state |
||||
set state(history) [lrange [lappend state(history) $msg] end-50 end] |
||||
set state(current) [llength $state(history)] |
||||
} |
||||
return -code break "" |
||||
} |
||||
|
||||
proc chatwidget::History {self dir} { |
||||
upvar #0 [namespace current]::$self state |
||||
switch -exact -- $dir { |
||||
prev { |
||||
if {$state(current) == 0} { return } |
||||
if {$state(current) == [llength $state(history)]} { |
||||
set state(temp) [$self entry get 1.0 end-1c] |
||||
} |
||||
if {$state(current)} { incr state(current) -1 } |
||||
$self entry delete 1.0 end |
||||
$self entry insert 1.0 [lindex $state(history) $state(current)] |
||||
return |
||||
} |
||||
next { |
||||
if {$state(current) == [llength $state(history)]} { return } |
||||
if {[incr state(current)] == [llength $state(history)] && [info exists state(temp)]} { |
||||
set msg $state(temp) |
||||
} else { |
||||
set msg [lindex $state(history) $state(current)] |
||||
} |
||||
$self entry delete 1.0 end |
||||
$self entry insert 1.0 $msg |
||||
} |
||||
default { |
||||
return -code error "invalid direction \"$dir\": |
||||
must be either prev or next" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc chatwidget::Nickcomplete {self} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[info exists state(nickcompletion)]} { |
||||
foreach {index matches after} $state(nickcompletion) break |
||||
after cancel $after |
||||
incr index |
||||
if {$index > [llength $matches]} { set index 0 } |
||||
set delta 2c |
||||
} else { |
||||
set delta 1c |
||||
set partial [$self entry get "insert - $delta wordstart" "insert - $delta wordend"] |
||||
set matches [lsearch -all -inline -glob -index 0 $state(names) $partial*] |
||||
set index 0 |
||||
} |
||||
switch -exact -- [llength $matches] { |
||||
0 { bell ; return -code break ""} |
||||
1 { set match [lindex [lindex $matches 0] 0]} |
||||
default { |
||||
set match [lindex [lindex $matches $index] 0] |
||||
set state(nickcompletion) [list $index $matches \ |
||||
[after 2000 [list [namespace origin NickcompleteCleanup] $self]]] |
||||
} |
||||
} |
||||
$self entry delete "insert - $delta wordstart" "insert - $delta wordend" |
||||
$self entry insert insert "$match " |
||||
return -code break "" |
||||
} |
||||
|
||||
proc chatwidget::NickcompleteCleanup {self} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {[info exists state(nickcompletion)]} { |
||||
unset state(nickcompletion) |
||||
} |
||||
} |
||||
|
||||
# Update the widget chatstate (one of active, composing, paused, inactive, gone) |
||||
# These are from XEP-0085 but seem likey useful in many chat-type environments. |
||||
# Note: this state is _per-widget_. This is not the same as [tk inactive] |
||||
# active = got focus and recently active |
||||
# composing = typing |
||||
# paused = 5 secs non typing |
||||
# inactive = no activity for 30 seconds |
||||
# gone = no activity for 2 minutes or closed the window |
||||
proc chatwidget::Chatstate {self what} { |
||||
upvar #0 [namespace current]::$self state |
||||
if {![info exists state]} { return } |
||||
after cancel $state(chatstatetimer) |
||||
switch -exact -- $what { |
||||
composing - active { |
||||
set state(chatstatetimer) [after 5000 [namespace code [list Chatstate $self paused]]] |
||||
} |
||||
paused { |
||||
set state(chatstatetimer) [after 25000 [namespace code [list Chatstate $self inactive]]] |
||||
} |
||||
inactive { |
||||
set state(chatstatetimer) [after 120000 [namespace code [list Chatstate $self gone]]] |
||||
} |
||||
gone {} |
||||
} |
||||
set fire [expr {$state(chatstate) eq $what ? 0 : 1}] |
||||
set state(chatstate) $what |
||||
if {$fire} { |
||||
catch {Hook $self run chatstate $what} |
||||
event generate $self <<ChatwidgetChatstate>> |
||||
} |
||||
} |
||||
|
||||
package provide chatwidget $chatwidget::version |
||||
@ -0,0 +1 @@
|
||||
package ifneeded chatwidget 1.1.4 [list source [file join $dir chatwidget.tcl]] |
||||
@ -0,0 +1,45 @@
|
||||
|
||||
|
||||
# |
||||
# This software is Copyright by the Board of Trustees of Michigan |
||||
# State University (c) Copyright 2005. |
||||
# |
||||
# You may use this software under the terms of the GNU public license |
||||
# (GPL) ir the Tcl BSD derived license The terms of these licenses |
||||
# are described at: |
||||
# |
||||
# GPL: http://www.gnu.org/licenses/gpl.txt |
||||
# Tcl: http://www.tcl.tk/softare/tcltk/license.html |
||||
# Start with the second paragraph under the Tcl/Tk License terms |
||||
# as ownership is solely by Board of Trustees at Michigan State University. |
||||
# |
||||
# Author: |
||||
# Ron Fox |
||||
# NSCL |
||||
# Michigan State University |
||||
# East Lansing, MI 48824-1321 |
||||
# |
||||
|
||||
# |
||||
# bindDown is a simple package that allows the user to attach |
||||
# bind tags to a hieararchy of widgets starting with the top of |
||||
# a widget tree. The most common use of this is in snit::widgets |
||||
# to allow a binding to be placed on the widget itself e.g: |
||||
# bindDown $win $win |
||||
# |
||||
# where the first item is the top of the widget tree, the second the |
||||
# bindtag to add to each widget in the subtree. |
||||
# This will allow bind $win <yada> yada to apply to the widget |
||||
# children. |
||||
# |
||||
# |
||||
package provide bindDown 1.0 |
||||
|
||||
proc bindDown {top tag} { |
||||
foreach widget [winfo children $top] { |
||||
set wtags [bindtags $widget] |
||||
lappend wtags $tag |
||||
bindtags $widget [lappend wtags $tag] |
||||
bindDown $widget $tag |
||||
} |
||||
} |
||||
@ -0,0 +1,17 @@
|
||||
# controlwidget.tcl -- |
||||
# Set up the requirements for the controlwidget module/package |
||||
# and source the individual files |
||||
# |
||||
|
||||
package require Tk 8.5- |
||||
package require snit |
||||
|
||||
package require bindDown |
||||
package require meter |
||||
package require led |
||||
package require rdial |
||||
package require tachometer |
||||
package require voltmeter |
||||
package require radioMatrix |
||||
|
||||
package provide controlwidget 0.1 |
||||
@ -0,0 +1,127 @@
|
||||
# |
||||
# This software is Copyright by the Board of Trustees of Michigan |
||||
# State University (c) Copyright 2005. |
||||
# |
||||
# You may use this software under the terms of the GNU public license |
||||
# (GPL) ir the Tcl BSD derived license The terms of these licenses |
||||
# are described at: |
||||
# |
||||
# GPL: http://www.gnu.org/licenses/gpl.txt |
||||
# Tcl: http://www.tcl.tk/softare/tcltk/license.html |
||||
# Start with the second paragraph under the Tcl/Tk License terms |
||||
# as ownership is solely by Board of Trustees at Michigan State University. |
||||
# |
||||
# Author: |
||||
# Ron Fox |
||||
# NSCL |
||||
# Michigan State University |
||||
# East Lansing, MI 48824-1321 |
||||
# |
||||
# Adjusted by Arjen Markus |
||||
# |
||||
# |
||||
# This package provides an LED |
||||
# widget. LED widgets are one color when on |
||||
# and another when off. |
||||
# Implementation is just a filled circle on a |
||||
# canvas. |
||||
# Options recognized: |
||||
# (all standard options for a frame). |
||||
# -size - Radius of the led. |
||||
# -on - Color of on state. |
||||
# -off - Color of off state. |
||||
# -variable - on color when variable is nonzero else off. |
||||
# Methods |
||||
# on - Turn led on. |
||||
# off - Turn led off. |
||||
# |
||||
# TODO: |
||||
# Add a label |
||||
# |
||||
|
||||
package provide led 1.0 |
||||
package require Tk |
||||
package require snit |
||||
package require bindDown |
||||
|
||||
namespace eval controlwidget { |
||||
namespace export led |
||||
} |
||||
|
||||
snit::widget controlwidget::led { |
||||
delegate option * to hull |
||||
option -size {17} |
||||
option -on green |
||||
option -off black |
||||
option -variable {} |
||||
|
||||
|
||||
constructor args { |
||||
$self configurelist $args |
||||
|
||||
canvas $win.led -width $options(-size) -height $options(-size) |
||||
set border [expr [$win cget -borderwidth] + 2] |
||||
set end [expr $options(-size) - $border] |
||||
$win.led create oval $border $border $end $end -fill $options(-off) |
||||
grid $win.led -sticky nsew |
||||
|
||||
bindDown $win $win |
||||
} |
||||
|
||||
# Process the -variable configuration by killing off prior traces |
||||
# and setting an new trace: |
||||
# |
||||
|
||||
onconfigure -variable name { |
||||
if {$options(-variable) ne ""} { |
||||
trace remove variable ::$options(-variable) write [mymethod varTrace] |
||||
} |
||||
trace add variable ::$name write [mymethod varTrace] |
||||
set options(-variable) $name |
||||
|
||||
# set our initial state to the current value of the var: |
||||
# the after is because we could be constructing an need to give |
||||
# the widgets a chance to get built: |
||||
|
||||
after 10 [list $self varTrace $name "" write] |
||||
|
||||
} |
||||
# Trace for the led variable.. |
||||
# |
||||
method varTrace {name index op} { |
||||
set name ::$name |
||||
set value [set $name] |
||||
if {[string is boolean -strict $value]} { |
||||
$self setstate $value |
||||
} |
||||
} |
||||
# |
||||
# Set the led on. |
||||
# |
||||
method on {} { |
||||
if {$options(-variable) ne ""} { |
||||
set ::$options(-variable) 1 |
||||
} else { |
||||
$self setstate 1 |
||||
} |
||||
} |
||||
# set the led off |
||||
# |
||||
method off {} { |
||||
if {$options(-variable) ne ""} { |
||||
set ::$options(-variable) 0 |
||||
} else { |
||||
$self setstate 0 |
||||
} |
||||
} |
||||
# |
||||
# Set the led state |
||||
# |
||||
method setstate {value} { |
||||
if {$value} { |
||||
$win.led itemconfigure 1 -fill $options(-on) |
||||
} else { |
||||
$win.led itemconfigure 1 -fill $options(-off) |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,23 @@
|
||||
# pkgIndex.tcl -- |
||||
# Index script for controlwidget package |
||||
# Note: |
||||
# We could split this into several parts. Now it is presented |
||||
# as a single package. |
||||
# |
||||
if {![package vsatisfies [package provide Tcl] 8.5]} { |
||||
# PRAGMA: returnok |
||||
return |
||||
} |
||||
if {![package vsatisfies [package provide Tcl] 8.5-]} { |
||||
# PRAGMA: returnok |
||||
return |
||||
} |
||||
|
||||
package ifneeded controlwidget 0.1 [list source [file join $dir controlwidget.tcl]] |
||||
package ifneeded meter 1.0 [list source [file join $dir vertical_meter.tcl]] |
||||
package ifneeded led 1.0 [list source [file join $dir led.tcl]] |
||||
package ifneeded rdial 0.7 [list source [file join $dir rdial.tcl]] |
||||
package ifneeded tachometer 0.1 [list source [file join $dir tachometer.tcl]] |
||||
package ifneeded voltmeter 0.1 [list source [file join $dir voltmeter.tcl]] |
||||
package ifneeded radioMatrix 1.0 [list source [file join $dir radioMatrix.tcl]] |
||||
package ifneeded bindDown 1.0 [list source [file join $dir bindDown.tcl]] |
||||
@ -0,0 +1,253 @@
|
||||
# |
||||
# This software is Copyright by the Board of Trustees of Michigan |
||||
# State University (c) Copyright 2005. |
||||
# |
||||
# You may use this software under the terms of the GNU public license |
||||
# (GPL) ir the Tcl BSD derived license The terms of these licenses |
||||
# are described at: |
||||
# |
||||
# GPL: http://www.gnu.org/licenses/gpl.txt |
||||
# Tcl: http://www.tcl.tk/softare/tcltk/license.html |
||||
# Start with the second paragraph under the Tcl/Tk License terms |
||||
# as ownership is solely by Board of Trustees at Michigan State University. |
||||
# |
||||
# Author: |
||||
# Ron Fox |
||||
# NSCL |
||||
# Michigan State University |
||||
# East Lansing, MI 48824-1321 |
||||
# |
||||
|
||||
|
||||
# Provide a megawidget that is a matrix of radio buttons |
||||
# and a variable that is tracked. The idea is that this |
||||
# can be used to control a device that has an enumerable |
||||
# set of values. |
||||
# |
||||
# OPTIONS: |
||||
# -orient Determines the order in which the radio buttons are |
||||
# laid out: |
||||
# vertical - buttons run from top to bottom then left to right. |
||||
# horizontal - buttons run from left to right top to bottom. |
||||
# -columns Number of columns. |
||||
# -rows Number of rows. |
||||
# -values Contains a list of values. Each element of the list is either |
||||
# a single element, which represents the value of the button or |
||||
# is a pair of values that represent a name/value pair for the button. |
||||
# If -values is provided, only one of -rows/-columns can be provided. |
||||
# If -values is not provided, both -rows and -columns must be provided |
||||
# and the label name/value pairs are 1,2,3,4,5... |
||||
# -variable Variable to track in the widget. |
||||
# -command Script to run when a radio button is clicked. |
||||
# |
||||
# METHODS: |
||||
# get - Gets the current button value. |
||||
# set - Sets the current button value (-command is invoked if defined). |
||||
# NOTES: |
||||
# 1. See the constraints on the options described above. |
||||
# 2. If, on entry, the variable (either global or fully namespace qualified |
||||
# is set and matches a radio button value, that radio button is initially |
||||
# lit. |
||||
# 3. The geometric properties of the widget can only be established at |
||||
# construction time, and are therefore static. |
||||
|
||||
package provide radioMatrix 1.0 |
||||
package require Tk |
||||
package require snit |
||||
package require bindDown |
||||
|
||||
namespace eval controlwidget { |
||||
namespace export radioMatrix |
||||
} |
||||
|
||||
snit::widget ::controlwidget::radioMatrix { |
||||
|
||||
delegate option -variable to label as -textvariable |
||||
delegate option * to hull |
||||
|
||||
|
||||
option -orient horizontal |
||||
option -rows {1} |
||||
option -columns {} |
||||
option -values [list] |
||||
option -command [list] |
||||
|
||||
|
||||
variable radioVariable; # for the radio button. |
||||
|
||||
# Construct the widget. |
||||
|
||||
constructor args { |
||||
|
||||
# The buttons go in a frame just to make it easy to lay them out.: |
||||
|
||||
set bf [frame $win.buttons] |
||||
install label using label $win.label |
||||
|
||||
# Process the configuration. |
||||
|
||||
$self configurelist $args |
||||
|
||||
|
||||
# Ensure that the option constraints are met. |
||||
|
||||
$self errorIfConstraintsNotMet |
||||
|
||||
# If the values have not been provided, then use the rows/columns |
||||
# to simluate them. |
||||
|
||||
if {$options(-values) eq ""} { |
||||
set totalValues [expr $options(-columns) * $options(-rows)] |
||||
for {set i 0} {$i < $totalValues} {incr i} { |
||||
lappend options(-values) $i |
||||
} |
||||
} |
||||
|
||||
# Top level layout decision based on orientation. |
||||
|
||||
if {$options(-orient) eq "horizontal"} { |
||||
$self arrangeHorizontally |
||||
} elseif {$options(-orient) eq "vertical"} { |
||||
$self arrangeVertically |
||||
} else { |
||||
error "Invalid -orient value: $options(-orient)" |
||||
} |
||||
|
||||
grid $bf |
||||
grid $win.label |
||||
|
||||
# If the label has a text variable evaluate it to see |
||||
# if we can do a set with it: |
||||
|
||||
set labelvar [$win.label cget -textvariable] |
||||
if {$labelvar ne ""} { |
||||
$self Set [set ::$labelvar] |
||||
} |
||||
bindDown $win $win |
||||
} |
||||
|
||||
# Public methods: |
||||
|
||||
method get {} { |
||||
return $radioVariable |
||||
} |
||||
method set value { |
||||
|
||||
set radioVariable $value |
||||
|
||||
} |
||||
|
||||
|
||||
# Private methods and procs. |
||||
|
||||
# Ensure the constraints on the options are met. |
||||
|
||||
method errorIfConstraintsNotMet {} { |
||||
if {$options(-values) eq "" && |
||||
($options(-rows) eq "" || $options(-columns) eq "")} { |
||||
error "If -values is not supplied, but -rows and -coumns must be." |
||||
} |
||||
if {($options(-rows) ne "" && $options(-columns) ne "") && |
||||
$options(-values) ne ""} { |
||||
error "If both -rows and -coumns were supplied, -values cannot be" |
||||
} |
||||
} |
||||
|
||||
|
||||
# Process radio button change. |
||||
# |
||||
method onChange {} { |
||||
set script $options(-command) |
||||
if {$script ne ""} { |
||||
eval $script |
||||
} |
||||
} |
||||
# Manage horizontal layout |
||||
|
||||
method arrangeHorizontally {} { |
||||
# |
||||
# Either both rows and columns are defined, or |
||||
# one is defined and the other must be computed from the |
||||
# length of the values list (which by god was defined). |
||||
# If both are defined, values was computed from them. |
||||
|
||||
set rows $options(-rows) |
||||
set cols $options(-columns) |
||||
|
||||
# Only really need # of cols. |
||||
|
||||
set len [llength $options(-values)] |
||||
if {$cols eq ""} { |
||||
set cols [expr ($len + $rows - 1)/$rows] |
||||
} |
||||
set index 0 |
||||
set rowNum 0 |
||||
|
||||
while {$index < $len} { |
||||
for {set i 0} {$i < $cols} {incr i} { |
||||
if {$index >= $len} { |
||||
break |
||||
} |
||||
set item [lindex $options(-values) $index] |
||||
|
||||
if {[llength $item] > 1} { |
||||
set label [lindex $item 0] |
||||
set value [lindex $item 1] |
||||
} else { |
||||
set value [lindex $item 0] |
||||
set label $value |
||||
} |
||||
radiobutton $win.buttons.cb$index \ |
||||
-command [mymethod onChange] \ |
||||
-variable ${selfns}::radioVariable \ |
||||
-value $value -text $label |
||||
grid $win.buttons.cb$index -row $rowNum -column $i |
||||
incr index |
||||
} |
||||
incr rowNum |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# manage vertical layout |
||||
|
||||
method arrangeVertically {} { |
||||
# |
||||
# See arrangeHorizontally for the overall picture, just swap cols |
||||
# and rows. |
||||
|
||||
set rows $options(-rows) |
||||
set cols $options(-columns) |
||||
|
||||
set len [llength $options(-values)] |
||||
if {$rows eq ""} { |
||||
set rows [expr ($len + $cols -1)/$cols] |
||||
} |
||||
set index 0 |
||||
set colNum 0 |
||||
while {$index < $len} { |
||||
for {set i 0} {$i < $rows} {incr i} { |
||||
if {$index >= $len} { |
||||
break |
||||
} |
||||
set item [lindex $options(-values) $index] |
||||
if {[llength $item] > 1} { |
||||
set label [lindex $item 0] |
||||
set value [lindex $item 1] |
||||
} else { |
||||
set value [lindex $item 0] |
||||
set label $value |
||||
} |
||||
|
||||
radiobutton $win.buttons.cb$index \ |
||||
-command [mymethod onChange] \ |
||||
-variable ${selfns}::radioVariable \ |
||||
-value $value -text $label |
||||
grid $win.buttons.cb$index -row $i -column $colNum |
||||
incr index |
||||
} |
||||
incr colNum |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,455 @@
|
||||
# rdial.tcl -- |
||||
# Rotated dial widget, part of controlwidget package |
||||
# |
||||
# Contents: a "rotated" dial widget or thumbnail "roller" dial |
||||
# Date: Son May 23, 2010 |
||||
# |
||||
# Abstract |
||||
# A mouse draggable "dial" widget from the side view - visible |
||||
# is the knurled area - Shift & Ctrl changes the sensitivity |
||||
# |
||||
# Copyright (c) Gerhard Reithofer, Tech-EDV 2010-05 |
||||
# |
||||
# Adjusted for Tklib (snitified) by Arjen Markus |
||||
# |
||||
# The author hereby grant permission to use, copy, modify, distribute, |
||||
# and license this software and its documentation for any purpose, |
||||
# provided that existing copyright notices are retained in all copies |
||||
# and that this notice is included verbatim in any distributions. No |
||||
# written agreement, license, or royalty fee is required for any of the |
||||
# authorized uses. Modifications to this software may be copyrighted by |
||||
# their authors and need not follow the licensing terms described here, |
||||
# provided that the new terms are clearly indicated on the first page of |
||||
# each file where they apply. |
||||
# |
||||
# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY |
||||
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES |
||||
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY |
||||
# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAVE BEEN ADVISED OF THE |
||||
# POSSIBILITY OF SUCH DAMAGE. |
||||
# |
||||
# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, |
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF |
||||
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND |
||||
# NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, |
||||
# AND THE AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE |
||||
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. |
||||
# |
||||
# Original syntax: |
||||
# |
||||
# Syntax: |
||||
# rdial::create w ?-width wid? ?-height hgt? ?-value floatval? |
||||
# ?-bg|-background bcol? ?-fg|-foreground fcol? ?-step step? |
||||
# ?-callback script? ?-scale "degrees"|"radians"|factor? |
||||
# ?-slow sfact? ?-fast ffact? ?-orient "horizontal"|"vertical"? |
||||
# ?-variable varname? ?-bindwheel step? |
||||
# |
||||
# History: |
||||
# 20100526: -scale option added |
||||
# 20100626: incorrect "rotation direction" in vertical mode repaired |
||||
# 20100704: added -variable option and methods get and set (AM) |
||||
# 20101020: bug {[info exists ...]<0} => {![info exists ...]} repaired |
||||
# 20101112: drag: set opt(-value) depending on scale - thank's Manfred R. |
||||
# 20101118: -variable option added |
||||
# 20170518: -bindwheel option added for scrollwheel input |
||||
# 20170523: boolean variable buttonwheel controls Button/Wheel binding. |
||||
# if false the <BindWheel> event is used (by default in Windows), |
||||
# the event <ButtonPress-4/5> if it is false (other systems). |
||||
# |
||||
# Todo: |
||||
# option -variable -- conflicts with -value |
||||
# methods get and set |
||||
# |
||||
|
||||
package require Tk 8.5- |
||||
package require snit |
||||
|
||||
namespace eval controlwidget { |
||||
namespace export rdial |
||||
} |
||||
|
||||
# rdial -- |
||||
# Rotated dial widget |
||||
# |
||||
snit::widget controlwidget::rdial { |
||||
|
||||
# |
||||
# widget default values |
||||
# |
||||
option -bg -default "#dfdfdf" -configuremethod SetOption |
||||
option -background -default "#dfdfdf" -configuremethod SetOption |
||||
option -fg -default "black" -configuremethod SetOption |
||||
option -foreground -default "black" -configuremethod SetOption |
||||
option -callback -default "" |
||||
option -orient -default horizontal |
||||
option -width -default 80 -configuremethod SetOption |
||||
option -height -default 8 -configuremethod SetOption |
||||
option -step -default 10 |
||||
option -value -default 0.0 -configuremethod SetOption |
||||
option -slow -default 0.1 |
||||
option -fast -default 10 |
||||
option -scale -default 1.0 -configuremethod SetOption |
||||
option -variable -default {} -configuremethod VariableName |
||||
option -bindwheel -default 2.0 -configuremethod SetOption |
||||
|
||||
variable d2r |
||||
variable sfact |
||||
variable ssize |
||||
variable ovalue |
||||
variable sector 88 |
||||
variable callback |
||||
variable buttonwheel 1 |
||||
variable wheelfactor 15.0 |
||||
|
||||
|
||||
constructor args { |
||||
|
||||
# I did not find a platform independent method :-( |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set buttonwheel 0 |
||||
} |
||||
|
||||
# |
||||
# A few constants to reduce expr |
||||
# |
||||
set d2r [expr {atan(1.0)/45.0}] |
||||
set ssize [expr {sin($sector*$d2r)}] |
||||
|
||||
# |
||||
# Now initialise the widget |
||||
# |
||||
$self configurelist $args |
||||
|
||||
canvas $win.c \ |
||||
-background $options(-background) |
||||
|
||||
grid $win.c -sticky nsew |
||||
|
||||
set wid $options(-width) |
||||
set hgt $options(-height) |
||||
set bgc $options(-background) |
||||
|
||||
# canvas dimensions and bindings |
||||
if {$options(-orient) eq "horizontal"} { |
||||
$win.c configure -width $wid -height $hgt |
||||
# standard bindings |
||||
bind $win.c <ButtonPress-1> [list $self SetVar ovalue %x] |
||||
bind $win.c <B1-Motion> [list $self drag %W %x 0] |
||||
bind $win.c <ButtonRelease-1> [list $self drag %W %x 0] |
||||
# course movement |
||||
bind $win.c <Shift-ButtonPress-1> [list $self SetVar ovalue %x] |
||||
bind $win.c <Shift-B1-Motion> [list $self drag %W %x 1] |
||||
bind $win.c <Shift-ButtonRelease-1> [list $self drag %W %x 1] |
||||
# fine movement |
||||
bind $win.c <Control-ButtonPress-1> [list $self SetVar ovalue %x] |
||||
bind $win.c <Control-B1-Motion> [list $self drag %W %x -1] |
||||
bind $win.c <Control-ButtonRelease-1> [list $self drag %W %x -1] |
||||
} else { |
||||
$win.c configure -width $hgt -height $wid |
||||
# standard binding |
||||
bind $win.c <ButtonPress-1> [list $self SetVar ovalue %y] |
||||
bind $win.c <B1-Motion> [list $self drag %W %y 0] |
||||
bind $win.c <ButtonRelease-1> [list $self drag %W %y 0] |
||||
# course movement |
||||
bind $win.c <Shift-ButtonPress-1> [list $self SetVar ovalue %y] |
||||
bind $win.c <Shift-B1-Motion> [list $self drag %W %y 1] |
||||
bind $win.c <Shift-ButtonRelease-1> [list $self drag %W %y 1] |
||||
# fine movement |
||||
bind $win.c <Control-ButtonPress-1> [list $self SetVar ovalue %y] |
||||
bind $win.c <Control-B1-Motion> [list $self drag %W %y -1] |
||||
bind $win.c <Control-ButtonRelease-1> [list $self drag %W %y -1] |
||||
} |
||||
if {$options(-bindwheel) != 0} { |
||||
if {$buttonwheel} { |
||||
set up $options(-bindwheel) |
||||
set dn [expr {0.0 - $up}] |
||||
# standard binding |
||||
bind $win.c <ButtonPress-4> [list $self roll %W $up 0] |
||||
bind $win.c <ButtonPress-5> [list $self roll %W $dn 0] |
||||
# course movement |
||||
bind $win.c <Shift-ButtonPress-4> [list $self roll %W $up 1] |
||||
bind $win.c <Shift-ButtonPress-5> [list $self roll %W $dn 1] |
||||
# fine movement |
||||
bind $win.c <Control-ButtonPress-4> [list $self roll %W $up -1] |
||||
bind $win.c <Control-ButtonPress-5> [list $self roll %W $dn -1] |
||||
} else { |
||||
# it seem that Shift+Control doesn't work :-( |
||||
bind $win.c <MouseWheel> [list $self roll %W %D 0] |
||||
bind $win.c <Shift-MouseWheel> [list $self roll %W %D 1] |
||||
bind $win.c <Control-MouseWheel> [list $self roll %W %D -1] |
||||
} |
||||
} |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
if { [info exists ::$options(-variable)] } { |
||||
set options(-value) [set ::$options(-variable)] |
||||
} else { |
||||
set ::options(-variable) [expr {$options(-value)*$options(-scale)}] |
||||
} |
||||
|
||||
trace add variable ::$options(-variable) write [mymethod variableChanged] |
||||
} |
||||
|
||||
# draw insides |
||||
$self draw $win.c $options(-value) |
||||
} |
||||
|
||||
# |
||||
# public methods -- |
||||
# |
||||
|
||||
method set {newValue} { |
||||
if { $options(-variable) != "" } { |
||||
set ::$options(-variable) $newValue ;#! This updates the dial too |
||||
} else { |
||||
set options(-value) $newValue |
||||
$self draw $win.c $options(-value) |
||||
} |
||||
} |
||||
method get {} { |
||||
return $options(-value) |
||||
} |
||||
|
||||
# |
||||
# private methods -- |
||||
# |
||||
|
||||
# store some private variable |
||||
method SetVar {var value} { |
||||
set $var $value |
||||
} |
||||
|
||||
# configure method - write only |
||||
method SetOption {option arg} { |
||||
switch -- $option { |
||||
"-bg" {set option "-background"} |
||||
"-fg" {set option "-foreground"} |
||||
"-scale" { |
||||
switch -glob -- $arg { |
||||
"d*" {set arg 1.0} |
||||
"r*" {set arg $d2r} |
||||
} |
||||
# numeric check |
||||
set arg [expr {$arg*1.0}] |
||||
} |
||||
"-value" { |
||||
set arg [expr {$arg/$options(-scale)}] |
||||
} |
||||
"-height" { |
||||
if { [winfo exists $win.c] } { |
||||
$win.c configure $option $arg |
||||
} |
||||
} |
||||
"-width" { |
||||
if { [winfo exists $win.c] } { |
||||
$win.c configure $option $arg |
||||
} |
||||
# sfact depends on width |
||||
set sfact [expr {$ssize*2/$arg}] |
||||
} |
||||
} |
||||
set options($option) $arg |
||||
|
||||
if { [winfo exists $win.c] } { |
||||
$self draw $win.c $options(-value) |
||||
} |
||||
} |
||||
|
||||
method VariableName {option name} { |
||||
|
||||
# Could be still constructing in which case |
||||
# $win.c does not exist: |
||||
|
||||
if {![winfo exists $win.c]} { |
||||
set options(-variable) $name |
||||
return; |
||||
} |
||||
|
||||
# Remove any old traces |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
trace remove variable ::$options(-variable) write [mymethod variableChanged] |
||||
} |
||||
|
||||
# Set new trace if appropriate and update value. |
||||
|
||||
set options(-variable) $name |
||||
if {$options(-variable) ne ""} { |
||||
trace add variable ::$options(-variable) write [mymethod variableChanged] |
||||
$self draw $win.c [set ::$options(-variable)] |
||||
} |
||||
} |
||||
|
||||
method variableChanged {name1 name2 op} { |
||||
|
||||
set options(-value) [expr {[set ::$options(-variable)]/$options(-scale)}] |
||||
$self draw $win.c [set ::$options(-variable)] |
||||
|
||||
if { $options(-callback) ne "" } { |
||||
{*}$options(-callback) [expr {$options(-value)*$options(-scale)}] |
||||
} |
||||
} |
||||
|
||||
|
||||
# cget method |
||||
proc GetOption {option} { |
||||
if { $option eq "-value" } { |
||||
return [expr {$options(-value)*$options(-scale)}] |
||||
} else { |
||||
return $options(-value) |
||||
} |
||||
} |
||||
|
||||
# draw the thumb wheel view |
||||
method draw {w val} { |
||||
|
||||
set stp $options(-step) |
||||
set wid $options(-width) |
||||
set hgt $options(-height) |
||||
set dfg $options(-foreground) |
||||
set dbg $options(-background) |
||||
|
||||
$win.c delete all |
||||
if {$options(-orient) eq "horizontal"} { |
||||
# every value is mapped to the visible sector |
||||
set mod [expr {$val-$sector*int($val/$sector)}] |
||||
$win.c create rectangle 0 0 $wid $hgt -fill $dbg |
||||
# from normalized value to left end |
||||
for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} { |
||||
set offs [expr {($ssize+sin($ri*$d2r))/$sfact}] |
||||
$win.c create line $offs 0 $offs $hgt -fill $dfg |
||||
} |
||||
# from normalized value to right end |
||||
for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} { |
||||
set offs [expr {($ssize+sin($ri*$d2r))/$sfact}] |
||||
$win.c create line $offs 0 $offs $hgt -fill $dfg |
||||
} |
||||
} else { |
||||
# every value is mapped to the visible sector |
||||
set mod [expr {$sector*int($val/$sector)-$val}] |
||||
$win.c create rectangle 0 0 $hgt $wid -fill $dbg |
||||
# from normalized value to upper end |
||||
for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} { |
||||
set offs [expr {($ssize+sin($ri*$d2r))/$sfact}] |
||||
$win.c create line 0 $offs $hgt $offs -fill $dfg |
||||
} |
||||
# from normalized value to lower end |
||||
for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} { |
||||
set offs [expr {($ssize+sin($ri*$d2r))/$sfact}] |
||||
$win.c create line 0 $offs $hgt $offs -fill $dfg |
||||
} |
||||
} |
||||
# let's return the widget/canvas |
||||
set options(-value) $val |
||||
} |
||||
|
||||
# update rdials after value change |
||||
method rdupdate {w diff} { |
||||
# calculate "new" calue |
||||
set options(-value) [expr {$options(-value)+$diff*$options(-scale)}] |
||||
|
||||
# call callback if defined... |
||||
if {$options(-callback) ne ""} { |
||||
{*}$options(-callback) $options(-value) |
||||
} |
||||
|
||||
# draw knob with new angle |
||||
$self draw $w $options(-value) |
||||
} |
||||
|
||||
# change by mouse dragging |
||||
method drag {w coord mode} { |
||||
variable ovalue |
||||
|
||||
# calculate new value |
||||
if {$options(-orient) eq "horizontal"} { |
||||
set diff [expr {$coord-$ovalue}] |
||||
} else { |
||||
set diff [expr {$ovalue-$coord}] |
||||
} |
||||
if {$mode<0} { |
||||
set diff [expr {$diff*$options(-slow)}] |
||||
} elseif {$mode>0} { |
||||
set diff [expr {$diff*$options(-fast)}] |
||||
} |
||||
$self rdupdate $w $diff |
||||
|
||||
# store "old" value for diff |
||||
set ovalue $coord |
||||
} |
||||
|
||||
# change by mouse wheel |
||||
method roll {w diff mode} { |
||||
|
||||
if {! $buttonwheel} { |
||||
set diff [expr {$diff/$wheelfactor/$options(-bindwheel)}] |
||||
} |
||||
if {$mode<0} { |
||||
set diff [expr {$diff*$options(-slow)}] |
||||
} elseif {$mode>0} { |
||||
set diff [expr {$diff*$options(-fast)}] |
||||
} |
||||
$self rdupdate $w $diff |
||||
} |
||||
} |
||||
|
||||
# Announce our presence |
||||
package provide rdial 0.7 |
||||
|
||||
#-------- test & demo ... disable it for package autoloading -> {0} |
||||
if {0} { |
||||
if {[info script] eq $argv0} { |
||||
array set disp_value {rs -30.0 rh 120.0 rv 10.0} |
||||
proc rndcol {} { |
||||
set col "#" |
||||
for {set i 0} {$i<3} {incr i} { |
||||
append col [format "%02x" [expr {int(rand()*230)+10}]] |
||||
} |
||||
return $col |
||||
} |
||||
proc set_rand_col {} { |
||||
.rs configure -fg [rndcol] -bg [rndcol] |
||||
} |
||||
proc show_value {which v} { |
||||
set val [.$which cget -value] |
||||
set ::disp_value($which) [format "%.1f" $val] |
||||
switch -- $which { |
||||
"rh" { |
||||
if {abs($val)<30} return |
||||
.rs configure -width [expr {abs($val)}] |
||||
} |
||||
"rv" { |
||||
if {abs($val)<5} return |
||||
.rs configure -height [expr {abs($val)}] |
||||
} |
||||
"rs" { |
||||
if {!(int($val)%10)} set_rand_col |
||||
} |
||||
} |
||||
} |
||||
set help "Use mouse button with Shift &" |
||||
append help "\nControl for dragging the dials" |
||||
append help "\nwith Mouswheel support" |
||||
label .lb -text $help |
||||
label .lv -textvariable disp_value(rv) |
||||
controlwidget::rdial .rv -callback {show_value rv} -value $disp_value(rv)\ |
||||
-width 200 -step 5 -bg blue -fg white \ |
||||
-variable score -bindwheel -10.0 |
||||
label .lh -textvariable disp_value(rh) |
||||
controlwidget::rdial .rh -callback {show_value rh} -value $disp_value(rh)\ |
||||
-width $disp_value(rh) -height 20 -fg blue -bg yellow -orient vertical |
||||
label .ls -textvariable disp_value(rs) |
||||
controlwidget::rdial .rs -callback {show_value rs} -value $disp_value(rs)\ |
||||
-width $disp_value(rh) -height $disp_value(rv) |
||||
pack {*}[winfo children .] |
||||
wm minsize . 220 300 |
||||
|
||||
after 2000 { |
||||
set ::score 0.0 |
||||
} |
||||
after 3000 { |
||||
set ::score 100.0 |
||||
.rh set 3 |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,389 @@
|
||||
# tachometer.tcl -- |
||||
# |
||||
# Adapted by Arjen Markus (snitified), july 2010 |
||||
# |
||||
# TODO: |
||||
# motion through the start and end - it can jump through the gap |
||||
# scaling (scale widget) |
||||
# deal with sizes of the widget (aspect ratio != 1) |
||||
# |
||||
# |
||||
# Part of: The TCL'ers Wiki |
||||
# Contents: a tachometer-like widget |
||||
# Date: Fri Jun 13, 2003 |
||||
# |
||||
# Abstract |
||||
# |
||||
# |
||||
# |
||||
# Copyright (c) 2003 Marco Maggi |
||||
# |
||||
# The author hereby grant permission to use, copy, modify, distribute, |
||||
# and license this software and its documentation for any purpose, |
||||
# provided that existing copyright notices are retained in all copies |
||||
# and that this notice is included verbatim in any distributions. No |
||||
# written agreement, license, or royalty fee is required for any of the |
||||
# authorized uses. Modifications to this software may be copyrighted by |
||||
# their authors and need not follow the licensing terms described here, |
||||
# provided that the new terms are clearly indicated on the first page of |
||||
# each file where they apply. |
||||
# |
||||
# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY |
||||
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES |
||||
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY |
||||
# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAVE BEEN ADVISED OF THE |
||||
# POSSIBILITY OF SUCH DAMAGE. |
||||
# |
||||
# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, |
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF |
||||
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND |
||||
# NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, |
||||
# AND THE AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE |
||||
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. |
||||
# |
||||
# $Id: tachometer.tcl,v 1.4 2010/09/10 17:16:29 andreas_kupries Exp $ |
||||
# |
||||
|
||||
package require Tk 8.5- |
||||
package require snit |
||||
package provide tachometer 0.1 |
||||
|
||||
namespace eval controlwidget { |
||||
namespace export tachometer |
||||
} |
||||
|
||||
# tachometer -- |
||||
# Tachometer-like widget |
||||
# |
||||
snit::widget controlwidget::tachometer { |
||||
|
||||
# |
||||
# widget default values |
||||
# |
||||
option -borderwidth -default 1 |
||||
option -title -default speed |
||||
option -labels -default {} |
||||
option -resolution -default 1 |
||||
option -showvalue -default 1 |
||||
option -variable -default {} -configuremethod VariableName |
||||
|
||||
option -min -default 0.0 |
||||
option -max -default 100.0 |
||||
option -dangerlevel -default 90.0 |
||||
option -dangercolor -default red |
||||
option -dangerwidth -default 3m |
||||
option -dialcolor -default white |
||||
option -pincolor -default red |
||||
option -indexid -default {} |
||||
|
||||
option -background -default gray |
||||
option -width -default 50m |
||||
option -height -default 50m |
||||
option -foreground -default black |
||||
option -highlightthickness -default 0 |
||||
option -relief -default raised |
||||
|
||||
variable pi [expr {3.14159265359/180.0}] |
||||
variable xc |
||||
variable yc |
||||
variable motion |
||||
|
||||
constructor args { |
||||
|
||||
# |
||||
# Configure the widget |
||||
# |
||||
$self configurelist $args |
||||
|
||||
canvas $win.c -background $options(-background) -width $options(-width) -height $options(-height) \ |
||||
-relief $options(-relief) -borderwidth $options(-borderwidth) |
||||
grid $win.c -sticky news |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
} |
||||
|
||||
# |
||||
# Draw the tachometer |
||||
# |
||||
set width [$win.c cget -width] |
||||
set height [$win.c cget -height] |
||||
set num [llength $options(-labels)] |
||||
set delta [expr {(360.0-40.0)/($num-1)}] |
||||
|
||||
# display |
||||
set x1 [expr {$width/50.0*2.0}] |
||||
set y1 [expr {$width/50.0*2.0}] |
||||
set x2 [expr {$width/50.0*48.0}] |
||||
set y2 [expr {$width/50.0*48.0}] |
||||
$win.c create oval $x1 $y1 $x2 $y2 -fill $options(-dialcolor) -width 1 -outline lightgray |
||||
shadowcircle $win.c $x1 $y1 $x2 $y2 40 0.7m 135.0 |
||||
|
||||
# pin |
||||
set x1 [expr {$width/50.0*23.0}] |
||||
set y1 [expr {$width/50.0*23.0}] |
||||
set x2 [expr {$width/50.0*27.0}] |
||||
set y2 [expr {$width/50.0*27.0}] |
||||
$win.c create oval $x1 $y1 $x2 $y2 -width 1 -outline lightgray -fill $options(-pincolor) |
||||
shadowcircle $win.c $x1 $y1 $x2 $y2 40 0.7m -45.0 |
||||
|
||||
# danger marker |
||||
if { $options(-dangerlevel) != {} && $options(-dangerlevel) < $options(-max)} { |
||||
|
||||
set deltadanger [expr {(360.0-40.0)*($options(-max)-$options(-dangerlevel))/(1.0*$options(-max)-$options(-min))}] |
||||
|
||||
# Transform the thickness into a plain number (if given in mm for instance) |
||||
set id [$win.c create line 0 0 1 0] |
||||
$win.c move $id $options(-dangerwidth) 0 |
||||
set coords [$win.c coords $id] |
||||
set thickness [expr {[lindex $coords 0]/2.0}] |
||||
$win.c delete $id |
||||
|
||||
# Create the arc for the danger level |
||||
$win.c create arc \ |
||||
[expr {$width/50.0*4.0+$thickness}] [expr {$width/50.0*4.0+$thickness}] \ |
||||
[expr {$width/50.0*46.0-$thickness}] [expr {$width/50.0*46.0-$thickness}] \ |
||||
-start -70 -extent $deltadanger -style arc \ |
||||
-outline $options(-dangercolor) -fill $options(-dangercolor) -width $options(-dangerwidth) |
||||
} |
||||
|
||||
# graduate line |
||||
set x1 [expr {$width/50.0*4.0}] |
||||
set y1 [expr {$width/50.0*4.0}] |
||||
set x2 [expr {$width/50.0*46.0}] |
||||
set y2 [expr {$width/50.0*46.0}] |
||||
$win.c create arc $x1 $y1 $x2 $y2 \ |
||||
-start -70 -extent 320 -style arc \ |
||||
-outline black -width 0.5m |
||||
set xc [expr {($x2+$x1)/2.0}] |
||||
set yc [expr {($y2+$y1)/2.0}] |
||||
|
||||
set motion 0 |
||||
bind $win.c <ButtonRelease> [list $self needleRelease %W] |
||||
bind $win.c <Motion> [list $self needleMotion %W %x %y] |
||||
|
||||
set half [expr {$width/2.0}] |
||||
set l1 [expr {$half*0.85}] |
||||
set l2 [expr {$half*0.74}] |
||||
set l3 [expr {$half*0.62}] |
||||
|
||||
set angle 110.0 |
||||
for {set i 0} {$i < $num} {incr i} \ |
||||
{ |
||||
set a [expr {($angle+$delta*$i)*$pi}] |
||||
|
||||
set x1 [expr {$half+$l1*cos($a)}] |
||||
set y1 [expr {$half+$l1*sin($a)}] |
||||
set x2 [expr {$half+$l2*cos($a)}] |
||||
set y2 [expr {$half+$l2*sin($a)}] |
||||
$win.c create line $x1 $y1 $x2 $y2 -fill black -width 0.5m |
||||
|
||||
set x1 [expr {$half+$l3*cos($a)}] |
||||
set y1 [expr {$half+$l3*sin($a)}] |
||||
|
||||
set label [lindex $options(-labels) $i] |
||||
if { [string length $label] } \ |
||||
{ |
||||
$win.c create text $x1 $y1 \ |
||||
-anchor center -justify center -fill black \ |
||||
-text $label -font { Helvetica 10 } |
||||
} |
||||
} |
||||
|
||||
rivet $win.c 10 10 |
||||
rivet $win.c [expr {$width-10}] 10 |
||||
rivet $win.c 10 [expr {$height-10}] |
||||
rivet $win.c [expr {$width-10}] [expr {$height-10}] |
||||
|
||||
set value 0 |
||||
$self drawline $win $value |
||||
} |
||||
|
||||
method destructor { widget } \ |
||||
{ |
||||
set varname [option get $widget varname {}] |
||||
trace remove variable $varname write \ |
||||
[namespace code "tracer $widget $varname"] |
||||
} |
||||
|
||||
# |
||||
# public methods -- |
||||
# |
||||
method set {newValue} { |
||||
if { $options(-variable) != "" } { |
||||
set ::$options(-variable) $newValue ;#! This updates the dial too |
||||
} else { |
||||
set options(-value) $newValue |
||||
$self draw $win.c $options(-value) |
||||
} |
||||
} |
||||
method get {} { |
||||
return $options(-value) |
||||
} |
||||
|
||||
|
||||
# |
||||
# private methods -- |
||||
# |
||||
|
||||
method VariableName {option name} { |
||||
|
||||
# Could be still constructing in which case |
||||
# $win.c does not exist: |
||||
|
||||
if {![winfo exists $win.c]} { |
||||
set options(-variable) $name |
||||
return; |
||||
} |
||||
|
||||
# Remove any old traces |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
trace remove variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
} |
||||
|
||||
# Set new trace if appropriate and update value. |
||||
|
||||
set options(-variable) $name |
||||
if {$options(-variable) ne ""} { |
||||
trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
$self drawline $win.c [set ::$options(-variable)] |
||||
} |
||||
} |
||||
method tracer { varname args } \ |
||||
{ |
||||
set options(-value) [set ::$varname] |
||||
$self drawline $win [set ::$varname] |
||||
} |
||||
|
||||
method drawline { widget value } \ |
||||
{ |
||||
set c $widget.c |
||||
|
||||
set min $options(-min) |
||||
set max $options(-max) |
||||
set id $options(-indexid) |
||||
|
||||
set v [expr { ($value <= ($max*1.02))? $value : ($max*1.02) }] |
||||
set angle [expr {((($v-$min)/($max-$min))*320.0+20.0)*$pi}] |
||||
|
||||
set width [$c cget -width] |
||||
set half [expr {$width/2.0}] |
||||
set length [expr {$half*0.8}] |
||||
|
||||
set xl [expr {$half-$length*sin($angle)}] |
||||
set yl [expr {$half+$length*cos($angle)}] |
||||
|
||||
set xs [expr {$half+0.2*$length*sin($angle)}] |
||||
set ys [expr {$half-0.2*$length*cos($angle)}] |
||||
|
||||
catch {$c delete $id} |
||||
set id [$c create line $xs $ys $xl $yl -fill $options(-pincolor) -width 0.6m] |
||||
$c bind $id <ButtonPress> [list $self needlePress %W] |
||||
set options(-indexid) $id |
||||
} |
||||
|
||||
method needlePress {w} \ |
||||
{ |
||||
set motion 1 |
||||
} |
||||
|
||||
method needleRelease {w} \ |
||||
{ |
||||
set motion 0 |
||||
} |
||||
|
||||
method needleMotion {w x y} \ |
||||
{ |
||||
if {! $motion} { return } |
||||
if {$y == $yc && $x == $xc} { return } |
||||
|
||||
# |
||||
# Compute the angle with the positive y-axis - easier to examine! |
||||
# |
||||
set angle [expr {atan2($xc - $x,$yc - $y) / $pi}] |
||||
if { $angle >= 160.0 } { |
||||
set angle 160.0 |
||||
} |
||||
if { $angle < -160.0 } { |
||||
set angle -160.0 |
||||
} |
||||
set ::$options(-variable) [expr {$options(-min) + ($options(-max)-$options(-min))*(160.0-$angle) / 320.0}] |
||||
} |
||||
|
||||
proc rivet { c xc yc } \ |
||||
{ |
||||
set width 5 |
||||
set bevel 0.5m |
||||
set angle -45.0 |
||||
set ticks 7 |
||||
shadowcircle $c \ |
||||
[expr {$xc-$width}] [expr {$yc-$width}] [expr {$xc+$width}] [expr {$yc+$width}] \ |
||||
$ticks $bevel $angle |
||||
} |
||||
|
||||
proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } \ |
||||
{ |
||||
set angle $orient |
||||
set delta [expr {180.0/$ticks}] |
||||
for {set i 0} {$i <= $ticks} {incr i} \ |
||||
{ |
||||
set a [expr {($angle+$i*$delta)}] |
||||
set b [expr {($angle-$i*$delta)}] |
||||
|
||||
set color [expr {40+$i*(200/$ticks)}] |
||||
set color [format "#%x%x%x" $color $color $color] |
||||
|
||||
$canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \ |
||||
-style arc -outline $color -width $width |
||||
$canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \ |
||||
-style arc -outline $color -width $width |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {0} { |
||||
# main -- |
||||
# Demonstration of the tachometer object |
||||
# |
||||
proc main { argc argv } \ |
||||
{ |
||||
global forever |
||||
|
||||
wm withdraw . |
||||
wm title . "A tachometer-like widget" |
||||
wm geometry . +10+10 |
||||
|
||||
controlwidget::tachometer .t1 -variable ::value1 -labels { 0 10 20 30 40 50 60 70 80 90 100 } \ |
||||
-pincolor green -dialcolor lightpink |
||||
scale .s1 -command "set ::value1" -variable ::value1 |
||||
|
||||
# |
||||
# Note: the labels are not used in the scaling of the values |
||||
# |
||||
controlwidget::tachometer .t2 -variable ::value2 -labels { 0 {} {} 5 {} {} 10 } -width 100m -height 100m \ |
||||
-min 0 -max 10 -dangerlevel 3 |
||||
scale .s2 -command "set ::value2" -variable ::value2 -from 0 -to 10 |
||||
|
||||
button .b -text Quit -command "set ::forever 1" |
||||
|
||||
grid .t1 .s1 .t2 .s2 .b -padx 2 -pady 2 |
||||
wm deiconify . |
||||
|
||||
console show |
||||
|
||||
|
||||
vwait forever |
||||
#tachometer::destructor .t1 |
||||
#tachometer::destructor .t2 |
||||
exit 0 |
||||
} |
||||
|
||||
main $argc $argv |
||||
} |
||||
|
||||
### end of file |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# page-delimiter: "^#PAGE" |
||||
# End: |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,347 @@
|
||||
# voltmeter.tcl -- |
||||
# |
||||
# Adapted by Arjen Markus (snitified), july 2010 |
||||
# |
||||
# |
||||
# |
||||
# |
||||
# Part of: The TCL'ers Wiki |
||||
# Contents: a voltmeter-like widget |
||||
# Date: Fri Jun 13, 2003 |
||||
# |
||||
# Abstract |
||||
# |
||||
# |
||||
# |
||||
# Copyright (c) 2003 Marco Maggi |
||||
# |
||||
# The author hereby grant permission to use, copy, modify, distribute, |
||||
# and license this software and its documentation for any purpose, |
||||
# provided that existing copyright notices are retained in all copies |
||||
# and that this notice is included verbatim in any distributions. No |
||||
# written agreement, license, or royalty fee is required for any of the |
||||
# authorized uses. Modifications to this software may be copyrighted by |
||||
# their authors and need not follow the licensing terms described here, |
||||
# provided that the new terms are clearly indicated on the first page of |
||||
# each file where they apply. |
||||
# |
||||
# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY |
||||
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES |
||||
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY |
||||
# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAVE BEEN ADVISED OF THE |
||||
# POSSIBILITY OF SUCH DAMAGE. |
||||
# |
||||
# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, |
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF |
||||
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND |
||||
# NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, |
||||
# AND THE AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE |
||||
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. |
||||
# |
||||
# $Id: voltmeter.tcl,v 1.3 2010/09/10 17:16:29 andreas_kupries Exp $ |
||||
# |
||||
|
||||
package require Tk 8.5- |
||||
package require snit |
||||
package provide voltmeter 0.1 |
||||
|
||||
namespace eval controlwidget { |
||||
namespace export voltmeter |
||||
} |
||||
|
||||
# voltmeter -- |
||||
# Voltmeter-like widget |
||||
# |
||||
snit::widget controlwidget::voltmeter { |
||||
|
||||
# |
||||
# widget default values |
||||
# |
||||
option -borderwidth -default 1 |
||||
option -background -default gray |
||||
option -dialcolor -default white |
||||
option -needlecolor -default black |
||||
option -scalecolor -default black |
||||
option -indexid -default {} |
||||
|
||||
option -variable -default {} -configuremethod VariableName |
||||
option -min -default 0.0 |
||||
option -max -default 100.0 |
||||
option -labelcolor -default black |
||||
option -titlecolor -default black |
||||
option -labelfont -default {Helvetica 8} |
||||
option -titlefont -default {Helvetica 9} |
||||
option -labels -default {} |
||||
option -title -default {} |
||||
option -width -default 50m |
||||
option -height -default 25m |
||||
option -highlightthickness -default 0 |
||||
option -relief -default raised |
||||
|
||||
variable pi [expr {3.14159265359/180.0}] |
||||
variable motion |
||||
variable xc |
||||
variable yc |
||||
|
||||
constructor args { |
||||
|
||||
# |
||||
# Configure the widget |
||||
# |
||||
$self configurelist $args |
||||
|
||||
canvas $win.c -background $options(-background) -width $options(-width) -height $options(-height) \ |
||||
-relief $options(-relief) -borderwidth $options(-borderwidth) |
||||
grid $win.c -sticky news -padx 2m -pady 2m |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
} |
||||
|
||||
set width [$win.c cget -width] |
||||
set height [$win.c cget -height] |
||||
set xcentre [expr {$width*0.5}] |
||||
set ycentre [expr {$width*1.4}] |
||||
set t 1.15 |
||||
set t1 1.25 |
||||
|
||||
$win.c create arc \ |
||||
[expr {$xcentre-$width*$t}] [expr {$ycentre-$width*$t}] \ |
||||
[expr {$xcentre+$width*$t}] [expr {$ycentre+$width*$t}] \ |
||||
-start 70.5 -extent 37 -style arc -outline lightgray \ |
||||
-width [expr {$ycentre*0.245}] |
||||
$win.c create arc \ |
||||
[expr {$xcentre-$width*$t}] [expr {$ycentre-$width*$t}] \ |
||||
[expr {$xcentre+$width*$t}] [expr {$ycentre+$width*$t}] \ |
||||
-start 71 -extent 36 -style arc -outline $options(-dialcolor) \ |
||||
-width [expr {$ycentre*0.23}] |
||||
$win.c create arc \ |
||||
[expr {$xcentre-$width*$t1}] [expr {$ycentre-$width*$t1}] \ |
||||
[expr {$xcentre+$width*$t1}] [expr {$ycentre+$width*$t1}] \ |
||||
-start 75 -extent 30 \ |
||||
-fill black -outline $options(-scalecolor) -style arc -width 0.5m |
||||
|
||||
set num [llength $options(-labels)] |
||||
set angle 255.0 |
||||
set delta [expr {30.0/($num-1)}] |
||||
set l1 [expr {$width*$t1}] |
||||
set l2 [expr {$width*$t1*0.95}] |
||||
set l3 [expr {$width*$t1*0.92}] |
||||
for {set i 0} {$i < $num} {incr i} { |
||||
set a [expr {($angle+$delta*$i)*$pi}] |
||||
|
||||
set x1 [expr {$xcentre+$l1*cos($a)}] |
||||
set y1 [expr {$ycentre+$l1*sin($a)}] |
||||
set x2 [expr {$xcentre+$l2*cos($a)}] |
||||
set y2 [expr {$ycentre+$l2*sin($a)}] |
||||
$win.c create line $x1 $y1 $x2 $y2 -fill $options(-scalecolor) -width 0.5m |
||||
|
||||
set x1 [expr {$xcentre+$l3*cos($a)}] |
||||
set y1 [expr {$ycentre+$l3*sin($a)}] |
||||
|
||||
set label [lindex $options(-labels) $i] |
||||
if { [string length $label] } { |
||||
$win.c create text $x1 $y1 \ |
||||
-anchor center -justify center -fill $options(-labelcolor) \ |
||||
-text $label -font $options(-labelfont) |
||||
} |
||||
} |
||||
|
||||
set title $options(-title) |
||||
if { [string length $title] } { |
||||
$win.c create text $xcentre [expr {$ycentre-$width*1.05}] \ |
||||
-anchor center -justify center -fill $options(-titlecolor) \ |
||||
-text $title -font $options(-titlefont) |
||||
} |
||||
|
||||
rivet $win.c 10 10 |
||||
rivet $win.c [expr {$width-10}] 10 |
||||
rivet $win.c 10 [expr {$height-10}] |
||||
rivet $win.c [expr {$width-10}] [expr {$height-10}] |
||||
|
||||
set motion 0 |
||||
set xc $xcentre |
||||
set yc $ycentre |
||||
bind $win.c <ButtonRelease> [list $self needleRelease %W] |
||||
bind $win.c <Motion> [list $self needleMotion %W %x %y] |
||||
|
||||
set value 0 |
||||
$self drawline $win $value |
||||
} |
||||
|
||||
method destructor {} { |
||||
set varname ::$options(-variable)] |
||||
trace remove variable $varname write \ |
||||
[namespace code "mymethod tracer $win $varname"] |
||||
} |
||||
|
||||
# |
||||
# public methods -- |
||||
# |
||||
method set {newValue} { |
||||
if { $options(-variable) != "" } { |
||||
set ::$options(-variable) $newValue ;#! This updates the dial too |
||||
} else { |
||||
set options(-value) $newValue |
||||
$self draw $win.c $options(-value) |
||||
} |
||||
} |
||||
method get {} { |
||||
return $options(-value) |
||||
} |
||||
|
||||
# |
||||
# private methods -- |
||||
# |
||||
|
||||
method VariableName {option name} { |
||||
|
||||
# Could be still constructing in which case |
||||
# $win.c does not exist: |
||||
|
||||
if {![winfo exists $win.c]} { |
||||
set options(-variable) $name |
||||
return; |
||||
} |
||||
|
||||
# Remove any old traces |
||||
|
||||
if {$options(-variable) ne ""} { |
||||
trace remove variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
} |
||||
|
||||
# Set new trace if appropriate and update value. |
||||
|
||||
set options(-variable) $name |
||||
if {$options(-variable) ne ""} { |
||||
trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)] |
||||
$self drawline $win.c [set ::$options(-variable)] |
||||
} |
||||
} |
||||
|
||||
method tracer { varname args } \ |
||||
{ |
||||
set options(-value) [set ::$varname] |
||||
$self drawline $win [set ::$varname] |
||||
} |
||||
|
||||
method drawline { widget value } { |
||||
set id $options(-indexid) |
||||
set min $options(-min) |
||||
set max $options(-max) |
||||
|
||||
set c $widget.c |
||||
|
||||
set v [expr { ($value <= ($max*1.05))? $value : ($max*1.05) }] |
||||
|
||||
set angle [expr {((($v-$min)/(1.0*($max-$min)))*30.0+165.0)*$pi}] |
||||
|
||||
set width [$c cget -width] |
||||
set xcentre [expr {$width/2.0}] |
||||
set ycentre [expr {$width*1.4}] |
||||
set l1 [expr {$ycentre*0.85}] |
||||
set l2 [expr {$ycentre*0.7}] |
||||
|
||||
set xl [expr {$xcentre-$l1*sin($angle)}] |
||||
set yl [expr {$ycentre+$l1*cos($angle)}] |
||||
set xs [expr {$xcentre-$l2*sin($angle)}] |
||||
set ys [expr {$ycentre+$l2*cos($angle)}] |
||||
|
||||
catch {$c delete $id} |
||||
set id [$c create line $xs $ys $xl $yl -fill $options(-needlecolor) -width 0.6m] |
||||
$c bind $id <ButtonPress> [list $self needlePress %W] |
||||
set options(-indexid) $id |
||||
} |
||||
|
||||
method needlePress {w} \ |
||||
{ |
||||
set motion 1 |
||||
} |
||||
|
||||
method needleRelease {w} \ |
||||
{ |
||||
set motion 0 |
||||
} |
||||
|
||||
method needleMotion {w x y} \ |
||||
{ |
||||
if {! $motion} { return } |
||||
if {$y == $yc && $x == $xc} { return } |
||||
|
||||
# |
||||
# Compute the angle with the positive y-axis - easier to examine! |
||||
# |
||||
set angle [expr {atan2($xc - $x,$yc - $y) / $pi}] |
||||
if { $angle >= 15.0 } { |
||||
set angle 15.0 |
||||
} |
||||
if { $angle < -15.0 } { |
||||
set angle -15.0 |
||||
} |
||||
set ::$options(-variable) [expr {$options(-min) + ($options(-max)-$options(-min))*(15.0-$angle) / 30.0}] |
||||
} |
||||
|
||||
|
||||
proc rivet { c xc yc } { |
||||
shadowcircle $c \ |
||||
[expr {$xc-4}] [expr {$yc-4}] [expr {$xc+4}] [expr {$yc+4}] \ |
||||
5 0.5m -45.0 |
||||
} |
||||
|
||||
proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } { |
||||
set radius [expr {($x2-$x1)/2.0}] |
||||
|
||||
set angle $orient |
||||
set delta [expr {180.0/$ticks}] |
||||
for {set i 0} {$i <= $ticks} {incr i} { |
||||
set a [expr {($angle+$i*$delta)}] |
||||
set b [expr {($angle-$i*$delta)}] |
||||
|
||||
set color [expr {40+$i*(200/$ticks)}] |
||||
set color [format "#%x%x%x" $color $color $color] |
||||
|
||||
$canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \ |
||||
-style arc -outline $color -width $width |
||||
$canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \ |
||||
-style arc -outline $color -width $width |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {0} { |
||||
# main -- |
||||
# Demonstration of the voltmeter object |
||||
# |
||||
proc main { argc argv } { |
||||
global forever |
||||
|
||||
wm withdraw . |
||||
wm title . "A voltmeter-like widget" |
||||
wm geometry . +10+10 |
||||
|
||||
::controlwidget::voltmeter .t1 -variable value1 -labels { 0 50 100 } -title "Voltmeter (V)" |
||||
scale .s1 -command "set ::value1" -variable value1 |
||||
|
||||
::controlwidget::voltmeter .t2 -variable value2 -labels { 0 {} 2.5 {} 5 } \ |
||||
-width 80m -height 40m -title "Ampere (mA)" -dialcolor lightgreen -scalecolor white \ |
||||
-min 0 -max 5 |
||||
scale .s2 -command "set ::value2" -variable value2 |
||||
|
||||
button .b -text Quit -command "set ::forever 1" |
||||
|
||||
grid .t1 .s1 .t2 .s2 .b |
||||
wm deiconify . |
||||
vwait forever |
||||
.t1 destructor |
||||
.t2 destructor |
||||
exit 0 |
||||
} |
||||
|
||||
main $argc $argv |
||||
} |
||||
|
||||
### end of file |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# page-delimiter: "^#PAGE" |
||||
# End: |
||||
@ -0,0 +1,598 @@
|
||||
# crosshair.tcl - |
||||
# |
||||
# Kevin's mouse-tracking crosshair in Tk's canvas widget. |
||||
# |
||||
# This package displays a mouse-tracking crosshair in the canvas widget. |
||||
# |
||||
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. |
||||
# Redistribution permitted under the terms of the Tcl License. |
||||
# |
||||
# Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking |
||||
# information to external users. |
||||
# |
||||
# Copyright (c) 2013 Frank Gover, Andreas Kupries. Added ability to |
||||
# bound the crosshairs to an area of the canvas. Useful |
||||
# for plots. |
||||
# (Actual code inspired by Frank's, but modified and extended (multiple bboxes)). |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.4- |
||||
package require Tk 8.4- |
||||
|
||||
namespace eval ::crosshair {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::crosshair -- |
||||
# |
||||
# Displays a pair of cross-hairs in a canvas widget. The |
||||
# cross-hairs track the pointing device. |
||||
# |
||||
# Parameters: |
||||
# w - The path name of the canvas |
||||
# args - Remaining args are treated as options as for |
||||
# [$w create line]. Of particular interest are |
||||
# -fill and -dash. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Adds the 'crosshair' bind tag to the widget so that |
||||
# crosshairs will be displayed on pointing device motion. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::crosshair { w args } { |
||||
variable config |
||||
set opts(args) $args |
||||
set opts(hidden) 0 |
||||
bindtags $w [linsert [bindtags $w] 1 Crosshair] |
||||
set config($w) [array get opts] |
||||
return |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::off - |
||||
# |
||||
# Removes the crosshairs from a canvas widget |
||||
# |
||||
# Parameters: |
||||
# w - The canvas from which the crosshairs should be removed |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# If the widget has crosshairs, they are removed. The 'Crosshair' |
||||
# bind tag is removed so that mouse motion will not restore them. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::off { w } { |
||||
variable config |
||||
if { ![info exists config($w)] } return |
||||
array set opts $config($w) |
||||
if { [winfo exists $w] } { |
||||
Hide $w |
||||
set bindtags [bindtags $w] |
||||
set pos [lsearch -exact $bindtags Crosshair] |
||||
if { $pos >= 0 } { |
||||
bindtags $w [lreplace $bindtags $pos $pos] |
||||
} |
||||
} |
||||
unset config($w) |
||||
return |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::configure -- |
||||
# |
||||
# Changes the appearance of crosshairs in the canvas widget. |
||||
# |
||||
# Parameters: |
||||
# w - Path name of the widget |
||||
# args - Additional args are flags to [$w create line]. Interesting |
||||
# ones include -fill and -dash |
||||
# |
||||
# Results: |
||||
# Returns the crosshairs' current configuration settings. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::configure { w args } { |
||||
variable config |
||||
if { ![info exists config($w)] } { |
||||
return -code error "no crosshairs in $w" |
||||
} |
||||
array set opts $config($w) |
||||
if { [llength $args] > 0 } { |
||||
array set flags $opts(args) |
||||
array set flags $args |
||||
set opts(args) [array get flags] |
||||
|
||||
# Immediately apply to a visible crosshair |
||||
if { [info exists opts(hhairl)] } { |
||||
eval [list $w itemconfig $opts(hhairl)] $args |
||||
eval [list $w itemconfig $opts(hhairr)] $args |
||||
eval [list $w itemconfig $opts(vhaird)] $args |
||||
eval [list $w itemconfig $opts(vhairu)] $args |
||||
} |
||||
set config($w) [array get opts] |
||||
} |
||||
return $opts(args) |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::bbox_add -- |
||||
# |
||||
# Confines the crosshairs to a rectangular area in the canvas widget. |
||||
# Multiple calls add areas, each allowing the crosshairs. |
||||
# |
||||
# NOTE: Bounding boxes can overlap to the point of being identical. |
||||
# |
||||
# Parameters: |
||||
# w - Path name of the widget |
||||
# bbox - Area in the canvas. A list of 4 numbers in the form |
||||
# {bbox_llx bbox_lly bbox_urx bbox_ury} |
||||
# where: |
||||
# bbox-llx = Lower left X coordinate of the area |
||||
# bbox-lly = Lower left Y coordinate of the area |
||||
# bbox-urx = Upper right X coordinate of the area |
||||
# bbox-ury = Upper right Y coordinate of the area |
||||
# |
||||
# Result: |
||||
# A token identifying the bounding box, for future removal. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::bbox_add { w bbox } { |
||||
variable config |
||||
if { ![info exists config($w)] } { |
||||
return -code error "no crosshairs in $w" |
||||
} |
||||
array set opts $config($w) |
||||
|
||||
if {[info exists opts(bbox)]} { |
||||
set len [llength $opts(bbox)] |
||||
} else { |
||||
set len 0 |
||||
} |
||||
set token bbox$w/$len |
||||
|
||||
lappend opts(bbox) $token |
||||
set config($w) [array get opts] |
||||
|
||||
foreach {nllx nlly nurx nury} $bbox break |
||||
# Tcl 8.4 foreach-as-lassign hack |
||||
set rect [$w create rect \ |
||||
$nllx $nlly $nurx $nury \ |
||||
-tags $token -state hidden] |
||||
|
||||
return $token |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::bbox_remove -- |
||||
# |
||||
# Remove a bounding box for the crosshairs, identified by token. |
||||
# The crosshairs are confined to the remaining boxes, or not at |
||||
# all if no boxes remain. |
||||
# |
||||
# NOTE: Bounding boxes can overlap to the point of being identical. |
||||
# |
||||
# Parameters: |
||||
# token - The bbox token, identifying both canvas and bbox in it. |
||||
# |
||||
# Result: |
||||
# Nothing. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::bbox_remove { token } { |
||||
variable config |
||||
if {![regexp {^bbox([^/]+)/(\d+)$} -> w index]} { |
||||
return -code error "Expected a bbox token, got \"$token\"" |
||||
} |
||||
if { ![info exists config($w)] } { |
||||
return -code error "no crosshairs in $w" |
||||
} |
||||
array set opts $config($w) |
||||
|
||||
# Replace chosen box with nothing. |
||||
incr index -1 |
||||
set newboxes [lreplace $opts(bbox) $index $index {}] |
||||
|
||||
# Remove empty boxes from the end of the list. |
||||
while {[llength $newboxes] && ![llength [lindex $newboxes end]]} { |
||||
set newboxes [lreplace $newboxes end end] |
||||
} |
||||
|
||||
if {![llength $newboxes]} { |
||||
# Nothing left, disable entirely |
||||
unset opts(bbox) |
||||
} else { |
||||
# Keep remainder. |
||||
set opts(bbox) $newboxes |
||||
} |
||||
|
||||
set config($w) [array get opts] |
||||
|
||||
#--- Delete Bbox |
||||
$w delete $token |
||||
|
||||
return |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::track -- |
||||
# |
||||
# (De)activates reporting of the cross-hair coordinates through |
||||
# a user-specified callback. |
||||
# |
||||
# Parameters: |
||||
# which - What to do (legal values: 'on', 'off'). |
||||
# w - The path name of the canvas |
||||
# cmd - Only for which == 'on', the command prefix to |
||||
# use for execute. |
||||
# |
||||
# The cmd is called with 7 arguments: The widget, and the x- and |
||||
# y-coordinates of 3 points: Crosshair position, and the topleft |
||||
# and bottomright corners of the canvas viewport. All position |
||||
# data in pixels. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# See description. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::track { which w args } { |
||||
variable config |
||||
|
||||
if { ![info exists config($w)] } { |
||||
return -code error "no crosshairs in $w" |
||||
} |
||||
|
||||
if { ![info exists config($w)] } return |
||||
array set opts $config($w) |
||||
|
||||
switch -exact -- $which { |
||||
on { |
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong\#args: Expected 'on w cmdprefix'" |
||||
} |
||||
set opts(track) [lindex $args 0] |
||||
} |
||||
off { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong\#args: Expected 'off w'" |
||||
} |
||||
catch { unset opts(track) } |
||||
} |
||||
} |
||||
|
||||
set config($w) [array get opts] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal commands. |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::Hide -- |
||||
# |
||||
# Hides the crosshair temporarily |
||||
# |
||||
# Parameters: |
||||
# w - Canvas widget containing crosshairs |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# If the canvas contains crosshairs, they are hidden. |
||||
# |
||||
# This procedure is invoked in response to the <Leave> event to |
||||
# hide the crosshair when the pointer is not in the window. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::Hide { w } { |
||||
variable config |
||||
if { ![info exists config($w)] } return |
||||
array set opts $config($w) |
||||
|
||||
# Already hidden, do nothing |
||||
if { $opts(hidden) } return |
||||
set opts(hidden) 1 |
||||
|
||||
# Destroy the parts of a visible cross-hair |
||||
Kill $w opts |
||||
|
||||
set config($w) [array get opts] |
||||
return |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::Unhide -- |
||||
# |
||||
# Places a hidden crosshair back on display |
||||
# |
||||
# Parameters: |
||||
# w - Canvas widget containing crosshairs |
||||
# x - x co-ordinate relative to the window where the vertical |
||||
# crosshair should appear |
||||
# y - y co-ordinate relative to the window where the horizontal |
||||
# crosshair should appear. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Crosshairs are put on display. |
||||
# |
||||
# This procedure is invoked in response to the <Enter> event to |
||||
# restore the crosshair to the display. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::Unhide { w x y } { |
||||
variable config |
||||
if { ![info exists config($w)] } return |
||||
array set opts $config($w) |
||||
|
||||
# Already unhidden, do nothing |
||||
if { !$opts(hidden) } return |
||||
set opts(hidden) 0 |
||||
|
||||
# Store changes back. |
||||
set config($w) [array get opts] |
||||
|
||||
# Recreate cross-hair. This takes the bounding boxes, if any, into |
||||
# account, i.e. if we are out of bounds nothing will appear. |
||||
Move $w $x $y |
||||
return |
||||
} |
||||
|
||||
proc ::crosshair::GetBoundaries { w x y llxv llyv urxv uryv } { |
||||
upvar 1 $llxv llx $llyv lly $urxv urx $uryv ury |
||||
variable config |
||||
array set opts $config($w) |
||||
|
||||
# Defaults |
||||
set llx [$w canvasx 0] |
||||
set lly [$w canvasy 0] |
||||
set urx [$w canvasx [winfo width $w]] |
||||
set ury [$w canvasy [winfo height $w]] |
||||
|
||||
# (x) No boxes confining the crosshair. |
||||
if {![info exists opts(bbox)]} { |
||||
#puts ANY($x,$y) |
||||
return 1 |
||||
} |
||||
|
||||
# Determine active boundaries based on the boxes we are in (or not). |
||||
|
||||
# NOTE: This is linear in the number of active boundaries on the |
||||
# canvas. If this is a really large number this will become |
||||
# slow. If that happens consider creation and maintenance of some |
||||
# fast data structure (R-tree, or similar) which can take |
||||
# advantage of overlap and nesting to quickly rule out large |
||||
# areas. Note that such a structure has its own price in time, |
||||
# memory, and code complexity. |
||||
|
||||
set first 1 |
||||
foreach token $opts(bbox) { |
||||
# Ignore removed boxes, not yet cleaned up. Note that we have |
||||
# at least one active box here to touch by the loop. If we had |
||||
# none the bbox_remove command ensured that (x) above |
||||
# triggered. |
||||
if {$token eq {}} continue |
||||
|
||||
# Get the box data, then test for usability. Ignore all boxes |
||||
# we are outside of. They are not used for the boundary |
||||
# calculation. |
||||
set box [$w coords $token] |
||||
if {[Outside $box $x $y]} continue |
||||
|
||||
# Unfold the box data and check if its boundaries are better |
||||
# (less restrictive) than we currently have, or if this is the |
||||
# first restriction. |
||||
|
||||
foreach {nllx nlly nurx nury} $box break |
||||
|
||||
if {$first || ($nllx < $llx)} { set llx $nllx } |
||||
if {$first || ($nlly > $lly)} { set lly $nlly } |
||||
if {$first || ($nurx > $urx)} { set urx $nurx } |
||||
if {$first || ($nury < $ury)} { set ury $nury } |
||||
|
||||
set first 0 |
||||
} |
||||
|
||||
if {$first} { |
||||
# We have boxes limiting us (See both (x)), and we are outside |
||||
# of all of them. Time to hide the crosshairs. |
||||
#puts OUT($x,$y) |
||||
return 0 |
||||
} |
||||
|
||||
# We are inside of some box and have the proper boundaries of |
||||
# visibility. |
||||
#puts LIMIT($x,$y):$llx,$lly,$urx,$ury |
||||
return 1 |
||||
} |
||||
|
||||
proc ::crosshair::Outside { box x y } { |
||||
# Unfold box |
||||
foreach {llx lly urx ury} $box break |
||||
|
||||
#puts \tTEST($x,$y):$llx,$lly,$urx,$ury:[expr {($x < $llx) || ($x > $urx) || ($y < $lly) || ($y > $ury)}] |
||||
|
||||
# Test each edge. Note that the border lines are considered as |
||||
# "outside". |
||||
|
||||
expr {($x <= $llx) || |
||||
($x >= $urx) || |
||||
($y <= $lly) || |
||||
($y >= $ury)} |
||||
} |
||||
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# ::crosshair::Move -- |
||||
# |
||||
# Moves the crosshairs in a camvas |
||||
# |
||||
# Parameters: |
||||
# w - Canvas widget containing crosshairs |
||||
# x - x co-ordinate relative to the window where the vertical |
||||
# crosshair should appear |
||||
# y - y co-ordinate relative to the window where the horizontal |
||||
# crosshair should appear. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Crosshairs move. |
||||
# |
||||
# This procedure is called in response to a <Motion> event in a canvas |
||||
# with crosshairs. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
proc ::crosshair::Move { w x y } { |
||||
variable config |
||||
array set opts $config($w) |
||||
|
||||
set x [$w canvasx $x] |
||||
set y [$w canvasy $y] |
||||
set opts(x) $x |
||||
set opts(y) $y |
||||
|
||||
if {![GetBoundaries $w $x $y opts(x0) opts(y0) opts(x1) opts(y1)]} { |
||||
# We are out of bounds. Kill the crosshair, store changes, and |
||||
# return. This last disables the use of the tracking |
||||
# callback. The crosshairs track only inside the allowed |
||||
# boxes. |
||||
Kill $w opts |
||||
|
||||
# Store changes back. |
||||
set config($w) [array get opts] |
||||
return |
||||
} |
||||
|
||||
# Inside the boundaries, create or move. |
||||
Place $w opts |
||||
|
||||
# Store changes back. |
||||
set config($w) [array get opts] |
||||
|
||||
# And run the tracking callback, if active. |
||||
if {![info exists opts(track)]} return |
||||
uplevel \#0 [linsert $opts(track) end \ |
||||
$w $opts(x) $opts(y) \ |
||||
$opts(x0) $opts(y0) $opts(x1) $opts(y1)] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Create, destroy, or modify the parts of a crosshair. |
||||
|
||||
proc ::crosshair::Place {w ov} { |
||||
upvar 1 $ov opts |
||||
|
||||
# +/-4 is the minimal possible distance which still prevents the |
||||
# canvas from choosing the crosshairs as 'current' object under |
||||
# the cursor. |
||||
set n 4 |
||||
|
||||
set x $opts(x) |
||||
set y $opts(y) |
||||
set x0 $opts(x0) |
||||
set y0 $opts(y0) |
||||
set x1 $opts(x1) |
||||
set y1 $opts(y1) |
||||
set ax [expr {$x-$n}] |
||||
set bx [expr {$x+$n}] |
||||
set ay [expr {$y-$n}] |
||||
set by [expr {$y+$n}] |
||||
|
||||
if { [info exists opts(hhairl)] } { |
||||
# Modify a visible crosshair. |
||||
|
||||
$w coords $opts(hhairl) $x0 $y $ax $y |
||||
$w coords $opts(hhairr) $bx $y $x1 $y |
||||
$w coords $opts(vhairu) $x $y0 $x $ay |
||||
$w coords $opts(vhaird) $x $by $x $y1 |
||||
|
||||
$w raise $opts(hhairl) |
||||
$w raise $opts(hhairr) |
||||
$w raise $opts(vhaird) |
||||
$w raise $opts(vhairu) |
||||
} else { |
||||
# Create a newly visible crosshair. After unhide and/or |
||||
# entering into one of the active bboxes, if any. |
||||
|
||||
set opts(hhairl) [eval [list $w create line $x0 $y $ax $y] $opts(args)] |
||||
set opts(hhairr) [eval [list $w create line $bx $y $x1 $y] $opts(args)] |
||||
set opts(vhaird) [eval [list $w create line $x $y0 $x $ay] $opts(args)] |
||||
set opts(vhairu) [eval [list $w create line $x $by $x $y1] $opts(args)] |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::crosshair::Kill {w ov} { |
||||
upvar 1 $ov opts |
||||
|
||||
if { ![info exists opts(hhairl)] } return |
||||
|
||||
$w delete $opts(hhairl) |
||||
$w delete $opts(hhairr) |
||||
$w delete $opts(vhaird) |
||||
$w delete $opts(vhairu) |
||||
|
||||
unset opts(hhairl) |
||||
unset opts(hhairr) |
||||
unset opts(vhairu) |
||||
unset opts(vhaird) |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State |
||||
|
||||
namespace eval ::crosshair { |
||||
|
||||
# Array holding information describing crosshairs in canvases |
||||
|
||||
variable config |
||||
array set config {} |
||||
|
||||
# Controller that positions crosshairs according to user actions |
||||
|
||||
bind Crosshair <Destroy> "[namespace code off] %W" |
||||
bind Crosshair <Enter> "[namespace code Unhide] %W %x %y" |
||||
bind Crosshair <Leave> "[namespace code Hide] %W" |
||||
bind Crosshair <Motion> "[namespace code Move] %W %x %y" |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide crosshair 1.2.1 |
||||
@ -0,0 +1,4 @@
|
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.4-]} {return} |
||||
|
||||
package ifneeded crosshair 1.2.1 [list source [file join $dir crosshair.tcl]] |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
package ifneeded ctext 3.3 [list source [file join $dir ctext.tcl]] |
||||
@ -0,0 +1,137 @@
|
||||
# cursor.tcl -- |
||||
# |
||||
# Tk cursor handling routines |
||||
# |
||||
# Copyright (c) 2001-2009 by Jeffrey Hobbs |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cursor.tcl,v 1.4 2011/01/18 18:17:17 andreas_kupries Exp $ |
||||
|
||||
package require Tk 8.0 |
||||
package provide cursor 0.3.1 |
||||
|
||||
namespace eval ::cursor { |
||||
namespace export propagate restore display |
||||
|
||||
# Default to depthfirst (bottom up) restore to account for |
||||
# megawidgets that will self-propagate cursor changes down. |
||||
variable depthfirst 1 |
||||
|
||||
variable cursors [list \ |
||||
X_cursor arrow based_arrow_down based_arrow_up boat bogosity \ |
||||
bottom_left_corner bottom_right_corner bottom_side bottom_tee \ |
||||
box_spiral center_ptr circle clock coffee_mug cross cross_reverse \ |
||||
crosshair diamond_cross dot dotbox double_arrow draft_large \ |
||||
draft_small draped_box exchange fleur gobbler gumby hand1 hand2 \ |
||||
heart icon iron_cross left_ptr left_side left_tee leftbutton \ |
||||
ll_angle lr_angle man middlebutton mouse pencil pirate plus \ |
||||
question_arrow right_ptr right_side right_tee rightbutton \ |
||||
rtl_logo sailboat sb_down_arrow sb_h_double_arrow sb_left_arrow \ |
||||
sb_right_arrow sb_up_arrow sb_v_double_arrow shuttle sizing \ |
||||
spider spraycan star target tcross top_left_arrow top_left_corner \ |
||||
top_right_corner top_side top_tee trek ul_angle umbrella \ |
||||
ur_angle watch xterm \ |
||||
] |
||||
|
||||
switch -exact $::tcl_platform(os) { |
||||
"windows" { |
||||
lappend cursors no starting size \ |
||||
size_ne_sw size_ns size_nw_se size_we uparrow wait |
||||
} |
||||
"macintosh" { |
||||
lappend cursors text cross-hair |
||||
} |
||||
"unix" { |
||||
# no extra cursors |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::cursor::propagate -- |
||||
# |
||||
# Propagates a cursor to a widget and all descendants. |
||||
# |
||||
# Arguments: |
||||
# w Parent widget to set cursor on (includes children) |
||||
# cursor The cursor to use |
||||
# |
||||
# Results: |
||||
# Set the cursor of $w and all descendants to $cursor |
||||
|
||||
proc ::cursor::propagate {w cursor} { |
||||
variable CURSOR |
||||
|
||||
# Ignores {} cursors or widgets that don't have a -cursor option |
||||
if {![catch {set CURSOR($w) [$w cget -cursor]}] && $CURSOR($w) != ""} { |
||||
$w configure -cursor $cursor |
||||
} else { |
||||
catch {unset CURSOR($w)} |
||||
} |
||||
foreach child [winfo children $w] { propagate $child $cursor } |
||||
} |
||||
|
||||
# ::cursor::restore -- |
||||
# |
||||
# Restores original cursor of a widget and all descendants. |
||||
# |
||||
# Arguments: |
||||
# w Parent widget to restore cursor for (includes children) |
||||
# cursor The default cursor to use (if none was cached by propagate) |
||||
# |
||||
# Results: |
||||
# Restore the cursor of $w and all descendants |
||||
|
||||
proc ::cursor::restore {w {cursor {}}} { |
||||
variable depthfirst |
||||
variable CURSOR |
||||
|
||||
if {$depthfirst} { |
||||
foreach child [winfo children $w] { restore $child $cursor } |
||||
} |
||||
if {[info exists CURSOR($w)]} { |
||||
$w configure -cursor $CURSOR($w) |
||||
} else { |
||||
# Not all widgets have -cursor |
||||
catch {$w configure -cursor $cursor} |
||||
} |
||||
if {!$depthfirst} { |
||||
foreach child [winfo children $w] { restore $child $cursor } |
||||
} |
||||
} |
||||
|
||||
|
||||
# ::cursor::display -- |
||||
# |
||||
# Show all known cursors for viewing |
||||
# |
||||
# Arguments: |
||||
# w Parent widget to use for dialog |
||||
# |
||||
# Results: |
||||
# Pops up a dialog |
||||
|
||||
proc ::cursor::display {{root .}} { |
||||
variable cursors |
||||
if {$root == "."} { |
||||
set t .__cursorDisplay |
||||
} else { |
||||
set t $root.__cursorDisplay |
||||
} |
||||
destroy $t |
||||
toplevel $t |
||||
wm withdraw $t |
||||
label $t.lbl -text "Select a cursor:" -anchor w |
||||
listbox $t.lb -selectmode single -yscrollcommand [list $t.sy set] |
||||
scrollbar $t.sy -orient v -command [list $t.lb yview] |
||||
button $t.d -text Dismiss -command [list destroy $t] |
||||
pack $t.d -side bottom |
||||
pack $t.lbl -side top -fill x |
||||
pack $t.sy -side right -fill y |
||||
pack $t.lb -side right -fill both -expand 1 |
||||
eval [list $t.lb insert end] $cursors |
||||
bind $t.lb <Button-1> { %W configure -cursor [%W get [%W nearest %y]] } |
||||
wm deiconify $t |
||||
} |
||||
|
||||
@ -0,0 +1 @@
|
||||
package ifneeded cursor 0.3.1 [list source [file join $dir cursor.tcl]] |
||||
@ -0,0 +1,456 @@
|
||||
##+########################################################################## |
||||
# |
||||
# datefield.tcl |
||||
# |
||||
# Implements a datefield entry widget ala Iwidget::datefield |
||||
# by Keith Vetter (keith@ebook.gemstar.com) |
||||
# |
||||
# Datefield creates an entry widget but with a special binding to KeyPress |
||||
# (based on Iwidget::datefield) to ensure that the current value is always |
||||
# a valid date. All normal entry commands and configurations still work. |
||||
# |
||||
# Usage: |
||||
# ::datefield::datefield .df -background yellow -textvariable myDate \ |
||||
# -format "%Y-%m-%d" |
||||
# pack .df |
||||
# |
||||
# Bugs: |
||||
# o won't work if you programmatically put in an invalid date |
||||
# e.g. .df insert end "abc" will cause it to behave erratically |
||||
# |
||||
# Revisions: |
||||
# KPV Feb 07, 2002 - initial revision |
||||
# TW Mar 26, 2017 - support more keys and the mouse wheel |
||||
# - add option -format to support 3 date-styles: |
||||
# "%d.%m.%Y" (for German) |
||||
# "%m/%d/%Y" (for English, standard) |
||||
# "%Y-%m-%d" (for ISO) |
||||
# |
||||
##+########################################################################## |
||||
############################################################################# |
||||
|
||||
package require Tk 8.0 |
||||
package provide datefield 0.3 |
||||
|
||||
namespace eval ::datefield { |
||||
namespace export datefield |
||||
|
||||
# Have the widget use tile/ttk should it be available. |
||||
|
||||
variable entry entry |
||||
if {![catch { |
||||
package require tile |
||||
}]} { |
||||
set entry ttk::entry |
||||
} |
||||
|
||||
proc datefield {w args} { |
||||
variable entry |
||||
variable Format |
||||
variable Separator |
||||
|
||||
set i [lsearch $args "-form*"] |
||||
if {$i == -1} { # Default English |
||||
set Format($w) "%m/%d/%Y" |
||||
} else { |
||||
set Format($w) [lindex [lreplace $args $i $i] $i] |
||||
switch -- $Format($w) { |
||||
"%d.%m.%Y" { # German |
||||
} |
||||
"%m/%d/%Y" { # English |
||||
} |
||||
"%Y-%m-%d" { # ISO |
||||
} |
||||
default { # Error |
||||
error "ERROR: Unknown value for option -format on datefield $w $args" |
||||
} |
||||
} |
||||
set args [lreplace $args $i $i] |
||||
set args [lreplace $args $i $i] |
||||
} |
||||
set Separator($w) [string range $Format($w) 2 2] |
||||
eval $entry $w -width 10 -justify center $args |
||||
if {([$w get] eq "") \ |
||||
|| [catch {clock scan [$w get] -format $Format($w)} base]} { |
||||
$w delete 0 end |
||||
$w insert end [clock format [clock seconds] -format $Format($w)] |
||||
} |
||||
$w icursor 0 |
||||
bind $w <KeyPress> [list ::datefield::KeyPress $w %A %K %s] |
||||
bind $w <MouseWheel> [list ::datefield::MouseWheel $w %D] |
||||
bind $w <Button1-Motion> break |
||||
bind $w <Button2-Motion> break |
||||
bind $w <Double-Button> break |
||||
bind $w <Triple-Button> break |
||||
bind $w <2> break |
||||
return $w |
||||
} |
||||
|
||||
proc Spin {w dir unit code} { |
||||
variable Format |
||||
|
||||
set base [clock scan [$w get] -format $Format($w)] |
||||
set new [clock add $base $dir $unit] |
||||
set date [clock format $new -format $Format($w)] |
||||
set icursor [$w index insert] |
||||
$w delete 0 end |
||||
$w insert end $date |
||||
$w icursor $icursor |
||||
return $code |
||||
} |
||||
|
||||
proc MouseWheel {w dir} { |
||||
$w selection clear |
||||
set Dir [expr {$dir / 120}] |
||||
return -code [Spin $w $Dir "day" continue] |
||||
} |
||||
|
||||
# internal routine for all key presses in the datefield entry widget |
||||
proc KeyPress {w char sym state} { |
||||
variable Format |
||||
variable Separator |
||||
|
||||
proc Move {w dir} { |
||||
variable Format |
||||
|
||||
set icursor [$w index insert] |
||||
set icursor [expr {($icursor + 10 + $dir) % 10}] |
||||
if {$Format($w) ne "%Y-%m-%d"} { # English or German |
||||
if {($icursor == 2) || ($icursor == 5)} { # Don't land on a / or . |
||||
set icursor [expr {($icursor + 10 + $dir) % 10}] |
||||
} |
||||
} \ |
||||
elseif {($icursor == 4) || ($icursor == 7)} { # ISO # Don't land on a - |
||||
set icursor [expr {($icursor + 10 + $dir) % 10}] |
||||
} |
||||
$w icursor $icursor |
||||
} |
||||
|
||||
set icursor [$w index insert] |
||||
$w selection clear |
||||
# Handle some non-number characters first |
||||
switch -exact -- $sym { |
||||
"Down" {return -code [Spin $w -1 "day" continue]} |
||||
"End" {$w icursor 9; return -code break} |
||||
"minus" {return -code [Spin $w -1 "day" break]} |
||||
"Next" {return -code [Spin $w -1 "month" continue]} |
||||
"plus" {return -code [Spin $w 1 "day" break]} |
||||
"Prior" {return -code [Spin $w 1 "month" continue]} |
||||
"Up" {return -code [Spin $w 1 "day" continue]} |
||||
"BackSpace" - |
||||
"Delete" - |
||||
"Left" {Move $w -1; return -code break} |
||||
"Right" {Move $w 1; return -code break} |
||||
"Tab" { |
||||
if {$Format($w) ne "%Y-%m-%d"} { # English or German |
||||
if {($state & 5) == 0} { # ->| |
||||
if {$icursor < 3} { # from 1st to 2nd |
||||
$w icursor 3 |
||||
} \ |
||||
elseif {$icursor < 6} { # from 2nd to 10th-year |
||||
$w icursor 8 |
||||
} else { # next widget |
||||
return -code continue |
||||
} |
||||
} \ |
||||
elseif {$icursor > 4} { # |<- |
||||
$w icursor 3 ;# from year to 2nd |
||||
} \ |
||||
elseif {$icursor > 1} { # from 2nd to 1st |
||||
$w icursor 0 |
||||
} else { # previous widget |
||||
return -code continue |
||||
} |
||||
} \ |
||||
elseif {($state & 5) == 0} { # ->| ISO |
||||
if {$icursor < 5} { # from year to month |
||||
$w icursor 5 |
||||
} \ |
||||
elseif {$icursor < 8} { # from month to day |
||||
$w icursor 8 |
||||
} else { # next widget |
||||
return -code continue |
||||
} |
||||
} \ |
||||
elseif {$icursor > 6} { # |<- |
||||
$w icursor 5 ;# from day to month |
||||
} \ |
||||
elseif {$icursor > 2} { # from month to 10th-year |
||||
$w icursor 2 |
||||
} else { # previous widget |
||||
return -code continue |
||||
} |
||||
return -code break |
||||
} |
||||
} |
||||
if {$char eq ""} { # remaining special keys |
||||
return -code continue |
||||
} |
||||
if {! [regexp -- {[0-9]} $char]} { # Unknown character |
||||
bell |
||||
return -code break |
||||
} |
||||
if {$icursor >= 10} { # Can't add beyond end |
||||
bell |
||||
return -code break |
||||
} |
||||
switch -- $Separator($w) { |
||||
"." { # German |
||||
foreach {day month year} [split [$w get] $Separator($w)] break |
||||
if {$icursor < 2} { # DAY SECTION |
||||
set endday [lastDay $month $year] |
||||
foreach {d1 d2} [split $day ""] break |
||||
set cursor 3 ;# Where to leave the cursor |
||||
if {$icursor == 0} { # 1st digit of day |
||||
if {($char < 3) \ |
||||
|| (($char == 3) && ($month ne "02"))} { |
||||
set day "$char$d2" |
||||
if {$day eq "00"} {set day "01"} |
||||
if {$day > $endday} {set day $endday} |
||||
set cursor 1 |
||||
} else { |
||||
set day "0$char" |
||||
} |
||||
} else { # 2nd digit of day |
||||
set day "$d1$char" |
||||
if {($day > $endday) || ($day eq "00")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 0 2 |
||||
$w insert 0 $day |
||||
$w icursor $cursor |
||||
return -code break |
||||
} |
||||
if {$icursor < 5} { # MONTH SECTION |
||||
foreach {m1 m2} [split $month ""] break |
||||
set cursor 6 ;# Where to leave the cursor |
||||
if {$icursor == 3} { # 1st digit of month |
||||
if {$char < 2} { |
||||
set month "$char$m2" |
||||
set cursor 4 |
||||
} else { |
||||
set month "0$char" |
||||
} |
||||
if {$month > 12} {set month "10"} |
||||
if {$month eq "00"} {set month "01"} |
||||
} else { # 2nd digit of month |
||||
set month "$m1$char" |
||||
if {$month > 12} {set month "0$char"} |
||||
if {$month eq "00"} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 3 5 |
||||
$w insert 3 $month |
||||
# Validate the day of the month |
||||
if {$day > [set endday [lastDay $month $year]]} { |
||||
$w delete 0 2 |
||||
$w insert 0 $endday |
||||
} |
||||
$w icursor $cursor |
||||
return -code break |
||||
} |
||||
set y1 [string range $year 0 0]; # YEAR SECTION |
||||
if {$icursor < 7} { # 1st digit of year |
||||
if {($char ne "1") && ($char ne "2")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
if {$char != $y1} { # Different century |
||||
set y 1999 |
||||
if {$char eq "2"} {set y 2000} |
||||
$w delete 6 end |
||||
$w insert end $y |
||||
} |
||||
$w icursor 7 |
||||
return -code break |
||||
} |
||||
$w delete $icursor |
||||
$w insert $icursor $char |
||||
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
||||
$w delete 6 end |
||||
$w insert end $year ;# Put back in the old year |
||||
$w icursor $icursor |
||||
bell |
||||
} |
||||
} |
||||
"/" { # English |
||||
foreach {month day year} [split [$w get] $Separator($w)] break |
||||
if {$icursor < 2} { # MONTH SECTION |
||||
foreach {m1 m2} [split $month ""] break |
||||
set cursor 3 ;# Where to leave the cursor |
||||
if {$icursor == 0} { # 1st digit of month |
||||
if {$char < 2} { |
||||
set month "$char$m2" |
||||
set cursor 1 |
||||
} else { |
||||
set month "0$char" |
||||
} |
||||
if {$month > 12} {set month "10"} |
||||
if {$month eq "00"} {set month "01"} |
||||
} else { # 2nd digit of month |
||||
set month "$m1$char" |
||||
if {$month > 12} {set month "0$char"} |
||||
if {$month eq "00"} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 0 2 |
||||
$w insert 0 $month |
||||
# Validate the day of the month |
||||
if {$day > [set endday [lastDay $month $year]]} { |
||||
$w delete 3 5 |
||||
$w insert 3 $endday |
||||
} |
||||
$w icursor $cursor |
||||
return -code break |
||||
} |
||||
if {$icursor < 5} { # DAY SECTION |
||||
set endday [lastDay $month $year] |
||||
foreach {d1 d2} [split $day ""] break |
||||
set cursor 6 ;# Where to leave the cursor |
||||
if {$icursor == 3} { # 1st digit of day |
||||
if {($char < 3) \ |
||||
|| (($char == 3) && ($month ne "02"))} { |
||||
set day "$char$d2" |
||||
if {$day eq "00"} {set day "01"} |
||||
if {$day > $endday} {set day $endday} |
||||
set cursor 4 |
||||
} else { |
||||
set day "0$char" |
||||
} |
||||
} else { # 2nd digit of day |
||||
set day "$d1$char" |
||||
if {($day > $endday) || ($day eq "00")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 3 5 |
||||
$w insert 3 $day |
||||
$w icursor $cursor |
||||
return -code break |
||||
} |
||||
set y1 [string range $year 0 0]; # YEAR SECTION |
||||
if {$icursor < 7} { # 1st digit of year |
||||
if {($char ne "1") && ($char ne "2")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
if {$char != $y1} { # Different century |
||||
set y 1999 |
||||
if {$char eq "2"} {set y 2000} |
||||
$w delete 6 end |
||||
$w insert end $y |
||||
} |
||||
$w icursor 7 |
||||
return -code break |
||||
} |
||||
$w delete $icursor |
||||
$w insert $icursor $char |
||||
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
||||
$w delete 6 end |
||||
$w insert end $year ;# Put back in the old year |
||||
$w icursor $icursor |
||||
bell |
||||
} |
||||
} |
||||
default { # ISO |
||||
foreach {year month day} [split [$w get] $Separator($w)] break |
||||
if {$icursor < 4} { # YEAR SECTION |
||||
set y1 [string range $year 0 0]; |
||||
if {$icursor == 0} { # 1st digit of year |
||||
if {($char ne "1") && ($char ne "2")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
if {$char != $y1} { # Different century |
||||
set y 1999 |
||||
if {$char eq "2"} {set y 2000} |
||||
$w delete 0 4 |
||||
$w insert 0 $y |
||||
} |
||||
$w icursor 1 |
||||
return -code break |
||||
} |
||||
$w delete $icursor |
||||
$w insert $icursor $char |
||||
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
||||
$w delete 0 4 |
||||
$w insert 0 $year ;# Put back in the old year |
||||
$w icursor $icursor |
||||
bell |
||||
} |
||||
if {$icursor == 3} { # last digit of year |
||||
$w icursor 5 ;# Don't land on a - |
||||
} |
||||
return -code break |
||||
} |
||||
if {$icursor < 7} { # MONTH SECTION |
||||
foreach {m1 m2} [split $month ""] break |
||||
set cursor 8 ;# Where to leave the cursor |
||||
if {$icursor == 5} { # 1st digit of month |
||||
if {$char < 2} { |
||||
set month "$char$m2" |
||||
set cursor 6 |
||||
} else { |
||||
set month "0$char" |
||||
} |
||||
if {$month > 12} {set month "10"} |
||||
if {$month eq "00"} {set month "01"} |
||||
} else { # 2nd digit of month |
||||
set month "$m1$char" |
||||
if {$month > 12} {set month "0$char"} |
||||
if {$month eq "00"} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 5 7 |
||||
$w insert 5 $month |
||||
# Validate the day of the month |
||||
if {$day > [set endday [lastDay $month $year]]} { |
||||
$w delete 8 end |
||||
$w insert end $endday |
||||
} |
||||
$w icursor $cursor |
||||
return -code break |
||||
} |
||||
set endday [lastDay $month $year] ;# DAY SECTION |
||||
foreach {d1 d2} [split $day ""] break |
||||
set cursor 10 ;# Where to leave the cursor |
||||
if {$icursor == 8} { # 1st digit of day |
||||
if {($char < 3) \ |
||||
|| (($char == 3) && ($month ne "02"))} { |
||||
set day "$char$d2" |
||||
if {$day eq "00"} {set day "01"} |
||||
if {$day > $endday} {set day $endday} |
||||
set cursor 9 |
||||
} else { |
||||
set day "0$char" |
||||
} |
||||
} else { # 2nd digit of day |
||||
set day "$d1$char" |
||||
if {($day > $endday) || ($day eq "00")} { |
||||
bell |
||||
return -code break |
||||
} |
||||
} |
||||
$w delete 8 end |
||||
$w insert end $day |
||||
$w icursor $cursor |
||||
} |
||||
} |
||||
return -code break |
||||
} |
||||
|
||||
# internal routine that returns the last valid day of a given month and year |
||||
proc lastDay {month year} { |
||||
return [clock format [clock scan "+1 month -1 day" \ |
||||
-base [clock scan "$month/01/$year"]] -format %d] |
||||
} |
||||
} |
||||
@ -0,0 +1 @@
|
||||
package ifneeded datefield 0.3 [list source [file join $dir datefield.tcl]] |
||||
@ -0,0 +1,470 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# application on top of the diagram drawing package. |
||||
# |
||||
|
||||
## Use Cases |
||||
## (1) Reading a single diagram file and showing it on a canvas. |
||||
|
||||
## (1a) Like (1), for multiple input files. This requires an additional |
||||
## selection step before the diagram is shown. |
||||
|
||||
## (2) Convert one or more diagram files into raster images in various |
||||
## formats. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Command syntax |
||||
|
||||
## (Ad 1) show picfile |
||||
## (Ad 1a) show picfile picfile... |
||||
|
||||
## (Ad 2) convert -o output-file-or-dir format picfile |
||||
## convert -o output-dir format picfile picfile... |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.5 |
||||
package require Tk 8.5 |
||||
package require fileutil |
||||
|
||||
wm withdraw . ; # Hide the main toplevel until we actually need it, if |
||||
# ever. |
||||
namespace eval ::diagram::application {} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Implementation |
||||
|
||||
proc ::diagram::application {arguments} { |
||||
variable application::mode |
||||
application::ProcessCmdline $arguments |
||||
application::Run::$mode |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::showerror {text} { |
||||
global argv0 |
||||
puts stderr "$argv0: $text" |
||||
exit 1 |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Internal data and status |
||||
|
||||
namespace eval ::diagram::application { |
||||
# Path to where the output goes to. Depending on the chosen mode |
||||
# this information may be irrelevant, a file, or a directory. |
||||
# Specified through the option '-o' where suitable. |
||||
|
||||
variable output "" |
||||
|
||||
# Paths of the documents to convert. Always a list, even in the |
||||
# case of a single input file. Specified through the trailing |
||||
# arguments on the command line. The relative path of a file under |
||||
# 'input' also becomes its relative path under 'output'. |
||||
|
||||
variable input "" |
||||
|
||||
# The name of the format to convert the diagram documents |
||||
# into. Used as extension for the generated files as well when |
||||
# converting multiple files. Internally this is the name of the |
||||
# canvas::* or img::* package for the image format. The two cases |
||||
# are distinguished by the value of the boolean flag "snap". True |
||||
# indicates a raster format via img::*, false a canvas::* dump |
||||
# package ... FUTURE :: Should have a 'canvas::write::*' or |
||||
# somesuch family of packages which hide this type of difference |
||||
# from us. |
||||
|
||||
variable format "" |
||||
variable snap 0 |
||||
|
||||
# Name of the found processing mode. Derived during processing all |
||||
# arguments on the command line. This value is used during the |
||||
# dispatch to the command implementing the mode, after processing |
||||
# the command line. |
||||
# |
||||
# Possible/Legal values: Meaning |
||||
# --------------------- ------- |
||||
# --------------------- ------- |
||||
|
||||
variable mode "" |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## |
||||
|
||||
proc ::diagram::application::ProcessCmdline {arguments} { |
||||
variable input {} ; # Set defaults. |
||||
variable output "" ; # |
||||
variable format "" ; # |
||||
variable mode "" ; # |
||||
|
||||
# syntax: show file... |
||||
# convert -o output format file... |
||||
|
||||
if {[llength $arguments] < 2} Usage |
||||
set arguments [lassign $arguments command] |
||||
|
||||
switch -exact -- $command { |
||||
show {ProcessShow $arguments} |
||||
convert {ProcessConvert $arguments} |
||||
default Usage |
||||
} |
||||
|
||||
set mode $command |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::ProcessShow {arguments} { |
||||
if {[llength $arguments] < 1} Usage |
||||
variable input {} |
||||
variable trusted 0 |
||||
|
||||
# Basic option processing and validation. |
||||
while {[llength $arguments]} { |
||||
set opt [lindex $arguments 0] |
||||
if {![string match "-*" $opt]} break |
||||
|
||||
switch -exact -- $opt { |
||||
-t { |
||||
if {[llength $arguments] < 1} Usage |
||||
set arguments [lassign $arguments _opt_] |
||||
set trusted 1 |
||||
} |
||||
default Usage |
||||
} |
||||
} |
||||
|
||||
set input $arguments |
||||
CheckInput |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::ProcessConvert {arguments} { |
||||
variable output "" |
||||
variable input {} |
||||
variable format "" |
||||
variable trusted 0 |
||||
|
||||
if {[llength $arguments] < 4} Usage |
||||
|
||||
# Basic option processing and validation. |
||||
while {[llength $arguments]} { |
||||
set opt [lindex $arguments 0] |
||||
if {![string match "-*" $opt]} break |
||||
|
||||
switch -exact -- $opt { |
||||
-o { |
||||
if {[llength $arguments] < 2} Usage |
||||
set arguments [lassign $arguments _opt_ output] |
||||
} |
||||
-t { |
||||
if {[llength $arguments] < 1} Usage |
||||
set arguments [lassign $arguments _opt_] |
||||
set trusted 1 |
||||
} |
||||
default Usage |
||||
} |
||||
} |
||||
# Format and at least one file are expected. |
||||
if {[llength $arguments] < 2} Usage |
||||
set input [lassign $arguments format] |
||||
|
||||
ValidateFormat |
||||
CheckInput |
||||
CheckOutput |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
proc ::diagram::application::Usage {} { |
||||
showerror "wrong#args, expected: show file...|convert -o outputpath format file..." |
||||
# not reached ... |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Various complex checks on the arguments |
||||
|
||||
proc ::diagram::application::ValidateFormat {} { |
||||
variable format |
||||
variable snap |
||||
if {![catch { |
||||
package require canvas::snap |
||||
package require img::$format |
||||
set snap 1 |
||||
} msgA]} return |
||||
|
||||
if {![catch { |
||||
package require canvas::$format |
||||
} msgB]} return |
||||
|
||||
showerror "Unable to handle format \"$format\", because of: $msgA and $msgB" |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::CheckInput {} { |
||||
variable input |
||||
foreach f $input { |
||||
if {![file exists $f]} { |
||||
showerror "Unable to find picture \"$f\"" |
||||
} elseif {![file readable $f]} { |
||||
showerror "picture \"$f\" not readable (permission denied)" |
||||
} |
||||
} |
||||
if {[llength $input] < 1} { |
||||
showerror "No picture(s) specified" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::CheckOutput {} { |
||||
variable input |
||||
variable output |
||||
|
||||
if {$output eq ""} { |
||||
showerror "No output path specified" |
||||
} |
||||
|
||||
set base [file dirname $output] |
||||
if {$base eq ""} {set base [pwd]} |
||||
|
||||
# Multiple inputs: Output must either exist as directory, or |
||||
# output base writable so that we can create the directory. |
||||
# Single input: As above except existence as file. |
||||
|
||||
if {![file exists $output]} { |
||||
if {![file exists $base]} { |
||||
showerror "Output base path \"$base\" not found" |
||||
} |
||||
if {![file writable $base]} { |
||||
showerror "Output base path \"$base\" not writable (permission denied)" |
||||
} |
||||
} else { |
||||
if {![file writable $output]} { |
||||
showerror "Output path \"$output\" not writable (permission denied)" |
||||
} |
||||
|
||||
if {[llength $input] > 1} { |
||||
if {![file isdirectory $output]} { |
||||
showerror "Output path \"$output\" not a directory" |
||||
} |
||||
} else { |
||||
if {![file isfile $output]} { |
||||
showerror "Output path \"$output\" not a file" |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## |
||||
|
||||
namespace eval ::diagram::application::Run::GUI {} |
||||
|
||||
proc ::diagram::application::Run::show {} { |
||||
variable ::diagram::application::input |
||||
|
||||
GUI::Show |
||||
|
||||
if {[llength $input] == 1} { |
||||
after 100 { |
||||
.l selection clear 0 end |
||||
.l selection set 0 |
||||
event generate .l <<ListboxSelect>> |
||||
} |
||||
} |
||||
|
||||
vwait __forever__ |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::convert {} { |
||||
variable ::diagram::application::input |
||||
variable ::diagram::application::output |
||||
|
||||
set dip [MakeInterpreter] |
||||
GUI::Convert |
||||
PrepareOutput |
||||
|
||||
if {[llength $input] > 1} { |
||||
foreach f $input { |
||||
Convert $dip $f [GetDestination $f] |
||||
} |
||||
} else { |
||||
set f [lindex $input 0] |
||||
if {[file exists $output] && [file isdirectory $output]} { |
||||
Convert $dip $f [GetExtension $output/[file tail $input]] |
||||
} else { |
||||
Convert $dip $f $output |
||||
} |
||||
} |
||||
|
||||
interp delete $dip |
||||
GUI::Close |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::Convert {dip src dst} { |
||||
variable ::diagram::application::format |
||||
variable ::diagram::application::snap |
||||
|
||||
puts ${src}... |
||||
set pic [fileutil::cat $src] |
||||
|
||||
if {[catch { |
||||
$dip eval [list D draw $pic] |
||||
} msg]} { |
||||
puts "FAIL $msg : $src" |
||||
} elseif {$snap} { |
||||
set DIA [canvas::snap .c] |
||||
$DIA write $dst -format $format |
||||
image delete $DIA |
||||
} else { |
||||
# Direct canvas dump ... |
||||
fileutil::writeFile $dst [canvas::$format .c] |
||||
} |
||||
|
||||
# Wipe controller state, no information transfer between pictures. |
||||
$dip eval {D reset} |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GUI::Show {} { |
||||
package require widget::scrolledwindow |
||||
#package require crosshair |
||||
|
||||
set dip [::diagram::application::Run::MakeInterpreter] |
||||
|
||||
ttk::notebook .n |
||||
button .e -text Exit -command ::exit |
||||
widget::scrolledwindow .sl -borderwidth 1 -relief sunken |
||||
widget::scrolledwindow .sc -borderwidth 1 -relief sunken |
||||
widget::scrolledwindow .st -borderwidth 1 -relief sunken |
||||
listbox .l -width 40 -selectmode single -listvariable ::diagram::application::input |
||||
canvas .c -width 800 -height 600 -scrollregion {-4000 -4000 4000 4000} |
||||
text .t -font {Arial 20} |
||||
|
||||
.sl setwidget .l |
||||
.sc setwidget .c |
||||
.st setwidget .t |
||||
|
||||
pack .e -fill none -expand 0 -side bottom -anchor e |
||||
|
||||
#panedwindow .p -orient vertical |
||||
#.p add .sl .sc |
||||
#.p paneconfigure .sl -width 100 |
||||
|
||||
pack .sl -fill both -expand 1 -padx 4 -pady 4 -side left |
||||
pack .n -fill both -expand 1 -padx 4 -pady 4 -side right |
||||
|
||||
.n add .sc -state normal -sticky swen -text Diagram |
||||
.n add .st -state normal -sticky swen -text Code |
||||
|
||||
bind .l <<ListboxSelect>> [list ::diagram::application::Run::GUI::ShowPicture $dip] |
||||
|
||||
# Panning via mouse |
||||
bind .c <ButtonPress-2> {%W scan mark %x %y} |
||||
bind .c <B2-Motion> {%W scan dragto %x %y} |
||||
|
||||
# Cross hairs ... |
||||
#.c configure -cursor tcross |
||||
#crosshair::crosshair .c -width 0 -fill \#999999 -dash {.} |
||||
#crosshair::track on .c TRACK |
||||
|
||||
wm deiconify . |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GUI::ShowPicture {dip} { |
||||
|
||||
set selection [.l curselection] |
||||
if {![llength $selection]} return |
||||
|
||||
$dip eval {catch {D destroy}} |
||||
$dip eval {diagram D .c} |
||||
|
||||
set pic [fileutil::cat [.l get $selection]] |
||||
|
||||
.t delete 0.1 end |
||||
.t insert 0.1 $pic |
||||
|
||||
after 0 [list $dip eval [list D draw $pic]] |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GUI::Convert {} { |
||||
canvas .c -width 800 -height 600 -scrollregion {0 0 1200 1000} |
||||
grid .c -row 0 -column 0 -sticky swen |
||||
|
||||
grid rowconfigure . 0 -weight 1 |
||||
grid columnconfigure . 0 -weight 1 |
||||
|
||||
wm attributes . -fullscreen 1 |
||||
wm deiconify . |
||||
tkwait visibility . |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GUI::Close {} { |
||||
wm withdraw . |
||||
destroy . |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::PrepareOutput {} { |
||||
variable ::diagram::application::input |
||||
variable ::diagram::application::output |
||||
|
||||
if {[llength $input] > 1} { |
||||
file mkdir [file dirname $output] |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GetDestination {f} { |
||||
variable ::diagram::application::output |
||||
|
||||
if {[file pathtype $f] ne "relative"} { |
||||
return set f [file join $output {*}[lrange [file split $f] 1 end]] |
||||
} else { |
||||
set f $output/$f |
||||
} |
||||
file mkdir [file dirname $f] |
||||
return [GetExtension $f] |
||||
} |
||||
|
||||
proc ::diagram::application::Run::GetExtension {f} { |
||||
variable ::diagram::application::format |
||||
return [file rootname $f].$format |
||||
} |
||||
|
||||
proc ::diagram::application::Run::MakeInterpreter {} { |
||||
variable ::diagram::application::trusted |
||||
set sec [expr {[lindex [time { |
||||
if {$trusted} { |
||||
puts {Creating trusted environment, please wait...} |
||||
set dip [interp create] |
||||
$dip eval [list set auto_path $::auto_path] |
||||
} else { |
||||
puts {Creating safe environment, please wait...} |
||||
set dip [::safe::interpCreate] |
||||
} |
||||
interp alias $dip .c {} .c ; # Import of canvas |
||||
interp alias $dip tk {} tk ; # enable tk scaling |
||||
$dip eval {package require diagram} |
||||
$dip eval {diagram D .c} |
||||
}] 0]/double(1e6)}] |
||||
puts "... completed in $sec seconds." |
||||
after 100 |
||||
return $dip |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
package provide diagram::application 1.2 |
||||
return |
||||
@ -0,0 +1,383 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# diagram attribute database, basic data plus extensibility features. |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it brings (dicts, {*}, etc.) |
||||
package require snit ; # Object framework. |
||||
package require struct::queue ; # Word storage when processing attribute arguments. |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
|
||||
snit::type ::diagram::attribute { |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Attribute extensibility |
||||
|
||||
method new {name args} { |
||||
array set spec $args |
||||
|
||||
if {![info exists spec(key)]} { set spec(key) $name } |
||||
set key $spec(key) |
||||
|
||||
set getvalue [GetFunction spec] |
||||
set ovalidate [ValidateFunction spec] ; # snit validation type, or API compatible. |
||||
set otransform [TransformFunction spec] ; # o* <=> optional function. |
||||
set merger [MergeFunction spec $key] |
||||
set odefault [DefaultFunction spec $key] |
||||
|
||||
set myattrp($name) [ProcessingFunction $getvalue $ovalidate $otransform $merger] |
||||
|
||||
if {![llength $odefault]} return |
||||
|
||||
set myattrd($key) $odefault |
||||
{*}$odefault init |
||||
return |
||||
} |
||||
|
||||
method {unknown =} {unknowncmd} { |
||||
set myunknown [list $unknowncmd] |
||||
return |
||||
} |
||||
|
||||
method {unknown +} {unknowncmd} { |
||||
lappend myunknown $unknowncmd |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: attribute processing, integrated loading of requested defaults. |
||||
|
||||
method attributes {shape words required} { |
||||
return [$self defaults [$self process $shape $words] $required] |
||||
} |
||||
|
||||
method process {shape words} { |
||||
if {![llength $words]} { |
||||
return {} |
||||
} |
||||
|
||||
set attributes [ReadySame $shape] |
||||
|
||||
{*}$wq clear |
||||
{*}$wq put {*}$words |
||||
|
||||
while {[{*}$wq size]} { |
||||
set aname [{*}$wq get] |
||||
set shape [dict get $attributes /shape] |
||||
|
||||
if {[{*}$wq size]} { |
||||
#puts A|do|$aname|/$shape|\t\t(([{*}$wq peek [{*}$wq size]])) |
||||
} else { |
||||
#puts A|do|$aname|/$shape|\t\t(()) |
||||
} |
||||
|
||||
# Check for a shape-specific attribute first, then try the |
||||
# name as is. |
||||
|
||||
if {[info exists myattrp(${shape}::$aname)]} { |
||||
{*}$myattrp(${shape}::$aname) $wq attributes |
||||
continue |
||||
} elseif {[info exists myattrp($aname)]} { |
||||
{*}$myattrp($aname) $wq attributes |
||||
continue |
||||
} |
||||
|
||||
#puts A|unknown|$aname| |
||||
|
||||
# Hooks for unknown names, for dynamic extension. |
||||
{*}$wq unget $aname |
||||
set ok 0 |
||||
foreach hook $myunknown { |
||||
#puts A|unknown/$shape|\t\t(([{*}$wq peek [{*}$wq size]])) |
||||
if {[{*}$hook $shape $wq]} { |
||||
#puts A|unknown|taken|$hook |
||||
set ok 1 |
||||
break |
||||
} |
||||
} |
||||
if {$ok} continue |
||||
BadAttribute $shape $wq |
||||
} |
||||
|
||||
#puts A|done|$attributes| |
||||
|
||||
SaveSame $attributes |
||||
return $attributes |
||||
} |
||||
|
||||
method defaults {attributes required} { |
||||
# Note: All default hooks are run, even if the key is already |
||||
# specified. This gives the hook the opportunity to not only |
||||
# fill in defaults, but to compute and store derived |
||||
# information (from multiple other attributes) as well. An |
||||
# example using this ability are the Waypoint and ArcLocation |
||||
# handlers which essentially precompute large parts of their |
||||
# elements' geometry. |
||||
|
||||
foreach key $required { |
||||
#if {[dict exists $attributes $key]} continue |
||||
if {![info exists myattrd($key)]} { |
||||
#return -code error "Unable to determine a default for \"$key\"" |
||||
continue |
||||
} |
||||
{*}$myattrd($key) fill attributes |
||||
} |
||||
return $attributes |
||||
} |
||||
|
||||
method set {attributes} { |
||||
dict for {key value} $attributes { |
||||
if {![info exists myattrd($key)]} continue |
||||
{*}$myattrd($key) set $key $value |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Instance construction |
||||
|
||||
constructor {core} { |
||||
# Core attributes (shape redefinition, history access (same)) |
||||
set mycore $core |
||||
#set myunknown [myproc BadAttribute] |
||||
|
||||
$self new /shape merge [mymethod Merge/shape] |
||||
$self new same get [mymethod GetSame] merge [mymethod MergeSame] |
||||
|
||||
install wq using struct::queue ${selfns}::WQ |
||||
|
||||
# Queue Tracer |
||||
if {0} {set wq [list ::apply [list {args} { |
||||
puts $args |
||||
uplevel 1 $args |
||||
}] $wq]} |
||||
|
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## |
||||
|
||||
proc ReadySame {shape} { |
||||
upvar 1 mycurrentsame mycurrentsame mysame mysame |
||||
set mycurrentsame {} |
||||
catch { |
||||
set mycurrentsame $mysame($shape) |
||||
} |
||||
return [list /shape $shape] |
||||
} |
||||
|
||||
proc SaveSame {attributes} { |
||||
upvar 1 mysame mysame |
||||
set shape [dict get $attributes /shape] |
||||
set mysame($shape) $attributes |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
proc BadAttribute {shape words} { |
||||
return -code error "Expected attribute, got \"[{*}$words peek]\"" |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
method GetSame {words_dummy} { |
||||
return $mycurrentsame |
||||
} |
||||
|
||||
method MergeSame {key samedict attributes} { |
||||
# key == "same" |
||||
return [dict merge $attributes $samedict] |
||||
} |
||||
|
||||
method Merge/shape {key newshape attributes} { |
||||
# key == "/shape" |
||||
ReadySame $newshape |
||||
dict set attributes /shape $newshape |
||||
return $attributes |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
method Get {words} { |
||||
return [{*}$words get] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
method Set {key value attributes} { |
||||
#puts AM.=|$key||$value|\t|$attributes| |
||||
|
||||
dict set attributes $key $value |
||||
|
||||
#puts AM:=|$attributes| |
||||
return $attributes |
||||
} |
||||
|
||||
method Lappend {key value attributes} { |
||||
#puts AM++|$key||$value|\t|$attributes| |
||||
|
||||
dict lappend attributes $key $value |
||||
|
||||
#puts AM:=|$attributes| |
||||
return $attributes |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
method Linked {key varname defaultvalue cmd args} { |
||||
#puts "Linked ($key $varname $defaultvalue) $cmd $args" |
||||
|
||||
$self Linked_ $cmd $key $varname $defaultvalue {*}$args |
||||
} |
||||
|
||||
method {Linked_ init} {key varname defaultvalue} { |
||||
$mycore state set $varname $defaultvalue |
||||
return |
||||
} |
||||
|
||||
method {Linked_ set} {key varname defaultvalue _key newvalue} { |
||||
$mycore state set $varname $newvalue |
||||
return |
||||
} |
||||
|
||||
method {Linked_ fill} {key varname defaultvalue av} { |
||||
upvar 2 $av attributes ; # Bypass the 'Linked' dispatcher. |
||||
#puts LINK|$key|$varname|-|$attributes|-|[$mycore state get $varname]| |
||||
if {[dict exists $attributes $key]} return |
||||
dict set attributes $key [$mycore state get $varname] |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Helper commands processing an attribute specification into a set of anonymous functions |
||||
|
||||
proc GetFunction {sv} { |
||||
upvar 1 $sv spec selfns selfns |
||||
if {[info exists spec(get)]} { return $spec(get) } |
||||
return [mymethod Get] |
||||
} |
||||
|
||||
proc ValidateFunction {sv} { |
||||
upvar 1 $sv spec |
||||
if {[info exists spec(type)]} { |
||||
set f $spec(type) |
||||
if {[llength $f] > 1} { |
||||
# The specification is type + arguments. Create a |
||||
# proper object by inserting a name into the command and then running it. |
||||
set f [eval [linsert $f 1 AttrType%AUTO%]] |
||||
} |
||||
return [list {*}$f validate] |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
proc TransformFunction {sv} { |
||||
upvar 1 $sv spec |
||||
if {[info exists spec(transform)]} { return $spec(transform) } |
||||
return {} |
||||
} |
||||
|
||||
proc MergeFunction {sv key} { |
||||
upvar 1 $sv spec selfns selfns |
||||
if {[info exists spec(merge)]} { return [list {*}$spec(merge) $key] } |
||||
if {![info exists spec(aggregate)]} { |
||||
set spec(aggregate) 0 |
||||
} |
||||
if {$spec(aggregate)} { |
||||
return [mymethod Lappend $key] |
||||
} else { |
||||
return [mymethod Set $key] |
||||
} |
||||
} |
||||
|
||||
proc DefaultFunction {sv key} { |
||||
upvar 1 $sv spec selfns selfns |
||||
if {[info exists spec(default)]} { return $spec(default) } |
||||
if {[info exists spec(linked)]} { |
||||
#lassign $spec(linked) varname defaultvalue |
||||
return [mymethod Linked $key {*}$spec(linked)] |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
proc ProcessingFunction {get validate transform merge} { |
||||
# partial functions. |
||||
# validate, transform - optional |
||||
# get, merge - required |
||||
|
||||
# Types |
||||
# get : wordvar -> value |
||||
# transform : value -> value |
||||
# validate : value -> value |
||||
# merge : value -> dict -> dict |
||||
|
||||
if {[llength $validate] && [llength $transform]} { |
||||
return [list ::apply [list {get validate transform merge words av} { |
||||
upvar 1 $av attributes |
||||
set value [{*}$get $words] |
||||
set value [{*}$transform $value] |
||||
set value [{*}$validate $value] |
||||
set attributes [{*}$merge $value $attributes] |
||||
}] $get $validate $transform $merge] |
||||
|
||||
} elseif {[llength $validate]} { |
||||
return [list ::apply [list {get validate merge words av} { |
||||
upvar 1 $av attributes |
||||
set value [{*}$get $words] |
||||
set value [{*}$validate $value] |
||||
set attributes [{*}$merge $value $attributes] |
||||
}] $get $validate $merge] |
||||
|
||||
} elseif {[llength $transform]} { |
||||
return [list ::apply [list {get transform merge words av} { |
||||
upvar 1 $av attributes |
||||
set value [{*}$get $words] |
||||
set value [{*}$transform $value] |
||||
set attributes [{*}$merge $value $attributes] |
||||
}] $get $transform $merge] |
||||
|
||||
} else { |
||||
return [list ::apply [list {get merge words av} { |
||||
upvar 1 $av attributes |
||||
set value [{*}$get $words] |
||||
set attributes [{*}$merge $value $attributes] |
||||
}] $get $merge] |
||||
} |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Instance data. Maps from attribute names and dictionary keys to |
||||
## relevant functions for processing input and defaults. |
||||
|
||||
variable mycore {} |
||||
variable myunknown {} |
||||
|
||||
variable myattrp -array {} ; # attribute command -> processing function |
||||
variable myattrd -array {} ; # attribute key -> default management function |
||||
|
||||
# History stack, one level deep, keyed by shape name. |
||||
|
||||
variable mysame -array {} |
||||
variable mycurrentsame {} |
||||
|
||||
component wq ; # Storage for the words we are processing as attributes. |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
package provide diagram::attribute 1 |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,62 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# diagram drawing package. |
||||
# |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it brings |
||||
# (dicts, {*}, etc.) |
||||
package require diagram::core ; # Core drawing management |
||||
package require diagram::basic ; # Basic shapes. |
||||
package require snit ; # Object framework. |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
|
||||
snit::type ::diagram { |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Instance construction, and method routing |
||||
|
||||
constructor {canvas args} { |
||||
install core using diagram::core ${selfns}::CORE $canvas |
||||
install basic using diagram::basic ${selfns}::BASIC $core |
||||
|
||||
set mybaseline [$core snap] |
||||
|
||||
if {![llength $args]} return |
||||
$core draw {*}$args |
||||
return |
||||
} |
||||
|
||||
method reset {} { |
||||
$core drop |
||||
$core restore $mybaseline |
||||
return |
||||
} |
||||
|
||||
delegate method * to core |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Instance data, just two components, |
||||
|
||||
component core ; # Fundamental drawing engine and management |
||||
component basic ; # Fundamental shapes we can draw |
||||
|
||||
variable mybaseline |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
package provide diagram 1 |
||||
@ -0,0 +1,254 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# Database of named directions, for use in the diagram controller. |
||||
# |
||||
# Directions are identified by name and each has a set of attributes, |
||||
# each identified by name, with associated value. The attributes are |
||||
# not typed. |
||||
# |
||||
# Standard attributes are 'angle' and 'oppposite', the first providing |
||||
# the angle of the direction, in degrees (0-360, 0 == right/east, 90 |
||||
# == up/north), and the second naming the complentary direction going |
||||
# into the opposite direction (+/- 180 degrees). |
||||
# |
||||
# The eight directions (octants) of the compass rose are predefined, |
||||
# standard. |
||||
# |
||||
# Beyond the directions the system also manages 'aliases', |
||||
# i.e. alternate/secondary names for the primary directions. |
||||
# |
||||
# All names are handled case-insensitive! |
||||
# |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it brings (dicts, {*}, etc.) |
||||
package require snit ; # Object framework. |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
|
||||
snit::type ::diagram::direction { |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Extending the database |
||||
|
||||
method {new direction} {name args} { |
||||
set thename [string tolower $name] |
||||
# Argument validation. |
||||
if {[info exists myinfo($thename)] || |
||||
[info exists myalias($thename)]} { |
||||
return -code error "direction already known" |
||||
} elseif {[llength $args] % 2 == 1} { |
||||
return -code error "Expected a dictionary, got \"$args\"" |
||||
} elseif {![dict exists $args angle]} { |
||||
return -code error "Standard attribute 'angle' is missing" |
||||
} elseif {![dict exists $args opposite]} { |
||||
return -code error "Standard attribute 'opposite' is missing" |
||||
} |
||||
# Note: Can't check the value of opposite, a direction, for |
||||
# existence, because then we are unable to define the pairs. |
||||
|
||||
# Should either check the angle, or auto-reduce to the proper |
||||
# interval. |
||||
|
||||
set myinfo($thename) $args |
||||
return |
||||
} |
||||
|
||||
method {new alias} {name primary} { |
||||
set thename [string tolower $name] |
||||
set theprimary [string tolower $primary] |
||||
# Argument validation. |
||||
if {[info exists myalias($thename)]} { |
||||
return -code error "alias already known" |
||||
} elseif {![info exists myalias($theprimary)] && |
||||
![info exists myinfo($theprimary)]} { |
||||
return -code error "existing direction expected, not known" |
||||
} |
||||
# (*a) Resolve alias to alias in favor of the underlying |
||||
# primary => Short lookup, no iteration required. |
||||
if {[info exists myalias($theprimary)]} { |
||||
set theprimary $myalias($theprimary) |
||||
} |
||||
# And remember the mapping. |
||||
set mydb($thename) $theprimary |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Validate directions, either as explict angle, or named. |
||||
## and return it normalized (angle reduced to |
||||
## interval, primary name of any alias). |
||||
|
||||
method validate {direction} { |
||||
if {[Norm $direction angle]} { return $angle } |
||||
set d $direction |
||||
# Only one alias lookup necessary, see (*a) in 'new alias'. |
||||
if {[info exists myalias($d)]} { set d $myalias($d) } |
||||
if {[info exists myinfo($d)]} { return $d } |
||||
return -code error "Expected direction, got \"$direction\"" |
||||
} |
||||
|
||||
method is {d} { |
||||
if {[Norm $d angle]} { return 1 } |
||||
# Only one alias lookup necessary, see (*a) in 'new alias'. |
||||
if {[info exists myalias($d)]} { set d $myalias($d) } |
||||
return [info exists myinfo($d)] |
||||
} |
||||
|
||||
method isStrict {d} { |
||||
# Only one alias lookup necessary, see (*a) in 'new alias'. |
||||
if {[info exists myalias($d)]} { set d $myalias($d) } |
||||
return [info exists myinfo($d)] |
||||
} |
||||
|
||||
method map {corners c} { |
||||
if {[dict exists $corners $c]} { |
||||
return $c |
||||
} elseif {[$self is $c]} { |
||||
set new [$self validate $c] |
||||
if {$new ne $c} { |
||||
return $new |
||||
} |
||||
} |
||||
|
||||
# Find nearest corner by angle. |
||||
set angle [$self get $c angle] |
||||
set delta Inf |
||||
set min {} |
||||
foreach d [dict keys $corners] { |
||||
if {![$self isStrict $d]} continue |
||||
if {[catch { |
||||
set da [$self get $d angle] |
||||
}]} continue |
||||
set dda [expr {abs($da - $angle)}] |
||||
if {$dda >= $delta} continue |
||||
set delta $dda |
||||
set min $d |
||||
} |
||||
if {$min ne $c} { |
||||
return $min |
||||
} |
||||
return $c |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Retrieve directional attributes (all, or |
||||
## specific). Accepts angles as well, and uses |
||||
## nearest named direction. |
||||
|
||||
method get {direction {detail {}}} { |
||||
if {[Norm $direction angle]} { |
||||
set d [$self FindByAngle $angle] |
||||
} elseif {[info exists myalias($direction)]} { |
||||
set d $myalias($direction) |
||||
} else { |
||||
set d $direction |
||||
} |
||||
if {[info exists myinfo($d)]} { |
||||
if {[llength [info level 0]] == 7} { |
||||
return [dict get $myinfo($d) $detail] |
||||
} else { |
||||
return $myinfo($d) |
||||
} |
||||
} |
||||
return -code error "Expected direction, got \"$direction\"" |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
proc Norm {angle varname} { |
||||
if {![string is double -strict $angle]} { return 0 } |
||||
while {$angle < 0} { set angle [expr {$angle + 360}] } |
||||
while {$angle > 360} { set angle [expr {$angle - 360}] } |
||||
upvar 1 $varname normalized |
||||
set normalized $angle |
||||
return 1 |
||||
} |
||||
|
||||
method FindByAngle {angle} { |
||||
# Find nearest named angle. |
||||
set name {} |
||||
set delta 720 |
||||
foreach k [array names myinfo] { |
||||
if {![dict exists $myinfo($k) angle]} continue |
||||
set a [dict get $myinfo($k) angle] |
||||
if {$a eq {}} continue |
||||
set d [expr {abs($a-$angle)}] |
||||
if {$d < $delta} { |
||||
set delta $d |
||||
set name $k |
||||
} |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Instance data, database tables as arrays, keyed by direction |
||||
## and alias names. |
||||
|
||||
# Standard directions, the eight sections of the compass rose, |
||||
# with angles and opposite, complementary direction. |
||||
# |
||||
# 135 90 45 |
||||
# nw n ne |
||||
# \|/ |
||||
# 180 w -*- e 0 |
||||
# /|\. |
||||
# sw s se |
||||
# 225 270 315 |
||||
|
||||
variable myinfo -array { |
||||
east {angle 0 opposite west } |
||||
northeast {angle 45 opposite southwest} |
||||
north {angle 90 opposite south } |
||||
northwest {angle 135 opposite southeast} |
||||
west {angle 180 opposite east } |
||||
southwest {angle 225 opposite northeast} |
||||
south {angle 270 opposite north } |
||||
southeast {angle 315 opposite northwest} |
||||
|
||||
center {} |
||||
} |
||||
|
||||
# Predefined aliases for the standard directions |
||||
# Cardinal and intermediate directions. |
||||
# Names and appropriate unicode symbols. |
||||
variable myalias -array { |
||||
c center |
||||
|
||||
w west left west \u2190 west |
||||
s south down south \u2191 north |
||||
e east right east \u2192 east |
||||
n north up north \u2193 south |
||||
|
||||
t north top north r east |
||||
b south bottom south l west |
||||
bot south |
||||
|
||||
nw northwest up-left northwest \u2196 northwest |
||||
ne northeast up-right northeast \u2197 northeast |
||||
se southeast down-right southeast \u2198 southeast |
||||
sw southwest down-left southwest \u2199 southwest |
||||
|
||||
upleft northwest leftup northwest |
||||
upright northeast rightup northeast |
||||
downright southeast rightdown southeast |
||||
downleft southwest leftdown southwest |
||||
} |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
package provide diagram::direction 1 |
||||
@ -0,0 +1,298 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# Database of the created/drawn elements, with their canvas items, |
||||
# corners (named points), and sub-elements. |
||||
# |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it |
||||
# brings (dicts, {*}, etc.) |
||||
package require snit ; # Object framework. |
||||
package require math::geometry 1.1.2 ; # Vector math (points, line |
||||
# (segments), poly-lines). |
||||
package require diagram::point |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
|
||||
snit::type ::diagram::element { |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
typemethod validate {id} { |
||||
if {[$type is $id]} {return $id} |
||||
return -code error "Expected element id, got \"$id\"" |
||||
} |
||||
|
||||
typemethod is {id} { |
||||
return [expr {[llength $id] == 2 && |
||||
[lindex $id 0] eq "element" && |
||||
[string is integer -strict [lindex $id 1]] && |
||||
([lindex $id 1] >= 1)}] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
method shape {shape} { |
||||
set myshape($shape) . |
||||
return |
||||
} |
||||
|
||||
method isShape {shape} { |
||||
return [info exists myshape($shape)] |
||||
} |
||||
|
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Extending the database |
||||
|
||||
method new {shape corners items subelements} { |
||||
# Generate key |
||||
set id [NewIdentifier] |
||||
|
||||
# Save the element information. |
||||
set myelement($id) [dict create \ |
||||
shape $shape \ |
||||
corners $corners \ |
||||
items $items \ |
||||
elements $subelements] |
||||
|
||||
lappend myhistory() $id |
||||
lappend myhistory($shape) $id |
||||
|
||||
return $id |
||||
} |
||||
|
||||
method drop {} { |
||||
set mycounter 0 |
||||
array unset myelement * |
||||
array unset myhistory * |
||||
set myhistory() {} |
||||
return |
||||
} |
||||
|
||||
method {history get} {} { |
||||
return [array get myhistory] |
||||
} |
||||
|
||||
method {history set} {history} { |
||||
array unset myhistory * |
||||
array set myhistory $history |
||||
return |
||||
} |
||||
|
||||
method {history find} {shape offset} { |
||||
# 1, 2,...: Offset from the beginning of history, forward. |
||||
# -1,-2,...: Offset from the end history, backward. |
||||
|
||||
if {$offset < 0} { |
||||
set offset [expr {[llength $myhistory($shape)] + $offset}] |
||||
} else { |
||||
incr offset -1 |
||||
} |
||||
|
||||
#parray myhistory |
||||
#puts E|hf|$shape|$offset| |
||||
|
||||
return [lindex $myhistory($shape) $offset] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Query database. |
||||
|
||||
method elements {} { |
||||
return $myhistory() |
||||
} |
||||
|
||||
method corner {id corner} { |
||||
#puts MAP($corner)=|[MapCorner $id $corner]| |
||||
set corners [dict get $myelement($id) corners] |
||||
return [dict get $corners [$dir map $corners $corner]] |
||||
} |
||||
|
||||
method corners {id} { |
||||
return [dict get $myelement($id) corners] |
||||
} |
||||
|
||||
method names {id {pattern *}} { |
||||
return [dict keys [dict get $myelement($id) corners] $pattern] |
||||
} |
||||
|
||||
method items {args} { |
||||
set items {} |
||||
foreach id $args { |
||||
lappend items {*}[dict get $myelement($id) items] |
||||
lappend items {*}[$self items {*}[dict get $myelement($id) elements]] |
||||
} |
||||
|
||||
# Elements with sub-elements elements can cause canvas items |
||||
# to appear multiple times. Reduce this to only one |
||||
# appearance. Otherwise items may be processed multiple times |
||||
# later. |
||||
|
||||
return [lsort -uniq $items] |
||||
} |
||||
|
||||
method bbox {args} { |
||||
# We compute the bounding box from the corners we have for the |
||||
# specified elements. This makes the assumption that the |
||||
# convex hull of the element's corners is a good approximation |
||||
# of the areas they cover. |
||||
# |
||||
# (1) We cannot fall back to canvas items, as the items may |
||||
# cover a much smaller area than the system believes. This |
||||
# notably happens for text elements. In essence a user- |
||||
# declared WxH would be ignored by looking at the canvas. |
||||
# |
||||
# (2) We have to look at all corners because the simple NW/SE |
||||
# diagonal may underestimate the box. This happens for circles |
||||
# where these anchors are near the circle boundary and thus |
||||
# describe the in-scribed box, instead of the outer bounds. |
||||
|
||||
# Note that corners may contain other information than |
||||
# points. This is why the corner values are type tagged, |
||||
# allowing us to ignore the non-point corners. |
||||
|
||||
set polyline {} |
||||
foreach id $args { |
||||
foreach v [dict values [dict get $myelement($id) corners]] { |
||||
lassign $v cmd detail |
||||
if {$cmd ne "point"} continue |
||||
lappend polyline [geo::x $detail] [geo::y $detail] |
||||
} |
||||
} |
||||
|
||||
return [geo::bbox $polyline] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Move elements to a point. |
||||
|
||||
method relocate {id destination corner canvas} { |
||||
|
||||
#puts \trelocate($id).$corner\ @$destination |
||||
|
||||
# Move the id'entified element such that the corner's point is |
||||
# at the destination. |
||||
|
||||
# Retrieve element data. |
||||
array set el $myelement($id) |
||||
|
||||
# Find current location of the specified corner. |
||||
set origin [diagram::point unbox [$self corner $id $corner]] |
||||
|
||||
#puts \t$corner=$origin |
||||
|
||||
# Determine the movement vector which brings the corner into |
||||
# coincidence with the destination. |
||||
set delta [geo::- $destination $origin] |
||||
|
||||
#puts \tdelta=$delta |
||||
|
||||
# And perform the movement. |
||||
$self Move $id $delta $canvas |
||||
return |
||||
} |
||||
|
||||
method move {delta corners} { |
||||
set newcorners {} |
||||
foreach {key location} $corners { |
||||
#puts PLACE|$key|$location|$delta| |
||||
if {[llength $location] == 2} { |
||||
lassign $location cmd detail |
||||
if {$cmd eq "point"} { |
||||
#puts \tSHIFT |
||||
lappend newcorners $key \ |
||||
[list $cmd [geo::+ $detail $delta]] |
||||
} else { |
||||
lappend newcorners $key $location |
||||
} |
||||
} else { |
||||
lappend newcorners $key $location |
||||
} |
||||
} |
||||
|
||||
return $newcorners |
||||
} |
||||
|
||||
method Move {id delta canvas} { |
||||
# Retrieve element data. |
||||
array set el $myelement($id) |
||||
|
||||
# Move the primary items on the canvas. |
||||
foreach item $el(items) { |
||||
$canvas move $item {*}$delta |
||||
} |
||||
|
||||
# Recursively move child elements |
||||
foreach sid $el(elements) { |
||||
$self Move $sid $delta $canvas |
||||
} |
||||
|
||||
# And modify the corners appropriately |
||||
|
||||
set newcorners [$self move $delta $el(corners)] |
||||
|
||||
dict set myelement($id) corners $newcorners |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
constructor {thedir} { |
||||
set dir $thedir |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
proc NewIdentifier {} { |
||||
upvar 1 mycounter mycounter |
||||
return [list element [incr mycounter]] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Instance data, database tables as arrays, keyed by direction |
||||
## and alias names. |
||||
|
||||
component dir ; # Database of named directions. |
||||
# Used to check for and resolve |
||||
# corner aliases. |
||||
variable mycounter 0 ; # Counter for the generation of |
||||
# element identifiers. See |
||||
# 'NewIdentifier' for the user. |
||||
variable myelement -array {} ; # Database of drawn elements. Maps |
||||
# from element identifiers to a |
||||
# dictionary holding the pertinent |
||||
# information (type, canvas items, |
||||
# sub elements, and corners (aka |
||||
# attributes). |
||||
variable myhistory -array { |
||||
{} {} |
||||
} ; # History database. Keyed by |
||||
# element type, they are mapped to |
||||
# lists of element identifiers |
||||
# naming the elements in order of |
||||
# creation. The empty key has the |
||||
# history without regard to type. |
||||
|
||||
variable myshape -array {} ; # Database of element shapes. |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
} |
||||
|
||||
namespace eval ::diagram::element::geo { |
||||
namespace import ::math::geometry::* |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
package provide diagram::element 1 |
||||
@ -0,0 +1,138 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# Auto-layout management |
||||
# |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it |
||||
# brings (dicts, {*}, etc.) |
||||
package require snit ; # Object framework. |
||||
package require struct::stack |
||||
package require diagram::point |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
|
||||
snit::type ::diagram::navigation { |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Modify the state |
||||
|
||||
method reset {} { |
||||
set mylocation {0 0} |
||||
set mydirection east |
||||
set mycorner west |
||||
set mycorners {} |
||||
$mystack clear |
||||
return |
||||
} |
||||
|
||||
method turn {direction {commit 0}} { |
||||
#puts T|$direction|$commit |
||||
set mydirection [$mydirections validate $direction] |
||||
set mycorner [$mydirections get $mydirection opposite] |
||||
#puts O|$mycorner |
||||
|
||||
if {$commit && [dict exists $mycorners $mydirection]} { |
||||
set mylocation \ |
||||
[diagram::point unbox \ |
||||
[diagram::point absolute \ |
||||
[dict get $mycorners $mydirection]]] |
||||
} |
||||
return |
||||
} |
||||
|
||||
method move {newcorners} { |
||||
#puts M|$newcorners |
||||
if {[dict exists $newcorners end]} { |
||||
set mycorners {} |
||||
set at [dict get $newcorners end] |
||||
} else { |
||||
# Note: We map mydirection to the corners to handle the |
||||
# possibility of directions which are not on the compass |
||||
# rose. Such are mapped to the nearest compass or other |
||||
# direction which is supported by the element we have |
||||
# moved to. |
||||
set mycorners $newcorners |
||||
set at [dict get $newcorners \ |
||||
[$mydirections map $newcorners $mydirection]] |
||||
} |
||||
|
||||
set mylocation \ |
||||
[diagram::point unbox [diagram::point absolute $at]] |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: State nesting |
||||
|
||||
method save {} { |
||||
$mystack push [list \ |
||||
$mylocation \ |
||||
$mydirection \ |
||||
$mycorner \ |
||||
$mycorners] |
||||
return |
||||
} |
||||
|
||||
method restore {} { |
||||
lassign [$mystack pop] \ |
||||
mylocation \ |
||||
mydirection \ |
||||
mycorner \ |
||||
mycorners |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Querying |
||||
|
||||
method at {} { |
||||
# TODO :: gap processing goes here -- maybe not required, given 'chop'. |
||||
return $mylocation |
||||
} |
||||
|
||||
method corner {} { |
||||
return $mycorner |
||||
} |
||||
|
||||
method direction {} { |
||||
return $mydirection |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: |
||||
|
||||
constructor {directions} { |
||||
install mystack using struct::stack ${selfns}::STACK |
||||
set mydirections $directions |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Instance data, |
||||
|
||||
component mystack |
||||
component mydirections |
||||
|
||||
variable mylocation {0 0} ; # attribute 'at' default |
||||
variable mydirection east ; # current layout direction. |
||||
variable mycorner west ; # attribute 'with' default |
||||
# (opposite of direction'). |
||||
variable mycorners {} ; # The corners we can turn to. |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
package provide diagram::navigation 1 |
||||
@ -0,0 +1,15 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5]} { |
||||
# PRAGMA: returnok |
||||
return |
||||
} |
||||
package ifneeded diagram::navigation 1 [list source [file join $dir navigation.tcl]] |
||||
package ifneeded diagram::direction 1 [list source [file join $dir direction.tcl]] |
||||
package ifneeded diagram::element 1 [list source [file join $dir element.tcl]] |
||||
package ifneeded diagram::attribute 1 [list source [file join $dir attributes.tcl]] |
||||
package ifneeded diagram::point 1 [list source [file join $dir point.tcl]] |
||||
package ifneeded diagram::core 1 [list source [file join $dir core.tcl]] |
||||
package ifneeded diagram::basic 1.0.1 [list source [file join $dir basic.tcl]] |
||||
package ifneeded diagram 1 [list source [file join $dir diagram.tcl]] |
||||
|
||||
package ifneeded diagram::application 1.2 [list source [file join $dir application.tcl]] |
||||
|
||||
@ -0,0 +1,184 @@
|
||||
## -*- tcl -*- |
||||
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
## BSD Licensed |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# |
||||
# diagram points. |
||||
# |
||||
# Type validation and implementation of the various operations on |
||||
# points and lines. The low-level commands for this come from |
||||
# math::geometry. The operations here additionally (un)box from/to |
||||
# tagged values. They also handle operations mixing polar and |
||||
# cartesian specifications. |
||||
# |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 ; # Want the nice things it |
||||
# brings (dicts, {*}, etc.) |
||||
package require math::geometry 1.1.2 ; # Vector math (points, line |
||||
# (segments), poly-lines). |
||||
|
||||
namespace eval ::diagram::point { |
||||
namespace export is isa validate absolute at delta by unbox + - | resolve |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Implementation |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: validation |
||||
|
||||
proc ::diagram::point::validate {value} { |
||||
if {[is $value]} {return $value} |
||||
return -code error "Expected diagram::point, got \"$value\"" |
||||
} |
||||
|
||||
proc ::diagram::point::absolute {value} { |
||||
if {[isa $value]} {return $value} |
||||
return -code error "Expected absolute diagram::point, got \"$value\"" |
||||
} |
||||
|
||||
proc ::diagram::point::is {value} { |
||||
return [expr {([llength $value] == 2) && |
||||
([lindex $value 0] in {point + by})}] |
||||
} |
||||
|
||||
proc ::diagram::point::isa {value} { |
||||
# note overlap with constructor 'at'. |
||||
return [expr {([llength $value] == 2) || |
||||
([lindex $value 0] eq "point")}] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Constructors |
||||
|
||||
# Absolute location |
||||
proc ::diagram::point::at {x y} { |
||||
return [list point [list $x $y]] |
||||
} |
||||
|
||||
# Relative location, cartesian |
||||
proc ::diagram::point::delta {dx dy} { |
||||
return [list + [list $dx $dy]] |
||||
} |
||||
|
||||
# Relative location, polar |
||||
proc ::diagram::point::by {distance angle} { |
||||
return [list by [list $distance $angle]] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
proc ::diagram::point::unbox {p} { |
||||
return [lindex $p 1] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Public API :: Point arithmetic |
||||
|
||||
proc ::diagram::point::+ {a b} { |
||||
set a [2cartesian [validate $a]] |
||||
set b [2cartesian [validate $b]] |
||||
|
||||
# Unboxing |
||||
|
||||
lassign $a atag adetail |
||||
lassign $b btag bdetail |
||||
|
||||
# Calculation and result type determination |
||||
|
||||
set result [geo::+ $adetail $bdetail] |
||||
set rtype [expr {(($atag eq "point") || ($btag eq "point")) |
||||
? "at" |
||||
: "delta"}] |
||||
|
||||
return [$rtype {*}$result] |
||||
} |
||||
|
||||
proc ::diagram::point::- {a b} { |
||||
set a [2cartesian [validate $a]] |
||||
set b [2cartesian [validate $b]] |
||||
|
||||
# Unboxing |
||||
|
||||
lassign $a atag adetail |
||||
lassign $b btag bdetail |
||||
|
||||
# Calculation and result type determination |
||||
|
||||
set result [geo::- $adetail $bdetail] |
||||
set rtype [expr {(($atag eq "point") || ($btag eq "point")) |
||||
? "at" |
||||
: "delta"}] |
||||
|
||||
return [$rtype {*}$result] |
||||
} |
||||
|
||||
proc ::diagram::point::| {a b} { |
||||
set a [2cartesian [absolute $a]] |
||||
set b [2cartesian [absolute $b]] |
||||
|
||||
# Unboxing |
||||
|
||||
lassign $a atag adetail ; lassign $adetail ax ay |
||||
lassign $b btag bdetail ; lassign $bdetail bx by |
||||
|
||||
# Calculation of the projection. |
||||
return [at $ax $by] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
proc ::diagram::point::resolve {base p} { |
||||
#puts P|resolve|$base|$p| |
||||
|
||||
# The base is an untagged point, p is a tagged point or delta. |
||||
lassign $p tag detail |
||||
|
||||
# A point is returned unchanged. |
||||
if {$tag eq "point"} { return [unbox $p] } |
||||
|
||||
# A delta is normalized, then added to the base. |
||||
|
||||
#puts R|$base|$p| |
||||
#puts R|[2cartesian $p]| |
||||
#puts R|[unbox [2cartesian $p]]| |
||||
|
||||
return [geo::+ $base [unbox [2cartesian $p]]] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# Normalize point/delta information to cartesian |
||||
# coordinates. Input and output are both tagged, and points not |
||||
# using a polar representation are not modified. |
||||
|
||||
proc ::diagram::point::2cartesian {p} { |
||||
lassign $p tag details |
||||
if {$tag ne "by"} { return $p } |
||||
return [delta {*}[polar2cartesian $details]] |
||||
} |
||||
|
||||
# Conversion of a delta from polar to cartesian coordinates, |
||||
# operating on untagged data. |
||||
|
||||
proc ::diagram::point::polar2cartesian {polar} { |
||||
lassign $polar distance angle |
||||
return [geo::s* $distance [geo::direction $angle]] |
||||
} |
||||
|
||||
## |
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ready |
||||
|
||||
namespace eval ::diagram::point::geo { |
||||
namespace import ::math::geometry::* |
||||
} |
||||
|
||||
package provide diagram::point 1 |
||||
@ -0,0 +1,13 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4] } { return } |
||||
package ifneeded getstring 0.1 [list source [file join $dir tk_getString.tcl]] |
||||
|
||||
@ -0,0 +1,124 @@
|
||||
# tk_getString.tcl -- |
||||
# |
||||
# A dialog which prompts for a string input |
||||
# |
||||
# Copyright (c) 2005 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: tk_getString.tcl,v 1.11 2005/04/13 01:29:22 andreas_kupries Exp $ |
||||
|
||||
package require Tk |
||||
package provide getstring 0.1 |
||||
|
||||
namespace eval ::getstring { |
||||
namespace export tk_getString |
||||
} |
||||
|
||||
if {[tk windowingsystem] == "win32"} { |
||||
option add *TkSDialog*Button.width -8 widgetDefault |
||||
option add *TkSDialog*Button.padX 1m widgetDefault |
||||
} else { |
||||
option add *TkSDialog.borderWidth 1 widgetDefault |
||||
option add *TkSDialog*Button.width 5 widgetDefault |
||||
} |
||||
option add *TkSDialog*Entry.width 20 widgetDefault |
||||
|
||||
proc ::getstring::tk_getString {w var text args} { |
||||
array set options { |
||||
-allowempty 0 |
||||
-entryoptions {} |
||||
-title "Enter Information" |
||||
} |
||||
parseOpts options {{-allowempty boolean} {-entryoptions {}} {-geometry {}} \ |
||||
{-title {}}} $args |
||||
|
||||
variable ::getstring::result |
||||
upvar $var result |
||||
catch {destroy $w} |
||||
set focus [focus] |
||||
set grab [grab current .] |
||||
|
||||
toplevel $w -relief raised -class TkSDialog |
||||
wm title $w $options(-title) |
||||
wm iconname $w $options(-title) |
||||
wm protocol $w WM_DELETE_WINDOW {set ::getstring::result 0} |
||||
wm transient $w [winfo toplevel [winfo parent $w]] |
||||
wm resizable $w 1 0 |
||||
|
||||
eval [list entry $w.entry] $options(-entryoptions) |
||||
button $w.ok -text OK -default active -command {set ::getstring::result 1} |
||||
button $w.cancel -text Cancel -command {set ::getstring::result 0} |
||||
label $w.label -text $text |
||||
|
||||
grid $w.label -columnspan 2 -sticky ew -padx 5 -pady 3 |
||||
grid $w.entry -columnspan 2 -sticky ew -padx 5 -pady 3 |
||||
grid $w.ok $w.cancel -padx 4 -pady 7 |
||||
grid rowconfigure $w 2 -weight 1 |
||||
grid columnconfigure $w {0 1} -uniform 1 -weight 1 |
||||
|
||||
bind $w <Return> [list $w.ok invoke] |
||||
bind $w <Escape> [list $w.cancel invoke] |
||||
bind $w <Destroy> {set ::getstring::result 0} |
||||
if {!$options(-allowempty)} { |
||||
bind $w.entry <KeyPress> [list after idle [list ::getstring::getStringEnable $w]] |
||||
$w.ok configure -state disabled |
||||
} |
||||
|
||||
wm withdraw $w |
||||
update idletasks |
||||
focus -force $w.entry |
||||
if {[info exists options(-geometry)]} { |
||||
wm geometry $w $options(-geometry) |
||||
} elseif {[winfo parent $w] == "."} { |
||||
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] |
||||
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] |
||||
wm geom $w +$x+$y |
||||
} else { |
||||
set t [winfo toplevel [winfo parent $w]] |
||||
set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] |
||||
set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] |
||||
wm geom $w +$x+$y |
||||
} |
||||
wm deiconify $w |
||||
grab $w |
||||
|
||||
tkwait variable ::getstring::result |
||||
set result [$w.entry get] |
||||
bind $w <Destroy> {} |
||||
grab release $w |
||||
destroy $w |
||||
focus -force $focus |
||||
if {$grab != ""} {grab $grab} |
||||
update idletasks |
||||
return $::getstring::result |
||||
} |
||||
|
||||
proc ::getstring::parseOpts {var opts input} { |
||||
upvar $var output |
||||
for {set i 0} {$i < [llength $input]} {incr i} { |
||||
for {set a 0} {$a < [llength $opts]} {incr a} { |
||||
if {[lindex $opts $a 0] == [lindex $input $i]} { break } |
||||
} |
||||
if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" } |
||||
set opt [lindex $opts $a] |
||||
if {[llength $opt] > 1} { |
||||
foreach {opt type} $opt {break} |
||||
if {[incr i] >= [llength $input]} { error "$opt requires an argument" } |
||||
if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" } |
||||
set output($opt) [lindex $input $i] |
||||
} else { |
||||
set output($opt) {} |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::getstring::getStringEnable {w} { |
||||
if {![winfo exists $w.entry]} { return } |
||||
if {[$w.entry get] != ""} { |
||||
$w.ok configure -state normal |
||||
} else { |
||||
$w.ok configure -state disabled |
||||
} |
||||
} |
||||
@ -0,0 +1,113 @@
|
||||
# history.tcl -- |
||||
# |
||||
# Provides a history mechanism for entry widgets |
||||
# |
||||
# Copyright (c) 2005 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: history.tcl,v 1.4 2005/08/25 03:36:58 andreas_kupries Exp $ |
||||
|
||||
package require Tk |
||||
package provide history 0.1 |
||||
|
||||
namespace eval history { |
||||
bind History <Up> {::history::up %W} |
||||
bind History <Down> {::history::down %W} |
||||
} |
||||
|
||||
proc ::history::init {w {len 30}} { |
||||
variable history |
||||
variable prefs |
||||
set bt [bindtags $w] |
||||
if {[lsearch $bt History] > -1} { error "$w already has a history" } |
||||
if {[set i [lsearch $bt $w]] < 0} { error "cant find $w in bindtags" } |
||||
bindtags $w [linsert $bt [expr {$i + 1}] History] |
||||
array set history [list $w,list {} $w,cur -1] |
||||
set prefs(maxlen,$w) $len |
||||
return $w |
||||
} |
||||
|
||||
proc ::history::remove {w} { |
||||
variable history |
||||
variable prefs |
||||
set bt [bindtags $w] |
||||
if {[set i [lsearch $bt History]] < 0} { error "$w has no history" } |
||||
bindtags $w [lreplace $bt $i $i] |
||||
unset prefs(maxlen,$w) history($w,list) history($w,cur) |
||||
} |
||||
|
||||
proc ::history::add {w line} { |
||||
variable history |
||||
variable prefs |
||||
if {$history($w,cur) > -1 && [lindex $history($w,list) $history($w,cur)] == $line} { |
||||
set history($w,list) [lreplace $history($w,list) $history($w,cur) $history($w,cur)] |
||||
} |
||||
set history($w,list) [linsert $history($w,list) 0 $line] |
||||
set history($w,list) [lrange $history($w,list) 0 $prefs(maxlen,$w)] |
||||
set history($w,cur) -1 |
||||
} |
||||
|
||||
proc ::history::up {w} { |
||||
variable history |
||||
if {[lindex $history($w,list) [expr {$history($w,cur) + 1}]] != ""} { |
||||
if {$history($w,cur) == -1} { |
||||
set history($w,tmp) [$w get] |
||||
} |
||||
$w delete 0 end |
||||
incr history($w,cur) |
||||
$w insert end [lindex $history($w,list) $history($w,cur)] |
||||
} else { |
||||
alert $w |
||||
} |
||||
} |
||||
|
||||
proc ::history::down {w} { |
||||
variable history |
||||
if {$history($w,cur) != -1} { |
||||
$w delete 0 end |
||||
if {$history($w,cur) == 0} { |
||||
$w insert end $history($w,tmp) |
||||
set history($w,cur) -1 |
||||
} else { |
||||
incr history($w,cur) -1 |
||||
$w insert end [lindex $history($w,list) $history($w,cur)] |
||||
} |
||||
} else { |
||||
alert $w |
||||
} |
||||
} |
||||
|
||||
proc ::history::get {w} { |
||||
variable history |
||||
return $history($w,list) |
||||
} |
||||
|
||||
proc ::history::clear {w} { |
||||
variable history |
||||
set history($w,cur) -1 |
||||
set history($w,list) {} |
||||
unset -nocomplain history($w,tmp) |
||||
} |
||||
|
||||
proc ::history::configure {w option {value {}}} { |
||||
variable history |
||||
variable prefs |
||||
switch -exact -- $option { |
||||
length { |
||||
if {$value == ""} { return $prefs(maxlen,$w) } |
||||
if {![string is integer -strict $value]} { error "length must be an integer" } |
||||
set prefs(maxlen,$w) $value |
||||
} |
||||
alert { |
||||
if {$value == ""} { return [info body ::history::alert] } |
||||
proc ::history::alert w $value |
||||
} |
||||
default { |
||||
error "unknown option $option" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::history::alert {w} {bell} |
||||
@ -0,0 +1,13 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4] } { return } |
||||
package ifneeded history 0.1 [list source [file join $dir history.tcl]] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,9 @@
|
||||
# pkgIndex.tcl -- |
||||
# |
||||
# Copyright (c) 2003 ActiveState Corporation. |
||||
# All rights reserved. |
||||
# |
||||
# RCS: @(#) $Id: pkgIndex.tcl,v 1.11 2011/10/05 00:10:46 hobbs Exp $ |
||||
|
||||
package ifneeded ico 0.3.2 [list source [file join $dir ico0.tcl]] |
||||
package ifneeded ico 1.1 [list source [file join $dir ico.tcl]] |
||||
@ -0,0 +1,975 @@
|
||||
# ipentry.tcl -- |
||||
# |
||||
# An entry widget for IP addresses. |
||||
# |
||||
# Copyright (c) 2003-2008 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
# Copyright (c) 2008 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: ipentry.tcl,v 1.19 2009/01/21 07:10:03 afaupell Exp $ |
||||
|
||||
package require Tk |
||||
package provide ipentry 0.3 |
||||
|
||||
namespace eval ::ipentry { |
||||
namespace export ipentry ipentry6 |
||||
# copy all the bindings from Entry class to our own IPEntrybindtag class |
||||
foreach x [bind Entry] { |
||||
bind IPEntrybindtag $x [bind Entry $x] |
||||
} |
||||
# then replace certain keys we are interested in with our own |
||||
bind IPEntrybindtag <KeyPress> {::ipentry::keypress %W %K} |
||||
bind IPEntrybindtag <BackSpace> {::ipentry::backspace %W} |
||||
bind IPEntrybindtag <period> {::ipentry::dot %W} |
||||
bind IPEntrybindtag <Key-Right> {::ipentry::arrow %W %K} |
||||
bind IPEntrybindtag <Key-Left> {::ipentry::arrow %W %K} |
||||
bind IPEntrybindtag <FocusIn> {::ipentry::FocusIn %W} |
||||
bind IPEntrybindtag <FocusOut> {::ipentry::FocusOut %W} |
||||
bind IPEntrybindtag <<Paste>> {::ipentry::Paste %W CLIPBOARD} |
||||
bind IPEntrybindtag <<PasteSelection>> {::ipentry::Paste %W PRIMARY} |
||||
|
||||
# copy all the bindings from IPEntrybindtag |
||||
foreach x [bind IPEntrybindtag] { |
||||
bind IPEntrybindtag6 $x [bind IPEntrybindtag $x] |
||||
} |
||||
# and replace certain keys with ip6 bindings |
||||
bind IPEntrybindtag6 <KeyPress> {::ipentry::keypress %W %K 6} |
||||
bind IPEntrybindtag6 <colon> {::ipentry::dot %W} |
||||
bind IPEntrybindtag6 <period> {} |
||||
|
||||
#if {[package vsatisfies [package provide Tk] 8.5]} { |
||||
# ttk::style layout IPEntryFrame { |
||||
# Entry.field -sticky news -border 1 -children { |
||||
# IPEntryFrame.padding -sticky news |
||||
# } |
||||
# } |
||||
# bind [winfo class .] <<ThemeChanged>> \ |
||||
# [list +ttk::style layout IPEntryFrame \ |
||||
# [ttk::style layout IPEntryFrame]] |
||||
# } |
||||
} |
||||
|
||||
# ipentry -- |
||||
# |
||||
# main entry point - construct a new ipentry widget |
||||
# |
||||
# ARGS: |
||||
# w path name of widget to create |
||||
# |
||||
# see ::ipentry::configure for args |
||||
# |
||||
# RETURNS: |
||||
# the widget path name |
||||
# |
||||
proc ::ipentry::ipentry {w args} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
#set state(themed) [package vsatisfies [package provide Tk] 8.5] |
||||
set state(themed) 0 |
||||
foreach {name val} $args { |
||||
if {$name eq "-themed"} { |
||||
set state(themed) $val |
||||
} |
||||
} |
||||
if {$state(themed)} { |
||||
ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 |
||||
} else { |
||||
frame $w -relief sunken -class IPEntry;#-padx 5 |
||||
} |
||||
foreach x {0 1 2 3} y {d1 d2 d3 d4} { |
||||
#if {$state(themed)} { |
||||
# ttk::entry $w.$x -width 3 -justify center |
||||
# ttk::label $w.$y -text . |
||||
#} |
||||
entry $w.$x -borderwidth 0 -width 3 -highlightthickness 0 \ |
||||
-justify center -takefocus 0 |
||||
label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text . \ |
||||
-justify center -cursor [$w.$x cget -cursor] \ |
||||
-background [$w.$x cget -background] \ |
||||
-disabledforeground [$w.$x cget -disabledforeground] |
||||
pack $w.$x $w.$y -side left |
||||
bindtags $w.$x [list $w.$x IPEntrybindtag . all] |
||||
bind $w.$y <Button-1> {::ipentry::dotclick %W %x} |
||||
} |
||||
destroy $w.d4 |
||||
$w.0 configure -takefocus 1 |
||||
if {$state(themed)} { |
||||
pack configure $w.0 -padx {1 0} -pady 1 |
||||
pack configure $w.3 -padx {0 1} -pady 1 -fill x -expand 1 |
||||
$w.3 configure -justify left |
||||
} else { |
||||
$w configure -borderwidth [lindex [$w.0 configure -bd] 3] |
||||
#-background [$w.0 cget -bg] |
||||
} |
||||
rename ::$w ::ipentry::_$w |
||||
# redirect the widget name command to the widgetCommand dispatcher |
||||
interp alias {} ::$w {} ::ipentry::widgetCommand $w |
||||
bind $w <Destroy> [list ::ipentry::destroyWidget $w] |
||||
if {[llength $args] > 0} { |
||||
eval [list $w configure] $args |
||||
} |
||||
return $w |
||||
} |
||||
|
||||
# ipentry -- |
||||
# |
||||
# main entry point - construct a new ipentry6 widget |
||||
# |
||||
# ARGS: |
||||
# w path name of widget to create |
||||
# |
||||
# see ::ipentry::configure for args |
||||
# |
||||
# RETURNS: |
||||
# the widget path name |
||||
# |
||||
proc ::ipentry::ipentry6 {w args} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
#set state(themed) [package vsatisfies [package provide Tk] 8.5] |
||||
set state(themed) 0 |
||||
foreach {name val} $args { |
||||
if {$name eq "-themed"} { |
||||
set state(themed) $val |
||||
} |
||||
} |
||||
if {$state(themed)} { |
||||
ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 |
||||
} else { |
||||
frame $w -relief sunken -class IPEntry;#-padx 5 |
||||
} |
||||
foreach x {0 1 2 3 4 5 6 7} y {d1 d2 d3 d4 d5 d6 d7 d8} { |
||||
entry $w.$x -borderwidth 0 -width 4 -highlightthickness 0 \ |
||||
-justify center -takefocus 0 |
||||
label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text : \ |
||||
-justify center -cursor [$w.$x cget -cursor] \ |
||||
-background [$w.$x cget -background] \ |
||||
-disabledforeground [$w.$x cget -disabledforeground] |
||||
pack $w.$x $w.$y -side left |
||||
bindtags $w.$x [list $w.$x IPEntrybindtag6 . all] |
||||
bind $w.$y <Button-1> {::ipentry::dotclick %W %x} |
||||
} |
||||
destroy $w.d8 |
||||
$w.0 configure -takefocus 1 |
||||
if {$state(themed)} { |
||||
pack configure $w.0 -padx {1 0} -pady 1 |
||||
pack configure $w.7 -padx {0 1} -pady 1 -fill x -expand 1 |
||||
$w.7 configure -justify left |
||||
} else { |
||||
$w configure -borderwidth [lindex [$w.0 configure -bd] 3] |
||||
#-background [$w.0 cget -bg] |
||||
} |
||||
rename ::$w ::ipentry::_$w |
||||
# redirect the widget name command to the widgetCommand dispatcher |
||||
interp alias {} ::$w {} ::ipentry::widgetCommand6 $w |
||||
bind $w <Destroy> [list ::ipentry::destroyWidget $w] |
||||
if {[llength $args] > 0} { |
||||
eval [list $w configure] $args |
||||
} |
||||
return $w |
||||
} |
||||
|
||||
# keypress -- |
||||
# |
||||
# called every time a key is pressed in an ipentry widget |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# key the keysym (%K) from the event |
||||
# type empty string or "6" depending on the type of ipentry |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::keypress {w key {type {}}} { |
||||
if {![validate$type $w $key]} { return } |
||||
# sel.first and sel.last throw an error if the selection isnt in $w |
||||
catch { |
||||
set insert [$w index insert] |
||||
# if a key is pressed while there is a selection then delete the |
||||
# selected chars |
||||
if {([$w index sel.first] <= $insert) && ([$w index sel.last] >= $insert)} { |
||||
$w delete sel.first sel.last |
||||
} |
||||
} |
||||
$w insert insert $key |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
|
||||
# backspace -- |
||||
# |
||||
# called when the Backspace key is pressed in an ipentry widget |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# try to act like a normal backspace except if the cursor is at index 0 |
||||
# of one entry we need to move to the end of the preceding entry |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::backspace {w} { |
||||
if {[$w selection present]} { |
||||
$w delete sel.first sel.last |
||||
} else { |
||||
if {[$w index insert] == 0} { |
||||
set w [skip $w prev] |
||||
} |
||||
$w delete [expr {[$w index insert] - 1}] |
||||
} |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
|
||||
# dot -- |
||||
# |
||||
# called when the dot (Period) key is pressed in an ipentry widget |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# treat the current entry as done and move to the next entry field |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::dot {w} { |
||||
if {[string length [$w get]] > 0} { |
||||
skip $w next 1 |
||||
} |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
|
||||
# FocusIn -- |
||||
# |
||||
# called when the focus enters any of the child widgets of an ipentry |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# clear the selection of all child widgets other than the one with focus |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::FocusIn {w} { |
||||
set p [winfo parent $w] |
||||
foreach x {0 1 2 3 4 5 6 7} { |
||||
if {![winfo exists $p.$x]} { break } |
||||
if {"$p.$x" != $w} { |
||||
$p.$x selection clear |
||||
} |
||||
} |
||||
} |
||||
|
||||
# FocusOut -- |
||||
# |
||||
# called when the focus leaves any of the child widgets of an ipentry |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# dont allow a 0 in the first quad |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::FocusOut {w} { |
||||
set s [$w get] |
||||
if {[string match {*.0} $w] && $s != "" && $s < 1} { |
||||
$w delete 0 end |
||||
$w insert end 1 |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
# trim off leading zeros |
||||
if {[string length $s] > 1} { |
||||
set n [string trimleft $s 0] |
||||
if {$n eq ""} { set n 0 } |
||||
if {![string equal $n $s]} { |
||||
$w delete 0 end |
||||
$w insert end $n |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Paste -- |
||||
# |
||||
# called from the <<Paste>> virtual event |
||||
# used by ipentry only |
||||
# |
||||
# clear the selection of all child widgets other than the one with focus |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# sel one of CLIPBOARD or PRIMARY |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::Paste {w sel} { |
||||
if {[catch {::tk::GetSelection $w $sel} paste]} { return } |
||||
$w delete 0 end |
||||
foreach char [split $paste {}] { |
||||
# ignore everything except dots and digits |
||||
if {![string match {[0123456789.]} $char]} { continue } |
||||
if {$char != "."} { |
||||
$w insert end $char |
||||
} |
||||
# if value is over 255 truncate it |
||||
if {[$w get] > 255} { |
||||
$w delete 0 end |
||||
$w insert 0 255 |
||||
} |
||||
# if char is a . then get the index of the current entry |
||||
# and update $w to point to the next entry |
||||
if {$char == "."} { |
||||
set n [string index $w end] |
||||
if { $n >= 3 } { return } |
||||
set w [string trimright $w "0123"][expr {$n + 1}] |
||||
$w delete 0 end |
||||
continue |
||||
} |
||||
} |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
|
||||
# Paste6 -- |
||||
# |
||||
# called from the <<Paste>> virtual event |
||||
# used by both ipentry6 only |
||||
# |
||||
# clear the selection of all child widgets other than the one with focus |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# sel one of CLIPBOARD or PRIMARY |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::Paste6 {w sel} { |
||||
if {[catch {::tk::GetSelection $w $sel} paste]} { return } |
||||
$w delete 0 end |
||||
foreach char [split $paste {}] { |
||||
# ignore everything except colons and hex digits |
||||
if {![string match {[0123456789abcdefABCDEF:]} $char]} { continue } |
||||
if {$char != ":"} { |
||||
$w insert end $char |
||||
} |
||||
# if char is a : then get the index of the current entry |
||||
# and update $w to point to the next entry |
||||
if {$char == ":"} { |
||||
set n [string index $w end] |
||||
if { $n >= 7 } { return } |
||||
set w [string trimright $w "01234567"][expr {$n + 1}] |
||||
$w delete 0 end |
||||
continue |
||||
} |
||||
} |
||||
::ipentry::updateTextvar $w |
||||
} |
||||
|
||||
# dotclick -- |
||||
# |
||||
# called when mouse button 1 is clicked on any of the label widgets |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# decide which side of the dot was clicked and put the focus and cursor |
||||
# in the correct entry |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::dotclick {w x} { |
||||
if {$x > ([winfo width $w] / 2)} { |
||||
set w [winfo parent $w].[string index $w end] |
||||
focus $w |
||||
$w icursor 0 |
||||
} else { |
||||
set w [winfo parent $w].[expr {[string index $w end] - 1}] |
||||
focus $w |
||||
$w icursor end |
||||
} |
||||
} |
||||
|
||||
# arrow -- |
||||
# |
||||
# called when the left or right arrow keys are pressed in an ipentry |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# key one of Left or Right |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::arrow {w key} { |
||||
set i [$w index insert] |
||||
set l [string length [$w get]] |
||||
# move the icursor +1 or -1 position |
||||
$w icursor [expr $i [string map {Right + Left -} $key] 1] |
||||
$w selection clear |
||||
# if we are moving right and the cursor is at the end, or the entry is empty |
||||
if {$key == "Right" && ($i == $l || $l == 0)} { |
||||
skip $w next |
||||
} elseif {$key == "Left" && $i == 0} { |
||||
skip $w prev |
||||
} |
||||
} |
||||
|
||||
# validate -- |
||||
# |
||||
# called by keypress to validate the input |
||||
# used by ipentry only |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# key the key pressed |
||||
# |
||||
# RETURNS: |
||||
# a boolean indicating if the key is valid or not |
||||
# |
||||
proc ::ipentry::validate {w key} { |
||||
if {![string match {[0123456789]} $key]} { return 0 } |
||||
set curval [$w get] |
||||
set insert [$w index insert] |
||||
# dont allow more than a single 0 to be entered |
||||
if {$curval == "0" && $key == "0"} { return 0 } |
||||
if {[string length $curval] == 2} { |
||||
set curval [join [linsert [split $curval {}] $insert $key] {}] |
||||
if {$curval > 255} { |
||||
$w delete 0 end |
||||
$w insert 0 255 |
||||
$w selection range 0 end |
||||
::ipentry::updateTextvar $w |
||||
return 0 |
||||
} elseif {$insert == 2} { |
||||
skip $w next 1 |
||||
} |
||||
return 1 |
||||
} |
||||
if {[string length $curval] >= 3 && ![$w selection present]} { |
||||
if {$insert == 3} { skip $w next 1 } |
||||
return 0 |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
# validate6 -- |
||||
# |
||||
# called by keypress to validate the input |
||||
# used by ipentry6 only |
||||
# |
||||
# ARGS: |
||||
# w window argument (%W) from the event binding |
||||
# key the key pressed |
||||
# |
||||
# RETURNS: |
||||
# a boolean indicating if the key is valid or not |
||||
# |
||||
proc ::ipentry::validate6 {w key} { |
||||
if {![string is xdigit $key]} { return 0 } |
||||
set curval 0x[$w get] |
||||
set insert [$w index insert] |
||||
# dont allow more than a single 0 to be entered |
||||
if {$curval == "0" && $key == "0"} { return 0 } |
||||
if {[string length $curval] == 5} { |
||||
set curval [join [linsert [split $curval {}] $insert $key] {}] |
||||
if {$insert == 3} { |
||||
skip $w next 1 |
||||
} |
||||
return 1 |
||||
} |
||||
if {[string length $curval] >= 6 && ![$w selection present]} { |
||||
if {$insert == 4} { skip $w next 1 } |
||||
return 0 |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
# skip -- |
||||
# |
||||
# move the cursor to the previous or next entry widget |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w name of the current entry widget |
||||
# dir direction to move, one of next or prev |
||||
# sel boolean indicating whether to select the digits in the next entry |
||||
# |
||||
# RETURNS: |
||||
# the name of the widget with focus |
||||
# |
||||
proc ::ipentry::skip {w dir {sel 0}} { |
||||
set n [string index $w end] |
||||
if {$dir == "next"} { |
||||
set next [string trimright $w "012345678"][expr {$n + 1}] |
||||
if { ![winfo exists $next] } { return $w } |
||||
focus $next |
||||
if {$sel} { |
||||
$next icursor 0 |
||||
$next selection range 0 end |
||||
} |
||||
return $next |
||||
} else { |
||||
if { $n <= 0 } { return $w } |
||||
set prev [string trimright $w "012345678"][expr {$n - 1}] |
||||
focus $prev |
||||
$prev icursor end |
||||
return $prev |
||||
} |
||||
} |
||||
|
||||
# _foreach -- |
||||
# |
||||
# utility for the widget configure command |
||||
# |
||||
# perform a command on every subwidget of an ipentry frame |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry frame |
||||
# cmd command to perform |
||||
# type one of empty, "entry", or "dot" |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::_foreach {w cmd {type {}}} { |
||||
if {$type == "" || $type == "entry"} { |
||||
foreach x {0 1 2 3 4 5 6 7} { |
||||
if {![winfo exists $w.$x]} { break } |
||||
eval [list $w.$x] $cmd |
||||
} |
||||
} |
||||
if {$type == "" || $type == "dot"} { |
||||
foreach x {d1 d2 d3 d4 d5 d6 d7} { |
||||
if {![winfo exists $w.$x]} { break } |
||||
eval [list $w.$x] $cmd |
||||
} |
||||
} |
||||
} |
||||
|
||||
# cget -- |
||||
# |
||||
# handle the widgetName cget subcommand |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# cmd name of a configuration option |
||||
# |
||||
# RETURNS: |
||||
# the value of the requested option |
||||
# |
||||
proc ::ipentry::cget {w cmd} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
switch -exact -- $cmd { |
||||
-bd - |
||||
-borderwidth - |
||||
-relief { |
||||
# for bd and relief return the value from the container frame |
||||
if {!$state(themed)} { |
||||
return [::ipentry::_$w cget $cmd] |
||||
} |
||||
} |
||||
-textvariable { |
||||
if {[info exists ::ipentry::textvars($w)]} { |
||||
return $::ipentry::textvars($w) |
||||
} |
||||
return {} |
||||
} |
||||
-themed { return $state(themed) } |
||||
-takefocus { return 0 } |
||||
default { |
||||
# for all other commands return the value from the first entry |
||||
return [$w.0 cget $cmd] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# configure -- |
||||
# |
||||
# handle the widgetName configure subcommand |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# args name/value pairs of configuration options |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::configure {w args} { |
||||
upvar #0 [namespace current]::widget_$w Priv |
||||
while {[set cmd [lindex $args 0]] != ""} { |
||||
switch -exact -- $cmd { |
||||
-state { |
||||
set state [lindex $args 1] |
||||
if {$state == "disabled"} { |
||||
_foreach $w [list configure -state disabled] |
||||
if {[set dbg [$w.0 cget -disabledbackground]] == ""} { |
||||
set dbg [$w.0 cget -bg] |
||||
} |
||||
_foreach $w [list configure -bg $dbg] dot |
||||
if {$Priv(themed)} { |
||||
::ipentry::_$w state disabled |
||||
} else { |
||||
::ipentry::_$w configure -background $dbg |
||||
} |
||||
} elseif {$state == "normal"} { |
||||
_foreach $w [list configure -state normal] |
||||
_foreach $w [list configure -bg [$w.0 cget -bg]] dot |
||||
if {$Priv(themed)} { |
||||
::ipentry::_$w state {!readonly !disabled} |
||||
} else { |
||||
::ipentry::_$w configure -background [$w.0 cget -bg] |
||||
} |
||||
} elseif {$state == "readonly"} { |
||||
_foreach $w [list configure -state readonly] entry |
||||
if {[set robg [$w.0 cget -readonlybackground]] == ""} { |
||||
set robg [$w.0 cget -bg] |
||||
} |
||||
_foreach $w [list configure -bg $robg] dot |
||||
if {$Priv(themed)} { |
||||
::ipentry::_$w state !readonly |
||||
} else { |
||||
::ipentry::_$w configure -background $robg |
||||
} |
||||
} |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-bg - -background { |
||||
set bg [lindex $args 1] |
||||
_foreach $w [list configure -background $bg] |
||||
if {!$Priv(themed)} { |
||||
::ipentry::_$w configure -background $bg |
||||
} |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-disabledforeground { |
||||
_foreach $w [list configure -disabledforeground [lindex $args 1]] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-font - |
||||
-fg - -foreground { |
||||
_foreach $w [list configure $cmd [lindex $args 1]] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-bd - -borderwidth - |
||||
-relief - |
||||
-highlightcolor - |
||||
-highlightbackground - |
||||
-highlightthickness { |
||||
_$w configure $cmd [lindex $args 1] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-readonlybackground - |
||||
-disabledbackground - |
||||
-selectforeground - |
||||
-selectbackground - |
||||
-selectborderwidth - |
||||
-insertbackground { |
||||
_foreach $w [list configure $cmd [lindex $args 1]] entry |
||||
set args [lrange $args 2 end] |
||||
} |
||||
-themed { |
||||
# ignored - only used in widget creation |
||||
} |
||||
-textvariable { |
||||
set name [lindex $args 1] |
||||
upvar #0 $name var |
||||
#if {![string match ::* $name]} { set name ::$name } |
||||
if {[info exists ::ipentry::textvars($w)]} { |
||||
set trace [trace info variable var] |
||||
trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] |
||||
} |
||||
set ::ipentry::textvars($w) $name |
||||
if {![info exists var]} { set var "" } |
||||
::ipentry::traceFired $w $name {} write |
||||
if {[winfo exists $w.4]} { |
||||
trace add variable var {write unset} [list ::ipentry::traceFired6 $w] |
||||
} else { |
||||
trace add variable var {write unset} [list ::ipentry::traceFired $w] |
||||
} |
||||
set args [lrange $args 2 end] |
||||
} |
||||
default { |
||||
error "unknown option \"[lindex $args 0]\"" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# destroyWidget -- |
||||
# |
||||
# bound to the <Destroy> event |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::destroyWidget {w} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
if {[info exists ::ipentry::textvars($w)]} { |
||||
upvar #0 $::ipentry::textvars($w) var |
||||
set trace [trace info variable var] |
||||
trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] |
||||
} |
||||
rename $w {} |
||||
unset state |
||||
} |
||||
|
||||
# traceFired -- |
||||
# |
||||
# called by the variable trace on the ipentry textvariable |
||||
# used by ipentry only |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# varname name of the variable being traced |
||||
# key array index of the variable |
||||
# op operation performed on the variable, read/write/unset |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::traceFired {w name key op} { |
||||
upvar #0 $name var |
||||
if {[info level] > 1} { |
||||
set caller [lindex [info level -1] 0] |
||||
if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired"} { return } |
||||
} |
||||
if {$op == "write"} { |
||||
_insert $w [split $var .] |
||||
set val [string trim [join [$w get] .] .] |
||||
# allow a dot at the end, but only if we have less than 3 already |
||||
if {[string index $var end] == "." && [regexp -all {\.+} $var] <= 3} { append val . } |
||||
if {$val eq $var} return |
||||
after 0 [list set $name $val] |
||||
set var $val |
||||
} elseif {$op == "unset"} { |
||||
::ipentry::updateTextvar $w.0 |
||||
trace add variable var {write unset} [list ipentry::traceFired $w] |
||||
} |
||||
} |
||||
|
||||
# traceFired6 -- |
||||
# |
||||
# called by the variable trace on the ipentry textvariable |
||||
# used by ipentry6 only |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# varname name of the variable being traced |
||||
# key array index of the variable |
||||
# op operation performed on the variable, read/write/unset |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::traceFired6 {w name key op} { |
||||
upvar #0 $name var |
||||
if {[info level] > 1} { |
||||
set caller [lindex [info level -1] 0] |
||||
if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired6"} { return } |
||||
} |
||||
if {$op == "write"} { |
||||
_insert6 $w [split $var :] |
||||
set val [string trim [join [$w get] :] :] |
||||
# allow a dot at the end, but only if we have less than 3 already |
||||
if {[string index $var end] == ":" && [regexp -all {\:+} $var] <= 7} { append val : } |
||||
if {$val eq $var} return |
||||
after 0 [list set $name $val] |
||||
set var $val |
||||
} elseif {$op == "unset"} { |
||||
::ipentry::updateTextvar $w.0 |
||||
trace add variable var {write unset} [list ipentry::traceFired6 $w] |
||||
} |
||||
} |
||||
|
||||
# updateTextvar -- |
||||
# |
||||
# called by all procs which change the value of the ipentry |
||||
# used by both ipentry and ipentry6 |
||||
# |
||||
# update the textvariable if it exists with the new value |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::updateTextvar {w} { |
||||
set p [winfo parent $w] |
||||
if {![info exists ::ipentry::textvars($p)]} { return } |
||||
set c [$p.d1 cget -text] |
||||
set val [string trim [join [$p get] $c] $c] |
||||
upvar #0 $::ipentry::textvars($p) var |
||||
if {[info exists var] && $var == $val} { return } |
||||
set var $val |
||||
} |
||||
|
||||
# _insert -- |
||||
# |
||||
# called by the variable trace on the ipentry textvariable and widget insert cmd |
||||
# used by ipentry only |
||||
# |
||||
# ARGS: |
||||
# w name of an ipentry widget |
||||
# val a list of 4 values to be inserted into the ipentry |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::_insert {w val} { |
||||
foreach x {0 1 2 3} { |
||||
set n [lindex $val $x] |
||||
if {$n != ""} { |
||||
if {![string is integer -strict $n]} { |
||||
#error "cannot insert non-numeric arguments" |
||||
return |
||||
} |
||||
if {$n > 255} { set n 255 } |
||||
if {$n <= 0} { set n 0 } |
||||
if {$x == 0 && $n < 1} { set n 1 } |
||||
} |
||||
$w.$x delete 0 end |
||||
$w.$x insert 0 $n |
||||
} |
||||
} |
||||
|
||||
# _insert6 -- |
||||
# |
||||
# called by the variable trace on the ipentry textvariable and widget insert cmd |
||||
# used by both ipentry6 only |
||||
# |
||||
# ARGS: |
||||
# w name of an ipentry widget |
||||
# val a list of 8 values to be inserted into the ipentry |
||||
# |
||||
# RETURNS: |
||||
# nothing |
||||
# |
||||
proc ::ipentry::_insert6 {w val} { |
||||
foreach x {0 1 2 3 4 5 6 7} { |
||||
set n [lindex $val $x] |
||||
if {![string is xdigit $n]} { |
||||
#error "cannot insert non-hex arguments" |
||||
return |
||||
} |
||||
if {$n != "" } { |
||||
if "$x == 0 && 0x$n < 1" { set n 1 } |
||||
if "0x$n > 0xffff" { set n ffff } |
||||
} |
||||
$w.$x delete 0 end |
||||
$w.$x insert 0 $n |
||||
} |
||||
} |
||||
|
||||
# widgetCommand -- |
||||
# |
||||
# handle the widgetName command |
||||
# used by ipentry, with some commands passed through from widgetCommand6 |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# cmd the subcommand |
||||
# args arguments to the subcommand |
||||
# |
||||
# RETURNS: |
||||
# the results of the invoked subcommand |
||||
# |
||||
proc ::ipentry::widgetCommand {w cmd args} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
switch -exact -- $cmd { |
||||
get { |
||||
# return the 4 entry values as a list |
||||
foreach x {0 1 2 3 4 5 6 7} { |
||||
if {![winfo exists $w.$x]} { break } |
||||
set s [$w.$x get] |
||||
if {[string length $s] > 1} { |
||||
set s [string trimleft $s 0] |
||||
if {$s == ""} { set s 0 } |
||||
} |
||||
|
||||
lappend r $s |
||||
} |
||||
return $r |
||||
} |
||||
insert { |
||||
_insert $w [join $args] |
||||
::ipentry::updateTextvar $w.3 |
||||
} |
||||
icursor { |
||||
if {![string match $w.* [focus]]} { return } |
||||
set i [lindex $args 0] |
||||
if {![string is integer -strict $i]} { error "argument must be an integer" } |
||||
set s [expr {$i / 4}] |
||||
focus $w.$s |
||||
$w.$s icursor [expr {$i % 4}] |
||||
} |
||||
complete { |
||||
foreach x {0 1 2 3 4 5 6 7} { |
||||
if {![winfo exists $w.$x]} { break } |
||||
if {[$w.$x get] == ""} { return 0 } |
||||
} |
||||
return 1 |
||||
} |
||||
configure { |
||||
eval [list ::ipentry::configure $w] $args |
||||
} |
||||
cget { |
||||
return [::ipentry::cget $w [lindex $args 0]] |
||||
} |
||||
default { |
||||
error "bad option \"$cmd\": must be get, insert, complete, cget, or configure" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# widgetCommand6 -- |
||||
# |
||||
# handle the widgetName command for ipentry6 widgets |
||||
# most subcommands are passed through to widgetCommand by the default case |
||||
# |
||||
# ARGS: |
||||
# w name of the ipentry widget |
||||
# cmd the subcommand |
||||
# args arguments to the subcommand |
||||
# |
||||
# RETURNS: |
||||
# the results of the invoked subcommand |
||||
# |
||||
proc ::ipentry::widgetCommand6 {w cmd args} { |
||||
upvar #0 [namespace current]::widget_$w state |
||||
switch -exact -- $cmd { |
||||
insert { |
||||
_insert6 $w [join $args] |
||||
::ipentry::updateTextvar $w.7 |
||||
} |
||||
icursor { |
||||
if {![string match $w.* [focus]]} { return } |
||||
set i [lindex $args 0] |
||||
if {![string is integer -strict $i]} { error "argument must be am integer" } |
||||
set s [expr {$i / 8}] |
||||
focus $w.$s |
||||
$w.$s icursor [expr {$i % 8}] |
||||
} |
||||
default { |
||||
return [eval [list ::ipentry::widgetCommand $w $cmd] $args] |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,3 @@
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4] } { return } |
||||
package ifneeded ipentry 0.3 [list source [file join $dir ipentry.tcl]] |
||||
|
||||
@ -0,0 +1,74 @@
|
||||
# ROOT.msg -- |
||||
# |
||||
# Default English-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2006 by Kevin B. Kenny. All rights reserved. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: ROOT.msg,v 1.2 2006/09/05 18:52:22 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/ROOT.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# Make sure that help text is available in the root locale. |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
# If you edit this file, also edit the corresponding text in en.msg, |
||||
# which is provided for 8.4 compatibility. |
||||
|
||||
::msgcat::mcset {} HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM allows you to input international characters from a |
||||
keyboard that doesn't support them. It works independently of |
||||
any input method that the operating system may supply; it is |
||||
intended for when you don't have control over your keyboard |
||||
mapping and still need to input text in other languages. |
||||
|
||||
To use KHIM, bring up the KHIM Controls (the way this is done |
||||
depends on your application) and enable KHIM by checking "Use |
||||
KHIM". You also need to choose a key on your keyboard that is |
||||
seldom used, and designate it as the "Compose" key by pressing |
||||
the button labelled, "Compose key:" then striking the key you |
||||
wish to designate. Generally speaking, this key should not be |
||||
the key designated as "Compose" on the keyboard; that key will |
||||
continue to invoke whatever input method the local operating |
||||
system supplies. |
||||
|
||||
Once KHIM is enabled, you can enter international characters |
||||
in any widget that is configured to use KHIM by pressing the |
||||
Compose key followed by a two-character sequence. The listbox |
||||
in the KHIM controls shows the available sequences. In |
||||
addition, if you strike the Compose key twice, you get a |
||||
dialog that allows you to input arbitrary symbols from a |
||||
Unicode character map. In the map, you can navigate among the |
||||
characters using either the cursor keys or the mouse, and you |
||||
can select the current character for insertion by |
||||
double-clicking it, pressing the space bar, or pressing the |
||||
Enter (or Return) key. |
||||
|
||||
To define a new sequence for use with the Compose key, bring |
||||
up the KHIM controls, enter the two characters in the |
||||
"Input key sequence" entry and the desired character to insert |
||||
into the "Character" entry, and press "Change". (You may copy |
||||
and paste the character from another application, or use the |
||||
"Unicode..." button (or press the Compose key twice) to select |
||||
the character from a map of all available Unicode code |
||||
points.) To remove a sequence, select it in the listbox and |
||||
press "Delete". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset {} {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Please press the |
||||
key that you want |
||||
to use as the |
||||
"Compose" key. |
||||
}] |
||||
|
||||
} |
||||
|
||||
@ -0,0 +1,108 @@
|
||||
# cs.msg -- |
||||
# |
||||
# Czech-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# Translation by Michal Mestan <mestan@dix.cz> |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: cs.msg,v 1.1 2006/12/06 17:28:12 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/cs.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
::msgcat::mcset cs HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM vám umožňuje zadávat mezinárodní znaky včetně těch, |
||||
které na vaší klávesnici nejspou. Pracuje nezávisle na |
||||
požité vstupní metodě kterou váš operační systém může |
||||
poskytovat. Je hlavně určen pro případy, kdy nemáte možnost |
||||
měnit mapování klávesnice a přesto potřebujete zapsat |
||||
cizojazyčný text. |
||||
|
||||
K nastavení KHIM slouží "Ovládací panel KHIM" (jeho vyvolání |
||||
je závaislé na konkrétní aplikaci), zde povolte KHIM zaškrtnutím |
||||
políčka "Používat KHIM". Mužete si zde též vybrat klávesu na |
||||
vaší klávesnici, kterou bude KHIM používat jako "mrtvá" |
||||
stisknutím talčítka "Mrtvá klávesa" a poté stisktnutím |
||||
patřičné klávesy. Obecně lze říci, nemůže to být jakákoliv |
||||
"mrtvá" klávasa vaší klávesové mapy, jelikož při stisknutí |
||||
je volána vstupní metoda operačního systému. |
||||
|
||||
Když je KHIM povolen, můžete vkládat mezinárodní znaky |
||||
v jakémkoliv přípravku, který je nastaven tak, aby používal |
||||
KHIM stiknutním "mrtvé" klávesy následované posloupností |
||||
dvou znaků. Seznam v "Ovládacím panelu KHIM" zobrazuje |
||||
dostupné posloupnosti. Pokud stisknete "mrtvou" klávesu |
||||
dvakrát, zobrazí se vám dialog, ve kterém můžete vybrat |
||||
žádaný symbol z unokódové mapy. V mapě se můžete pohybovat |
||||
kursorovými klávesami, dvojklikem myší, mezerníkem či klávesou |
||||
enter vybraný znak vložíte do textu. |
||||
|
||||
Chcete-li další znaky vkládat pomocí mrtvé klávesy, otevřete |
||||
"Ovládací panel KHIM" vložte dva znaky do pole "Posloupnost |
||||
kláves" a požadovaný znak, který chcete vložit do pole |
||||
"Vkládaný znak" a stisknětě talčítko "Změnit" (vkládaný |
||||
znak můžete nakopírovat z jiné aplikace nebo poučít talčítko |
||||
"Unikód..." (nebo stisknout dvakrát "mrtvou" klávesu) a vybrat |
||||
znak z unikódové mapy). K odstranění klávesové posloupnosti |
||||
slouží tlačítko "Smazat". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset cs {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Stiskněte klávesu |
||||
kterou chcete používat |
||||
jako "mrtvou" klávesu. |
||||
}] |
||||
|
||||
::msgcat::mcset cs {Apply} "Použít" |
||||
|
||||
::msgcat::mcset cs {Cancel} "Zrušit" |
||||
|
||||
::msgcat::mcset cs {Change} "Změnit" |
||||
|
||||
::msgcat::mcset cs {Character} "Znak" |
||||
|
||||
::msgcat::mcset cs {Compose Key} "Mrtvá klávesa" |
||||
|
||||
::msgcat::mcset cs {Compose key:} "Mrtvá klávesa:" |
||||
|
||||
::msgcat::mcset cs {Composed sequence must be two characters long} \ |
||||
"Vkládaný znak je vždy šložen z posloupnosti zdvou nzaků" |
||||
|
||||
::msgcat::mcset cs {Delete} "Smazat" |
||||
|
||||
::msgcat::mcset cs {Help...} "Nápověda..." |
||||
|
||||
::msgcat::mcset cs {Input key sequence} "Zadajete posloupnost kláves" |
||||
|
||||
::msgcat::mcset cs {Insert Character} "Vkládaný znak" |
||||
|
||||
::msgcat::mcset cs {Invalid sequence} "Chybná posloupnost" |
||||
|
||||
::msgcat::mcset cs {Key sequences} "Posloupnosti kláves" |
||||
|
||||
::msgcat::mcset cs {KHIM Controls} "Ovládací panel KHIM" |
||||
|
||||
::msgcat::mcset cs {OK} {OK} |
||||
|
||||
::msgcat::mcset cs {Select code page:} "Výběr kódové stránky:" |
||||
|
||||
::msgcat::mcset cs {Unicode...} "Unikód..." |
||||
|
||||
::msgcat::mcset cs {Use KHIM} "Používat KHIM" |
||||
|
||||
} |
||||
|
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
|
||||
|
||||
@ -0,0 +1,104 @@
|
||||
# da.msg -- |
||||
# |
||||
# Danish-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# Translation by Torsten Berg |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: da.msg,v 1.1 2006/09/05 13:48:49 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/da.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
::msgcat::mcset da {Apply} {Anvend} |
||||
|
||||
::msgcat::mcset da {Cancel} {Annuller} |
||||
|
||||
::msgcat::mcset da {Change} {Ændre} |
||||
|
||||
::msgcat::mcset da {Character} {Tegn} |
||||
|
||||
::msgcat::mcset da {Compose Key} {Compose taste} |
||||
|
||||
::msgcat::mcset da {Compose key:} {Compose taste:} |
||||
|
||||
::msgcat::mcset da {Composed sequence must be two characters long} \ |
||||
{Compose tegnfølgen skal bestå af to tegn} |
||||
|
||||
::msgcat::mcset da {Delete} {Slet} |
||||
|
||||
::msgcat::mcset da {Help...} {Hjælp...} |
||||
|
||||
::msgcat::mcset da HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM gør det muligt at indtaste internationale tegn med et tastatur |
||||
som ikke understøtter disse. Dette fungerer uafhængigt af en |
||||
bestående indtast metode som styresystemet måtte understøtte. |
||||
Det er tænkt til at hjælpe, hvis du ikke har kontrol over tilordningen |
||||
på dit tastatur og dog har brug for at indtaste tekst i andre sprog. |
||||
|
||||
For at benytte KHIM, vis kontrolpanelet (hvordan det gøres, afhænger af |
||||
dit program) og aktiver KHIM ved at afkrydse "Benyt KHIM". Du skal vælge |
||||
en taste der kun sjældent benyttes på dit tastatur og fastlægge denne som |
||||
"Compose" taste for at sætte tegn sammen med. Tryk dertil på knappen |
||||
markeret med "Compose taste:" og tryk derefter på den taste du ønsker at |
||||
fastlægge. Generellt skulle det ikke være den taste som normalt benyttes |
||||
til at konstruere tegn med; denne taste vil fortsat opråbe din lokale |
||||
systems indtast metode. |
||||
|
||||
Når KHIM er aktiveret kan du indtaste internationale tegn i enhver |
||||
kontrol der er konfigureret til at bruge KHIM ved at trykke på den valgte |
||||
"Compose" taste fulgt af to bestemte tegn. Rullelisten til venstre |
||||
på KHIM kontrolpanelet viser de tegnfølger der står til rådighed. Hvis |
||||
du trykker "Compose" tasten to gange kommer der et vindue frem hvor |
||||
du kan vælge vilkårlige symboler fra en unicode tabel. Du kan navigere |
||||
rundt i selve tabellen ved enten at benytte markøren eller markørtasterne. |
||||
Du kan udvælge det markerede tegn ved at doppelt-klikke på symbolet eller |
||||
ved at trykke på mellemrums-, enter- eller returtasten. |
||||
|
||||
Ny tegnfølger kan defineres ved at indtaste en følge af to tegn i feltet |
||||
markeret med "Indtast tegnfølge" og det ønskede symbol i feltet markeret |
||||
med "Tegn" og derefter trykke på "Ændre". Du kan også kopiere og indsætte |
||||
et symbol fra et andet program eller benytte "Unicode..." knappen |
||||
(eller trykke "Compose" tasten to gange) for at hente et symbol fra |
||||
tabellen med alle unicode koder. Tryk på "Slet" knappen for at fjerne |
||||
en tegnfølge. |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset da {Input key sequence} {Indtast tegnfølge} |
||||
|
||||
::msgcat::mcset da {Insert Character} {Indtast et tegn} |
||||
|
||||
::msgcat::mcset da {Invalid sequence} {Ugyldig tegnfølge} |
||||
|
||||
::msgcat::mcset da {Key sequences} {Tegnfølger} |
||||
|
||||
::msgcat::mcset da {KHIM Controls} {KHIM kontrolpanel} |
||||
|
||||
::msgcat::mcset da {OK} {O.k.} |
||||
|
||||
::msgcat::mcset da {Select code page:} {Vælg kode side:} |
||||
|
||||
::msgcat::mcset da {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Tryk på den taske |
||||
du ønsker at bruge |
||||
som "Compose" taste. |
||||
}] |
||||
|
||||
::msgcat::mcset da {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset da {Use KHIM} {Benyt KHIM} |
||||
|
||||
} |
||||
|
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,123 @@
|
||||
# de.msg -- |
||||
# |
||||
# German-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2006 by Andreas Kupries. All rights reserved. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: de.msg,v 1.2 2006/09/07 13:18:13 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/de.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
::msgcat::mcset de HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM ermöglicht die Eingabe von internationalen Zeichen |
||||
mittels einer Tastatur, welches diese nicht direkt |
||||
unterstützt. Es ist unabhängig von allen Eingabemethoden, |
||||
welche vom Betriebssystem bereitgestellt werden (könnten), |
||||
und für den Fall gedacht, wenn der Anwender keine Kontrolle |
||||
über die Tastatur hat und dennoch Text in anderen Sprachen |
||||
eingeben muß. |
||||
|
||||
Um KHIM zu benutzen, ist es notwendig, den KHIM Steuer-Dialog zu |
||||
öffnen (dies ist abhängig von der Anwendung) und dann KHIM |
||||
durch 'ticken' der 'Benutze KHIM'-Checkbox zu aktivieren. Es |
||||
ist weiterhin notwendig, eine Taste als die Kombinier-Taste zu |
||||
wählen. Die gewählte Taste sollte im Normalgebrauch selten |
||||
genutzt werden. Die Auswahl selbst besteht aus zwei Schritten. |
||||
Zuerst muß der Knopf "Kombinier-Taste:" gedrückt werden, |
||||
dann die gewünschte Taste. |
||||
|
||||
Allgemein gesprochen, wenn die benutzte Tastatur eine Taste |
||||
"Compose" besitzt, dann sollte diese _nicht_ als die |
||||
Kombinier-Taste für KHIM gewählt werden. Dies stellt sicher, |
||||
das diese Taste weiterhin vom Betriebssystem genutzt werden |
||||
kann, um dessen eventuelle Eingabemethoden zu aktivieren. |
||||
|
||||
Sobald KHIM aktiviert wurde, können in jedem Widget, welches |
||||
für die Benutzung von KHIM konfiguriert wurde, internationale |
||||
Zeichen eingegeben werden. Dies geschieht durch Drücken der |
||||
gewählten Kombinier-Taste, gefolgt von zwei weiteren Zeichen, |
||||
welche das gewünschte Zeichen identifizieren. Der KHIM |
||||
Steuer-Dialog stellt eine Liste der bekannten Zeichenfolgen |
||||
zur Verfügung. Zusätzlich ist es möglich einen Dialog zu |
||||
öffnen, welcher die Auswahl beliebiger Zeichen in einer Tabelle |
||||
erlaubt. Dies geschieht durch zweimaliges Drücken der |
||||
Kombinier-Taste. Navigation in der Tabelle geschieht mit der |
||||
Maus oder den Kursor-Tasten. Das einzufügende Zeichen kann |
||||
mit Doppel-Klick gewählt werden, durch Drücken der |
||||
Leer-Taste, oder durch Drücken der Enter- (oder Return-)Taste. |
||||
|
||||
Es ist auch möglich, die Liste der direkt anwählbären Zeichen |
||||
zu erweitern. Dies geschieht im KHIM Steuer-Dialog durch Eingabe |
||||
der zwei Zeichen für den Kode im Eingabefeld |
||||
"Eingabezeichenfolge", des gewünschten Zeichens im Feld |
||||
"Zeichen", gefolgt vom Drücken des Knopfes "Ändern". |
||||
|
||||
(Bezüglich der Herkunft des gewünschten Zeichens: Es kann aus |
||||
einer anderen Anwendung kopiert werden, oder man benutze den Knopf |
||||
"Unicode..." (oder drücke die Kombinier-Taste zweimal), um es |
||||
aus der Tabelle aller Zeichen auszuwählen.) |
||||
|
||||
Eine Zeichenfolge wird gelöscht durch Auswahl der Folge in |
||||
der Liste aller Zeichenfolgen, gefolgt von der |
||||
Lösch/Entferne-Taste. |
||||
} |
||||
|
||||
::msgcat::mcset de {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Bitte drücken Sie |
||||
die Taste, welche Sie |
||||
als Kombinier-Taste |
||||
verwenden wollen. |
||||
}] |
||||
|
||||
::msgcat::mcset de {Apply} {Anwenden} |
||||
|
||||
::msgcat::mcset de {Cancel} {Abbrechen} |
||||
|
||||
::msgcat::mcset de {Change} {Ändern} |
||||
|
||||
::msgcat::mcset de {Character} {Zeichen} |
||||
|
||||
::msgcat::mcset de {Compose Key} {Kombinier-Taste} |
||||
|
||||
::msgcat::mcset de {Compose key:} {Kombinier-Taste:} |
||||
|
||||
::msgcat::mcset de {Composed sequence must be two characters long} \ |
||||
{Die Eingabezeichenfolge muß aus zwei Zeichen bestehen} |
||||
|
||||
::msgcat::mcset de {Delete} {Löschen} |
||||
|
||||
::msgcat::mcset de {Help...} {Hilfe...} |
||||
|
||||
::msgcat::mcset de {Input key sequence} {Eingabezeichenfolge} |
||||
|
||||
::msgcat::mcset de {Insert Character} {Zeichen einfügen} |
||||
|
||||
::msgcat::mcset de {Invalid sequence} {Ungültige Zeichenfolge} |
||||
|
||||
::msgcat::mcset de {Key sequences} {Zeichenfolgen} |
||||
|
||||
::msgcat::mcset de {KHIM Controls} {KHIM Steuerung} |
||||
|
||||
::msgcat::mcset de {OK} {OK} |
||||
|
||||
::msgcat::mcset de {Select code page:} {Wähle Code-Seite:} |
||||
|
||||
::msgcat::mcset de {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset de {Use KHIM} {Benutze KHIM} |
||||
|
||||
} |
||||
|
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
|
||||
@ -0,0 +1,114 @@
|
||||
# en.msg -- |
||||
# |
||||
# English-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: en.msg,v 1.3 2007/06/08 19:24:31 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/en.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
# If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding |
||||
# messages in ROOT.msg |
||||
|
||||
::msgcat::mcset en HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM allows you to input international characters from a |
||||
keyboard that doesn't support them. It works independently of |
||||
any input method that the operating system may supply; it is |
||||
intended for when you don't have control over your keyboard |
||||
mapping and still need to input text in other languages. |
||||
|
||||
To use KHIM, bring up the KHIM Controls (the way this is done |
||||
depends on your application) and enable KHIM by checking "Use |
||||
KHIM". You also need to choose a key on your keyboard that is |
||||
seldom used, and designate it as the "Compose" key by pressing |
||||
the button labelled, "Compose key:" then striking the key you |
||||
wish to designate. Generally speaking, this key should not be |
||||
the key designated as "Compose" on the keyboard; that key will |
||||
continue to invoke whatever input method the local operating |
||||
system supplies. |
||||
|
||||
Once KHIM is enabled, you can enter international characters |
||||
in any widget that is configured to use KHIM by pressing the |
||||
Compose key followed by a two-character sequence. The listbox |
||||
in the KHIM controls shows the available sequences. In |
||||
addition, if you strike the Compose key twice, you get a |
||||
dialog that allows you to input arbitrary symbols from a |
||||
Unicode character map. In the map, you can navigate among the |
||||
characters using either the cursor keys or the mouse, and you |
||||
can select the current character for insertion by |
||||
double-clicking it, pressing the space bar, or pressing the |
||||
Enter (or Return) key. |
||||
|
||||
To define a new sequence for use with the Compose key, bring |
||||
up the KHIM controls, enter the two characters in the |
||||
"Input key sequence" entry and the desired character to insert |
||||
into the "Character" entry, and press "Change". (You may copy |
||||
and paste the character from another application, or use the |
||||
"Unicode..." button (or press the Compose key twice) to select |
||||
the character from a map of all available Unicode code |
||||
points.) To remove a sequence, select it in the listbox and |
||||
press "Delete". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset en {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Please press the |
||||
key that you want |
||||
to use as the |
||||
"Compose" key. |
||||
}] |
||||
|
||||
::msgcat::mcset en {Apply} {Apply} |
||||
|
||||
::msgcat::mcset en {Cancel} {Cancel} |
||||
|
||||
::msgcat::mcset en {Change} {Change} |
||||
|
||||
::msgcat::mcset en {Character} {Character} |
||||
|
||||
::msgcat::mcset en {Compose Key} {Compose Key} |
||||
|
||||
::msgcat::mcset en {Compose key:} {Compose key:} |
||||
|
||||
::msgcat::mcset en {Composed sequence must be two characters long} \ |
||||
{Composed sequence must be two characters long} |
||||
|
||||
::msgcat::mcset en {Delete} {Delete} |
||||
|
||||
::msgcat::mcset en {KHIM Help} {KHIM Help} |
||||
|
||||
::msgcat::mcset en {Help...} {Help...} |
||||
|
||||
::msgcat::mcset en {Input key sequence} {Input key sequence} |
||||
|
||||
::msgcat::mcset en {Insert Character} {Insert Character} |
||||
|
||||
::msgcat::mcset en {Invalid sequence} {Invalid sequence} |
||||
|
||||
::msgcat::mcset en {Key sequences} {Key sequences} |
||||
|
||||
::msgcat::mcset en {KHIM Controls} {KHIM Controls} |
||||
|
||||
::msgcat::mcset en {OK} {OK} |
||||
|
||||
::msgcat::mcset en {Select code page:} {Select code page:} |
||||
|
||||
::msgcat::mcset en {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset en {Use KHIM} {Use KHIM} |
||||
|
||||
} |
||||
|
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,108 @@
|
||||
# es.msg -- |
||||
# |
||||
# Spanish-language messages for KHIM |
||||
# |
||||
# Copyright (c) 2008 by Emiliano Gavilán. |
||||
# Proofreading and corrections by Miguel Sofer. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: es.msg,v 1.3 2008/05/30 02:00:19 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/es.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
::msgcat::mcset es HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM permite ingresar caracteres internacionales desde un teclado |
||||
que no soporta esta funcionalidad. Funciona independientemente de |
||||
cualquier método de entrada que su sistema operativo pueda proveer; |
||||
su finalidad es permitirle ingresar caracteres en otros lenguajes, |
||||
aun cuando no tenga control del mapeo de su teclado. |
||||
|
||||
Para usar KHIM, seleccione el diálogo de control de KHIM |
||||
(la forma de lograr esto depende de su aplicación) y habilite |
||||
el uso de KHIM seleccionando "Usar KHIM". También necesitará |
||||
seleccionar una tecla que sea raramente usada y designarla como |
||||
tecla "Componer" presionando el botón con la leyenda "Tecla Componer:" |
||||
y luego la tecla que quiere asignar a esta función. Ésta tecla no |
||||
debe ser la tecla designada como la tecla de composición de su |
||||
teclado; dicha tecla seguirá invocando cualquier método de entrada |
||||
que su sistema operativo provea. |
||||
|
||||
Una vez que KHIM esté habilitado, podrá ingresar caracteres |
||||
internacionales en cualquier widget que este configurado para |
||||
usar KHIM presionando la tecla designada como Componer seguida |
||||
de una secuencia de dos teclas. La lista en el control de KHIM |
||||
muestra todas las secuencias disponibles. Además, si presiona |
||||
la tecla "Componer" dos veces, se mostrará un diálogo que le |
||||
permitirá ingresar cualquier carácter arbitrario desde un mapa |
||||
de caracteres Unicode. Dicho mapa puede navegarse utilizando |
||||
el ratón o las teclas de dirección, y se puede seleccionar el |
||||
carácter deseado con un doble click, la barra espaciadora o la |
||||
tecla Return (Enter). |
||||
|
||||
Para definir una nueva secuencia para utilizar con la tecla |
||||
"Componer", seleccione el control de KHIM, ingrese dos teclas en |
||||
secuencia en la entrada "Secuencia de teclas", el carácter deseado |
||||
en la entrada "Carácter", y luego presione la tecla "Cambiar". |
||||
(Usted puede copiar y pegar dicho carácter desde otra aplicación, |
||||
o presionar el botón "Unicode..." (o presione la tecla "Componer" |
||||
dos veces) para seleccionar el carácter desde el mapa de los |
||||
caracteres Unicode disponibles). Para borrar una secuencia, |
||||
selecciónela de la lista y presione "Borrar". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset es {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Por favor presione |
||||
la tecla que desee |
||||
usar como tecla |
||||
"Componer". |
||||
}] |
||||
|
||||
::msgcat::mcset es {Apply} {Aplicar} |
||||
|
||||
::msgcat::mcset es {Cancel} {Cancelar} |
||||
|
||||
::msgcat::mcset es {Change} {Cambiar} |
||||
|
||||
::msgcat::mcset es {Character} {Carácter} |
||||
|
||||
::msgcat::mcset es {Compose Key} {Tecla Componer} |
||||
|
||||
::msgcat::mcset es {Compose key:} {Tecla Componer:} |
||||
|
||||
::msgcat::mcset es {Composed sequence must be two characters long} \ |
||||
{La secuencia de composición debe ser de dos teclas} |
||||
|
||||
::msgcat::mcset es {Delete} {Borrar} |
||||
|
||||
::msgcat::mcset es {KHIM Help} {Ayuda de KHIM} |
||||
|
||||
::msgcat::mcset es {Help...} {Ayuda...} |
||||
|
||||
::msgcat::mcset es {Input key sequence} {Secuencia de teclas de entrada} |
||||
|
||||
::msgcat::mcset es {Insert Character} {Insertar carácter} |
||||
|
||||
::msgcat::mcset es {Invalid sequence} {Secuencia inválida} |
||||
|
||||
::msgcat::mcset es {Key sequences} {Secuencias de teclas} |
||||
|
||||
::msgcat::mcset es {KHIM Controls} {Controles de KHIM} |
||||
|
||||
::msgcat::mcset es {OK} {Aceptar} |
||||
|
||||
::msgcat::mcset es {Select code page:} {Seleccionar página de código:} |
||||
|
||||
::msgcat::mcset es {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset es {Use KHIM} {Usar KHIM} |
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,11 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
package ifneeded khim 1.0.1 [list source [file join $dir khim.tcl]] |
||||
@ -0,0 +1,113 @@
|
||||
# pl.msg -- |
||||
# |
||||
# Polish-language messages for KHIM |
||||
# Contributed by Irek Chmielowiec <irek.ch (at) gmail.com> |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
# If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding |
||||
# messages in ROOT.msg |
||||
|
||||
::msgcat::mcset pl HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) |
||||
|
||||
KHIM pozwala na wprowadzanie znaków narodowych i symboli z |
||||
klawiatury która tego nie obsługuje. Działa niezależnie od |
||||
metody wprowadzania znaków jaką może oferować system operacyjny; |
||||
jest przewidziany do sytuacji kiedy nie ma się kontroli nad |
||||
odwzorowaniem klawiszy a istnieje potrzeba wprowadzania tekstu w |
||||
różnych językach. |
||||
|
||||
Aby móc używać KHIM, uruchom okno Ustawień KHIM (sposób jego |
||||
uruchomienia zależy od używanej aplikacji) i włącz KHIM |
||||
zaznaczając opcję "Włącz KHIM". Należy także wybrać klawisz |
||||
który jest rzadko używany i przypisać mu funkcję klawisza |
||||
"sterującego" naciskając przycisk "Klawisz sterujący:", |
||||
a następnie naciskając klawisz któremu chcemy tę funkcję |
||||
przypisać. Mówiąc ogólnie, nie powinien to być klawisz |
||||
ustawiony jako sterujący dla używanego układu klawiatury (np. |
||||
Alt); klawisz ten będzie działał niezależnie od metody |
||||
wprowadzania znaków oferowanej przez lokalny system operacyjny. |
||||
|
||||
Kiedy KHIM jest już uruchomiony, można wprowadzać znaki narodowe |
||||
i symbole w każdym elemencie interfejsu użytkownika, który |
||||
został ustawiony do korzystania z KHIM, naciskając klawisz |
||||
sterujący razem z sekwencją dwóch znaków. Lista wyboru w |
||||
ustawieniach KHIM pokazuje dostępne kombinacje. Dodatkowo, po |
||||
dwukrotnym naciśnięciu klawisza sterującego pojawi się okno |
||||
pozwalające na bezpośrednie wstawienie wybranego znaku z tablicy |
||||
symboli Unicode. W oknie tablicy można nawigować pomiędzy |
||||
znakami używając klawiszy kursorów lub za pomocą myszy a wybór |
||||
znaku następuje przez dwukrotne kliknięcie, naciśnięcie spacji |
||||
lub naciśnięcie klawisza Enter (Return). |
||||
|
||||
Aby zdefiniować nową sekwencję do użycia z klawiszem sterującym |
||||
należy uruchomić ustawienia KHIM, wprowadzić dwa znaki w polu |
||||
"Sekwencja znaków" i znak jaki chcemy uzyskać w polu "Wynik" |
||||
oraz nacisnąć przycisk "Zmień". (Można także skopiować i |
||||
wkleić znak z innej aplikacji lub użyć przycisku "Tablica |
||||
Unicode..." (także przez dwukrotne naciśnięcie klawisza |
||||
sterującego) do wyboru znaku z tablicy wszystkich dostępnych |
||||
kodów Unicode.) Aby usunąć sekwencję znaków, należy wybrać ją z |
||||
listy i nacisnąć "Usuń". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset pl {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Proszę nacisnąć klawisz |
||||
który ma być używany |
||||
jako sterujący. |
||||
}] |
||||
|
||||
::msgcat::mcset pl {Apply} {Zastosuj} |
||||
|
||||
::msgcat::mcset pl {Cancel} {Anuluj} |
||||
|
||||
::msgcat::mcset pl {Change} {Zmień} |
||||
|
||||
::msgcat::mcset pl {Character} {Wynik} |
||||
|
||||
::msgcat::mcset pl {Compose Key} {Klawisz sterujący} |
||||
|
||||
::msgcat::mcset pl {Compose key:} {Klawisz sterujący:} |
||||
|
||||
::msgcat::mcset pl {Composed sequence must be two characters long} \ |
||||
{Sekwecja znaków musi być dwuelementowa} |
||||
|
||||
::msgcat::mcset pl {Delete} {Usuń} |
||||
|
||||
::msgcat::mcset pl {KHIM Help} {Pomoc KHIM} |
||||
|
||||
::msgcat::mcset pl {Help...} {Pomoc...} |
||||
|
||||
::msgcat::mcset pl {Input key sequence} {Sekwencja znaków} |
||||
|
||||
::msgcat::mcset pl {Insert Character} {Wstaw znak} |
||||
|
||||
::msgcat::mcset pl {Invalid sequence} {Nieprawidłowa sekwencja} |
||||
|
||||
::msgcat::mcset pl {Key sequences} {Sekwencje znaków} |
||||
|
||||
::msgcat::mcset pl {KHIM Controls} {Ustawienia KHIM} |
||||
|
||||
::msgcat::mcset pl {OK} {OK} |
||||
|
||||
::msgcat::mcset pl {Select code page:} {Wybierz kodowanie:} |
||||
|
||||
::msgcat::mcset pl {Unicode...} {Tablica Unicode...} |
||||
|
||||
::msgcat::mcset pl {Use KHIM} {Włącz KHIM} |
||||
|
||||
} |
||||
|
||||
# vim:ft=tcl:ts=8:sw=4:sts=4:noet |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,124 @@
|
||||
# ru.msg -- |
||||
# |
||||
# Russian-language messages for KHIM |
||||
# |
||||
# Contributed by Konstantin Khomoutov <flatworm@users.sourceforge.net>. |
||||
# Proof-read and edited by Serge Yudin <talking_zero@mail.ru>. |
||||
# |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# |
||||
# Refer to the file "license.terms" for the terms and conditions of |
||||
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES. |
||||
# |
||||
# $Id: ru.msg,v 1.1 2007/06/08 19:24:31 kennykb Exp $ |
||||
# $Source: /home/rkeene/tmp/cvs2fossil/tcllib/tklib/modules/khim/ru.msg,v $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
# If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding |
||||
# messages in ROOT.msg |
||||
|
||||
::msgcat::mcset ru HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) -- |
||||
Нетривиальный Метод Кевина для Ввода Символов |
||||
|
||||
KHIM делает возможным ввод символов национальных алфавитов |
||||
с клавиатуры, которая не позволяют этого делать. Он работает |
||||
независимо от любых способов ввода, которые поддерживает ОС; |
||||
его задача -- позволить осуществлять ввод таких символов, |
||||
которые невозможно ввести с текущими настройками ОС данного |
||||
компьютера, а менять их нет возможности или желания. |
||||
|
||||
Для того, чтобы использовать KHIM, следует вызвать диалог |
||||
"Настройки KHIM" (как это сделать, зависит от приложения, |
||||
использующего KHIM) и разрешить работу KHIM, включив переключатель |
||||
"Использовать KHIM". Также Вам понадобится выбрать редко |
||||
используемую клавишу на Вашей клавиатуре и назначить её |
||||
"клавишей композиции". Для этого нужно нажать кнопку, подписанную |
||||
"Клавиша композиции:", в диалоге настроек KHIM и затем нажать |
||||
выбранную клавишу на клавиатуре. Имейте в виду, что если на Вашей |
||||
клавиатуре есть клавиша, называемая "Compose", то её не следует |
||||
выбирать в качестве клавиши композиции для KHIM -- пусть она |
||||
продолжает вызывать тот метод ввода, |
||||
который назначен ей операционной системой. |
||||
|
||||
После того как KHIM активирован, Вы можете вставлять символы |
||||
национальных алфавитов в любое поле ввода, настроенное на |
||||
использование KHIM, таким образом: нажать и отпустить клавишу |
||||
композиции, затем ввести два символа -- "входную последовательность". |
||||
В диалоге настроек KHIM есть окно со списком доступных |
||||
последовательностей. Кроме того, двойное нажатие клавиши |
||||
композиции вызывает окно диалога, позволяющее выбрать произвольный |
||||
символ Unicode. Выбор нужного символа в этом диалоге |
||||
осуществляется мышью либо клавишами управления курсором, |
||||
а вставка выбранного символа -- двойным щелчком левой кнопки |
||||
мыши на нём, либо нажатием клавиши Пробел или Ввод. |
||||
|
||||
Чтобы создать новую входную последовательность для использования |
||||
совместно с клавишей композиции окройте диалог настроек KHIM, |
||||
введите два символа в поле "Входная последовательность" и |
||||
соответствующий ей символ в поле "Символ", затем нажмите |
||||
кнопку "Изменить". (Вы можете копировать и вставлять целевой |
||||
символ из другого приложения. Также можно воспользоваться |
||||
встроенным в KHIM диалогом выбора символов Unicode, нажав |
||||
кнопку "Unicode..." или дважды нажав клавишу композиции.) |
||||
Для удаления входной последовательности выберите её в списке |
||||
и дажмите "Удалить". |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset ru {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Нажмите клавишу, |
||||
которую вы хотите |
||||
использовать в качестве |
||||
"Клавиши композиции" |
||||
}] |
||||
|
||||
::msgcat::mcset ru {Apply} {Применить} |
||||
|
||||
::msgcat::mcset ru {Cancel} {Отменить} |
||||
|
||||
::msgcat::mcset ru {Change} {Изменить} |
||||
|
||||
::msgcat::mcset ru {Character} {Символ} |
||||
|
||||
::msgcat::mcset ru {Compose Key} {Клавиша композиции} |
||||
|
||||
::msgcat::mcset ru {Compose key:} {Клавиша композиции:} |
||||
|
||||
::msgcat::mcset ru {Composed sequence must be two characters long} \ |
||||
{Входная последовательность должна состоять из двух символов} |
||||
|
||||
::msgcat::mcset ru {Delete} {Удалить} |
||||
|
||||
::msgcat::mcset ru {KHIM Help} {Справка по KHIM} |
||||
|
||||
::msgcat::mcset ru {Help...} {Справка...} |
||||
|
||||
::msgcat::mcset ru {Input key sequence} {Входная последовательность} |
||||
|
||||
::msgcat::mcset ru {Insert Character} {Выберите символ} |
||||
|
||||
::msgcat::mcset ru {Invalid sequence} {Неправильная комбинация} |
||||
|
||||
::msgcat::mcset ru {Key sequences} {Комбинации клавиш} |
||||
|
||||
::msgcat::mcset ru {KHIM Controls} {Настройки KHIM} |
||||
|
||||
::msgcat::mcset ru {OK} {OK} |
||||
|
||||
::msgcat::mcset ru {Select code page:} {Выберите страницу кодов:} |
||||
|
||||
::msgcat::mcset ru {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset ru {Use KHIM} {Использовать KHIM} |
||||
|
||||
} |
||||
|
||||
# vim:ft=tcl:ts=8:sw=4:sts=4:noet |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,117 @@
|
||||
# uk.msg -- |
||||
# |
||||
# Ukrainian-language messages for KHIM |
||||
# |
||||
# Contributed by Fixer jabber:<uzver@jabber.kiev.ua>, email:<artem_brz@mail.ru>. |
||||
# |
||||
# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
namespace eval ::khim { |
||||
|
||||
# If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding |
||||
# messages in ROOT.msg |
||||
|
||||
::msgcat::mcset uk HELPTEXT { |
||||
|
||||
Kevin's Hacky Input Method (KHIM) -- |
||||
Нетривіальний Метод Кевіна для Введення Символів |
||||
|
||||
KHIM дає можливість вводити символи національних алфавітів |
||||
з клавіатури, яка не дозволяє цього робити. Він працює |
||||
незалежно від інших способів вводу, котрі підтримує ОС; |
||||
його завдання -- дати змогу здійснювати введення таких символів, |
||||
котрі неможливо ввести з теперішніми налаштуваннями ОС даного |
||||
компьютера, а поміняти їх немає ні можливості, ні бажання. |
||||
|
||||
Для того, щоб користуватися KHIM, треба відкрити діалог |
||||
"Налаштування KHIM" (як це зробити, залежить від програми, |
||||
яка використовує KHIM) і дозволити роботу KHIM, увімкнувши перемикач |
||||
"Використовувати KHIM". Також Вам необхідно обрати рідко |
||||
використовувану клавішу на Вашій клавіатурі і призначити її |
||||
"клавішою композиції". Для цього потрібно натиснути кнопку, підписану як |
||||
"Клавіша композиції:", у діалозі налаштувань KHIM, а потім натиснути |
||||
обрану клавішу на клавіатурі. Майте на увазі, що якшо на Вашій |
||||
клавіатурі є клавіша, що зветься "Compose", то її не треба |
||||
обирати в якості клавіши композиції для KHIM -- хай вона |
||||
продовжує викликати той метод вводу, |
||||
котрий призначений їй операційною системою. |
||||
|
||||
Після того як KHIM активувався, Ви можете вставляти символи |
||||
національних алфавітів в будь-яке поле для вводу, налаштоване на |
||||
використання KHIM, таким чином: натиснути і відпустити клавішу |
||||
композиції, а потім ввести два символи -- "вхідну послідовність". |
||||
У діалозі налаштувань KHIM є вікно з переліком доступних |
||||
послідовностей. Крім того, подвійне натискання клавіші |
||||
композиції викликає вікно діалогу, що дозволяє обрати довільний |
||||
символ Unicode. Вибір потрібного символу в цьому діалозі |
||||
здійснюється мишою чи клавішами управління курсором, |
||||
а вставляння обраного симолу -- подвійним клацанням лівої кнопки |
||||
миші на ньому, або натисканням клавіши Пробіл чи Ввід. |
||||
|
||||
Щоб створити нову вхідну послідовність для використання |
||||
сумісно з клавішою композиції відкрийте діалог налаштувань KHIM, |
||||
введіть два символи в поле "Вхідна послідовність" і |
||||
відповідний їй символ у полі "Символ", а потім натисніть |
||||
клавішу "Змінити". (Ви можете копіювати і вставляти цільовий |
||||
символ з іншої програми. Також можна скористатися |
||||
вбудованим у KHIM діалогом вибору символів Unicode, натиснувши |
||||
кнопку "Unicode...", або подвійно клацнувши клавішу композиції.) |
||||
Для видалення вхідної послідовності оберіть її у переліку |
||||
і натисніть "Видалити." |
||||
|
||||
} |
||||
|
||||
::msgcat::mcset uk {SELECT COMPOSE KEY} [string map [list \n\t \n] { |
||||
Натисніть клавішу, |
||||
котру ви бажаєте |
||||
використовувати в якості |
||||
"Клавіші композиції" |
||||
}] |
||||
|
||||
::msgcat::mcset uk {Apply} {Прийняти} |
||||
|
||||
::msgcat::mcset uk {Cancel} {Відмінити} |
||||
|
||||
::msgcat::mcset uk {Change} {Змінити} |
||||
|
||||
::msgcat::mcset uk {Character} {Символ} |
||||
|
||||
::msgcat::mcset uk {Compose Key} {Клавіша композиції} |
||||
|
||||
::msgcat::mcset uk {Compose key:} {Клавіша композиції:} |
||||
|
||||
::msgcat::mcset uk {Composed sequence must be two characters long} \ |
||||
{Вхідна послідовність повинна складатися з двох символів} |
||||
|
||||
::msgcat::mcset uk {Delete} {Видалити} |
||||
|
||||
::msgcat::mcset uk {KHIM Help} {Допомога по KHIM} |
||||
|
||||
::msgcat::mcset uk {Help...} {Допомога...} |
||||
|
||||
::msgcat::mcset uk {Input key sequence} {Вхідна послідовність} |
||||
|
||||
::msgcat::mcset uk {Insert Character} {Оберіть символ} |
||||
|
||||
::msgcat::mcset uk {Invalid sequence} {Неправильна комбінація} |
||||
|
||||
::msgcat::mcset uk {Key sequences} {Комбінації клавіш} |
||||
|
||||
::msgcat::mcset uk {KHIM Controls} {Налаштування KHIM} |
||||
|
||||
::msgcat::mcset uk {OK} {OK} |
||||
|
||||
::msgcat::mcset uk {Select code page:} {Оберіть кодову сторінку:} |
||||
|
||||
::msgcat::mcset uk {Unicode...} {Unicode...} |
||||
|
||||
::msgcat::mcset uk {Use KHIM} {Використовувати KHIM} |
||||
|
||||
} |
||||
|
||||
# vim:ft=tcl:ts=8:sw=4:sts=4:noet |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,13 @@
|
||||
#============================================================================== |
||||
# Main Mentry package module. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
package require -exact mentry::common 3.18 |
||||
|
||||
package provide mentry $::mentry::version |
||||
package provide Mentry $::mentry::version |
||||
|
||||
::mentry::useTile 0 |
||||
::mentry::createBindings |
||||
@ -0,0 +1,115 @@
|
||||
#============================================================================== |
||||
# Main Mentry and Mentry_tile package module. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
if {[catch {package require Wcb 3.1} result1] != 0 && |
||||
[catch {package require wcb 3.1} result2] != 0} { |
||||
error "$result1; $result2" |
||||
} |
||||
|
||||
namespace eval ::mentry { |
||||
# |
||||
# Public variables: |
||||
# |
||||
variable version 3.18 |
||||
variable library |
||||
if {$::tcl_version >= 8.4} { |
||||
set library [file dirname [file normalize [info script]]] |
||||
} else { |
||||
set library [file dirname [info script]] ;# no "file normalize" yet |
||||
} |
||||
|
||||
# |
||||
# Creates a new multi-entry widget: |
||||
# |
||||
namespace export mentry |
||||
|
||||
# |
||||
# Implement multi-entry widgets for date and time: |
||||
# |
||||
namespace export dateMentry timeMentry dateTimeMentry \ |
||||
putClockVal getClockVal |
||||
|
||||
# |
||||
# Implement a multi-entry widget for real numbers in fixed-point format: |
||||
# |
||||
namespace export fixedPointMentry putReal getReal |
||||
|
||||
# |
||||
# Implement a multi-entry widget for IP addresses: |
||||
# |
||||
namespace export ipAddrMentry putIPAddr getIPAddr |
||||
|
||||
# |
||||
# Implement a multi-entry widget for IPv6 addresses: |
||||
# |
||||
namespace export ipv6AddrMentry putIPv6Addr getIPv6Addr |
||||
} |
||||
|
||||
package provide mentry::common $::mentry::version |
||||
|
||||
if {$::tcl_version >= 8.4} { |
||||
interp alias {} ::mentry::addVarTrace {} trace add variable |
||||
} else { |
||||
proc ::mentry::addVarTrace {name ops cmd} { |
||||
set ops2 "" |
||||
foreach op $ops { append ops2 [string index $op 0] } |
||||
trace variable $name $ops2 $cmd |
||||
} |
||||
} |
||||
|
||||
# |
||||
# The following procedure, invoked in "mentry.tcl" and |
||||
# "mentry_tile.tcl", sets the variable ::mentry::usingTile |
||||
# to the given value and sets a trace on this variable. |
||||
# |
||||
proc ::mentry::useTile {bool} { |
||||
variable usingTile $bool |
||||
addVarTrace usingTile {write unset} [list ::mentry::restoreUsingTile $bool] |
||||
} |
||||
|
||||
# |
||||
# The following trace procedure is executed whenever the variable |
||||
# ::mentry::usingTile is written or unset. It restores the variable to its |
||||
# original value, given by the first argument. |
||||
# |
||||
proc ::mentry::restoreUsingTile {origVal varName index op} { |
||||
variable usingTile $origVal |
||||
switch -glob $op { |
||||
w* { |
||||
return -code error "it is not supported to use both Mentry and\ |
||||
Mentry_tile in the same application" |
||||
} |
||||
u* { |
||||
addVarTrace usingTile {write unset} \ |
||||
[list ::mentry::restoreUsingTile $origVal] |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::mentry::createTkAliases {} { |
||||
foreach cmd {frame entry label} { |
||||
if {[llength [info commands ::tk::$cmd]] == 0} { |
||||
interp alias {} ::tk::$cmd {} ::$cmd |
||||
} |
||||
} |
||||
} |
||||
::mentry::createTkAliases |
||||
|
||||
# |
||||
# Everything else needed is lazily loaded on demand, via the dispatcher |
||||
# set up in the subdirectory "scripts" (see the file "tclIndex"). |
||||
# |
||||
lappend auto_path [file join $::mentry::library scripts] |
||||
|
||||
# |
||||
# Load the package mwutil from the directory "scripts/mwutil". Take |
||||
# into account that it is also included in Scrollutil and Tablelist. |
||||
# |
||||
if {[catch {package present mwutil} version] == 0 && |
||||
[package vcompare $version 2.20] < 0} { |
||||
package forget mwutil |
||||
} |
||||
package require mwutil 2.20 |
||||
@ -0,0 +1,24 @@
|
||||
#============================================================================== |
||||
# Main Mentry_tile package module. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
package require Tk 8.4 |
||||
if {$::tk_version < 8.5 || [regexp {^8\.5a[1-5]$} $::tk_patchLevel]} { |
||||
package require tile 0.6 |
||||
} |
||||
package require -exact mentry::common 3.18 |
||||
|
||||
package provide mentry_tile $::mentry::version |
||||
package provide Mentry_tile $::mentry::version |
||||
|
||||
::mentry::useTile 1 |
||||
::mentry::createBindings |
||||
|
||||
namespace eval ::mentry { |
||||
# |
||||
# Commands related to tile themes: |
||||
# |
||||
namespace export getThemes getCurrentTheme setTheme setThemeDefaults |
||||
} |
||||
@ -0,0 +1,27 @@
|
||||
#============================================================================== |
||||
# Mentry and Mentry_tile package index file. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Regular packages: |
||||
# |
||||
package ifneeded mentry 3.18 \ |
||||
[list source [file join $dir mentry.tcl]] |
||||
package ifneeded mentry_tile 3.18 \ |
||||
[list source [file join $dir mentry_tile.tcl]] |
||||
|
||||
# |
||||
# Aliases: |
||||
# |
||||
package ifneeded Mentry 3.18 \ |
||||
[list package require -exact mentry 3.18] |
||||
package ifneeded Mentry_tile 3.18 \ |
||||
[list package require -exact mentry_tile 3.18] |
||||
|
||||
# |
||||
# Code common to all packages: |
||||
# |
||||
package ifneeded mentry::common 3.18 \ |
||||
[list source [file join $dir mentryCommon.tcl]] |
||||
@ -0,0 +1,863 @@
|
||||
#============================================================================== |
||||
# Contains the implementation of multi-entry widgets for date and time. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Namespace initialization |
||||
# ======================== |
||||
# |
||||
|
||||
namespace eval mentry { |
||||
# |
||||
# Min. and max. values of date/time components |
||||
# |
||||
variable dateTimeMins |
||||
variable dateTimeMaxs |
||||
array set dateTimeMins {d 1 m 1 y 0 Y 0 H 0 I 1 M 0 S 0} |
||||
array set dateTimeMaxs {d 31 m 12 y 99 Y 9999 H 23 I 12 M 59 S 59} |
||||
|
||||
# |
||||
# Define some bindings for the binding |
||||
# tags MentryDateTime and MentryMeridian |
||||
# |
||||
bind MentryDateTime <Up> { mentry::incrDateTimeComp %W 1 } |
||||
bind MentryDateTime <Down> { mentry::incrDateTimeComp %W -1 } |
||||
bind MentryDateTime <Prior> { mentry::incrDateTimeComp %W 10 } |
||||
bind MentryDateTime <Next> { mentry::incrDateTimeComp %W -10 } |
||||
bind MentryMeridian <Up> { mentry::setMeridian %W "P" } |
||||
bind MentryMeridian <Down> { mentry::setMeridian %W "A" } |
||||
bind MentryMeridian <Prior> { mentry::setMeridian %W "P" } |
||||
bind MentryMeridian <Next> { mentry::setMeridian %W "A" } |
||||
variable winSys |
||||
variable uniformWheelSupport |
||||
if {$uniformWheelSupport} { |
||||
bind MentryDateTime <MouseWheel> { |
||||
mentry::incrDateTimeComp %W \ |
||||
[expr {%D > 0 ? (%D + 119) / 120 : %D / 120}] |
||||
} |
||||
bind MentryDateTime <Option-MouseWheel> { |
||||
mentry::incrDateTimeComp %W \ |
||||
[expr {%D > 0 ? (%D + 11) / 12 : %D / 12}] |
||||
} |
||||
} elseif {[string compare $winSys "classic"] == 0 || |
||||
[string compare $winSys "aqua"] == 0} { |
||||
catch { |
||||
bind MentryDateTime <MouseWheel> { |
||||
mentry::incrDateTimeComp %W %D |
||||
} |
||||
bind MentryDateTime <Option-MouseWheel> { |
||||
mentry::incrDateTimeComp %W [expr {10 * %D}] |
||||
} |
||||
} |
||||
} else { |
||||
catch { |
||||
bind MentryDateTime <MouseWheel> { |
||||
mentry::incrDateTimeComp %W \ |
||||
[expr {%D > 0 ? (%D + 119) / 120 : %D / 120}] |
||||
} |
||||
} |
||||
|
||||
if {[string compare $winSys "x11"] == 0} { |
||||
bind MentryDateTime <Button-4> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrDateTimeComp %W 1 |
||||
} |
||||
} |
||||
bind MentryDateTime <Button-5> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrDateTimeComp %W -1 |
||||
} |
||||
} |
||||
bind MentryMeridian <Button-4> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::setMeridian %W "P" |
||||
} |
||||
} |
||||
bind MentryMeridian <Button-5> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::setMeridian %W "A" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
catch { |
||||
bind MentryMeridian <MouseWheel> { |
||||
mentry::setMeridian %W [expr {(%D < 0) ? "A" : "P"}] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Multi-entry widgets for date & time |
||||
# =================================== |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::dateMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit a date |
||||
# according to the argument fmt, which must be a string of length 3, consisting |
||||
# of the letters d for the day (01 - 31), m for the month (01 - 12), and y or Y |
||||
# for the year without century (00 - 99) or with century (e.g., 1999), in an |
||||
# arbitrary order. sep specifies the text to be displayed in the labels |
||||
# separating the entry children of the mentry widget. Sets the type attribute |
||||
# of the widget to Date, saves the value of fmt in its format attribute, and |
||||
# returns the name of the newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::dateMentry {win fmt sep args} { |
||||
# |
||||
# Parse the fmt argument |
||||
# |
||||
if {![regexp {^([dmyY])([dmyY])([dmyY])$} $fmt dummy \ |
||||
fields(0) fields(1) fields(2)]} { |
||||
return -code error \ |
||||
"bad format \"$fmt\": must be a string of length 3,\ |
||||
consisting of the letters d, m, and y or Y" |
||||
} |
||||
|
||||
# |
||||
# Check whether all the three date components are represented in fmt |
||||
# |
||||
for {set n 0} {$n < 3} {incr n} { |
||||
set lfields($n) [string tolower $fields($n)] |
||||
} |
||||
if {[string compare $lfields(0) $lfields(1)] == 0 || |
||||
[string compare $lfields(0) $lfields(2)] == 0 || |
||||
[string compare $lfields(1) $lfields(2)] == 0} { |
||||
return -code error \ |
||||
"bad format \"$fmt\": must have unique components for the\ |
||||
day, month, and year" |
||||
} |
||||
|
||||
# |
||||
# Create the widget, set its type to Date, and save the format string |
||||
# |
||||
eval [list mentry $win] $args |
||||
array set widths {d 2 m 2 y 2 Y 4} |
||||
::$win configure -body [list $widths($fields(0)) $sep $widths($fields(1)) \ |
||||
$sep $widths($fields(2))] |
||||
::$win attrib type Date format $fmt |
||||
|
||||
# |
||||
# In each entry child allow only unsigned integers of the corresp. |
||||
# max. values, and insert the binding tag MentryDateTime in the |
||||
# list of binding tags of the entry, just after its path name |
||||
# |
||||
variable dateTimeMaxs |
||||
for {set n 0} {$n < 3} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
wcb::cbappend $w before insert \ |
||||
"wcb::checkEntryForUInt $dateTimeMaxs($fields($n))" |
||||
::$win adjustentry $n "0123456789" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryDateTime] |
||||
} |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::timeMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit a time |
||||
# according to the argument fmt, which must be a string of length 2 or 3, |
||||
# consisting of the following field descriptor characters of the clock format |
||||
# command: H or I, followed by M, and optionally the letter S. An H as first |
||||
# character specifies the time format %H:%M or %H:%M:%S, while the letter I |
||||
# stands for %I:%M %p or %I:%M:%S %p. sep specifies the text to be displayed |
||||
# in the labels separating the entry children of the mentry widget. Sets the |
||||
# type attribute of the widget to Time, saves the value of fmt in its format |
||||
# attribute, and returns the name of the newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::timeMentry {win fmt sep args} { |
||||
# |
||||
# Parse the fmt argument |
||||
# |
||||
if {![regexp {^(H|I)(M)(S?)$} $fmt dummy fields(0) fields(1) fields(2)]} { |
||||
return -code error \ |
||||
"bad format \"$fmt\": must be a string of length 2 or 3\ |
||||
starting with H or I, followed by M and optionally by S" |
||||
} |
||||
|
||||
# |
||||
# Create the widget, set its type to Time, and save the format |
||||
# string. If the AM/PM indicator is needed, devide it into |
||||
# an entry (containing A or P) and a label (displaying M) |
||||
# |
||||
eval [list mentry $win] $args |
||||
set len [string length $fmt] |
||||
set body [list 2 $sep 2] |
||||
if {$len == 3} { |
||||
lappend body $sep 2 |
||||
} |
||||
if {[string compare $fields(0) "I"] == 0} { |
||||
lappend body " " 1 M |
||||
} |
||||
::$win configure -body $body |
||||
::$win attrib type Time format $fmt |
||||
|
||||
# |
||||
# In each of the first len entry children allow only unsigned integers |
||||
# of the corresp. max. values, and insert the binding tag MentryDateTime |
||||
# in the list of binding tags of the entry, just after its path name |
||||
# |
||||
variable dateTimeMaxs |
||||
for {set n 0} {$n < $len} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
wcb::cbappend $w before insert \ |
||||
"wcb::checkEntryForUInt $dateTimeMaxs($fields($n))" |
||||
::$win adjustentry $n "0123456789" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryDateTime] |
||||
} |
||||
|
||||
# |
||||
# In the entry child containing the first character of the AM/PM |
||||
# indicator (if present) install automatic uppercase conversion, |
||||
# allow only the characters A and P, insert the binding tag |
||||
# MentryMeridian in the list of binding tags of the entry, just |
||||
# after its path name, and make the entry right-justified |
||||
# |
||||
if {[string compare $fields(0) "I"] == 0} { |
||||
set w [::$win entrypath $len] |
||||
wcb::cbappend $w before insert \ |
||||
wcb::convStrToUpper {wcb::checkStrForRegExp {^[AP]$}} |
||||
::$win adjustentry $len "AP" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryMeridian] |
||||
$w configure -justify right |
||||
} |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::dateTimeMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit a date & time |
||||
# according to the argument fmt, which must be a string of length 5 or 6, with |
||||
# the first 3 characters consisting of the letters d for the day (01 - 31), m |
||||
# for the month (01 - 12), and y or Y for the year without century (00 - 99) or |
||||
# with century (e.g., 1999), in an arbitrary order, followed by 2 or 3 field |
||||
# descriptor characters of the clock format command, which must be: H or I, |
||||
# then M, and optionally the letter S. An H specifies the time format %H:%M or |
||||
# %H:%M:%S, while the letter I stands for %I:%M %p or %I:%M:%S %p. dateSep and |
||||
# timeSep specify the texts to be displayed in the labels separating the entry |
||||
# children of the mentry widget in the date and time parts, respectively (which |
||||
# in turn are separated from each other by a space character). Sets the type |
||||
# attribute of the widget to DateTime, saves the value of fmt in its format |
||||
# attribute, and returns the name of the newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::dateTimeMentry {win fmt dateSep timeSep args} { |
||||
# |
||||
# Parse the fmt argument |
||||
# |
||||
if {![regexp {^([dmyY])([dmyY])([dmyY])(H|I)(M)(S?)$} $fmt dummy \ |
||||
fields(0) fields(1) fields(2) fields(3) fields(4) fields(5)]} { |
||||
return -code error \ |
||||
"bad format \"$fmt\": must be a string of length 5 or 6,\ |
||||
with the first 3 characters consisting of the letters d, m,\ |
||||
and y or Y, followed by H or I, then M, and optionally by S" |
||||
} |
||||
|
||||
# |
||||
# Check whether all the three date components are represented in fmt |
||||
# |
||||
for {set n 0} {$n < 3} {incr n} { |
||||
set lfields($n) [string tolower $fields($n)] |
||||
} |
||||
if {[string compare $lfields(0) $lfields(1)] == 0 || |
||||
[string compare $lfields(0) $lfields(2)] == 0 || |
||||
[string compare $lfields(1) $lfields(2)] == 0} { |
||||
return -code error \ |
||||
"bad format \"$fmt\": must have unique components for the\ |
||||
day, month, and year" |
||||
} |
||||
|
||||
# |
||||
# Create the widget, set its type to DateTime, and save the |
||||
# format string. If the AM/PM indicator is needed, devide it |
||||
# into an entry (containing A or P) and a label (displaying M) |
||||
# |
||||
eval [list mentry $win] $args |
||||
array set widths {d 2 m 2 y 2 Y 4} |
||||
set len [string length $fmt] |
||||
set body [list $widths($fields(0)) $dateSep $widths($fields(1)) $dateSep \ |
||||
$widths($fields(2)) " " 2 $timeSep 2] |
||||
if {$len == 6} { |
||||
lappend body $timeSep 2 |
||||
} |
||||
if {[string compare $fields(3) "I"] == 0} { |
||||
lappend body " " 1 M |
||||
} |
||||
::$win configure -body $body |
||||
::$win attrib type DateTime format $fmt |
||||
|
||||
# |
||||
# In each of the first len entry children allow only unsigned integers |
||||
# of the corresp. max. values, and insert the binding tag MentryDateTime |
||||
# in the list of binding tags of the entry, just after its path name |
||||
# |
||||
variable dateTimeMaxs |
||||
for {set n 0} {$n < $len} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
wcb::cbappend $w before insert \ |
||||
"wcb::checkEntryForUInt $dateTimeMaxs($fields($n))" |
||||
::$win adjustentry $n "0123456789" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryDateTime] |
||||
} |
||||
|
||||
# |
||||
# In the entry child containing the first character of the AM/PM |
||||
# indicator (if present) install automatic uppercase conversion, |
||||
# allow only the characters A and P, insert the binding tag |
||||
# MentryMeridian in the list of binding tags of the entry, just |
||||
# after its path name, and make the entry right-justified |
||||
# |
||||
if {[string compare $fields(3) "I"] == 0} { |
||||
set w [::$win entrypath $len] |
||||
wcb::cbappend $w before insert \ |
||||
wcb::convStrToUpper {wcb::checkStrForRegExp {^[AP]$}} |
||||
::$win adjustentry $len "AP" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryMeridian] |
||||
$w configure -justify right |
||||
} |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::putClockVal |
||||
# |
||||
# Outputs the date, time, or date & time corresponding to the integer clockVal |
||||
# to the mentry widget win of type Date, Time, or DateTime. The keyword args |
||||
# stands for ?-gmt boolean?, like in the clock format command. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::putClockVal {clockVal win args} { |
||||
# |
||||
# Check whether clockVal is an integer number |
||||
# |
||||
if {[catch {format "%d" $clockVal} res] != 0} { |
||||
return -code error $res |
||||
} |
||||
|
||||
set type [checkIfDateOrTimeMentry $win] |
||||
set usage "putClockVal clockValue pathName ?-gmt boolean?" |
||||
|
||||
# |
||||
# Check the number of optional arguments |
||||
# |
||||
set count [llength $args] |
||||
if {$count != 0 && $count != 2} { |
||||
mwutil::wrongNumArgs $usage |
||||
} |
||||
|
||||
# |
||||
# Parse the command line |
||||
# |
||||
set useGMT 0 |
||||
foreach {opt val} $args { |
||||
if {[string compare $opt "-gmt"] == 0} { |
||||
# |
||||
# Get the boolean value specified by val |
||||
# |
||||
if {[catch {expr {$val ? 1 : 0}} useGMT] != 0} { |
||||
return -code error $useGMT |
||||
} |
||||
} else { |
||||
mwutil::wrongNumArgs $usage |
||||
} |
||||
} |
||||
|
||||
set fmt [::$win attrib format] |
||||
|
||||
# |
||||
# For each entry child of win, format clockVal according |
||||
# to the corresponding field descriptor character contained |
||||
# in fmt and to useGMT, and output the result to the entry |
||||
# |
||||
set len [string length $fmt] |
||||
for {set n 0} {$n < $len} {incr n} { |
||||
set field [string index $fmt $n] |
||||
::$win put $n [clock format $clockVal -format %$field -gmt $useGMT] |
||||
} |
||||
|
||||
switch $type { |
||||
Date { return "" } |
||||
Time { set idx 0 } |
||||
DateTime { set idx 3 } |
||||
} |
||||
|
||||
# |
||||
# In the entry child containing the first character of |
||||
# the AM/PM indicator (if present), display the first |
||||
# character of the corresponding time component |
||||
# |
||||
if {[string compare [string index $fmt $idx] "I"] == 0} { |
||||
if {[clock format $clockVal -format "%H"] < 12} { |
||||
::$win put $len A |
||||
} else { |
||||
::$win put $len P |
||||
} |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getClockVal |
||||
# |
||||
# Returns the clock value corresponding to the date, time, or date & time |
||||
# contained in the mentry widget win of type Date, Time, or DateTime. The |
||||
# keyword args stands for ?-base clockValue? ?-gmt boolean?, like in the clock |
||||
# scan command. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getClockVal {win args} { |
||||
set type [checkIfDateOrTimeMentry $win] |
||||
set usage "getClockVal pathName ?-base clockValue? ?-gmt boolean?" |
||||
|
||||
# |
||||
# Check the number of optional arguments |
||||
# |
||||
set count [llength $args] |
||||
if {$count > 4} { |
||||
mwutil::wrongNumArgs $usage |
||||
} |
||||
|
||||
# |
||||
# Parse the command line |
||||
# |
||||
set base [clock seconds] |
||||
set useGMT 0 |
||||
foreach {opt val} $args { |
||||
if {$count == 1} { |
||||
mwutil::wrongNumArgs $usage |
||||
} |
||||
if {[string compare $opt "-base"] == 0} { |
||||
# |
||||
# Check whether val is an integer number |
||||
# |
||||
if {[catch {format "%d" $val} res] != 0} { |
||||
return -code error $res |
||||
} |
||||
set base $val |
||||
} elseif {[string compare $opt "-gmt"] == 0} { |
||||
# |
||||
# Get the boolean value specified by val |
||||
# |
||||
if {[catch {expr {$val ? 1 : 0}} useGMT] != 0} { |
||||
return -code error $useGMT |
||||
} |
||||
} else { |
||||
mwutil::wrongNumArgs $usage |
||||
} |
||||
incr count -2 |
||||
} |
||||
|
||||
switch $type { |
||||
Date { return [getClockValFromDateMentry $win $base $useGMT] } |
||||
Time { return [getClockValFromTimeMentry $win $base $useGMT] } |
||||
DateTime { return [getClockValFromDateTimeMentry $win $base $useGMT] } |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Private procedures implementing the mentry widgets for date & time |
||||
# ================================================================== |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::checkIfDateOrTimeMentry |
||||
# |
||||
# Generates an error if win is not a mentry widget of type Date, Time, or |
||||
# DateTime. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::checkIfDateOrTimeMentry win { |
||||
if {![winfo exists $win]} { |
||||
return -code error "bad window path name \"$win\"" |
||||
} |
||||
|
||||
set type [::$win attrib type] |
||||
if {[string compare [winfo class $win] "Mentry"] != 0 || |
||||
[string compare $type "Date"] != 0 && |
||||
[string compare $type "Time"] != 0 && |
||||
[string compare $type "DateTime"] != 0} { |
||||
return -code error \ |
||||
"window \"$win\" is not a mentry widget\ |
||||
for date or time, or date & time" |
||||
} |
||||
|
||||
return $type |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getClockValFromDateMentry |
||||
# |
||||
# Returns the clock value corresponding to the date contained in the mentry |
||||
# widget win of type Date. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getClockValFromDateMentry {win base useGMT} { |
||||
# |
||||
# Scan the contents of the entry children; generate an error if |
||||
# any of them is empty or the value of the day or month is zero |
||||
# |
||||
set fmt [::$win attrib format] |
||||
variable dateTimeMins |
||||
for {set n 0} {$n < 3} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
scan $str "%d" vals($n) |
||||
set field [string index $fmt $n] |
||||
if {$vals($n) < $dateTimeMins($field)} { |
||||
tabToEntry $w |
||||
return -code error BAD |
||||
} |
||||
set idxs($field) $n |
||||
} |
||||
|
||||
# |
||||
# Get the year, month, and day displayed in the widget |
||||
# |
||||
if {[info exists idxs(y)]} { |
||||
set yearIdx $idxs(y) |
||||
set year $vals($yearIdx) |
||||
set yearStr [format "%02d" $year] |
||||
set format %m/%d/%y |
||||
} else { |
||||
set yearIdx $idxs(Y) |
||||
set year $vals($yearIdx) |
||||
set yearStr [format "%04d" $year] |
||||
set format %m/%d/%Y |
||||
} |
||||
set month $vals($idxs(m)) |
||||
set day $vals($idxs(d)) |
||||
|
||||
# |
||||
# Check whether they represent a valid date |
||||
# |
||||
set dayList {0 31 28 31 30 31 30 31 31 30 31 30 31} |
||||
if {($year % 4 == 0 && $year % 100 != 0) || $year % 400 == 0} { |
||||
set dayList [lreplace $dayList 2 2 29] |
||||
} |
||||
if {$day > [lindex $dayList $month]} { |
||||
set w [::$win entrypath 0] |
||||
focus $w |
||||
$w icursor 0 |
||||
return -code error BAD_DATE |
||||
} |
||||
|
||||
# |
||||
# Now we have a valid date: try to convert it to an integer clock |
||||
# value; generate an error if this fails (because of the year) |
||||
# |
||||
set cmd [list clock scan $month/$day/$yearStr -base $base -gmt $useGMT] |
||||
if {$::tcl_version >= 8.5} { |
||||
lappend cmd -format $format |
||||
} |
||||
if {[catch {eval $cmd} res] == 0} { |
||||
return $res |
||||
} else { |
||||
tabToEntry [::$win entrypath $yearIdx] |
||||
return -code error BAD_YEAR |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getClockValFromTimeMentry |
||||
# |
||||
# Returns the clock value corresponding to the time contained in the mentry |
||||
# widget win of type Time. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getClockValFromTimeMentry {win base useGMT} { |
||||
# |
||||
# Scan the contents of the numeric entry children; |
||||
# generate an error if the first or second one is empty |
||||
# or the value of the hour in 12-hour format is zero |
||||
# |
||||
set fmt [::$win attrib format] |
||||
set len [string length $fmt] |
||||
set meridianFlag [expr {[string compare [string index $fmt 0] "I"] == 0}] |
||||
for {set n 0} {$n < $len} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
if {$n == 2} { |
||||
set str 00 |
||||
::$win put $n 00 |
||||
} else { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
} |
||||
if {$n == 0 && $meridianFlag} { |
||||
scan $str "%d" val |
||||
if {$val < 1} { |
||||
tabToEntry $w |
||||
return -code error BAD |
||||
} |
||||
} |
||||
if {$n > 0} { |
||||
append timeStr : |
||||
} |
||||
append timeStr $str |
||||
} |
||||
|
||||
# |
||||
# Generate an error if the entry that should |
||||
# contain an A or P (if present) is empty |
||||
# |
||||
if {$meridianFlag} { |
||||
set w [::$win entrypath $len] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
append timeStr " ${str}M" |
||||
|
||||
if {$len == 2} { |
||||
set format "%I:%M %p" |
||||
} else { |
||||
set format "%I:%M:%S %p" |
||||
} |
||||
} else { |
||||
if {$len == 2} { |
||||
set format "%H:%M" |
||||
} else { |
||||
set format "%H:%M:%S" |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Convert the time string built from the contents |
||||
# of the widget to an integer clock value |
||||
# |
||||
if {$::tcl_version >= 8.5} { |
||||
return [clock scan $timeStr -base $base -gmt $useGMT -format $format] |
||||
} else { |
||||
return [clock scan $timeStr -base $base -gmt $useGMT] |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getClockValFromDateTimeMentry |
||||
# |
||||
# Returns the clock value corresponding to the date & time contained in the |
||||
# mentry widget win of type DateTime. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getClockValFromDateTimeMentry {win base useGMT} { |
||||
set fmt [::$win attrib format] |
||||
|
||||
# |
||||
# Scan the contents of the first 3 entry children; generate an error |
||||
# if any of them is empty or the value of the day or month is zero |
||||
# |
||||
variable dateTimeMins |
||||
for {set n 0} {$n < 3} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
scan $str "%d" vals($n) |
||||
set field [string index $fmt $n] |
||||
if {$vals($n) < $dateTimeMins($field)} { |
||||
tabToEntry $w |
||||
return -code error BAD |
||||
} |
||||
set idxs($field) $n |
||||
} |
||||
|
||||
# |
||||
# Get the year, month, and day displayed in the widget |
||||
# |
||||
if {[info exists idxs(y)]} { |
||||
set yearIdx $idxs(y) |
||||
set year $vals($yearIdx) |
||||
set yearStr [format "%02d" $year] |
||||
set format "%m/%d/%y " |
||||
} else { |
||||
set yearIdx $idxs(Y) |
||||
set year $vals($yearIdx) |
||||
set yearStr [format "%04d" $year] |
||||
set format "%m/%d/%Y " |
||||
} |
||||
set month $vals($idxs(m)) |
||||
set day $vals($idxs(d)) |
||||
|
||||
# |
||||
# Check whether they represent a valid date |
||||
# |
||||
set dayList {0 31 28 31 30 31 30 31 31 30 31 30 31} |
||||
if {($year % 4 == 0 && $year % 100 != 0) || $year % 400 == 0} { |
||||
set dayList [lreplace $dayList 2 2 29] |
||||
} |
||||
if {$day > [lindex $dayList $month]} { |
||||
set w [::$win entrypath 0] |
||||
focus $w |
||||
$w icursor 0 |
||||
return -code error BAD_DATE |
||||
} |
||||
|
||||
set dateTimeStr "$month/$day/$yearStr " |
||||
|
||||
# |
||||
# Scan the contents of the remaining numeric entry children; |
||||
# generate an error if the first or second one is empty |
||||
# or the value of the hour in 12-hour format is zero |
||||
# |
||||
set len [string length $fmt] |
||||
set meridianFlag [expr {[string compare [string index $fmt 3] "I"] == 0}] |
||||
for {set n 3} {$n < $len} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
if {$n == 5} { |
||||
set str 00 |
||||
::$win put $n 00 |
||||
} else { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
} |
||||
if {$n == 3 && $meridianFlag} { |
||||
scan $str "%d" val |
||||
if {$val < 1} { |
||||
tabToEntry $w |
||||
return -code error BAD |
||||
} |
||||
} |
||||
if {$n > 3} { |
||||
append dateTimeStr : |
||||
} |
||||
append dateTimeStr $str |
||||
} |
||||
|
||||
# |
||||
# Generate an error if the entry that should |
||||
# contain an A or P (if present) is empty |
||||
# |
||||
if {$meridianFlag} { |
||||
set w [::$win entrypath $len] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
append dateTimeStr " ${str}M" |
||||
|
||||
if {$len == 5} { |
||||
append format "%I:%M %p" |
||||
} else { |
||||
append format "%I:%M:%S %p" |
||||
} |
||||
} else { |
||||
if {$len == 5} { |
||||
append format "%H:%M" |
||||
} else { |
||||
append format "%H:%M:%S" |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Now we have a valid date & time: try to convert it to an integer |
||||
# clock value; generate an error if this fails (because of the year) |
||||
# |
||||
set cmd [list clock scan $dateTimeStr -base $base -gmt $useGMT] |
||||
if {$::tcl_version >= 8.5} { |
||||
lappend cmd -format $format |
||||
} |
||||
if {[catch {eval $cmd} res] == 0} { |
||||
return $res |
||||
} else { |
||||
tabToEntry [::$win entrypath $yearIdx] |
||||
return -code error BAD_YEAR |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Private procedures used in bindings related to mentry widgets for date & time |
||||
# ============================================================================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::incrDateTimeComp |
||||
# |
||||
# This procedure handles <Up>, <Down>, <Prior>, and <Next> events in the entry |
||||
# child w of a mentry widget for date, time, or date & time. It increments the |
||||
# entry's value by the specified amount if allowed. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::incrDateTimeComp {w amount} { |
||||
parseChildPath $w win n |
||||
set field [string index [::$win attrib format] $n] |
||||
|
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
# |
||||
# Insert the entry's min. value |
||||
# |
||||
variable dateTimeMins |
||||
set str [format "%0[::$win entrylimit $n]d" $dateTimeMins($field)] |
||||
_$w insert end $str |
||||
_$w icursor 0 |
||||
} else { |
||||
# |
||||
# Increment the entry's value by the given amount if allowed |
||||
# |
||||
scan $str "%d" val |
||||
if {$amount > 0} { |
||||
variable dateTimeMaxs |
||||
if {$val < $dateTimeMaxs($field)} { |
||||
incr val $amount |
||||
if {$val > $dateTimeMaxs($field)} { |
||||
set val $dateTimeMaxs($field) |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} else { |
||||
variable dateTimeMins |
||||
if {$val > $dateTimeMins($field)} { |
||||
incr val $amount |
||||
if {$val < $dateTimeMins($field)} { |
||||
set val $dateTimeMins($field) |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
set str [format "%0[::$win entrylimit $n]d" $val] |
||||
set oldPos [$w index insert] |
||||
_$w delete 0 end |
||||
_$w insert end $str |
||||
_$w icursor $oldPos |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::setMeridian |
||||
# |
||||
# This procedure handles <Up>, <Down>, <Prior>, and <Next> events in the entry |
||||
# child w of a mentry widget for time or date & time displaying the first |
||||
# character of the AM/PM indicator. It sets the entry's text to the specified |
||||
# value. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::setMeridian {w str} { |
||||
if {[string length [$w get]] == 0} { |
||||
# |
||||
# Insert an "A" |
||||
# |
||||
_$w insert end A |
||||
_$w icursor 0 |
||||
} else { |
||||
# |
||||
# Replace the entry's text with the given value |
||||
# |
||||
set oldPos [$w index insert] |
||||
_$w delete 0 end |
||||
_$w insert end $str |
||||
_$w icursor $oldPos |
||||
} |
||||
} |
||||
@ -0,0 +1,142 @@
|
||||
#============================================================================== |
||||
# Contains the implementation of a multi-entry widget for real numbers in |
||||
# fixed-point format. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Public procedures |
||||
# ================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::fixedPointMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit real numbers |
||||
# in fixed-point format, with cnt1 characters before and cnt2 digits after the |
||||
# decimal point. Sets the type attribute of the widget to FixedPoint and |
||||
# returns the name of the newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::fixedPointMentry {win cnt1 cnt2 args} { |
||||
# |
||||
# Check the arguments |
||||
# |
||||
if {[catch {format "%d" $cnt1}] != 0 || $cnt1 <= 0} { |
||||
return -code error "expected positive integer but got \"$cnt1\"" |
||||
} |
||||
if {[catch {format "%d" $cnt2}] != 0 || $cnt2 <= 0} { |
||||
return -code error "expected positive integer but got \"$cnt2\"" |
||||
} |
||||
|
||||
# |
||||
# Change the default separator if the first optional argument is -comma |
||||
# |
||||
set sep . |
||||
if {[string compare [lindex $args 0] "-comma"] == 0} { |
||||
set sep , |
||||
set args [lrange $args 1 end] |
||||
} |
||||
|
||||
# |
||||
# Create the widget and set its type to FixedPoint |
||||
# |
||||
eval [list mentry $win] $args |
||||
::$win configure -body [list $cnt1 $sep $cnt2] |
||||
::$win attrib type FixedPoint |
||||
|
||||
# |
||||
# Allow only integer input in the first entry |
||||
# |
||||
set w [::$win entrypath 0] |
||||
wcb::cbappend $w before insert wcb::checkEntryForInt |
||||
::$win adjustentry 0 "0123456789" "+-" |
||||
$w configure -justify right |
||||
|
||||
# |
||||
# Allow only decimal digits in the second entry |
||||
# |
||||
set w [::$win entrypath 1] |
||||
wcb::cbappend $w before insert wcb::checkStrForNum |
||||
::$win adjustentry 1 "0123456789" |
||||
$w configure -justify left |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::putReal |
||||
# |
||||
# Outputs the number num to the mentry widget win of type FixedPoint. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::putReal {num win} { |
||||
checkIfFixedPointMentry $win |
||||
|
||||
# |
||||
# Get the expected number of digits after the decimal point |
||||
# from the value of the -body configuration option of |
||||
# the mentry win and format the number num accordingly |
||||
# |
||||
set body [::$win cget -body] |
||||
if {[catch {format "%.*f" [lindex $body 2] $num} str] != 0} { |
||||
return -code error $str |
||||
} |
||||
|
||||
# |
||||
# Check whether the result of the format command fits into the widget |
||||
# |
||||
set lst [split $str .] |
||||
if {[string length [lindex $lst 0]] > [lindex $body 0]} { |
||||
return -code error \ |
||||
"the string \"$str\" does not fit into the mentry widget\ |
||||
\"$win\"" |
||||
} |
||||
|
||||
eval [list ::$win put 0] $lst |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getReal |
||||
# |
||||
# Returns the number contained in the mentry widget win of type FixedPoint. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getReal win { |
||||
checkIfFixedPointMentry $win |
||||
|
||||
# |
||||
# Generate an error if the widget is empty |
||||
# |
||||
if {[::$win isempty]} { |
||||
focus [::$win entrypath 0] |
||||
return -code error EMPTY |
||||
} |
||||
|
||||
# |
||||
# Scan the contents of the widget |
||||
# |
||||
::$win getarray strs |
||||
scan $strs(0).$strs(1) "%f" val |
||||
return $val |
||||
} |
||||
|
||||
# |
||||
# Private procedure |
||||
# ================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::checkIfFixedPointMentry |
||||
# |
||||
# Generates an error if win is not a mentry widget of type FixedPoint. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::checkIfFixedPointMentry win { |
||||
if {![winfo exists $win]} { |
||||
return -code error "bad window path name \"$win\"" |
||||
} |
||||
|
||||
if {[string compare [winfo class $win] "Mentry"] != 0 || |
||||
[string compare [::$win attrib type] "FixedPoint"] != 0} { |
||||
return -code error \ |
||||
"window \"$win\" is not a mentry widget for fixed-point numbers" |
||||
} |
||||
} |
||||
@ -0,0 +1,244 @@
|
||||
#============================================================================== |
||||
# Contains the implementation of a multi-entry widget for IP addresses. |
||||
# |
||||
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Namespace initialization |
||||
# ======================== |
||||
# |
||||
|
||||
namespace eval mentry { |
||||
# |
||||
# Define some bindings for the binding tag MentryIPAddr |
||||
# |
||||
bind MentryIPAddr <Up> { mentry::incrIPAddrComp %W 1 } |
||||
bind MentryIPAddr <Down> { mentry::incrIPAddrComp %W -1 } |
||||
bind MentryIPAddr <Prior> { mentry::incrIPAddrComp %W 10 } |
||||
bind MentryIPAddr <Next> { mentry::incrIPAddrComp %W -10 } |
||||
bind MentryIPAddr <<Paste>> { mentry::pasteIPAddr %W } |
||||
variable winSys |
||||
variable uniformWheelSupport |
||||
if {$uniformWheelSupport} { |
||||
bind MentryIPAddr <MouseWheel> { |
||||
mentry::incrIPAddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 119) / 120 : %D / 120}] |
||||
} |
||||
bind MentryIPAddr <Option-MouseWheel> { |
||||
mentry::incrIPAddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 11) / 12 : %D / 12}] |
||||
} |
||||
} elseif {[string compare $winSys "classic"] == 0 || |
||||
[string compare $winSys "aqua"] == 0} { |
||||
catch { |
||||
bind MentryIPAddr <MouseWheel> { |
||||
mentry::incrIPAddrComp %W %D |
||||
} |
||||
bind MentryIPAddr <Option-MouseWheel> { |
||||
mentry::incrIPAddrComp %W [expr {10 * %D}] |
||||
} |
||||
} |
||||
} else { |
||||
catch { |
||||
bind MentryIPAddr <MouseWheel> { |
||||
mentry::incrIPAddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 119) / 120 : %D / 120}] |
||||
} |
||||
} |
||||
|
||||
if {[string compare $winSys "x11"] == 0} { |
||||
bind MentryIPAddr <Button-4> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrIPAddrComp %W 1 |
||||
} |
||||
} |
||||
bind MentryIPAddr <Button-5> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrIPAddrComp %W -1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Public procedures |
||||
# ================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::ipAddrMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit IP addresses. |
||||
# Sets the type attribute of the widget to IPAddr and returns the name of the |
||||
# newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::ipAddrMentry {win args} { |
||||
# |
||||
# Create the widget and set its type to IPAddr |
||||
# |
||||
eval [list mentry $win] $args |
||||
::$win configure -body {3 . 3 . 3 . 3} |
||||
::$win attrib type IPAddr |
||||
|
||||
# |
||||
# In each entry component allow only unsigned integers of max. |
||||
# value 255, and insert the binding tag MentryIPAddr in the |
||||
# list of binding tags of the entry, just after its path name |
||||
# |
||||
for {set n 0} {$n < 4} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
wcb::cbappend $w before insert "wcb::checkEntryForUInt 255" |
||||
::$win adjustentry $n "0123456789" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryIPAddr] |
||||
} |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::putIPAddr |
||||
# |
||||
# Outputs the IP address addr to the mentry widget win of type IPAddr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::putIPAddr {addr win} { |
||||
set errorMsg "expected an IP address but got \"$addr\"" |
||||
|
||||
# |
||||
# Check the syntax of addr |
||||
# |
||||
set lst [split $addr .] |
||||
if {[llength $lst] != 4} { |
||||
return -code error $errorMsg |
||||
} |
||||
|
||||
# |
||||
# Try to convert the four components of addr to decimal |
||||
# strings and check whether they are in the range 0 - 255 |
||||
# |
||||
for {set n 0} {$n < 4} {incr n} { |
||||
set val [lindex $lst $n] |
||||
if {[catch {format "%d" $val} str$n] != 0 || $val < 0 || $val > 255} { |
||||
return -code error $errorMsg |
||||
} |
||||
} |
||||
|
||||
checkIfIPAddrMentry $win |
||||
::$win put 0 $str0 $str1 $str2 $str3 |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getIPAddr |
||||
# |
||||
# Returns the IP address contained in the mentry widget win of type IPAddr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getIPAddr win { |
||||
checkIfIPAddrMentry $win |
||||
|
||||
# |
||||
# Scan the contents of the entry components; |
||||
# generate an error if any of them is empty |
||||
# |
||||
for {set n 0} {$n < 4} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
focus $w |
||||
return -code error EMPTY |
||||
} |
||||
scan $str "%d" val$n |
||||
} |
||||
|
||||
return $val0.$val1.$val2.$val3 |
||||
} |
||||
|
||||
# |
||||
# Private procedures |
||||
# ================== |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::checkIfIPAddrMentry |
||||
# |
||||
# Generates an error if win is not a mentry widget of type IPAddr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::checkIfIPAddrMentry win { |
||||
if {![winfo exists $win]} { |
||||
return -code error "bad window path name \"$win\"" |
||||
} |
||||
|
||||
if {[string compare [winfo class $win] "Mentry"] != 0 || |
||||
[string compare [::$win attrib type] "IPAddr"] != 0} { |
||||
return -code error \ |
||||
"window \"$win\" is not a mentry widget for IP addresses" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::incrIPAddrComp |
||||
# |
||||
# This procedure handles <Up>, <Down>, <Prior>, and <Next> events in the entry |
||||
# component w of a mentry widget for IP addresses. It increments the entry's |
||||
# value by the specified amount if allowed. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::incrIPAddrComp {w amount} { |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
# |
||||
# Insert a "0" |
||||
# |
||||
_$w insert end 0 |
||||
_$w icursor 0 |
||||
} else { |
||||
# |
||||
# Increment the entry's value by the given amount if allowed |
||||
# |
||||
scan $str "%d" val |
||||
if {$amount > 0} { |
||||
if {$val < 255} { |
||||
incr val $amount |
||||
if {$val > 255} { |
||||
set val 255 |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} else { |
||||
if {$val > 0} { |
||||
incr val $amount |
||||
if {$val < 0} { |
||||
set val 0 |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
set str [format "%d" $val] |
||||
set oldPos [$w index insert] |
||||
_$w delete 0 end |
||||
_$w insert end $str |
||||
_$w icursor $oldPos |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::pasteIPAddr |
||||
# |
||||
# This procedure handles <<Paste>> events in the entry component w of a mentry |
||||
# widget for IP addresses by pasting the current contents of the clipboard into |
||||
# the mentry if it is a valid IP address. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::pasteIPAddr w { |
||||
if {[llength [info procs ::tk::GetSelection]] == 1} { |
||||
set res [catch {::tk::GetSelection $w CLIPBOARD} addr] |
||||
} else { ;# for Tk versions prior to 8.3 |
||||
set res [catch {selection get -displayof $w -selection CLIPBOARD} addr] |
||||
} |
||||
if {$res == 0} { |
||||
parseChildPath $w win n |
||||
catch { putIPAddr $addr $win } |
||||
} |
||||
|
||||
return -code break "" |
||||
} |
||||
@ -0,0 +1,282 @@
|
||||
#============================================================================== |
||||
# Contains the implementation of a multi-entry widget for IPv6 addresses. |
||||
# |
||||
# Copyright (c) 2009-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Namespace initialization |
||||
# ======================== |
||||
# |
||||
|
||||
namespace eval mentry { |
||||
# |
||||
# Define some bindings for the binding tag MentryIPv6Addr |
||||
# |
||||
bind MentryIPv6Addr <Up> { mentry::incrIPv6AddrComp %W 1 } |
||||
bind MentryIPv6Addr <Down> { mentry::incrIPv6AddrComp %W -1 } |
||||
bind MentryIPv6Addr <Prior> { mentry::incrIPv6AddrComp %W 10 } |
||||
bind MentryIPv6Addr <Next> { mentry::incrIPv6AddrComp %W -10 } |
||||
bind MentryIPv6Addr <<Paste>> { mentry::pasteIPv6Addr %W } |
||||
variable winSys |
||||
variable uniformWheelSupport |
||||
if {$uniformWheelSupport} { |
||||
bind MentryIPv6Addr <MouseWheel> { |
||||
mentry::incrIPv6AddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 119) / 120 : %D / 120}] |
||||
} |
||||
bind MentryIPv6Addr <Option-MouseWheel> { |
||||
mentry::incrIPv6AddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 11) / 12 : %D / 12}] |
||||
} |
||||
} elseif {[string compare $winSys "classic"] == 0 || |
||||
[string compare $winSys "aqua"] == 0} { |
||||
catch { |
||||
bind MentryIPv6Addr <MouseWheel> { |
||||
mentry::incrIPv6AddrComp %W %D |
||||
} |
||||
bind MentryIPv6Addr <Option-MouseWheel> { |
||||
mentry::incrIPv6AddrComp %W [expr {10 * %D}] |
||||
} |
||||
} |
||||
} else { |
||||
catch { |
||||
bind MentryIPv6Addr <MouseWheel> { |
||||
mentry::incrIPv6AddrComp %W \ |
||||
[expr {%D > 0 ? (%D + 11) / 12 : %D / 12}] |
||||
} |
||||
} |
||||
|
||||
if {[string compare $winSys "x11"] == 0} { |
||||
bind MentryIPv6Addr <Button-4> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrIPv6AddrComp %W 1 |
||||
} |
||||
} |
||||
bind MentryIPv6Addr <Button-5> { |
||||
if {!$tk_strictMotif} { |
||||
mentry::incrIPv6AddrComp %W -1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Public procedures |
||||
# ================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::ipv6AddrMentry |
||||
# |
||||
# Creates a new mentry widget win that allows to display and edit IPv6 |
||||
# addresses. Sets the type attribute of the widget to IPv6Addr and returns the |
||||
# name of the newly created widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::ipv6AddrMentry {win args} { |
||||
# |
||||
# Create the widget and set its type to IPv6Addr |
||||
# |
||||
eval [list mentry $win] $args |
||||
::$win configure -body {4 : 4 : 4 : 4 : 4 : 4 : 4 : 4} |
||||
::$win attrib type IPv6Addr |
||||
|
||||
# |
||||
# In each entry component allow only hexadecimal digits, and |
||||
# insert the binding tag MentryIPv6Addr in the list of |
||||
# binding tags of the entry, just after its path name |
||||
# |
||||
for {set n 0} {$n < 8} {incr n} { |
||||
set w [::$win entrypath $n] |
||||
wcb::cbappend $w before insert wcb::convStrToLower \ |
||||
{wcb::checkStrForRegExp {^[0-9a-fA-F]*$}} |
||||
::$win adjustentry $n "0123456789abcdefABCDEF" |
||||
bindtags $w [linsert [bindtags $w] 1 MentryIPv6Addr] |
||||
} |
||||
|
||||
return $win |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::putIPv6Addr |
||||
# |
||||
# Outputs the IPv6 address addr to the mentry widget win of type IPv6Addr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::putIPv6Addr {addr win} { |
||||
set errorMsg "expected an IPv6 address but got \"$addr\"" |
||||
|
||||
# |
||||
# Check the syntax of addr |
||||
# |
||||
if {[string match "*::*::*" $addr] || [string match "*:::*" $addr] || |
||||
[regexp {^:[^:]} $addr] || [regexp {[^:]:$} $addr]} { |
||||
return -code error $errorMsg |
||||
} |
||||
|
||||
# |
||||
# Split addr on colons; make sure that a starting or |
||||
# trailing "::" will give rise to a single empty string |
||||
# |
||||
if {[string compare $addr "::"] == 0} { |
||||
set lst [list ""] |
||||
} elseif {[regexp {^::(.+)} $addr dummy var]} { |
||||
set lst [list ""] |
||||
eval lappend lst [split $var ":"] |
||||
} elseif {[regexp {(.+)::$} $addr dummy var]} { |
||||
set lst [split $var ":"] |
||||
lappend lst "" |
||||
} else { |
||||
set lst [split $addr ":"] |
||||
} |
||||
|
||||
# |
||||
# Replace the unique empty element of the list |
||||
# (if any) with an appropriate number of zeros |
||||
# |
||||
set emptyIdx [lsearch -exact $lst ""] |
||||
set lstLen [llength $lst] |
||||
if {$emptyIdx < 0} { |
||||
if {$lstLen != 8} { |
||||
return -code error $errorMsg |
||||
} |
||||
} else { |
||||
if {$lstLen > 8} { |
||||
return -code error $errorMsg |
||||
} |
||||
|
||||
set count [expr {9 - $lstLen}] |
||||
for {set n 0} {$n < $count} {incr n} { |
||||
lappend lst2 0 |
||||
} |
||||
set lst [eval lreplace {$lst} $emptyIdx $emptyIdx $lst2] |
||||
} |
||||
|
||||
# |
||||
# Try to convert the 8 elements of the list to hexadecimal |
||||
# strings and check whether they are in the range 0 - 65535 |
||||
# |
||||
for {set n 0} {$n < 8} {incr n} { |
||||
set val 0x[lindex $lst $n] |
||||
if {[catch {format "%x" $val} str$n] != 0 | $val > 65535} { |
||||
return -code error $errorMsg |
||||
} |
||||
} |
||||
|
||||
checkIfIPv6AddrMentry $win |
||||
::$win put 0 $str0 $str1 $str2 $str3 $str4 $str5 $str6 $str7 |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getIPv6Addr |
||||
# |
||||
# Returns the IPv6 address contained in the mentry widget win of type IPv6Addr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getIPv6Addr win { |
||||
checkIfIPv6AddrMentry $win |
||||
|
||||
# |
||||
# Generate an error if any entry component is empty |
||||
# |
||||
for {set n 0} {$n < 8} {incr n} { |
||||
if {[::$win isempty $n]} { |
||||
focus [::$win entrypath $n] |
||||
return -code error EMPTY |
||||
} |
||||
} |
||||
|
||||
::$win getarray strs |
||||
return [format "%x:%x:%x:%x:%x:%x:%x:%x" \ |
||||
0x$strs(0) 0x$strs(1) 0x$strs(2) 0x$strs(3) \ |
||||
0x$strs(4) 0x$strs(5) 0x$strs(6) 0x$strs(7)] |
||||
} |
||||
|
||||
# |
||||
# Private procedures |
||||
# ================== |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::checkIfIPv6AddrMentry |
||||
# |
||||
# Generates an error if win is not a mentry widget of type IPv6Addr. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::checkIfIPv6AddrMentry win { |
||||
if {![winfo exists $win]} { |
||||
return -code error "bad window path name \"$win\"" |
||||
} |
||||
|
||||
if {[string compare [winfo class $win] "Mentry"] != 0 || |
||||
[string compare [::$win attrib type] "IPv6Addr"] != 0} { |
||||
return -code error \ |
||||
"window \"$win\" is not a mentry widget for IPv6 addresses" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::incrIPv6AddrComp |
||||
# |
||||
# This procedure handles <Up>, <Down>, <Prior>, and <Next> events in the entry |
||||
# component w of a mentry widget for IPv6 addresses. It increments the entry's |
||||
# value by the specified amount if allowed. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::incrIPv6AddrComp {w amount} { |
||||
set str [$w get] |
||||
if {[string length $str] == 0} { |
||||
# |
||||
# Insert a "0" |
||||
# |
||||
_$w insert end 0 |
||||
_$w icursor 0 |
||||
} else { |
||||
# |
||||
# Increment the entry's value by the given amount if allowed |
||||
# |
||||
scan $str "%x" val |
||||
if {$amount > 0} { |
||||
if {$val < 65535} { |
||||
incr val $amount |
||||
if {$val > 65535} { |
||||
set val 65535 |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} else { |
||||
if {$val > 0} { |
||||
incr val $amount |
||||
if {$val < 0} { |
||||
set val 0 |
||||
} |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
set str [format "%x" $val] |
||||
set oldPos [$w index insert] |
||||
_$w delete 0 end |
||||
_$w insert end $str |
||||
_$w icursor $oldPos |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::pasteIPv6Addr |
||||
# |
||||
# This procedure handles <<Paste>> events in the entry component w of a mentry |
||||
# widget for IPv6 addresses by pasting the current contents of the clipboard |
||||
# into the mentry if it is a valid IPv6 address. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::pasteIPv6Addr w { |
||||
if {[llength [info procs ::tk::GetSelection]] == 1} { |
||||
set res [catch {::tk::GetSelection $w CLIPBOARD} addr] |
||||
} else { ;# for Tk versions prior to 8.3 |
||||
set res [catch {selection get -displayof $w -selection CLIPBOARD} addr] |
||||
} |
||||
if {$res == 0} { |
||||
parseChildPath $w win n |
||||
catch { putIPv6Addr $addr $win } |
||||
} |
||||
|
||||
return -code break "" |
||||
} |
||||
@ -0,0 +1,675 @@
|
||||
#============================================================================== |
||||
# Contains procedures that populate the array themeDefaults with theme-specific |
||||
# values of some mentry configuration options. |
||||
# |
||||
# Structure of the module: |
||||
# - Public procedure related to tile themes |
||||
# - Private procedures related to tile themes |
||||
# - Private procedures related to global KDE configuration options |
||||
# |
||||
# Copyright (c) 2006-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
# |
||||
# Public procedure related to tile themes |
||||
# ======================================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::setThemeDefaults |
||||
# |
||||
# Populates the array themeDefaults with theme-specific default values of some |
||||
# mentry configuration options and updates the array configSpecs. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::setThemeDefaults {} { |
||||
# |
||||
# For several themes, some of the following most frequent |
||||
# values will be overridden by theme-specific ones: |
||||
# |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background white \ |
||||
-disabledbackground "" \ |
||||
-foreground black \ |
||||
-foreground,background black \ |
||||
-font TkTextFont \ |
||||
] |
||||
|
||||
if {[info exists themeDefaults(-readonlybackground)]} { |
||||
unset themeDefaults(-readonlybackground) |
||||
} |
||||
|
||||
set currentTheme [::mwutil::currentTheme] |
||||
variable isAwTheme \ |
||||
[llength [info commands ::ttk::theme::${currentTheme}::setTextColors]] |
||||
if {$isAwTheme} { |
||||
awTheme $currentTheme |
||||
} elseif {[catch {${currentTheme}Theme}] != 0} { |
||||
# |
||||
# Fall back to the "default" theme (which is the root of all |
||||
# themes) and then override the options set by the current one |
||||
# |
||||
defaultTheme |
||||
array set themeDefaults [styleConfig .] |
||||
|
||||
if {[set bg [styleConfig TEntry -fieldbackground]] eq ""} { |
||||
set bg [styleConfig . -fieldbackground] |
||||
} |
||||
if {$bg ne ""} { |
||||
set themeDefaults(-background) $bg |
||||
} |
||||
|
||||
if {[set fg [styleConfig TEntry -foreground]] eq ""} { |
||||
set fg [styleConfig . -foreground] |
||||
} |
||||
if {$fg ne ""} { |
||||
set themeDefaults(-foreground) $fg |
||||
} |
||||
set themeDefaults(-foreground,background) $themeDefaults(-foreground) |
||||
|
||||
set disabledBg "" |
||||
array set arr [style map TEntry -fieldbackground] |
||||
if {[info exists arr(disabled)]} { |
||||
set disabledBg $arr(disabled) |
||||
} else { |
||||
array set arr [style map . -fieldbackground] |
||||
if {[info exists arr(disabled)]} { |
||||
set disabledBg $arr(disabled) |
||||
} |
||||
} |
||||
set themeDefaults(-disabledbackground) $disabledBg ;# may be "" |
||||
|
||||
set disabledFg "" |
||||
unset arr |
||||
array set arr [style map TEntry -foreground] |
||||
if {[info exists arr(disabled)]} { |
||||
set disabledFg $arr(disabled) |
||||
} else { |
||||
array set arr [style map . -foreground] |
||||
if {[info exists arr(disabled)]} { |
||||
set disabledFg $arr(disabled) |
||||
} |
||||
} |
||||
if {$disabledFg ne ""} { |
||||
set themeDefaults(-disabledforeground) $disabledFg |
||||
} |
||||
|
||||
set themeDefaults(-borderwidth) 2 ;# just a guess |
||||
set themeDefaults(-labelpady) {2 2} ;# just a guess |
||||
} |
||||
|
||||
if {![info exists themeDefaults(-readonlybackground)]} { |
||||
set themeDefaults(-readonlybackground) \ |
||||
$themeDefaults(-disabledbackground) |
||||
} |
||||
|
||||
variable configSpecs |
||||
foreach opt {-background -foreground -font} { |
||||
if {[llength $configSpecs($opt)] < 4} { |
||||
lappend configSpecs($opt) $themeDefaults($opt) |
||||
} else { |
||||
lset configSpecs($opt) 3 $themeDefaults($opt) |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Private procedures related to tile themes |
||||
# ========================================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::awTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::awTheme theme { |
||||
switch $theme { |
||||
awarc - arc - |
||||
awbreeze - breeze - |
||||
awbreezedark { set bdWidth 3; set labelPadY {3 3} } |
||||
awblack - black - |
||||
awclearlooks - clearlooks - |
||||
awdark - |
||||
awlight - |
||||
awtemplate - |
||||
awwinxpblue - winxpblue - |
||||
default { set bdWidth 2; set labelPadY {2 2} } |
||||
} |
||||
|
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background [styleConfig . -fieldbackground] \ |
||||
-disabledbackground [lindex [style map TEntry -fieldbackground] 1] \ |
||||
-foreground [styleConfig TEntry -foreground] \ |
||||
-foreground,background [styleConfig TEntry -foreground] \ |
||||
-disabledforeground [lindex [style map TEntry -foreground] 1] \ |
||||
-selectbackground [styleConfig . -selectbackground] \ |
||||
-selectforeground [styleConfig . -selectforeground] \ |
||||
-selectborderwidth [styleConfig . -selectborderwidth] \ |
||||
-borderwidth $bdWidth \ |
||||
-labelpady $labelPadY \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::altTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::altTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledbackground #d9d9d9 \ |
||||
-disabledforeground #a3a3a3 \ |
||||
-selectbackground #4a6984 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::aquaTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::aquaTheme {} { |
||||
variable newAquaSupport |
||||
variable themeDefaults |
||||
if {$newAquaSupport} { |
||||
variable extendedAquaSupport |
||||
if {[tk::unsupported::MacWindowStyle isdark .]} { |
||||
set background [expr {$extendedAquaSupport ? "#3a3a3a" : "#4b4b4b"}] |
||||
} else { |
||||
set background #ffffff |
||||
} |
||||
|
||||
if {$extendedAquaSupport} { |
||||
scan $::tcl_platform(osVersion) "%d" majorOSVersion |
||||
set labelPadY [expr {$majorOSVersion >= 18 ? {4 7} : {4 5}}] |
||||
} else { |
||||
set labelPadY {4 7} |
||||
} |
||||
|
||||
array set themeDefaults [list \ |
||||
-background $background \ |
||||
-foreground systemTextColor \ |
||||
-foreground,background systemTextColor \ |
||||
-disabledforeground systemDisabledControlTextColor \ |
||||
-selectbackground systemSelectedTextBackgroundColor \ |
||||
-selectforeground systemSelectedTextColor \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 4 \ |
||||
-labelpady $labelPadY \ |
||||
] |
||||
} else { |
||||
array set themeDefaults [list \ |
||||
-background systemWindowBody \ |
||||
-foreground systemModelessDialogActiveText \ |
||||
-foreground,background systemModelessDialogInactiveText \ |
||||
-disabledforeground systemModelessDialogInactiveText \ |
||||
-selectbackground systemHighlight \ |
||||
-selectforeground systemModelessDialogActiveText \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 4 \ |
||||
-labelpady {4 4} \ |
||||
] |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::AquativoTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::AquativoTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground black \ |
||||
-selectbackground #000000 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::aquativoTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::aquativoTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #565248 \ |
||||
-selectbackground #000000 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::ArcTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::ArcTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledbackground #fbfcfc \ |
||||
-foreground #5c616c \ |
||||
-foreground,background #5c616c \ |
||||
-disabledforeground #a9acb2 \ |
||||
-selectbackground #5294e2 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 3 \ |
||||
-labelpady {3 3} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::blueTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::blueTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background #e6f3ff \ |
||||
-disabledforeground #666666 \ |
||||
-selectbackground #ffff33 \ |
||||
-selectforeground #000000 \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::clamTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::clamTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #999999 \ |
||||
-selectbackground #4a6984 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::classicTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::classicTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledbackground #d9d9d9 \ |
||||
-disabledforeground #a3a3a3 \ |
||||
-selectbackground #c3c3c3 \ |
||||
-selectforeground #000000 \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 3 \ |
||||
-labelpady {3 3} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::clearlooksTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::clearlooksTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-readonlybackground #efebe7 \ |
||||
-disabledforeground #b5b3ac \ |
||||
-selectbackground #7c99ad \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::defaultTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::defaultTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledbackground #d9d9d9 \ |
||||
-disabledforeground #a3a3a3 \ |
||||
-selectbackground #4a6984 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 1 \ |
||||
-labelpady {1 1} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::keramikTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::keramikTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #aaaaaa \ |
||||
-selectbackground #0a5f89 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::keramik_altTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::keramik_altTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #aaaaaa \ |
||||
-selectbackground #0a5f89 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::krocTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::krocTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #b2b2b2 \ |
||||
-selectbackground #000000 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::plastikTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::plastikTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #aaaaaa \ |
||||
-selectbackground #657a9e \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::srivTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::srivTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background #e6f3ff \ |
||||
-disabledforeground #666666 \ |
||||
-selectbackground #ffff33 \ |
||||
-selectforeground #000000 \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 1 \ |
||||
-labelpady {1 1} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::srivlgTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::srivlgTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background #e6f3ff \ |
||||
-disabledforeground #666666 \ |
||||
-selectbackground #ffff33 \ |
||||
-selectforeground #000000 \ |
||||
-selectborderwidth 1 \ |
||||
-borderwidth 3 \ |
||||
-labelpady {3 3} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::stepTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::stepTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #808080 \ |
||||
-selectbackground #fdcd00 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::tileqtTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::tileqtTheme {} { |
||||
set mentryBg [tileqt_currentThemeColour -base] |
||||
set mentryDisBg [tileqt_currentThemeColour -disabled -base] |
||||
set mentryFg [tileqt_currentThemeColour -text] |
||||
set mentryDisFg [tileqt_currentThemeColour -disabled -text] |
||||
set selectBg [tileqt_currentThemeColour -highlight] |
||||
set selectFg [tileqt_currentThemeColour -highlightedText] |
||||
|
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background $mentryBg \ |
||||
-disabledbackground $mentryDisBg \ |
||||
-foreground $mentryFg \ |
||||
-foreground,background $mentryFg \ |
||||
-disabledforeground $mentryDisFg \ |
||||
-selectbackground $selectBg \ |
||||
-selectforeground $selectFg \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 3 \ |
||||
-labelpady {3 3} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::vistaTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::vistaTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background SystemWindow \ |
||||
-disabledbackground SystemButtonFace \ |
||||
-foreground SystemWindowText \ |
||||
-foreground,background SystemWindowText \ |
||||
-disabledforeground SystemDisabledText \ |
||||
-selectbackground SystemHighlight \ |
||||
-selectforeground SystemHighlightText \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::winnativeTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::winnativeTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background SystemWindow \ |
||||
-disabledbackground SystemButtonFace \ |
||||
-foreground SystemWindowText \ |
||||
-foreground,background SystemWindowText \ |
||||
-disabledforeground SystemDisabledText \ |
||||
-selectbackground SystemHighlight \ |
||||
-selectforeground SystemHighlightText \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::winxpblueTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::winxpblueTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-disabledforeground #565248 \ |
||||
-selectbackground #4a6984 \ |
||||
-selectforeground #ffffff \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 2} \ |
||||
] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::xpnativeTheme |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::xpnativeTheme {} { |
||||
variable themeDefaults |
||||
array set themeDefaults [list \ |
||||
-background SystemWindow \ |
||||
-disabledbackground SystemButtonFace \ |
||||
-foreground SystemWindowText \ |
||||
-foreground,background SystemWindowText \ |
||||
-disabledforeground SystemDisabledText \ |
||||
-selectbackground SystemHighlight \ |
||||
-selectforeground SystemHighlightText \ |
||||
-selectborderwidth 0 \ |
||||
-borderwidth 2 \ |
||||
-labelpady {2 4} \ |
||||
] |
||||
} |
||||
|
||||
# |
||||
# Private procedures related to global KDE configuration options |
||||
# ============================================================== |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::getKdeConfigVal |
||||
# |
||||
# Returns the value of the global KDE configuration option identified by the |
||||
# given group (section) and key. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::getKdeConfigVal {group key} { |
||||
variable kdeDirList |
||||
|
||||
if {![info exists kdeDirList]} { |
||||
makeKdeDirList |
||||
} |
||||
|
||||
# |
||||
# Search for the entry corresponding to the given group and key in |
||||
# the file "share/config/kdeglobals" within the KDE directories |
||||
# |
||||
foreach dir $kdeDirList { |
||||
set fileName [file join $dir "share/config/kdeglobals"] |
||||
if {[set val [readKdeConfigVal $fileName $group $key]] ne ""} { |
||||
return $val |
||||
} |
||||
} |
||||
return "" |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::makeKdeDirList |
||||
# |
||||
# Builds the list of the directories to be considered when searching for global |
||||
# KDE configuration options. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::makeKdeDirList {} { |
||||
variable kdeDirList {} |
||||
|
||||
if {[info exists ::env(KDE_SESSION_VERSION)]} { |
||||
set ver $::env(KDE_SESSION_VERSION) |
||||
} else { |
||||
set ver "" |
||||
} |
||||
|
||||
if {[info exists ::env(USER)] && $::env(USER) eq "root"} { |
||||
set name "KDEROOTHOME" |
||||
} else { |
||||
set name "KDEHOME" |
||||
} |
||||
if {[info exists ::env($name)] && $::env($name) ne ""} { |
||||
set localKdeDir [file normalize $::env($name)] |
||||
} elseif {[info exists ::env(HOME)] && $::env(HOME) ne ""} { |
||||
set localKdeDir [file normalize [file join $::env(HOME) ".kde$ver"]] |
||||
} |
||||
if {[info exists localKdeDir] && $localKdeDir ne "-"} { |
||||
lappend kdeDirList $localKdeDir |
||||
} |
||||
|
||||
if {[info exists ::env(KDEDIRS)] && $::env(KDEDIRS) ne ""} { |
||||
foreach dir [split $::env(KDEDIRS) ":"] { |
||||
if {$dir ne ""} { |
||||
lappend kdeDirList $dir |
||||
} |
||||
} |
||||
} elseif {[info exists ::env(KDEDIR)] && $::env(KDEDIR) ne ""} { |
||||
lappend kdeDirList $::env(KDEDIR) |
||||
} |
||||
|
||||
set prefix [exec kde$ver-config --expandvars --prefix] |
||||
lappend kdeDirList $prefix |
||||
|
||||
set execPrefix [exec kde$ver-config --expandvars --exec-prefix] |
||||
if {$execPrefix ne $prefix} { |
||||
lappend kdeDirList $execPrefix |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mentry::readKdeConfigVal |
||||
# |
||||
# Reads the value of the global KDE configuration option identified by the |
||||
# given group (section) and key from the specified file. Note that the |
||||
# procedure performs a case-sensitive search and only works as expected for |
||||
# "simple" group and key names. |
||||
#------------------------------------------------------------------------------ |
||||
proc mentry::readKdeConfigVal {fileName group key} { |
||||
if {[catch {open $fileName r} chan] != 0} { |
||||
return "" |
||||
} |
||||
|
||||
# |
||||
# Search for the specified group |
||||
# |
||||
set groupFound 0 |
||||
while {[gets $chan line] >= 0} { |
||||
set line [string trim $line] |
||||
if {$line eq "\[$group\]"} { |
||||
set groupFound 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$groupFound} { |
||||
close $chan |
||||
return "" |
||||
} |
||||
|
||||
# |
||||
# Search for the specified key within the group |
||||
# |
||||
set pattern "^$key\\s*=\\s*(.+)$" |
||||
set keyFound 0 |
||||
while {[gets $chan line] >= 0} { |
||||
set line [string trim $line] |
||||
if {[string range $line 0 0] eq "\["} { |
||||
break |
||||
} |
||||
|
||||
if {[regexp $pattern $line dummy val]} { |
||||
set keyFound 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
close $chan |
||||
return [expr {$keyFound ? $val : ""}] |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,760 @@
|
||||
#============================================================================== |
||||
# Contains utility procedures for mega-widgets. |
||||
# |
||||
# Structure of the module: |
||||
# - Namespace initialization |
||||
# - Public utility procedures |
||||
# |
||||
# Copyright (c) 2000-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
package require Tk 8 |
||||
|
||||
# |
||||
# Namespace initialization |
||||
# ======================== |
||||
# |
||||
|
||||
namespace eval mwutil { |
||||
# |
||||
# Public variables: |
||||
# |
||||
variable version 2.20 |
||||
variable library |
||||
if {$::tcl_version >= 8.4} { |
||||
set library [file dirname [file normalize [info script]]] |
||||
} else { |
||||
set library [file dirname [info script]] ;# no "file normalize" yet |
||||
} |
||||
|
||||
# |
||||
# Public procedures: |
||||
# |
||||
namespace export wrongNumArgs getAncestorByClass convEventFields \ |
||||
defineKeyNav processTraversal focusNext focusPrev \ |
||||
configureWidget fullConfigOpt fullOpt enumOpts \ |
||||
configureSubCmd attribSubCmd hasattribSubCmd \ |
||||
unsetattribSubCmd getScrollInfo getScrollInfo2 \ |
||||
isScrollable scrollByUnits genMouseWheelEvent \ |
||||
containsPointer hasFocus windowingSystem currentTheme \ |
||||
normalizeColor parsePadding |
||||
|
||||
# |
||||
# Make modified versions of the procedures tk_focusNext and |
||||
# tk_focusPrev, to be invoked in the processTraversal command |
||||
# |
||||
proc makeFocusProcs {} { |
||||
# |
||||
# Enforce the evaluation of the Tk library file "focus.tcl" |
||||
# |
||||
tk_focusNext . |
||||
|
||||
# |
||||
# Build the procedures focusNext and focusPrev |
||||
# |
||||
foreach dir {Next Prev} { |
||||
set procBody [info body tk_focus$dir] |
||||
regsub -all {winfo children} $procBody {getChildren $class} procBody |
||||
proc focus$dir {w class} $procBody |
||||
} |
||||
} |
||||
makeFocusProcs |
||||
|
||||
# |
||||
# Invoked in the procedures focusNext and focusPrev defined above: |
||||
# |
||||
proc getChildren {class w} { |
||||
if {[string compare [winfo class $w] $class] == 0} { |
||||
return {} |
||||
} else { |
||||
return [winfo children $w] |
||||
} |
||||
} |
||||
} |
||||
|
||||
package provide mwutil $mwutil::version |
||||
|
||||
# |
||||
# Public utility procedures |
||||
# ========================= |
||||
# |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::wrongNumArgs |
||||
# |
||||
# Generates a "wrong # args" error message. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::wrongNumArgs args { |
||||
set optList {} |
||||
foreach arg $args { |
||||
lappend optList \"$arg\" |
||||
} |
||||
return -code error "wrong # args: should be [enumOpts $optList]" |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::getAncestorByClass |
||||
# |
||||
# Gets the path name of the widget of the specified class from the path name w |
||||
# of one of its descendants. It is assumed that all of the ancestors of w |
||||
# exist (but w itself needn't exist). |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::getAncestorByClass {w class} { |
||||
if {[regexp {^\.[^.]+$} $w]} { |
||||
return [expr {[string compare [winfo class .] $class] == 0 ? "." : ""}] |
||||
} elseif {[regexp {^(\..+)\.[^.]+$} $w dummy win]} { |
||||
while {[winfo exists $win]} { |
||||
if {[string compare [winfo class $win] $class] == 0} { |
||||
return $win |
||||
} else { |
||||
set win [winfo parent $win] |
||||
} |
||||
} |
||||
|
||||
return "" |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::convEventFields |
||||
# |
||||
# Gets the path name of the widget of the specified class and the x and y |
||||
# coordinates relative to the latter from the path name w of one of its |
||||
# descendants and from the x and y coordinates relative to the latter. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::convEventFields {w x y class} { |
||||
set win [getAncestorByClass $w $class] |
||||
set _x [expr {$x + [winfo rootx $w] - [winfo rootx $win]}] |
||||
set _y [expr {$y + [winfo rooty $w] - [winfo rooty $win]}] |
||||
|
||||
return [list $win $_x $_y] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::defineKeyNav |
||||
# |
||||
# For a given mega-widget class, the procedure defines the binding tag |
||||
# ${class}KeyNav as a partial replacement for "all", by substituting the |
||||
# scripts bound to the events <Tab>, <Shift-Tab>, and <<PrevWindow>> with new |
||||
# ones which propagate these events to the mega-widget of the given class |
||||
# containing the widget to which the event was reported. (The event |
||||
# <Shift-Tab> was replaced with <<PrevWindow>> in Tk 8.3.0.) This tag is |
||||
# designed to be inserted before "all" in the list of binding tags of a |
||||
# descendant of a mega-widget of the specified class. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::defineKeyNav class { |
||||
foreach event {<Tab> <Shift-Tab> <<PrevWindow>>} { |
||||
bind ${class}KeyNav $event \ |
||||
[list mwutil::processTraversal %W $class $event] |
||||
} |
||||
|
||||
bind Entry <<TraverseIn>> { %W selection range 0 end; %W icursor end } |
||||
bind Spinbox <<TraverseIn>> { %W selection range 0 end; %W icursor end } |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::processTraversal |
||||
# |
||||
# Processes the given traversal event for the mega-widget of the specified |
||||
# class containing the widget w if that mega-widget is not the only widget |
||||
# receiving the focus during keyboard traversal within its toplevel widget. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::processTraversal {w class event} { |
||||
set win [getAncestorByClass $w $class] |
||||
|
||||
if {[string compare $event "<Tab>"] == 0} { |
||||
set target [focusNext $win $class] |
||||
} else { |
||||
set target [focusPrev $win $class] |
||||
} |
||||
|
||||
if {[string compare $target $win] != 0} { |
||||
set focusWin [focus -displayof $win] |
||||
if {[string length $focusWin] != 0} { |
||||
event generate $focusWin <<TraverseOut>> |
||||
} |
||||
|
||||
focus $target |
||||
event generate $target <<TraverseIn>> |
||||
} |
||||
|
||||
return -code break "" |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::configureWidget |
||||
# |
||||
# Configures the widget win by processing the command-line arguments specified |
||||
# in optValPairs and, if the value of initialize is true, also those database |
||||
# options that don't match any command-line arguments. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::configureWidget {win configSpecsName configCmd cgetCmd \ |
||||
optValPairs initialize} { |
||||
upvar $configSpecsName configSpecs |
||||
|
||||
# |
||||
# Process the command-line arguments |
||||
# |
||||
set cmdLineOpts {} |
||||
set savedOptValPairs {} |
||||
set failed 0 |
||||
set count [llength $optValPairs] |
||||
foreach {opt val} $optValPairs { |
||||
if {[catch {fullConfigOpt $opt configSpecs} result] != 0} { |
||||
set failed 1 |
||||
break |
||||
} |
||||
if {$count == 1} { |
||||
set result "value for \"$opt\" missing" |
||||
set failed 1 |
||||
break |
||||
} |
||||
set opt $result |
||||
lappend cmdLineOpts $opt |
||||
lappend savedOptValPairs $opt [eval $cgetCmd [list $win $opt]] |
||||
if {[catch {eval $configCmd [list $win $opt $val]} result] != 0} { |
||||
set failed 1 |
||||
break |
||||
} |
||||
incr count -2 |
||||
} |
||||
|
||||
if {$failed} { |
||||
# |
||||
# Restore the saved values |
||||
# |
||||
foreach {opt val} $savedOptValPairs { |
||||
eval $configCmd [list $win $opt $val] |
||||
} |
||||
|
||||
return -code error $result |
||||
} |
||||
|
||||
if {$initialize} { |
||||
# |
||||
# Process those configuration options that were not |
||||
# given as command-line arguments; use the corresponding |
||||
# values from the option database if available |
||||
# |
||||
foreach opt [lsort [array names configSpecs]] { |
||||
if {[llength $configSpecs($opt)] == 1 || |
||||
[lsearch -exact $cmdLineOpts $opt] >= 0} { |
||||
continue |
||||
} |
||||
set dbName [lindex $configSpecs($opt) 0] |
||||
set dbClass [lindex $configSpecs($opt) 1] |
||||
set dbValue [option get $win $dbName $dbClass] |
||||
if {[string length $dbValue] == 0} { |
||||
set default [lindex $configSpecs($opt) 3] |
||||
eval $configCmd [list $win $opt $default] |
||||
} else { |
||||
if {[catch { |
||||
eval $configCmd [list $win $opt $dbValue] |
||||
} result] != 0} { |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "" |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::fullConfigOpt |
||||
# |
||||
# Returns the full configuration option corresponding to the possibly |
||||
# abbreviated option opt. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::fullConfigOpt {opt configSpecsName} { |
||||
upvar $configSpecsName configSpecs |
||||
|
||||
if {[info exists configSpecs($opt)]} { |
||||
if {[llength $configSpecs($opt)] == 1} { |
||||
return $configSpecs($opt) |
||||
} else { |
||||
return $opt |
||||
} |
||||
} |
||||
|
||||
set optList [lsort [array names configSpecs]] |
||||
set count 0 |
||||
foreach elem $optList { |
||||
if {[string first $opt $elem] == 0} { |
||||
incr count |
||||
if {$count == 1} { |
||||
set option $elem |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$count == 1} { |
||||
if {[llength $configSpecs($option)] == 1} { |
||||
return $configSpecs($option) |
||||
} else { |
||||
return $option |
||||
} |
||||
} elseif {$count == 0} { |
||||
### return -code error "unknown option \"$opt\"" |
||||
return -code error \ |
||||
"bad option \"$opt\": must be [enumOpts $optList]" |
||||
} else { |
||||
### return -code error "unknown option \"$opt\"" |
||||
return -code error \ |
||||
"ambiguous option \"$opt\": must be [enumOpts $optList]" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::fullOpt |
||||
# |
||||
# Returns the full option corresponding to the possibly abbreviated option opt. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::fullOpt {kind opt optList} { |
||||
if {[lsearch -exact $optList $opt] >= 0} { |
||||
return $opt |
||||
} |
||||
|
||||
set count 0 |
||||
foreach elem $optList { |
||||
if {[string first $opt $elem] == 0} { |
||||
incr count |
||||
if {$count == 1} { |
||||
set option $elem |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$count == 1} { |
||||
return $option |
||||
} elseif {$count == 0} { |
||||
return -code error \ |
||||
"bad $kind \"$opt\": must be [enumOpts $optList]" |
||||
} else { |
||||
return -code error \ |
||||
"ambiguous $kind \"$opt\": must be [enumOpts $optList]" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::enumOpts |
||||
# |
||||
# Returns a string consisting of the elements of the given list, separated by |
||||
# commas and spaces. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::enumOpts optList { |
||||
set optCount [llength $optList] |
||||
set n 1 |
||||
foreach opt $optList { |
||||
if {$n == 1} { |
||||
set str $opt |
||||
} elseif {$n < $optCount} { |
||||
append str ", $opt" |
||||
} else { |
||||
if {$optCount > 2} { |
||||
append str "," |
||||
} |
||||
append str " or $opt" |
||||
} |
||||
|
||||
incr n |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::configureSubCmd |
||||
# |
||||
# This procedure is invoked to process configuration subcommands. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::configureSubCmd {win configSpecsName configCmd cgetCmd argList} { |
||||
upvar $configSpecsName configSpecs |
||||
|
||||
set argCount [llength $argList] |
||||
if {$argCount > 1} { |
||||
# |
||||
# Set the specified configuration options to the given values |
||||
# |
||||
return [configureWidget $win configSpecs $configCmd $cgetCmd $argList 0] |
||||
} elseif {$argCount == 1} { |
||||
# |
||||
# Return the description of the specified configuration option |
||||
# |
||||
set opt [fullConfigOpt [lindex $argList 0] configSpecs] |
||||
set dbName [lindex $configSpecs($opt) 0] |
||||
set dbClass [lindex $configSpecs($opt) 1] |
||||
set default [lindex $configSpecs($opt) 3] |
||||
return [list $opt $dbName $dbClass $default \ |
||||
[eval $cgetCmd [list $win $opt]]] |
||||
} else { |
||||
# |
||||
# Return a list describing all available configuration options |
||||
# |
||||
foreach opt [lsort [array names configSpecs]] { |
||||
if {[llength $configSpecs($opt)] == 1} { |
||||
set alias $configSpecs($opt) |
||||
if {$::tk_version >= 8.1} { |
||||
lappend result [list $opt $alias] |
||||
} else { |
||||
set dbName [lindex $configSpecs($alias) 0] |
||||
lappend result [list $opt $dbName] |
||||
} |
||||
} else { |
||||
set dbName [lindex $configSpecs($opt) 0] |
||||
set dbClass [lindex $configSpecs($opt) 1] |
||||
set default [lindex $configSpecs($opt) 3] |
||||
lappend result [list $opt $dbName $dbClass $default \ |
||||
[eval $cgetCmd [list $win $opt]]] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::attribSubCmd |
||||
# |
||||
# This procedure is invoked to process *attrib subcommands. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::attribSubCmd {win prefix argList} { |
||||
set classNs [string tolower [winfo class $win]] |
||||
upvar ::${classNs}::ns${win}::attribs attribs |
||||
|
||||
set argCount [llength $argList] |
||||
if {$argCount > 1} { |
||||
# |
||||
# Set the specified attributes to the given values |
||||
# |
||||
if {$argCount % 2 != 0} { |
||||
return -code error "value for \"[lindex $argList end]\" missing" |
||||
} |
||||
foreach {attr val} $argList { |
||||
set attribs($prefix-$attr) $val |
||||
} |
||||
return "" |
||||
} elseif {$argCount == 1} { |
||||
# |
||||
# Return the value of the specified attribute |
||||
# |
||||
set attr [lindex $argList 0] |
||||
set name $prefix-$attr |
||||
if {[info exists attribs($name)]} { |
||||
return $attribs($name) |
||||
} else { |
||||
return "" |
||||
} |
||||
} else { |
||||
# |
||||
# Return the current list of attribute names and values |
||||
# |
||||
set len [string length "$prefix-"] |
||||
set result {} |
||||
foreach name [lsort [array names attribs "$prefix-*"]] { |
||||
set attr [string range $name $len end] |
||||
lappend result [list $attr $attribs($name)] |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::hasattribSubCmd |
||||
# |
||||
# This procedure is invoked to process has*attrib subcommands. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::hasattribSubCmd {win prefix attr} { |
||||
set classNs [string tolower [winfo class $win]] |
||||
upvar ::${classNs}::ns${win}::attribs attribs |
||||
|
||||
return [info exists attribs($prefix-$attr)] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::unsetattribSubCmd |
||||
# |
||||
# This procedure is invoked to process unset*attrib subcommands. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::unsetattribSubCmd {win prefix attr} { |
||||
set classNs [string tolower [winfo class $win]] |
||||
upvar ::${classNs}::ns${win}::attribs attribs |
||||
|
||||
set name $prefix-$attr |
||||
if {[info exists attribs($name)]} { |
||||
unset attribs($name) |
||||
} |
||||
|
||||
return "" |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::getScrollInfo |
||||
# |
||||
# Parses a list of arguments of the form "moveto <fraction>" or "scroll |
||||
# <number> units|pages" and returns the corresponding list consisting of two or |
||||
# three properly formatted elements. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::getScrollInfo argList { |
||||
set argCount [llength $argList] |
||||
set opt [lindex $argList 0] |
||||
|
||||
if {[string first $opt "moveto"] == 0} { |
||||
if {$argCount != 2} { |
||||
wrongNumArgs "moveto fraction" |
||||
} |
||||
|
||||
set fraction [lindex $argList 1] |
||||
format "%f" $fraction ;# floating-point number check with error message |
||||
return [list moveto $fraction] |
||||
} elseif {[string first $opt "scroll"] == 0} { |
||||
if {$argCount != 3} { |
||||
wrongNumArgs "scroll number units|pages" |
||||
} |
||||
|
||||
set number [lindex $argList 1] |
||||
format "%f" $number ;# floating-point number check with error message |
||||
set number [expr {int($number > 0 ? ceil($number) : floor($number))}] |
||||
set what [lindex $argList 2] |
||||
if {[string first $what "units"] == 0} { |
||||
return [list scroll $number units] |
||||
} elseif {[string first $what "pages"] == 0} { |
||||
return [list scroll $number pages] |
||||
} else { |
||||
return -code error "bad argument \"$what\": must be units or pages" |
||||
} |
||||
} else { |
||||
return -code error "unknown option \"$opt\": must be moveto or scroll" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::getScrollInfo2 |
||||
# |
||||
# Parses a list of arguments of the form "moveto <fraction>" or "scroll |
||||
# <number> units|pages" and returns the corresponding list consisting of two or |
||||
# three properly formatted elements. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::getScrollInfo2 {cmd argList} { |
||||
set argCount [llength $argList] |
||||
set opt [lindex $argList 0] |
||||
|
||||
if {[string first $opt "moveto"] == 0} { |
||||
if {$argCount != 2} { |
||||
wrongNumArgs "$cmd moveto fraction" |
||||
} |
||||
|
||||
set fraction [lindex $argList 1] |
||||
format "%f" $fraction ;# floating-point number check with error message |
||||
return [list moveto $fraction] |
||||
} elseif {[string first $opt "scroll"] == 0} { |
||||
if {$argCount != 3} { |
||||
wrongNumArgs "$cmd scroll number units|pages" |
||||
} |
||||
|
||||
set number [lindex $argList 1] |
||||
format "%f" $number ;# floating-point number check with error message |
||||
set number [expr {int($number > 0 ? ceil($number) : floor($number))}] |
||||
set what [lindex $argList 2] |
||||
if {[string first $what "units"] == 0} { |
||||
return [list scroll $number units] |
||||
} elseif {[string first $what "pages"] == 0} { |
||||
return [list scroll $number pages] |
||||
} else { |
||||
return -code error "bad argument \"$what\": must be units or pages" |
||||
} |
||||
} else { |
||||
return -code error "unknown option \"$opt\": must be moveto or scroll" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::isScrollable |
||||
# |
||||
# Returns a boolean value indicating whether the widget w is scrollable along a |
||||
# given axis (x or y). |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::isScrollable {w axis} { |
||||
set viewCmd ${axis}view |
||||
return [expr { |
||||
[catch {$w cget -${axis}scrollcommand}] == 0 && |
||||
[catch {$w $viewCmd} view] == 0 && |
||||
[catch {$w $viewCmd moveto [lindex $view 0]}] == 0 && |
||||
[catch {$w $viewCmd scroll 0 units}] == 0 && |
||||
[catch {$w $viewCmd scroll 0 pages}] == 0 |
||||
}] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::scrollByUnits |
||||
# |
||||
# Scrolls the widget w along a given axis (x or y) by units. The number of |
||||
# units is obtained by converting the fraction built from the last two |
||||
# arguments to an integer, rounded away from 0. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::scrollByUnits {w axis delta divisor} { |
||||
set number [expr {$delta/$divisor}] |
||||
set number [expr {int($number > 0 ? ceil($number) : floor($number))}] |
||||
$w ${axis}view scroll $number units |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::genMouseWheelEvent |
||||
# |
||||
# Generates a mouse wheel event with the given root coordinates and delta on |
||||
# the widget w. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::genMouseWheelEvent {w event rootX rootY delta} { |
||||
set needsFocus [expr {($::tk_version < 8.6 || |
||||
[package vcompare $::tk_patchLevel "8.6b2"] < 0) && |
||||
[string compare $::tcl_platform(platform) "windows"] == 0}] |
||||
|
||||
if {$needsFocus} { |
||||
set focusWin [focus -displayof $w] |
||||
focus $w |
||||
} |
||||
|
||||
event generate $w $event -rootx $rootX -rooty $rootY -delta $delta |
||||
|
||||
if {$needsFocus} { |
||||
focus $focusWin |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::containsPointer |
||||
# |
||||
# Returns a boolean value indicating whether the widget w contains the mouse |
||||
# pointer. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::containsPointer w { |
||||
if {![winfo viewable $w]} { |
||||
return 0 |
||||
} |
||||
|
||||
foreach {ptrX ptrY} [winfo pointerxy $w] {} |
||||
set wX [winfo rootx $w] |
||||
set wY [winfo rooty $w] |
||||
return [expr { |
||||
$ptrX >= $wX && $ptrX < $wX + [winfo width $w] && |
||||
$ptrY >= $wY && $ptrY < $wY + [winfo height $w] |
||||
}] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::hasFocus |
||||
# |
||||
# Returns a boolean value indicating whether the focus window is (a descendant |
||||
# of) the widget w and has the same toplevel. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::hasFocus w { |
||||
set focusWin [focus -displayof $w] |
||||
if {[string length $focusWin] == 0} { |
||||
return 0 |
||||
} |
||||
|
||||
return [expr { |
||||
([string compare $w "."] == 0 || [string first $w. $focusWin.] == 0) && |
||||
[string compare [winfo toplevel $w] [winfo toplevel $focusWin]] == 0 |
||||
}] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::windowingSystem |
||||
# |
||||
# Returns the windowing system ("x11", "win32", "classic", or "aqua"). |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::windowingSystem {} { |
||||
if {[catch {tk windowingsystem} winSys] != 0} { |
||||
switch $::tcl_platform(platform) { |
||||
unix { set winSys x11 } |
||||
windows { set winSys win32 } |
||||
macintosh { set winSys classic } |
||||
} |
||||
} |
||||
|
||||
return $winSys |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::currentTheme |
||||
# |
||||
# Returns the current tile theme. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::currentTheme {} { |
||||
if {[catch {ttk::style theme use} result] == 0} { |
||||
return $result |
||||
} elseif {[info exists ::ttk::currentTheme]} { |
||||
return $::ttk::currentTheme |
||||
} elseif {[info exists ::tile::currentTheme]} { |
||||
return $::tile::currentTheme |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::normalizeColor |
||||
# |
||||
# Returns the representation of a given color in the form "#RRGGBB". |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::normalizeColor color { |
||||
foreach {r g b} [winfo rgb . $color] {} |
||||
return [format "#%02x%02x%02x" \ |
||||
[expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]] |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# mwutil::parsePadding |
||||
# |
||||
# Returns the 4-elements list of pixels corresponding to a given padding |
||||
# specification. |
||||
#------------------------------------------------------------------------------ |
||||
proc mwutil::parsePadding {w padding} { |
||||
switch [llength $padding] { |
||||
0 { |
||||
set l 0; set t 0; set r 0; set b 0 |
||||
} |
||||
1 { |
||||
set l [winfo pixels $w $padding] |
||||
set t $l; set r $l; set b $l |
||||
} |
||||
2 { |
||||
foreach {l t} $padding {} |
||||
set l [winfo pixels $w $l] |
||||
set t [winfo pixels $w $t] |
||||
set r $l; set b $t |
||||
} |
||||
3 { |
||||
foreach {l t r} $padding {} |
||||
set l [winfo pixels $w $l] |
||||
set t [winfo pixels $w $t] |
||||
set r [winfo pixels $w $r] |
||||
set b $t |
||||
} |
||||
4 { |
||||
foreach {l t r b} $padding {} |
||||
set l [winfo pixels $w $l] |
||||
set t [winfo pixels $w $t] |
||||
set r [winfo pixels $w $r] |
||||
set b [winfo pixels $w $b] |
||||
} |
||||
default { |
||||
return -code error "wrong # elements in padding spec \"$padding\"" |
||||
} |
||||
} |
||||
|
||||
set result [list $l $t $r $b] |
||||
foreach pad $result { |
||||
if {$pad < 0} { |
||||
return -code error "bad pad value \"$pad\"" |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
@ -0,0 +1,7 @@
|
||||
#============================================================================== |
||||
# mwutil package index file. |
||||
# |
||||
# Copyright (c) 2020-2022 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) |
||||
#============================================================================== |
||||
|
||||
package ifneeded mwutil 2.20 [list source [file join $dir mwutil.tcl]] |
||||
@ -0,0 +1,111 @@
|
||||
# Tcl autoload index file, version 2.0 |
||||
# This file is generated by the "auto_mkindex" command |
||||
# and sourced to set up indexing information for one or |
||||
# more commands. Typically each line is a command that |
||||
# sets an element in the auto_index array, where the |
||||
# element name is the name of a command and the value is |
||||
# a script that loads the command. |
||||
|
||||
set auto_index(::mentry::dateMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::timeMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::dateTimeMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::putClockVal) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::getClockVal) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::checkIfDateOrTimeMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::getClockValFromDateMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::getClockValFromTimeMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::getClockValFromDateTimeMentry) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::incrDateTimeComp) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::setMeridian) [list source [file join $dir mentryDateTime.tcl]] |
||||
set auto_index(::mentry::fixedPointMentry) [list source [file join $dir mentryFixedPoint.tcl]] |
||||
set auto_index(::mentry::putReal) [list source [file join $dir mentryFixedPoint.tcl]] |
||||
set auto_index(::mentry::getReal) [list source [file join $dir mentryFixedPoint.tcl]] |
||||
set auto_index(::mentry::checkIfFixedPointMentry) [list source [file join $dir mentryFixedPoint.tcl]] |
||||
set auto_index(::mentry::ipAddrMentry) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::putIPAddr) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::getIPAddr) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::checkIfIPAddrMentry) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::incrIPAddrComp) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::pasteIPAddr) [list source [file join $dir mentryIPAddr.tcl]] |
||||
set auto_index(::mentry::ipv6AddrMentry) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::putIPv6Addr) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::getIPv6Addr) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::checkIfIPv6AddrMentry) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::incrIPv6AddrComp) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::pasteIPv6Addr) [list source [file join $dir mentryIPv6Addr.tcl]] |
||||
set auto_index(::mentry::setThemeDefaults) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::awTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::altTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::aquaTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::AquativoTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::aquativoTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::ArcTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::blueTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::clamTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::classicTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::clearlooksTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::defaultTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::keramikTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::keramik_altTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::krocTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::plastikTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::srivTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::srivlgTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::stepTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::tileqtTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::vistaTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::winnativeTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::winxpblueTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::xpnativeTheme) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::getKdeConfigVal) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::makeKdeDirList) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::readKdeConfigVal) [list source [file join $dir mentryThemes.tcl]] |
||||
set auto_index(::mentry::createTileAliases) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::extendConfigSpecs) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::createBindings) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::mentry) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::doConfig) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::doCget) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::createChildren) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::mentryWidgetCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::adjustentrySubCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::putSubCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::setentryextrawidthSubCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::setentryfontSubCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::setentrywidthSubCmd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::childIndex) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::condTabToNext) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::condGoToNeighbor) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::updateLabelForegrounds) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::updateFonts) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::handleThemeChangedEvent) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::updateConfigSpecs) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::handleAppearanceEvent) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::updateAppearance) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::tabToPrev) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::tabToNext) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::goToHome) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::goToEnd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::selectToHome) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::selectToEnd) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::backSpace) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::delToLeft) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::procLabelChars) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::labelButton1) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::parseChildPath) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::framePath) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::entryPath) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::labelPath) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::entries) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::labels) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::prevNormal) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::nextNormal) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::firstNormal) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::lastNormal) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::adjustChildren) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::tabToEntry) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::entrySetCursor) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::entryViewCursor) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::configEntry) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::reqEntryWidth) [list source [file join $dir mentryWidget.tcl]] |
||||
set auto_index(::mentry::geomParams) [list source [file join $dir mentryWidget.tcl]] |
||||
@ -0,0 +1,226 @@
|
||||
# debug.tcl -- |
||||
# |
||||
# Package that add debugging procedures to the global namespace |
||||
# and to the menubar::Tree class. |
||||
# |
||||
# Copyright (c) 2009 Tom Krehbiel <tomk@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: debug.tcl,v 1.5 2010/01/06 20:55:54 tomk Exp $ |
||||
|
||||
package require TclOO |
||||
package require menubar |
||||
|
||||
package provide menubar::debug 0.5 |
||||
|
||||
# The ::oo namespace contains Tcloo commands that must be preceeded by 'my'. |
||||
# as the default namespace for callback commands |
||||
|
||||
# -- |
||||
# |
||||
# Generic debugging method for TclOO object instance. |
||||
# |
||||
oo::define ::oo::object method debug {{pat *}} { |
||||
set res [list class [info object class [self]]] |
||||
foreach i [info object vars [self] $pat] { |
||||
variable $i |
||||
lappend res $i [set $i] |
||||
} |
||||
set res |
||||
} |
||||
|
||||
# -- pdict |
||||
# |
||||
# A pretty printer for dict object, similar to parray. |
||||
# |
||||
# Usage: |
||||
# |
||||
# pdict <dict> [d [i [p [s]]]] |
||||
# |
||||
# Where: |
||||
# d - dict to be printed |
||||
# i - indent level |
||||
# p - prefix string for one level of indent |
||||
# s - seperator string between key and value |
||||
# |
||||
# Examples: |
||||
# % set d [dict create a {1 i 2 j 3 k} b {x y z} c {i m j {q w e r} k o}] |
||||
# % a {1 i 2 j 3 k} b {x y z} c {i m j {q w e r} k o} |
||||
# % pdict $d |
||||
# a -> |
||||
# 1 -> 'i' |
||||
# 2 -> 'j' |
||||
# 3 -> 'k' |
||||
# b -> 'x y z' |
||||
# c -> |
||||
# i -> 'm' |
||||
# j -> |
||||
# q -> 'w' |
||||
# e -> 'r' |
||||
# k -> 'o' |
||||
# |
||||
proc ::pdict { d {i 0} {p " "} {s " -> "} } { |
||||
if { [catch {dict keys ${d}}] } { |
||||
error "error: pdict - argument is not a dict" |
||||
} |
||||
set result "" |
||||
set prefix [string repeat ${p} ${i}] |
||||
set max 0 |
||||
foreach key [dict keys ${d}] { |
||||
if { [string length ${key}] > ${max} } { |
||||
set max [string length ${key}] |
||||
} |
||||
} |
||||
dict for {key val} ${d} { |
||||
append result "${prefix}[format "%-${max}s" ${key}]${s}" |
||||
if { [catch {dict keys ${val}}] } { |
||||
append result "'${val}'\n" |
||||
} else { |
||||
append result "\n" |
||||
append result "[pdict ${val} [expr ${i}+1] ${p} ${s}]\n" |
||||
} |
||||
} |
||||
return ${result} |
||||
} |
||||
|
||||
# ------------------------------------------------------------ |
||||
# |
||||
# Add debugging methods to ::menubar::tree class |
||||
# |
||||
# ------------------------------------------------------------ |
||||
|
||||
# -- ptree |
||||
# debugging utility |
||||
oo::define ::menubar::tree method ptree { {name ""} } { |
||||
variable root |
||||
if { ${name} eq "" } { |
||||
my DumpSubtree ${root} |
||||
} else { |
||||
if { [my exists ${name}] ne "" } { |
||||
error "node (${name}) - not found" |
||||
} |
||||
my DumpSubtree ${name} |
||||
} |
||||
} |
||||
|
||||
# -- pnodes |
||||
# debugging utility |
||||
oo::define ::menubar::tree method pnodes { } { |
||||
variable nodes |
||||
foreach name [lsort -dictionary [dict keys ${nodes}]] { |
||||
set node [dict get ${nodes} ${name}] |
||||
set pnode [${node} parent] |
||||
set children [my children ${name}] |
||||
puts [format "(%-12s) %-12s %s -> %s" ${pnode} ${node} ${name} [join ${children} {, }]] |
||||
} |
||||
} |
||||
|
||||
# -- pkeys |
||||
# debugging utility |
||||
oo::define ::menubar::tree method pkeys { args } { |
||||
if { [llength ${args}] == 0 } { |
||||
set args [my nodes] |
||||
} else { |
||||
set notfound [my exists {*}${args}] |
||||
if { ${notfound} ne "" } { |
||||
error "node (${notfound}) - not found" |
||||
} |
||||
} |
||||
foreach name ${args} { |
||||
set node [my Name2Node ${name}] |
||||
puts "node(${name})" |
||||
set width 0 |
||||
foreach key [${node} attr.keys] { |
||||
set len [string length ${key}] |
||||
if { ${len} > ${width} } { set width ${len} } |
||||
} |
||||
foreach {key val} [${node} attrs.filter] { |
||||
puts " [format "%-${width}s" ${key}]: '${val}'" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# -- pstream |
||||
# debugging utility |
||||
oo::define ::menubar::tree method pstream { stream } { |
||||
lassign ${stream} name attrs children |
||||
my Pstream ${name} ${attrs} ${children} 0 |
||||
} |
||||
|
||||
# ------------------------------------------------------------ |
||||
# |
||||
# Add debugging methods to ::menubar class |
||||
# |
||||
# ------------------------------------------------------------ |
||||
oo::define ::menubar method debug { {type tree} } { |
||||
variable mtree |
||||
variable installs |
||||
variable notebookVals |
||||
|
||||
set result "" |
||||
if { ${type} eq "tree" } { |
||||
lappend result "##### tag tree #####" |
||||
lappend result "menubar" |
||||
lappend result {*}[my children menubar] |
||||
|
||||
} elseif { ${type} eq "nodes" } { |
||||
lappend result "##### tag defs #####" |
||||
foreach node [lsort -dictionary [${mtree} nodes]] { |
||||
lappend result ${node} |
||||
foreach {attr val} [${mtree} key.getall ${node} +*] { |
||||
lappend result " ${attr}: ${val}" |
||||
} |
||||
foreach {opt val} [${mtree} key.getall ${node} -*] { |
||||
lappend result " ${opt}: ${val}" |
||||
} |
||||
} |
||||
} elseif { ${type} eq "installs" } { |
||||
lappend result "##### installs #####" |
||||
lappend result [pdict ${installs}] |
||||
} elseif { ${type} eq "notebook" } { |
||||
lappend result "##### notebookVals #####" |
||||
lappend result [pdict ${notebookVals}] |
||||
} |
||||
return ${result} |
||||
} |
||||
oo::define ::menubar method children { node {indent 1} } { |
||||
variable mtree |
||||
set result "" |
||||
foreach _node [${mtree} children ${node}] { |
||||
lappend result [string repeat " " ${indent}]${_node} |
||||
set more [my children ${_node} [expr ${indent}+1]] |
||||
if { [string trim ${more}] ne "" } { |
||||
lappend result {*}${more} |
||||
} |
||||
} |
||||
return ${result} |
||||
} |
||||
oo::define ::menubar method debug_node { node } { |
||||
variable mtree |
||||
lappend result "==== node: ${node}" |
||||
foreach {attr val} [${mtree} key.getall ${node} +*] { |
||||
lappend result " ${attr}: ${val}" |
||||
} |
||||
foreach {opt val} [${mtree} key.getall ${node} -*] { |
||||
lappend result " ${opt}: ${val}" |
||||
} |
||||
return ${result} |
||||
} |
||||
|
||||
oo::define ::menubar method print { type } { |
||||
variable mtree |
||||
switch -exact ${type} { |
||||
"tree" { |
||||
${mtree} ptree |
||||
} |
||||
"nodes" { |
||||
${mtree} pnodes |
||||
} |
||||
"keys" { |
||||
${mtree} pkeys |
||||
} |
||||
default { |
||||
}} |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,161 @@
|
||||
# node.tcl -- |
||||
# |
||||
# Package that defines the menubar::Node class. This class is a |
||||
# privite class used by the menubar::Tree class. |
||||
# |
||||
# Copyright (c) 2009 Tom Krehbiel <tomk@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: node.tcl,v 1.4 2010/01/06 20:55:54 tomk Exp $ |
||||
|
||||
package require TclOO |
||||
|
||||
package provide menubar::node 0.5 |
||||
|
||||
# -------------------------------------------------- |
||||
# |
||||
# manubar::Node class - used by menubar::Tree class |
||||
# |
||||
# -------------------------------------------------- |
||||
|
||||
# -- |
||||
# parent - contains the parent node instance |
||||
# children - contains list of child node instances |
||||
# attrs - a dictionary of attribute/value pairs |
||||
oo::class create ::menubar::node { |
||||
|
||||
# -- |
||||
# create a named node |
||||
constructor { pnode } { |
||||
variable parent |
||||
variable children |
||||
variable attrs |
||||
|
||||
set parent ${pnode} |
||||
set children {} |
||||
set attrs [dict create] |
||||
} |
||||
|
||||
# -- |
||||
# If 'pnode' isn't blank, set the node's parent to its |
||||
# value; return the current parent. |
||||
method parent { {pnode ""} } { |
||||
variable parent |
||||
if { ${pnode} ne "" } { |
||||
set parent ${pnode} |
||||
} |
||||
return ${parent} |
||||
} |
||||
|
||||
# -- |
||||
# If 'clist' is empty then return the current childern list else |
||||
# set the node's children to 'clist' and return the current childern list. |
||||
# If the option '-force' is found then set the node's children even |
||||
# if 'clist' is blank. |
||||
method children { {clist ""} args } { |
||||
variable children |
||||
if { [llength ${clist}] != 0 || "-force" in ${args} } { |
||||
set children ${clist} |
||||
} |
||||
return ${children} |
||||
} |
||||
|
||||
# -- |
||||
# Insert a list of node instances ('args') into the |
||||
# child list at location 'index'. |
||||
method insert { index args } { |
||||
variable children |
||||
set children [linsert ${children} ${index} {*}${args}] |
||||
return |
||||
} |
||||
|
||||
# -- |
||||
# If 'kdict' isn't blank set the node attributes to its |
||||
# value; return the current value of attributes. |
||||
method attrs { {kdict ""} {force ""} } { |
||||
variable attrs |
||||
if { ${kdict} ne "" || ${force} eq "-force" } { |
||||
set attrs ${kdict} |
||||
} |
||||
return ${attrs} |
||||
} |
||||
|
||||
# -- |
||||
# Return the node's attributes as a dict of key/value pairs. If |
||||
# globpat exists, only keys that match the glob pattern will be |
||||
# returned. |
||||
method attrs.filter { {globpat ""} } { |
||||
variable attrs |
||||
if { ${globpat} eq "" } { |
||||
return ${attrs} |
||||
} else { |
||||
return [dict filter ${attrs} key ${globpat}] |
||||
} |
||||
} |
||||
|
||||
# -- |
||||
# Return the node's attribute keys as a list. If globpat exists, |
||||
# only return keys that match the glob pattern. |
||||
method attr.keys { {globpat ""} } { |
||||
variable attrs |
||||
if { ${globpat} eq "" } { |
||||
return [dict keys ${attrs}] |
||||
} else { |
||||
return [dict keys ${attrs} ${globpat}] |
||||
} |
||||
} |
||||
|
||||
# -- |
||||
# Set the value of the attribute 'key' to 'value'. If 'key |
||||
# doesn't exist add it to the node. |
||||
method attr.set { key value } { |
||||
variable attrs |
||||
dict set attrs ${key} ${value} |
||||
return ${value} |
||||
} |
||||
|
||||
# -- |
||||
# |
||||
method attr.unset { key } { |
||||
variable attrs |
||||
dict unset attrs ${key} |
||||
return |
||||
} |
||||
|
||||
# -- |
||||
# Return true of attribute 'key' exists for node else return false. |
||||
method attr.exists { key } { |
||||
variable attrs |
||||
return [dict exist ${attrs} ${key}] |
||||
} |
||||
|
||||
# -- |
||||
# Return the value of the attribute 'key' for node. |
||||
method attr.get { key } { |
||||
variable attrs |
||||
if { [dict exist ${attrs} ${key}] } { |
||||
return [dict get ${attrs} ${key}] |
||||
} |
||||
error "attribute '${key}' - not found" |
||||
} |
||||
|
||||
# -- |
||||
# Do a string append of 'value' to the value of attribute 'key' for |
||||
# node. Return the resulting string value. |
||||
method attr.append { key value } { |
||||
variable attrs |
||||
dict append attrs ${key} ${value} |
||||
return |
||||
} |
||||
|
||||
# -- |
||||
# Do a list append of 'value' to the value of attribute 'key' for |
||||
# node. Return the resulting list value. |
||||
method attr.lappend { key value } { |
||||
variable attrs |
||||
dict lappend attrs ${key} ${value} |
||||
return |
||||
} |
||||
} |
||||
@ -0,0 +1,4 @@
|
||||
package ifneeded menubar::node 0.5 [list source [file join $dir node.tcl]] |
||||
package ifneeded menubar::tree 0.5 [list source [file join $dir tree.tcl]] |
||||
package ifneeded menubar 0.5 [list source [file join $dir menubar.tcl]] |
||||
package ifneeded menubar::debug 0.5 [list source [file join $dir debug.tcl]] |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,105 @@
|
||||
#notifywindow.tcl: provides routines for posting a Growl-style "notification window" in the upper right corner of the screen, fading in and out in an unobtrusive fashion |
||||
|
||||
#(c) 2015-2019 Kevin Walzer/WordTech Communications LLC. License: standard Tcl license, http://www.tcl.tk/software/tcltk/license.html |
||||
|
||||
package provide notifywindow 1.0 |
||||
|
||||
namespace eval notifywindow { |
||||
|
||||
#Main procedure for window |
||||
|
||||
proc notifywindow {msg img} { |
||||
set w [toplevel ._notify] |
||||
if {[tk windowingsystem] eq "aqua"} { |
||||
::tk::unsupported::MacWindowStyle style $w utility {hud |
||||
closeBox resizable} |
||||
wm title $w "Alert" |
||||
} |
||||
if {[tk windowingsystem] eq "win32"} { |
||||
wm attributes $w -toolwindow true |
||||
wm title $w "Alert" |
||||
} |
||||
if {[lsearch [image names] $img] > -1} { |
||||
label $w.l -bg gray30 -fg white -image $img |
||||
pack $w.l -fill both -expand yes -side left |
||||
} |
||||
message $w.message -aspect 150 -bg gray30 -fg white -aspect 150 -text $msg -width 280 |
||||
pack $w.message -side right -fill both -expand yes |
||||
if {[tk windowingsystem] eq "x11"} { |
||||
wm overrideredirect $w true |
||||
} |
||||
wm attributes $w -alpha 0.0 |
||||
puts [winfo reqwidth $w] |
||||
set xpos [expr [winfo screenwidth $w] - 325] |
||||
wm geometry $w +$xpos+30 |
||||
notifywindow::fade_in $w |
||||
after 3000 notifywindow::fade_out $w |
||||
} |
||||
|
||||
#Fade and destroy window |
||||
proc fade_out {w} { |
||||
catch { |
||||
set prev_degree [wm attributes $w -alpha] |
||||
set new_degree [expr $prev_degree - 0.05] |
||||
set current_degree [wm attributes $w -alpha $new_degree] |
||||
if {$new_degree > 0.0 && $new_degree != $prev_degree} { |
||||
after 10 [list notifywindow::fade_out $w] |
||||
} else { |
||||
destroy $w |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
#Fade the window into view |
||||
proc fade_in {w} { |
||||
catch { |
||||
raise $w |
||||
wm attributes $w -topmost 1 |
||||
set prev_degree [wm attributes $w -alpha] |
||||
set new_degree [expr $prev_degree + 0.05] |
||||
set current_degree [wm attributes $w -alpha $new_degree] |
||||
focus -force $w |
||||
if {$new_degree < 0.9 && $new_degree != $prev_degree} { |
||||
after 10 [list notifywindow::fade_in $w] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
#The obligatory demo |
||||
proc demo {} { |
||||
|
||||
image create photo flag -data { |
||||
R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ |
||||
a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx |
||||
AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r |
||||
j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA |
||||
YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr |
||||
/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA |
||||
liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP |
||||
/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi |
||||
lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ |
||||
xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW |
||||
MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// |
||||
a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW |
||||
AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O |
||||
zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg |
||||
pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiZAAMIHEhQoLqD |
||||
CAsqFAigIQB3Dd0tNKjOXSxXrmABWBABgLqCByECuAir5EYJHimKvOgqFqxXrzZ2lBhgJUaY |
||||
LV/GOpkSIqybOF3ClPlQIEShMF/lfLVzAcqPRhsKXRqTY1GCFaUy1ckTKkiRGhtapTkxa82u |
||||
ExUSJZs2qtOUbQ2ujTsQ4luvbdXNpRtA712+UeEC7ou3YEAAADt= |
||||
} |
||||
|
||||
notifywindow::notifywindow "Man page for Message\n\nSpecifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. Used to choose line length for text if -width option is not specified. Defaults to 150." flag |
||||
|
||||
} |
||||
|
||||
namespace export * |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue