Attachment "hyperhelp-0.8.1.app" to
wiki page [releases]
added by
dgroth
2020-02-28 06:31:22.
#!/usr/bin/env tclsh
#
# -- tcl module generated by mk_tmModule
#
if {[file exists "/tmp"]} {set tmpdir "/tmp"}
catch {set tmpdir $::env(TMP)}
catch {set tmpdir $::env(TEMP)}
set fd [open [info script] r]
fconfigure $fd -translation binary
set data [read $fd]
close $fd
set startIndex [string first \u001A $data]
incr startIndex
#-- From snit2.tmp
#-----------------------------------------------------------------------
# TITLE:
# snit2.tcl
#
# AUTHOR:
# Will Duquette
#
# DESCRIPTION:
# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
#
# Snit 2.x Loader
#
# Copyright (C) 2003-2006 by William H. Duquette
# This code is licensed as described in license.txt.
#
#-----------------------------------------------------------------------
package require Tcl 8.5
# Define the snit namespace and save the library directory
namespace eval ::snit:: {
set library [file dirname [info script]]
}
# Load the kernel.
# Load the library of Snit validation types.
package provide snit 2.3.2
#-- From main2.tcl
#-----------------------------------------------------------------------
# TITLE:
# main2.tcl
#
# AUTHOR:
# Will Duquette
#
# DESCRIPTION:
# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
#
# Snit 2.x Compiler and Run-Time Library
#
# Copyright (C) 2003-2006 by William H. Duquette
# This code is licensed as described in license.txt.
#
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Namespace
namespace eval ::snit:: {
namespace export \
compile type widget widgetadaptor typemethod method macro
}
#-----------------------------------------------------------------------
# Some Snit variables
namespace eval ::snit:: {
variable reservedArgs {type selfns win self}
# Widget classes which can be hulls (must have -class)
variable hulltypes {
toplevel tk::toplevel
frame tk::frame ttk::frame
labelframe tk::labelframe ttk::labelframe
}
}
#-----------------------------------------------------------------------
# Snit Type Implementation template
namespace eval ::snit:: {
# Template type definition: All internal and user-visible Snit
# implementation code.
#
# The following placeholders will automatically be replaced with
# the client's code, in two passes:
#
# First pass:
# %COMPILEDDEFS% The compiled type definition.
#
# Second pass:
# %TYPE% The fully qualified type name.
# %IVARDECS% Instance variable declarations
# %TVARDECS% Type variable declarations
# %TCONSTBODY% Type constructor body
# %INSTANCEVARS% The compiled instance variable initialization code.
# %TYPEVARS% The compiled type variable initialization code.
# This is the overall type template.
variable typeTemplate
# This is the normal type proc
variable nominalTypeProc
# This is the "-hastypemethods no" type proc
variable simpleTypeProc
}
set ::snit::typeTemplate {
#-------------------------------------------------------------------
# The type's namespace definition and the user's type variables
namespace eval %TYPE% {%TYPEVARS%
}
#----------------------------------------------------------------
# Commands for use in methods, typemethods, etc.
#
# These are implemented as aliases into the Snit runtime library.
interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
interp alias {} %TYPE%::typevariable {} ::variable
interp alias {} %TYPE%::variable {} ::snit::RT.variable
interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
interp alias {} %TYPE%::varname {} ::snit::RT.myvar
interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
#-------------------------------------------------------------------
# Snit's internal variables
namespace eval %TYPE% {
# Array: General Snit Info
#
# ns: The type's namespace
# hasinstances: T or F, from pragma -hasinstances.
# simpledispatch: T or F, from pragma -hasinstances.
# canreplace: T or F, from pragma -canreplace.
# counter: Count of instances created so far.
# widgetclass: Set by widgetclass statement.
# hulltype: Hull type (frame or toplevel) for widgets only.
# exceptmethods: Methods explicitly not delegated to *
# excepttypemethods: Methods explicitly not delegated to *
# tvardecs: Type variable declarations--for dynamic methods
# ivardecs: Instance variable declarations--for dyn. methods
typevariable Snit_info
set Snit_info(ns) %TYPE%::
set Snit_info(hasinstances) 1
set Snit_info(simpledispatch) 0
set Snit_info(canreplace) 0
set Snit_info(counter) 0
set Snit_info(widgetclass) {}
set Snit_info(hulltype) frame
set Snit_info(exceptmethods) {}
set Snit_info(excepttypemethods) {}
set Snit_info(tvardecs) {%TVARDECS%}
set Snit_info(ivardecs) {%IVARDECS%}
# Array: Public methods of this type.
# The index is the method name, or "*".
# The value is [list $pattern $componentName], where
# $componentName is "" for normal methods.
typevariable Snit_typemethodInfo
array unset Snit_typemethodInfo
# Array: Public methods of instances of this type.
# The index is the method name, or "*".
# The value is [list $pattern $componentName], where
# $componentName is "" for normal methods.
typevariable Snit_methodInfo
array unset Snit_methodInfo
# Array: option information. See dictionary.txt.
typevariable Snit_optionInfo
array unset Snit_optionInfo
set Snit_optionInfo(local) {}
set Snit_optionInfo(delegated) {}
set Snit_optionInfo(starcomp) {}
set Snit_optionInfo(except) {}
}
#----------------------------------------------------------------
# Compiled Procs
#
# These commands are created or replaced during compilation:
# Snit_instanceVars selfns
#
# Initializes the instance variables, if any. Called during
# instance creation.
proc %TYPE%::Snit_instanceVars {selfns} {
%INSTANCEVARS%
}
# Type Constructor
proc %TYPE%::Snit_typeconstructor {type} {
%TVARDECS%
namespace path [namespace parent $type]
%TCONSTBODY%
}
#----------------------------------------------------------------
# Default Procs
#
# These commands might be replaced during compilation:
# Snit_destructor type selfns win self
#
# Default destructor for the type. By default, it does
# nothing. It's replaced by any user destructor.
# For types, it's called by method destroy; for widgettypes,
# it's called by a destroy event handler.
proc %TYPE%::Snit_destructor {type selfns win self} { }
#----------------------------------------------------------
# Compiled Definitions
%COMPILEDDEFS%
#----------------------------------------------------------
# Finally, call the Type Constructor
%TYPE%::Snit_typeconstructor %TYPE%
}
#-----------------------------------------------------------------------
# Type procs
#
# These procs expect the fully-qualified type name to be
# substituted in for %TYPE%.
# This is the nominal type proc. It supports typemethods and
# delegated typemethods.
set ::snit::nominalTypeProc {
# WHD: Code for creating the type ensemble
namespace eval %TYPE% {
namespace ensemble create \
-unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \
-prefixes 0
}
}
# This is the simplified type proc for when there are no typemethods
# except create. In this case, it doesn't take a method argument;
# the method is always "create".
set ::snit::simpleTypeProc {
# Type dispatcher function. Note: This function lives
# in the parent of the %TYPE% namespace! All accesses to
# %TYPE% variables and methods must be qualified!
proc %TYPE% {args} {
::variable %TYPE%::Snit_info
# FIRST, if the are no args, the single arg is %AUTO%
if {[llength $args] == 0} {
if {$Snit_info(isWidget)} {
error "wrong \# args: should be \"%TYPE% name args\""
}
lappend args %AUTO%
}
# NEXT, we're going to call the create method.
# Pass along the return code unchanged.
if {$Snit_info(isWidget)} {
set command [list ::snit::RT.widget.typemethod.create %TYPE%]
} else {
set command [list ::snit::RT.type.typemethod.create %TYPE%]
}
set retval [catch {uplevel 1 $command $args} result]
if {$retval} {
if {$retval == 1} {
global errorInfo
global errorCode
return -code error -errorinfo $errorInfo \
-errorcode $errorCode $result
} else {
return -code $retval $result
}
}
return $result
}
}
#=======================================================================
# Snit Type Definition
#
# These are the procs used to define Snit types, widgets, and
# widgetadaptors.
#-----------------------------------------------------------------------
# Snit Compilation Variables
#
# The following variables are used while Snit is compiling a type,
# and are disposed afterwards.
namespace eval ::snit:: {
# The compiler variable contains the name of the slave interpreter
# used to compile type definitions.
variable compiler ""
# The compile array accumulates information about the type or
# widgettype being compiled. It is cleared before and after each
# compilation. It has these indices:
#
# type: The name of the type being compiled, for use
# in compilation procs.
# defs: Compiled definitions, both standard and client.
# which: type, widget, widgetadaptor
# instancevars: Instance variable definitions and initializations.
# ivprocdec: Instance variable proc declarations.
# tvprocdec: Type variable proc declarations.
# typeconstructor: Type constructor body.
# widgetclass: The widgetclass, for snit::widgets, only
# hasoptions: False, initially; set to true when first
# option is defined.
# localoptions: Names of local options.
# delegatedoptions: Names of delegated options.
# localmethods: Names of locally defined methods.
# delegatesmethods: no if no delegated methods, yes otherwise.
# hashierarchic : no if no hierarchic methods, yes otherwise.
# components: Names of defined components.
# typecomponents: Names of defined typecomponents.
# typevars: Typevariable definitions and initializations.
# varnames: Names of instance variables
# typevarnames Names of type variables
# hasconstructor False, initially; true when constructor is
# defined.
# resource-$opt The option's resource name
# class-$opt The option's class
# -default-$opt The option's default value
# -validatemethod-$opt The option's validate method
# -configuremethod-$opt The option's configure method
# -cgetmethod-$opt The option's cget method.
# -hastypeinfo The -hastypeinfo pragma
# -hastypedestroy The -hastypedestroy pragma
# -hastypemethods The -hastypemethods pragma
# -hasinfo The -hasinfo pragma
# -hasinstances The -hasinstances pragma
# -simpledispatch The -simpledispatch pragma WHD: OBSOLETE
# -canreplace The -canreplace pragma
variable compile
# This variable accumulates method dispatch information; it has
# the same structure as the %TYPE%::Snit_methodInfo array, and is
# used to initialize it.
variable methodInfo
# This variable accumulates typemethod dispatch information; it has
# the same structure as the %TYPE%::Snit_typemethodInfo array, and is
# used to initialize it.
variable typemethodInfo
# The following variable lists the reserved type definition statement
# names, e.g., the names you can't use as macros. It's built at
# compiler definition time using "info commands".
variable reservedwords {}
}
#-----------------------------------------------------------------------
# type compilation commands
#
# The type and widgettype commands use a slave interpreter to compile
# the type definition. These are the procs
# that are aliased into it.
# Initialize the compiler
proc ::snit::Comp.Init {} {
variable compiler
variable reservedwords
if {$compiler eq ""} {
# Create the compiler's interpreter
set compiler [interp create]
# Initialize the interpreter
$compiler eval {
catch {close stdout}
catch {close stderr}
catch {close stdin}
# Load package information
# TBD: see if this can be moved outside.
# @mdgen NODEP: ::snit::__does_not_exist__
catch {package require ::snit::__does_not_exist__}
# Protect some Tcl commands our type definitions
# will shadow.
rename proc _proc
rename variable _variable
}
# Define compilation aliases.
$compiler alias pragma ::snit::Comp.statement.pragma
$compiler alias widgetclass ::snit::Comp.statement.widgetclass
$compiler alias hulltype ::snit::Comp.statement.hulltype
$compiler alias constructor ::snit::Comp.statement.constructor
$compiler alias destructor ::snit::Comp.statement.destructor
$compiler alias option ::snit::Comp.statement.option
$compiler alias oncget ::snit::Comp.statement.oncget
$compiler alias onconfigure ::snit::Comp.statement.onconfigure
$compiler alias method ::snit::Comp.statement.method
$compiler alias typemethod ::snit::Comp.statement.typemethod
$compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
$compiler alias proc ::snit::Comp.statement.proc
$compiler alias typevariable ::snit::Comp.statement.typevariable
$compiler alias variable ::snit::Comp.statement.variable
$compiler alias typecomponent ::snit::Comp.statement.typecomponent
$compiler alias component ::snit::Comp.statement.component
$compiler alias delegate ::snit::Comp.statement.delegate
$compiler alias expose ::snit::Comp.statement.expose
# Get the list of reserved words
set reservedwords [$compiler eval {info commands}]
}
}
# Compile a type definition, and return the results as a list of two
# items: the fully-qualified type name, and a script that will define
# the type when executed.
#
# which type, widget, or widgetadaptor
# type the type name
# body the type definition
proc ::snit::Comp.Compile {which type body} {
variable typeTemplate
variable nominalTypeProc
variable simpleTypeProc
variable compile
variable compiler
variable methodInfo
variable typemethodInfo
# FIRST, qualify the name.
if {![string match "::*" $type]} {
# Get caller's namespace;
# append :: if not global namespace.
set ns [uplevel 2 [list namespace current]]
if {"::" != $ns} {
append ns "::"
}
set type "$ns$type"
}
# NEXT, create and initialize the compiler, if needed.
Comp.Init
# NEXT, initialize the class data
array unset methodInfo
array unset typemethodInfo
array unset compile
set compile(type) $type
set compile(defs) {}
set compile(which) $which
set compile(hasoptions) no
set compile(localoptions) {}
set compile(instancevars) {}
set compile(typevars) {}
set compile(delegatedoptions) {}
set compile(ivprocdec) {}
set compile(tvprocdec) {}
set compile(typeconstructor) {}
set compile(widgetclass) {}
set compile(hulltype) {}
set compile(localmethods) {}
set compile(delegatesmethods) no
set compile(hashierarchic) no
set compile(components) {}
set compile(typecomponents) {}
set compile(varnames) {}
set compile(typevarnames) {}
set compile(hasconstructor) no
set compile(-hastypedestroy) yes
set compile(-hastypeinfo) yes
set compile(-hastypemethods) yes
set compile(-hasinfo) yes
set compile(-hasinstances) yes
set compile(-canreplace) no
set isWidget [string match widget* $which]
set isWidgetAdaptor [string match widgetadaptor $which]
# NEXT, Evaluate the type's definition in the class interpreter.
$compiler eval $body
# NEXT, Add the standard definitions
append compile(defs) \
"\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
append compile(defs) \
"\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
# Indicate whether the type can create instances that replace
# existing commands.
append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
# Check pragmas for conflict.
if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
error "$which $type has neither typemethods nor instances"
}
# If there are typemethods, define the standard typemethods and
# the nominal type proc. Otherwise define the simple type proc.
if {$compile(-hastypemethods)} {
# Add the info typemethod unless the pragma forbids it.
if {$compile(-hastypeinfo)} {
Comp.statement.delegate typemethod info \
using {::snit::RT.typemethod.info %t}
}
# Add the destroy typemethod unless the pragma forbids it.
if {$compile(-hastypedestroy)} {
Comp.statement.delegate typemethod destroy \
using {::snit::RT.typemethod.destroy %t}
}
# Add the nominal type proc.
append compile(defs) $nominalTypeProc
} else {
# Add the simple type proc.
append compile(defs) $simpleTypeProc
}
# Add standard methods/typemethods that only make sense if the
# type has instances.
if {$compile(-hasinstances)} {
# Add the info method unless the pragma forbids it.
if {$compile(-hasinfo)} {
Comp.statement.delegate method info \
using {::snit::RT.method.info %t %n %w %s}
}
# Add the option handling stuff if there are any options.
if {$compile(hasoptions)} {
Comp.statement.variable options
Comp.statement.delegate method cget \
using {::snit::RT.method.cget %t %n %w %s}
Comp.statement.delegate method configurelist \
using {::snit::RT.method.configurelist %t %n %w %s}
Comp.statement.delegate method configure \
using {::snit::RT.method.configure %t %n %w %s}
}
# Add a default constructor, if they haven't already defined one.
# If there are options, it will configure args; otherwise it
# will do nothing.
if {!$compile(hasconstructor)} {
if {$compile(hasoptions)} {
Comp.statement.constructor {args} {
$self configurelist $args
}
} else {
Comp.statement.constructor {} {}
}
}
if {!$isWidget} {
Comp.statement.delegate method destroy \
using {::snit::RT.method.destroy %t %n %w %s}
Comp.statement.delegate typemethod create \
using {::snit::RT.type.typemethod.create %t}
} else {
Comp.statement.delegate typemethod create \
using {::snit::RT.widget.typemethod.create %t}
}
# Save the method info.
append compile(defs) \
"\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
} else {
append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
}
# NEXT, compiling the type definition built up a set of information
# about the type's locally defined options; add this information to
# the compiled definition.
Comp.SaveOptionInfo
# NEXT, compiling the type definition built up a set of information
# about the typemethods; save the typemethod info.
append compile(defs) \
"\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
# NEXT, if this is a widget define the hull component if it isn't
# already defined.
if {$isWidget} {
Comp.DefineComponent hull
}
# NEXT, substitute the compiled definition into the type template
# to get the type definition script.
set defscript [Expand $typeTemplate \
%COMPILEDDEFS% $compile(defs)]
# NEXT, substitute the defined macros into the type definition script.
# This is done as a separate step so that the compile(defs) can
# contain the macros defined below.
set defscript [Expand $defscript \
%TYPE% $type \
%IVARDECS% $compile(ivprocdec) \
%TVARDECS% $compile(tvprocdec) \
%TCONSTBODY% $compile(typeconstructor) \
%INSTANCEVARS% $compile(instancevars) \
%TYPEVARS% $compile(typevars) \
]
array unset compile
return [list $type $defscript]
}
# Information about locally-defined options is accumulated during
# compilation, but not added to the compiled definition--the option
# statement can appear multiple times, so it's easier this way.
# This proc fills in Snit_optionInfo with the accumulated information.
#
# It also computes the option's resource and class names if needed.
#
# Note that the information for delegated options was put in
# Snit_optionInfo during compilation.
proc ::snit::Comp.SaveOptionInfo {} {
variable compile
foreach option $compile(localoptions) {
if {$compile(resource-$option) eq ""} {
set compile(resource-$option) [string range $option 1 end]
}
if {$compile(class-$option) eq ""} {
set compile(class-$option) [Capitalize $compile(resource-$option)]
}
# NOTE: Don't verify that the validate, configure, and cget
# values name real methods; the methods might be defined outside
# the typedefinition using snit::method.
Mappend compile(defs) {
# Option %OPTION%
lappend %TYPE%::Snit_optionInfo(local) %OPTION%
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
} %OPTION% $option \
%RESOURCE% $compile(resource-$option) \
%CLASS% $compile(class-$option) \
%DEFAULT% [list $compile(-default-$option)] \
%VALIDATE% [list $compile(-validatemethod-$option)] \
%CONFIGURE% [list $compile(-configuremethod-$option)] \
%CGET% [list $compile(-cgetmethod-$option)] \
%READONLY% $compile(-readonly-$option) \
%TYPESPEC% [list $compile(-type-$option)]
}
}
# Evaluates a compiled type definition, thus making the type available.
proc ::snit::Comp.Define {compResult} {
# The compilation result is a list containing the fully qualified
# type name and a script to evaluate to define the type.
set type [lindex $compResult 0]
set defscript [lindex $compResult 1]
# Execute the type definition script.
# Consider using namespace eval %TYPE%. See if it's faster.
if {[catch {eval $defscript} result]} {
namespace delete $type
catch {rename $type ""}
error $result
}
return $type
}
# Sets pragma options which control how the type is defined.
proc ::snit::Comp.statement.pragma {args} {
variable compile
set errRoot "Error in \"pragma...\""
foreach {opt val} $args {
switch -exact -- $opt {
-hastypeinfo -
-hastypedestroy -
-hastypemethods -
-hasinstances -
-simpledispatch -
-hasinfo -
-canreplace {
if {![string is boolean -strict $val]} {
error "$errRoot, \"$opt\" requires a boolean value"
}
set compile($opt) $val
}
default {
error "$errRoot, unknown pragma"
}
}
}
}
# Defines a widget's option class name.
# This statement is only available for snit::widgets,
# not for snit::types or snit::widgetadaptors.
proc ::snit::Comp.statement.widgetclass {name} {
variable compile
# First, widgetclass can only be set for true widgets
if {"widget" != $compile(which)} {
error "widgetclass cannot be set for snit::$compile(which)s"
}
# Next, validate the option name. We'll require that it begin
# with an uppercase letter.
set initial [string index $name 0]
if {![string is upper $initial]} {
error "widgetclass \"$name\" does not begin with an uppercase letter"
}
if {"" != $compile(widgetclass)} {
error "too many widgetclass statements"
}
# Next, save it.
Mappend compile(defs) {
set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
} %WIDGETCLASS% [list $name]
set compile(widgetclass) $name
}
# Defines a widget's hull type.
# This statement is only available for snit::widgets,
# not for snit::types or snit::widgetadaptors.
proc ::snit::Comp.statement.hulltype {name} {
variable compile
variable hulltypes
# First, hulltype can only be set for true widgets
if {"widget" != $compile(which)} {
error "hulltype cannot be set for snit::$compile(which)s"
}
# Next, it must be one of the valid hulltypes (frame, toplevel, ...)
if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
error "invalid hulltype \"$name\", should be one of\
[join $hulltypes {, }]"
}
if {"" != $compile(hulltype)} {
error "too many hulltype statements"
}
# Next, save it.
Mappend compile(defs) {
set %TYPE%::Snit_info(hulltype) %HULLTYPE%
} %HULLTYPE% $name
set compile(hulltype) $name
}
# Defines a constructor.
proc ::snit::Comp.statement.constructor {arglist body} {
variable compile
CheckArgs "constructor" $arglist
# Next, add a magic reference to self.
set arglist [concat type selfns win self $arglist]
# Next, add variable declarations to body:
set body "%TVARDECS%\n%IVARDECS%\n$body"
set compile(hasconstructor) yes
append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
}
# Defines a destructor.
proc ::snit::Comp.statement.destructor {body} {
variable compile
# Next, add variable declarations to body:
set body "%TVARDECS%\n%IVARDECS%\n$body"
append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
}
# Defines a type option. The option value can be a triple, specifying
# the option's -name, resource name, and class name.
proc ::snit::Comp.statement.option {optionDef args} {
variable compile
# First, get the three option names.
set option [lindex $optionDef 0]
set resourceName [lindex $optionDef 1]
set className [lindex $optionDef 2]
set errRoot "Error in \"option [list $optionDef]...\""
# Next, validate the option name.
if {![Comp.OptionNameIsValid $option]} {
error "$errRoot, badly named option \"$option\""
}
if {$option in $compile(delegatedoptions)} {
error "$errRoot, cannot define \"$option\" locally, it has been delegated"
}
if {!($option in $compile(localoptions))} {
# Remember that we've seen this one.
set compile(hasoptions) yes
lappend compile(localoptions) $option
# Initialize compilation info for this option.
set compile(resource-$option) ""
set compile(class-$option) ""
set compile(-default-$option) ""
set compile(-validatemethod-$option) ""
set compile(-configuremethod-$option) ""
set compile(-cgetmethod-$option) ""
set compile(-readonly-$option) 0
set compile(-type-$option) ""
}
# NEXT, see if we have a resource name. If so, make sure it
# isn't being redefined differently.
if {$resourceName ne ""} {
if {$compile(resource-$option) eq ""} {
# If it's undefined, just save the value.
set compile(resource-$option) $resourceName
} elseif {$resourceName ne $compile(resource-$option)} {
# It's been redefined differently.
error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
}
}
# NEXT, see if we have a class name. If so, make sure it
# isn't being redefined differently.
if {$className ne ""} {
if {$compile(class-$option) eq ""} {
# If it's undefined, just save the value.
set compile(class-$option) $className
} elseif {$className ne $compile(class-$option)} {
# It's been redefined differently.
error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
}
}
# NEXT, handle the args; it's not an error to redefine these.
if {[llength $args] == 1} {
set compile(-default-$option) [lindex $args 0]
} else {
foreach {optopt val} $args {
switch -exact -- $optopt {
-default -
-validatemethod -
-configuremethod -
-cgetmethod {
set compile($optopt-$option) $val
}
-type {
set compile($optopt-$option) $val
if {[llength $val] == 1} {
# The type spec *is* the validation object
append compile(defs) \
"\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
} else {
# Compilation the creation of the validation object
set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
append compile(defs) \
"\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
}
}
-readonly {
if {![string is boolean -strict $val]} {
error "$errRoot, -readonly requires a boolean, got \"$val\""
}
set compile($optopt-$option) $val
}
default {
error "$errRoot, unknown option definition option \"$optopt\""
}
}
}
}
}
# 1 if the option name is valid, 0 otherwise.
proc ::snit::Comp.OptionNameIsValid {option} {
if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
return 0
}
return 1
}
# Defines an option's cget handler
proc ::snit::Comp.statement.oncget {option body} {
variable compile
set errRoot "Error in \"oncget $option...\""
if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
return -code error "$errRoot, option \"$option\" is delegated"
}
if {[lsearch -exact $compile(localoptions) $option] == -1} {
return -code error "$errRoot, option \"$option\" unknown"
}
Comp.statement.method _cget$option {_option} $body
Comp.statement.option $option -cgetmethod _cget$option
}
# Defines an option's configure handler.
proc ::snit::Comp.statement.onconfigure {option arglist body} {
variable compile
if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
return -code error "onconfigure $option: option \"$option\" is delegated"
}
if {[lsearch -exact $compile(localoptions) $option] == -1} {
return -code error "onconfigure $option: option \"$option\" unknown"
}
if {[llength $arglist] != 1} {
error \
"onconfigure $option handler should have one argument, got \"$arglist\""
}
CheckArgs "onconfigure $option" $arglist
# Next, add a magic reference to the option name
set arglist [concat _option $arglist]
Comp.statement.method _configure$option $arglist $body
Comp.statement.option $option -configuremethod _configure$option
}
# Defines an instance method.
proc ::snit::Comp.statement.method {method arglist body} {
variable compile
variable methodInfo
# FIRST, check the method name against previously defined
# methods.
Comp.CheckMethodName $method 0 ::snit::methodInfo \
"Error in \"method [list $method]...\""
if {[llength $method] > 1} {
set compile(hashierarchic) yes
}
# Remeber this method
lappend compile(localmethods) $method
CheckArgs "method [list $method]" $arglist
# Next, add magic references to type and self.
set arglist [concat type selfns win self $arglist]
# Next, add variable declarations to body:
set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body"
# Next, save the definition script.
if {[llength $method] == 1} {
set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
Mappend compile(defs) {
proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
} else {
set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
Mappend compile(defs) {
proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
} %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
%BODY% [list $body]
}
}
# Check for name collisions; save prefix information.
#
# method The name of the method or typemethod.
# delFlag 1 if delegated, 0 otherwise.
# infoVar The fully qualified name of the array containing
# information about the defined methods.
# errRoot The root string for any error messages.
proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
upvar $infoVar methodInfo
# FIRST, make sure the method name is a valid Tcl list.
if {[catch {lindex $method 0}]} {
error "$errRoot, the name \"$method\" must have list syntax."
}
# NEXT, check whether we can define it.
if {![catch {set methodInfo($method)} data]} {
# We can't redefine methods with submethods.
if {[lindex $data 0] == 1} {
error "$errRoot, \"$method\" has submethods."
}
# You can't delegate a method that's defined locally,
# and you can't define a method locally if it's been delegated.
if {$delFlag && [lindex $data 2] eq ""} {
error "$errRoot, \"$method\" has been defined locally."
} elseif {!$delFlag && [lindex $data 2] ne ""} {
error "$errRoot, \"$method\" has been delegated"
}
}
# Handle hierarchical case.
if {[llength $method] > 1} {
set prefix {}
set tokens $method
while {[llength $tokens] > 1} {
lappend prefix [lindex $tokens 0]
set tokens [lrange $tokens 1 end]
if {![catch {set methodInfo($prefix)} result]} {
# Prefix is known. If it's not a prefix, throw an
# error.
if {[lindex $result 0] == 0} {
error "$errRoot, \"$prefix\" has no submethods."
}
}
set methodInfo($prefix) [list 1]
}
}
}
# Defines a typemethod method.
proc ::snit::Comp.statement.typemethod {method arglist body} {
variable compile
variable typemethodInfo
# FIRST, check the typemethod name against previously defined
# typemethods.
Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
"Error in \"typemethod [list $method]...\""
CheckArgs "typemethod $method" $arglist
# First, add magic reference to type.
set arglist [concat type $arglist]
# Next, add typevariable declarations to body:
set body "%TVARDECS%\n# END snit method prolog\n$body"
# Next, save the definition script
if {[llength $method] == 1} {
set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
Mappend compile(defs) {
proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
} else {
set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
Mappend compile(defs) {
proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
} %JMETHOD% [join $method _] \
%ARGLIST% [list $arglist] %BODY% [list $body]
}
}
# Defines a type constructor.
proc ::snit::Comp.statement.typeconstructor {body} {
variable compile
if {"" != $compile(typeconstructor)} {
error "too many typeconstructors"
}
set compile(typeconstructor) $body
}
# Defines a static proc in the type's namespace.
proc ::snit::Comp.statement.proc {proc arglist body} {
variable compile
# If "ns" is defined, the proc can see instance variables.
if {[lsearch -exact $arglist selfns] != -1} {
# Next, add instance variable declarations to body:
set body "%IVARDECS%\n$body"
}
# The proc can always see typevariables.
set body "%TVARDECS%\n$body"
append compile(defs) "
# Proc $proc
proc [list %TYPE%::$proc $arglist $body]
"
}
# Defines a static variable in the type's namespace.
proc ::snit::Comp.statement.typevariable {name args} {
variable compile
set errRoot "Error in \"typevariable $name...\""
set len [llength $args]
if {$len > 2 ||
($len == 2 && [lindex $args 0] ne "-array")} {
error "$errRoot, too many initializers"
}
if {[lsearch -exact $compile(varnames) $name] != -1} {
error "$errRoot, \"$name\" is already an instance variable"
}
lappend compile(typevarnames) $name
if {$len == 1} {
append compile(typevars) \
"\n\t [list ::variable $name [lindex $args 0]]"
} elseif {$len == 2} {
append compile(typevars) \
"\n\t [list ::variable $name]"
append compile(typevars) \
"\n\t [list array set $name [lindex $args 1]]"
} else {
append compile(typevars) \
"\n\t [list ::variable $name]"
}
if {$compile(tvprocdec) eq ""} {
set compile(tvprocdec) "\n\t"
append compile(tvprocdec) "namespace upvar [list $compile(type)]"
}
append compile(tvprocdec) " [list $name $name]"
}
# Defines an instance variable; the definition will go in the
# type's create typemethod.
proc ::snit::Comp.statement.variable {name args} {
variable compile
set errRoot "Error in \"variable $name...\""
set len [llength $args]
if {$len > 2 ||
($len == 2 && [lindex $args 0] ne "-array")} {
error "$errRoot, too many initializers"
}
if {[lsearch -exact $compile(typevarnames) $name] != -1} {
error "$errRoot, \"$name\" is already a typevariable"
}
lappend compile(varnames) $name
# Add a ::variable to instancevars, so that ::variable is used
# at least once; ::variable makes the variable visible to
# [info vars] even if no value is assigned.
append compile(instancevars) "\n"
Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name
if {$len == 1} {
append compile(instancevars) \
"\nset $name [list [lindex $args 0]]\n"
} elseif {$len == 2} {
append compile(instancevars) \
"\narray set $name [list [lindex $args 1]]\n"
}
if {$compile(ivprocdec) eq ""} {
set compile(ivprocdec) "\n\t"
append compile(ivprocdec) {namespace upvar $selfns}
}
append compile(ivprocdec) " [list $name $name]"
}
# Defines a typecomponent, and handles component options.
#
# component The logical name of the delegate
# args options.
proc ::snit::Comp.statement.typecomponent {component args} {
variable compile
set errRoot "Error in \"typecomponent $component...\""
# FIRST, define the component
Comp.DefineTypecomponent $component $errRoot
# NEXT, handle the options.
set publicMethod ""
set inheritFlag 0
foreach {opt val} $args {
switch -exact -- $opt {
-public {
set publicMethod $val
}
-inherit {
set inheritFlag $val
if {![string is boolean $inheritFlag]} {
error "typecomponent $component -inherit: expected boolean value, got \"$val\""
}
}
default {
error "typecomponent $component: Invalid option \"$opt\""
}
}
}
# NEXT, if -public specified, define the method.
if {$publicMethod ne ""} {
Comp.statement.delegate typemethod [list $publicMethod *] to $component
}
# NEXT, if "-inherit 1" is specified, delegate typemethod * to
# this component.
if {$inheritFlag} {
Comp.statement.delegate typemethod "*" to $component
}
}
# Defines a name to be a typecomponent
#
# The name becomes a typevariable; in addition, it gets a
# write trace so that when it is set, all of the component mechanisms
# get updated.
#
# component The component name
proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
variable compile
if {[lsearch -exact $compile(varnames) $component] != -1} {
error "$errRoot, \"$component\" is already an instance variable"
}
if {[lsearch -exact $compile(typecomponents) $component] == -1} {
# Remember we've done this.
lappend compile(typecomponents) $component
# Make it a type variable with no initial value
Comp.statement.typevariable $component ""
# Add a write trace to do the component thing.
Mappend compile(typevars) {
trace add variable %COMP% write \
[list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
} %TYPE% $compile(type) %COMP% $component
}
}
# Defines a component, and handles component options.
#
# component The logical name of the delegate
# args options.
#
# TBD: Ideally, it should be possible to call this statement multiple
# times, possibly changing the option values. To do that, I'd need
# to cache the option values and not act on them until *after* I'd
# read the entire type definition.
proc ::snit::Comp.statement.component {component args} {
variable compile
set errRoot "Error in \"component $component...\""
# FIRST, define the component
Comp.DefineComponent $component $errRoot
# NEXT, handle the options.
set publicMethod ""
set inheritFlag 0
foreach {opt val} $args {
switch -exact -- $opt {
-public {
set publicMethod $val
}
-inherit {
set inheritFlag $val
if {![string is boolean $inheritFlag]} {
error "component $component -inherit: expected boolean value, got \"$val\""
}
}
default {
error "component $component: Invalid option \"$opt\""
}
}
}
# NEXT, if -public specified, define the method.
if {$publicMethod ne ""} {
Comp.statement.delegate method [list $publicMethod *] to $component
}
# NEXT, if -inherit is specified, delegate method/option * to
# this component.
if {$inheritFlag} {
Comp.statement.delegate method "*" to $component
Comp.statement.delegate option "*" to $component
}
}
# Defines a name to be a component
#
# The name becomes an instance variable; in addition, it gets a
# write trace so that when it is set, all of the component mechanisms
# get updated.
#
# component The component name
proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
variable compile
if {[lsearch -exact $compile(typevarnames) $component] != -1} {
error "$errRoot, \"$component\" is already a typevariable"
}
if {[lsearch -exact $compile(components) $component] == -1} {
# Remember we've done this.
lappend compile(components) $component
# Make it an instance variable with no initial value
Comp.statement.variable $component ""
# Add a write trace to do the component thing.
Mappend compile(instancevars) {
trace add variable ${selfns}::%COMP% write \
[list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
} %TYPE% $compile(type) %COMP% $component
}
}
# Creates a delegated method, typemethod, or option.
proc ::snit::Comp.statement.delegate {what name args} {
# FIRST, dispatch to correct handler.
switch $what {
typemethod { Comp.DelegatedTypemethod $name $args }
method { Comp.DelegatedMethod $name $args }
option { Comp.DelegatedOption $name $args }
default {
error "Error in \"delegate $what $name...\", \"$what\"?"
}
}
if {([llength $args] % 2) != 0} {
error "Error in \"delegate $what $name...\", invalid syntax"
}
}
# Creates a delegated typemethod delegating it to a particular
# typecomponent or an arbitrary command.
#
# method The name of the method
# arglist Delegation options
proc ::snit::Comp.DelegatedTypemethod {method arglist} {
variable compile
variable typemethodInfo
set errRoot "Error in \"delegate typemethod [list $method]...\""
# Next, parse the delegation options.
set component ""
set target ""
set exceptions {}
set pattern ""
set methodTail [lindex $method end]
foreach {opt value} $arglist {
switch -exact $opt {
to { set component $value }
as { set target $value }
except { set exceptions $value }
using { set pattern $value }
default {
error "$errRoot, unknown delegation option \"$opt\""
}
}
}
if {$component eq "" && $pattern eq ""} {
error "$errRoot, missing \"to\""
}
if {$methodTail eq "*" && $target ne ""} {
error "$errRoot, cannot specify \"as\" with \"*\""
}
if {$methodTail ne "*" && $exceptions ne ""} {
error "$errRoot, can only specify \"except\" with \"*\""
}
if {$pattern ne "" && $target ne ""} {
error "$errRoot, cannot specify both \"as\" and \"using\""
}
foreach token [lrange $method 1 end-1] {
if {$token eq "*"} {
error "$errRoot, \"*\" must be the last token."
}
}
# NEXT, define the component
if {$component ne ""} {
Comp.DefineTypecomponent $component $errRoot
}
# NEXT, define the pattern.
if {$pattern eq ""} {
if {$methodTail eq "*"} {
set pattern "%c %m"
} elseif {$target ne ""} {
set pattern "%c $target"
} else {
set pattern "%c %m"
}
}
# Make sure the pattern is a valid list.
if {[catch {lindex $pattern 0} result]} {
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
}
# NEXT, check the method name against previously defined
# methods.
Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
set typemethodInfo($method) [list 0 $pattern $component]
if {[string equal $methodTail "*"]} {
Mappend compile(defs) {
set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
} %EXCEPT% [list $exceptions]
}
}
# Creates a delegated method delegating it to a particular
# component or command.
#
# method The name of the method
# arglist Delegation options.
proc ::snit::Comp.DelegatedMethod {method arglist} {
variable compile
variable methodInfo
set errRoot "Error in \"delegate method [list $method]...\""
# Next, parse the delegation options.
set component ""
set target ""
set exceptions {}
set pattern ""
set methodTail [lindex $method end]
foreach {opt value} $arglist {
switch -exact $opt {
to { set component $value }
as { set target $value }
except { set exceptions $value }
using { set pattern $value }
default {
error "$errRoot, unknown delegation option \"$opt\""
}
}
}
if {$component eq "" && $pattern eq ""} {
error "$errRoot, missing \"to\""
}
if {$methodTail eq "*" && $target ne ""} {
error "$errRoot, cannot specify \"as\" with \"*\""
}
if {$methodTail ne "*" && $exceptions ne ""} {
error "$errRoot, can only specify \"except\" with \"*\""
}
if {$pattern ne "" && $target ne ""} {
error "$errRoot, cannot specify both \"as\" and \"using\""
}
foreach token [lrange $method 1 end-1] {
if {$token eq "*"} {
error "$errRoot, \"*\" must be the last token."
}
}
# NEXT, we delegate some methods
set compile(delegatesmethods) yes
# NEXT, define the component. Allow typecomponents.
if {$component ne ""} {
if {[lsearch -exact $compile(typecomponents) $component] == -1} {
Comp.DefineComponent $component $errRoot
}
}
# NEXT, define the pattern.
if {$pattern eq ""} {
if {$methodTail eq "*"} {
set pattern "%c %m"
} elseif {$target ne ""} {
set pattern "%c $target"
} else {
set pattern "%c %m"
}
}
# Make sure the pattern is a valid list.
if {[catch {lindex $pattern 0} result]} {
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
}
# NEXT, check the method name against previously defined
# methods.
Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
# NEXT, save the method info.
set methodInfo($method) [list 0 $pattern $component]
if {[string equal $methodTail "*"]} {
Mappend compile(defs) {
set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
} %EXCEPT% [list $exceptions]
}
}
# Creates a delegated option, delegating it to a particular
# component and, optionally, to a particular option of that
# component.
#
# optionDef The option definition
# args definition arguments.
proc ::snit::Comp.DelegatedOption {optionDef arglist} {
variable compile
# First, get the three option names.
set option [lindex $optionDef 0]
set resourceName [lindex $optionDef 1]
set className [lindex $optionDef 2]
set errRoot "Error in \"delegate option [list $optionDef]...\""
# Next, parse the delegation options.
set component ""
set target ""
set exceptions {}
foreach {opt value} $arglist {
switch -exact $opt {
to { set component $value }
as { set target $value }
except { set exceptions $value }
default {
error "$errRoot, unknown delegation option \"$opt\""
}
}
}
if {$component eq ""} {
error "$errRoot, missing \"to\""
}
if {$option eq "*" && $target ne ""} {
error "$errRoot, cannot specify \"as\" with \"delegate option *\""
}
if {$option ne "*" && $exceptions ne ""} {
error "$errRoot, can only specify \"except\" with \"delegate option *\""
}
# Next, validate the option name
if {"*" != $option} {
if {![Comp.OptionNameIsValid $option]} {
error "$errRoot, badly named option \"$option\""
}
}
if {$option in $compile(localoptions)} {
error "$errRoot, \"$option\" has been defined locally"
}
if {$option in $compile(delegatedoptions)} {
error "$errRoot, \"$option\" is multiply delegated"
}
# NEXT, define the component
Comp.DefineComponent $component $errRoot
# Next, define the target option, if not specified.
if {![string equal $option "*"] &&
[string equal $target ""]} {
set target $option
}
# NEXT, save the delegation data.
set compile(hasoptions) yes
if {![string equal $option "*"]} {
lappend compile(delegatedoptions) $option
# Next, compute the resource and class names, if they aren't
# already defined.
if {"" == $resourceName} {
set resourceName [string range $option 1 end]
}
if {"" == $className} {
set className [Capitalize $resourceName]
}
Mappend compile(defs) {
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
} %OPTION% $option \
%COMP% $component \
%TARGET% $target \
%RES% $resourceName \
%CLASS% $className
} else {
Mappend compile(defs) {
set %TYPE%::Snit_optionInfo(starcomp) %COMP%
set %TYPE%::Snit_optionInfo(except) %EXCEPT%
} %COMP% $component %EXCEPT% [list $exceptions]
}
}
# Exposes a component, effectively making the component's command an
# instance method.
#
# component The logical name of the delegate
# "as" sugar; if not "", must be "as"
# methodname The desired method name for the component's command, or ""
proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
variable compile
# FIRST, define the component
Comp.DefineComponent $component
# NEXT, define the method just as though it were in the type
# definition.
if {[string equal $methodname ""]} {
set methodname $component
}
Comp.statement.method $methodname args [Expand {
if {[llength $args] == 0} {
return $%COMPONENT%
}
if {[string equal $%COMPONENT% ""]} {
error "undefined component \"%COMPONENT%\""
}
set cmd [linsert $args 0 $%COMPONENT%]
return [uplevel 1 $cmd]
} %COMPONENT% $component]
}
#-----------------------------------------------------------------------
# Public commands
# Compile a type definition, and return the results as a list of two
# items: the fully-qualified type name, and a script that will define
# the type when executed.
#
# which type, widget, or widgetadaptor
# type the type name
# body the type definition
proc ::snit::compile {which type body} {
return [Comp.Compile $which $type $body]
}
proc ::snit::type {type body} {
return [Comp.Define [Comp.Compile type $type $body]]
}
proc ::snit::widget {type body} {
return [Comp.Define [Comp.Compile widget $type $body]]
}
proc ::snit::widgetadaptor {type body} {
return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
}
proc ::snit::typemethod {type method arglist body} {
# Make sure the type exists.
if {![info exists ${type}::Snit_info]} {
error "no such type: \"$type\""
}
upvar ${type}::Snit_info Snit_info
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
# FIRST, check the typemethod name against previously defined
# typemethods.
Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
"Cannot define \"$method\""
# NEXT, check the arguments
CheckArgs "snit::typemethod $type $method" $arglist
# Next, add magic reference to type.
set arglist [concat type $arglist]
# Next, add typevariable declarations to body:
set body "$Snit_info(tvardecs)\n$body"
# Next, define it.
if {[llength $method] == 1} {
set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
} else {
set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
set suffix [join $method _]
uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
}
}
proc ::snit::method {type method arglist body} {
# Make sure the type exists.
if {![info exists ${type}::Snit_info]} {
error "no such type: \"$type\""
}
upvar ${type}::Snit_methodInfo Snit_methodInfo
upvar ${type}::Snit_info Snit_info
# FIRST, check the method name against previously defined
# methods.
Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
"Cannot define \"$method\""
# NEXT, check the arguments
CheckArgs "snit::method $type $method" $arglist
# Next, add magic references to type and self.
set arglist [concat type selfns win self $arglist]
# Next, add variable declarations to body:
set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body"
# Next, define it.
if {[llength $method] == 1} {
set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
} else {
set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
set suffix [join $method _]
uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
}
}
# Defines a proc within the compiler; this proc can call other
# type definition statements, and thus can be used for meta-programming.
proc ::snit::macro {name arglist body} {
variable compiler
variable reservedwords
# FIRST, make sure the compiler is defined.
Comp.Init
# NEXT, check the macro name against the reserved words
if {[lsearch -exact $reservedwords $name] != -1} {
error "invalid macro name \"$name\""
}
# NEXT, see if the name has a namespace; if it does, define the
# namespace.
set ns [namespace qualifiers $name]
if {$ns ne ""} {
$compiler eval "namespace eval $ns {}"
}
# NEXT, define the macro
$compiler eval [list _proc $name $arglist $body]
}
#-----------------------------------------------------------------------
# Utility Functions
#
# These are utility functions used while compiling Snit types.
# Builds a template from a tagged list of text blocks, then substitutes
# all symbols in the mapTable, returning the expanded template.
proc ::snit::Expand {template args} {
return [string map $args $template]
}
# Expands a template and appends it to a variable.
proc ::snit::Mappend {varname template args} {
upvar $varname myvar
append myvar [string map $args $template]
}
# Checks argument list against reserved args
proc ::snit::CheckArgs {which arglist} {
variable reservedArgs
foreach name $reservedArgs {
if {$name in $arglist} {
error "$which's arglist may not contain \"$name\" explicitly"
}
}
}
# Capitalizes the first letter of a string.
proc ::snit::Capitalize {text} {
return [string toupper $text 0]
}
#=======================================================================
# Snit Runtime Library
#
# These are procs used by Snit types and widgets at runtime.
#-----------------------------------------------------------------------
# Object Creation
# Creates a new instance of the snit::type given its name and the args.
#
# type The snit::type
# name The instance name
# args Args to pass to the constructor
proc ::snit::RT.type.typemethod.create {type name args} {
variable ${type}::Snit_info
variable ${type}::Snit_optionInfo
# FIRST, qualify the name.
if {![string match "::*" $name]} {
# Get caller's namespace;
# append :: if not global namespace.
set ns [uplevel 1 [list namespace current]]
if {"::" != $ns} {
append ns "::"
}
set name "$ns$name"
}
# NEXT, if %AUTO% appears in the name, generate a unique
# command name. Otherwise, ensure that the name isn't in use.
if {[string match "*%AUTO%*" $name]} {
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
} elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
error "command \"$name\" already exists"
}
# NEXT, create the instance's namespace.
set selfns \
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
namespace eval $selfns {}
# NEXT, install the dispatcher
RT.MakeInstanceCommand $type $selfns $name
# Initialize the options to their defaults.
namespace upvar ${selfns} options options
foreach opt $Snit_optionInfo(local) {
set options($opt) $Snit_optionInfo(default-$opt)
}
# Initialize the instance vars to their defaults.
# selfns must be defined, as it is used implicitly.
${type}::Snit_instanceVars $selfns
# Execute the type's constructor.
set errcode [catch {
RT.ConstructInstance $type $selfns $name $args
} result]
if {$errcode} {
global errorInfo
global errorCode
set theInfo $errorInfo
set theCode $errorCode
::snit::RT.DestroyObject $type $selfns $name
error "Error in constructor: $result" $theInfo $theCode
}
# NEXT, return the object's name.
return $name
}
# Creates a new instance of the snit::widget or snit::widgetadaptor
# given its name and the args.
#
# type The snit::widget or snit::widgetadaptor
# name The instance name
# args Args to pass to the constructor
proc ::snit::RT.widget.typemethod.create {type name args} {
variable ${type}::Snit_info
variable ${type}::Snit_optionInfo
# FIRST, if %AUTO% appears in the name, generate a unique
# command name.
if {[string match "*%AUTO%*" $name]} {
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
}
# NEXT, create the instance's namespace.
set selfns \
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
namespace eval $selfns { }
# NEXT, Initialize the widget's own options to their defaults.
namespace upvar $selfns options options
foreach opt $Snit_optionInfo(local) {
set options($opt) $Snit_optionInfo(default-$opt)
}
# Initialize the instance vars to their defaults.
${type}::Snit_instanceVars $selfns
# NEXT, if this is a normal widget (not a widget adaptor) then create a
# frame as its hull. We set the frame's -class to the user's widgetclass,
# or, if none, search for -class in the args list, otherwise default to
# the basename of the $type with an initial upper case letter.
if {!$Snit_info(isWidgetAdaptor)} {
# FIRST, determine the class name
set wclass $Snit_info(widgetclass)
if {$Snit_info(widgetclass) eq ""} {
set idx [lsearch -exact $args -class]
if {$idx >= 0 && ($idx%2 == 0)} {
# -class exists and is in the -option position
set wclass [lindex $args [expr {$idx+1}]]
set args [lreplace $args $idx [expr {$idx+1}]]
} else {
set wclass [::snit::Capitalize [namespace tail $type]]
}
}
# NEXT, create the widget
set self $name
package require Tk
${type}::installhull using $Snit_info(hulltype) -class $wclass
# NEXT, let's query the option database for our
# widget, now that we know that it exists.
foreach opt $Snit_optionInfo(local) {
set dbval [RT.OptionDbGet $type $name $opt]
if {"" != $dbval} {
set options($opt) $dbval
}
}
}
# Execute the type's constructor, and verify that it
# has a hull.
set errcode [catch {
RT.ConstructInstance $type $selfns $name $args
::snit::RT.Component $type $selfns hull
# Prepare to call the object's destructor when the
# <Destroy> event is received. Use a Snit-specific bindtag
# so that the widget name's tag is unencumbered.
bind Snit$type$name <Destroy> [::snit::Expand {
::snit::RT.DestroyObject %TYPE% %NS% %W
} %TYPE% $type %NS% $selfns]
# Insert the bindtag into the list of bindtags right
# after the widget name.
set taglist [bindtags $name]
set ndx [lsearch -exact $taglist $name]
incr ndx
bindtags $name [linsert $taglist $ndx Snit$type$name]
} result]
if {$errcode} {
global errorInfo
global errorCode
set theInfo $errorInfo
set theCode $errorCode
::snit::RT.DestroyObject $type $selfns $name
error "Error in constructor: $result" $theInfo $theCode
}
# NEXT, return the object's name.
return $name
}
# RT.MakeInstanceCommand type selfns instance
#
# type The object type
# selfns The instance namespace
# instance The instance name
#
# Creates the instance proc.
proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
variable ${type}::Snit_info
# FIRST, remember the instance name. The Snit_instance variable
# allows the instance to figure out its current name given the
# instance namespace.
namespace upvar $selfns Snit_instance Snit_instance
set Snit_instance $instance
# NEXT, qualify the proc name if it's a widget.
if {$Snit_info(isWidget)} {
set procname ::$instance
} else {
set procname $instance
}
# NEXT, install the new proc
# WHD: Snit 2.0 code
set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""]
set createCmd [list namespace ensemble create \
-command $procname \
-unknown $unknownCmd \
-prefixes 0]
namespace eval $selfns $createCmd
# NEXT, add the trace.
trace add command $procname {rename delete} \
[list ::snit::RT.InstanceTrace $type $selfns $instance]
}
# This proc is called when the instance command is renamed.
# If op is delete, then new will always be "", so op is redundant.
#
# type The fully-qualified type name
# selfns The instance namespace
# win The original instance/tk window name.
# old old instance command name
# new new instance command name
# op rename or delete
#
# If the op is delete, we need to clean up the object; otherwise,
# we need to track the change.
#
# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
# traces aren't propagated correctly. Instead, they silently
# vanish. Add a catch to output any error message.
proc ::snit::RT.InstanceTrace {type selfns win old new op} {
variable ${type}::Snit_info
# Note to developers ...
# For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
# Therefore we catch them here and create some output to help in
# debugging such problems.
if {[catch {
# FIRST, clean up if necessary
if {"" == $new} {
if {$Snit_info(isWidget)} {
destroy $win
} else {
::snit::RT.DestroyObject $type $selfns $win
}
} else {
# Otherwise, track the change.
variable ${selfns}::Snit_instance
set Snit_instance [uplevel 1 [list namespace which -command $new]]
# Also, clear the instance caches, as many cached commands
# might be invalid.
RT.ClearInstanceCaches $selfns
}
} result]} {
global errorInfo
# Pop up the console on Windows wish, to enable stdout.
# This clobbers errorInfo on unix, so save it so we can print it.
set ei $errorInfo
catch {console show}
puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
puts $ei
}
}
# Calls the instance constructor and handles related housekeeping.
proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
variable ${type}::Snit_optionInfo
variable ${selfns}::Snit_iinfo
# Track whether we are constructed or not.
set Snit_iinfo(constructed) 0
# Call the user's constructor
eval [linsert $arglist 0 \
${type}::Snit_constructor $type $selfns $instance $instance]
set Snit_iinfo(constructed) 1
# Validate the initial set of options (including defaults)
foreach option $Snit_optionInfo(local) {
set value [set ${selfns}::options($option)]
if {$Snit_optionInfo(typespec-$option) ne ""} {
if {[catch {
$Snit_optionInfo(typeobj-$option) validate $value
} result]} {
return -code error "invalid $option default: $result"
}
}
}
# Unset the configure cache for all -readonly options.
# This ensures that the next time anyone tries to
# configure it, an error is thrown.
foreach opt $Snit_optionInfo(local) {
if {$Snit_optionInfo(readonly-$opt)} {
unset -nocomplain ${selfns}::Snit_configureCache($opt)
}
}
return
}
# Returns a unique command name.
#
# REQUIRE: type is a fully qualified name.
# REQUIRE: name contains "%AUTO%"
# PROMISE: the returned command name is unused.
proc ::snit::RT.UniqueName {countervar type name} {
upvar $countervar counter
while 1 {
# FIRST, bump the counter and define the %AUTO% instance name;
# then substitute it into the specified name. Wrap around at
# 2^31 - 2 to prevent overflow problems.
incr counter
if {$counter > 2147483646} {
set counter 0
}
set auto "[namespace tail $type]$counter"
set candidate [Expand $name %AUTO% $auto]
if {![llength [info commands $candidate]]} {
return $candidate
}
}
}
# Returns a unique instance namespace, fully qualified.
#
# countervar The name of a counter variable
# type The instance's type
#
# REQUIRE: type is fully qualified
# PROMISE: The returned namespace name is unused.
proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
upvar $countervar counter
while 1 {
# FIRST, bump the counter and define the namespace name.
# Then see if it already exists. Wrap around at
# 2^31 - 2 to prevent overflow problems.
incr counter
if {$counter > 2147483646} {
set counter 0
}
set ins "${type}::Snit_inst${counter}"
if {![namespace exists $ins]} {
return $ins
}
}
}
# Retrieves an option's value from the option database.
# Returns "" if no value is found.
proc ::snit::RT.OptionDbGet {type self opt} {
variable ${type}::Snit_optionInfo
return [option get $self \
$Snit_optionInfo(resource-$opt) \
$Snit_optionInfo(class-$opt)]
}
#-----------------------------------------------------------------------
# Object Destruction
# Implements the standard "destroy" method
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
proc ::snit::RT.method.destroy {type selfns win self} {
variable ${selfns}::Snit_iinfo
# Can't destroy the object if it isn't complete constructed.
if {!$Snit_iinfo(constructed)} {
return -code error "Called 'destroy' method in constructor"
}
# Calls Snit_cleanup, which (among other things) calls the
# user's destructor.
::snit::RT.DestroyObject $type $selfns $win
}
# This is the function that really cleans up; it's automatically
# called when any instance is destroyed, e.g., by "$object destroy"
# for types, and by the <Destroy> event for widgets.
#
# type The fully-qualified type name.
# selfns The instance namespace
# win The original instance command name.
proc ::snit::RT.DestroyObject {type selfns win} {
variable ${type}::Snit_info
# If the variable Snit_instance doesn't exist then there's no
# instance command for this object -- it's most likely a
# widgetadaptor. Consequently, there are some things that
# we don't need to do.
if {[info exists ${selfns}::Snit_instance]} {
namespace upvar $selfns Snit_instance instance
# First, remove the trace on the instance name, so that we
# don't call RT.DestroyObject recursively.
RT.RemoveInstanceTrace $type $selfns $win $instance
# Next, call the user's destructor
${type}::Snit_destructor $type $selfns $win $instance
# Next, if this isn't a widget, delete the instance command.
# If it is a widget, get the hull component's name, and rename
# it back to the widget name
# Next, delete the hull component's instance command,
# if there is one.
if {$Snit_info(isWidget)} {
set hullcmd [::snit::RT.Component $type $selfns hull]
catch {rename $instance ""}
# Clear the bind event
bind Snit$type$win <Destroy> ""
if {[llength [info commands $hullcmd]]} {
# FIRST, rename the hull back to its original name.
# If the hull is itself a megawidget, it will have its
# own cleanup to do, and it might not do it properly
# if it doesn't have the right name.
rename $hullcmd ::$instance
# NEXT, destroy it.
destroy $instance
}
} else {
catch {rename $instance ""}
}
}
# Next, delete the instance's namespace. This kills any
# instance variables.
namespace delete $selfns
return
}
# Remove instance trace
#
# type The fully qualified type name
# selfns The instance namespace
# win The original instance name/Tk window name
# instance The current instance name
proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
variable ${type}::Snit_info
if {$Snit_info(isWidget)} {
set procname ::$instance
} else {
set procname $instance
}
# NEXT, remove any trace on this name
catch {
trace remove command $procname {rename delete} \
[list ::snit::RT.InstanceTrace $type $selfns $win]
}
}
#-----------------------------------------------------------------------
# Typecomponent Management and Method Caching
# Typecomponent trace; used for write trace on typecomponent
# variables. Saves the new component object name, provided
# that certain conditions are met. Also clears the typemethod
# cache.
proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
namespace upvar $type \
Snit_info Snit_info \
$component cvar \
Snit_typecomponents Snit_typecomponents
# Save the new component value.
set Snit_typecomponents($component) $cvar
# Clear the typemethod cache.
# TBD: can we unset just the elements related to
# this component?
# WHD: Namespace 2.0 code
namespace ensemble configure $type -map {}
}
# WHD: Snit 2.0 code
#
# RT.UnknownTypemethod type eId eCmd method args
#
# type The type
# eId The ensemble command ID; "" for the instance itself.
# eCmd The ensemble command name.
# method The unknown method name.
# args The additional arguments, if any.
#
# This proc looks up the method relative to the specified ensemble.
# If no method is found, it assumes that the "create" method is
# desired, and that the "method" is the instance name. In this case,
# it returns the "create" typemethod command with the instance name
# appended; this will cause the instance to be created without updating
# the -map. If the method is found, the method's command is created and
# added to the -map; the function returns the empty list.
proc snit::RT.UnknownTypemethod {type eId eCmd method args} {
namespace upvar $type \
Snit_typemethodInfo Snit_typemethodInfo \
Snit_typecomponents Snit_typecomponents \
Snit_info Snit_info
# FIRST, get the pattern data and the typecomponent name.
set implicitCreate 0
set instanceName ""
set fullMethod $eId
lappend fullMethod $method
set starredMethod [concat $eId *]
set methodTail $method
if {[info exists Snit_typemethodInfo($fullMethod)]} {
set key $fullMethod
} elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
set key $starredMethod
} else {
# WHD: The method is explicitly not delegated, so this is an error.
# Or should we treat it as an instance name?
return [list ]
}
} elseif {[llength $fullMethod] > 1} {
return [list ]
} elseif {$Snit_info(hasinstances)} {
# Assume the unknown name is an instance name to create, unless
# this is a widget and the style of the name is wrong, or the
# name mimics a standard typemethod.
if {[set ${type}::Snit_info(isWidget)] &&
![string match ".*" $method]} {
return [list ]
}
# Without this check, the call "$type info" will redefine the
# standard "::info" command, with disastrous results. Since it's
# a likely thing to do if !-typeinfo, put in an explicit check.
if {$method eq "info" || $method eq "destroy"} {
return [list ]
}
set implicitCreate 1
set instanceName $method
set key create
set method create
} else {
return [list ]
}
foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
if {$flag == 1} {
# FIRST, define the ensemble command.
lappend eId $method
set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _]
set unknownCmd [list ::snit::RT.UnknownTypemethod \
$type $eId]
set createCmd [list namespace ensemble create \
-command $newCmd \
-unknown $unknownCmd \
-prefixes 0]
namespace eval $type $createCmd
# NEXT, add the method to the current ensemble
set map [namespace ensemble configure $eCmd -map]
dict append map $method $newCmd
namespace ensemble configure $eCmd -map $map
return [list ]
}
# NEXT, build the substitution list
set subList [list \
%% % \
%t $type \
%M $fullMethod \
%m [lindex $fullMethod end] \
%j [join $fullMethod _]]
if {$compName ne ""} {
if {![info exists Snit_typecomponents($compName)]} {
error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
}
lappend subList %c [list $Snit_typecomponents($compName)]
}
set command {}
foreach subpattern $pattern {
lappend command [string map $subList $subpattern]
}
if {$implicitCreate} {
# In this case, $method is the name of the instance to
# create. Don't cache, as we usually won't do this one
# again.
lappend command $instanceName
return $command
}
# NEXT, if the actual command name isn't fully qualified,
# assume it's global.
set cmd [lindex $command 0]
if {[string index $cmd 0] ne ":"} {
set command [lreplace $command 0 0 "::$cmd"]
}
# NEXT, update the ensemble map.
set map [namespace ensemble configure $eCmd -map]
dict append map $method $command
namespace ensemble configure $eCmd -map $map
return [list ]
}
#-----------------------------------------------------------------------
# Component Management and Method Caching
# Retrieves the object name given the component name.
proc ::snit::RT.Component {type selfns name} {
variable ${selfns}::Snit_components
if {[catch {set Snit_components($name)} result]} {
variable ${selfns}::Snit_instance
error "component \"$name\" is undefined in $type $Snit_instance"
}
return $result
}
# Component trace; used for write trace on component instance
# variables. Saves the new component object name, provided
# that certain conditions are met. Also clears the method
# cache.
proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
namespace upvar $type Snit_info Snit_info
namespace upvar $selfns \
$component cvar \
Snit_components Snit_components
# If they try to redefine the hull component after
# it's been defined, that's an error--but only if
# this is a widget or widget adaptor.
if {"hull" == $component &&
$Snit_info(isWidget) &&
[info exists Snit_components($component)]} {
set cvar $Snit_components($component)
error "The hull component cannot be redefined"
}
# Save the new component value.
set Snit_components($component) $cvar
# Clear the instance caches.
# TBD: can we unset just the elements related to
# this component?
RT.ClearInstanceCaches $selfns
}
# WHD: Snit 2.0 code
#
# RT.UnknownMethod type selfns win eId eCmd method args
#
# type The type or widget command.
# selfns The instance namespace.
# win The original instance name.
# eId The ensemble command ID; "" for the instance itself.
# eCmd The real ensemble command name
# method The unknown method name
# args The additional arguments, if any.
#
# This proc looks up the method relative to the specific ensemble.
# If no method is found, it returns an empty list; this will result in
# the parent ensemble throwing an error.
# If the method is found, the ensemble's -map is extended with the
# correct command, and the empty list is returned; this caches the
# method's command. If the method is found, and it is also an
# ensemble, the ensemble command is created with an empty map.
proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} {
variable ${type}::Snit_info
variable ${type}::Snit_methodInfo
variable ${type}::Snit_typecomponents
variable ${selfns}::Snit_components
# FIRST, get the "self" value
set self [set ${selfns}::Snit_instance]
# FIRST, get the pattern data and the component name.
set fullMethod $eId
lappend fullMethod $method
set starredMethod [concat $eId *]
set methodTail $method
if {[info exists Snit_methodInfo($fullMethod)]} {
set key $fullMethod
} elseif {[info exists Snit_methodInfo($starredMethod)] &&
[lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
set key $starredMethod
} else {
return [list ]
}
foreach {flag pattern compName} $Snit_methodInfo($key) {}
if {$flag == 1} {
# FIRST, define the ensemble command.
lappend eId $method
# Fix provided by Anton Kovalenko; previously this call erroneously
# used ${type} rather than ${selfns}.
set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _]
set unknownCmd [list ::snit::RT.UnknownMethod \
$type $selfns $win $eId]
set createCmd [list namespace ensemble create \
-command $newCmd \
-unknown $unknownCmd \
-prefixes 0]
namespace eval $selfns $createCmd
# NEXT, add the method to the current ensemble
set map [namespace ensemble configure $eCmd -map]
dict append map $method $newCmd
namespace ensemble configure $eCmd -map $map
return [list ]
}
# NEXT, build the substitution list
set subList [list \
%% % \
%t $type \
%M $fullMethod \
%m [lindex $fullMethod end] \
%j [join $fullMethod _] \
%n [list $selfns] \
%w [list $win] \
%s [list $self]]
if {$compName ne ""} {
if {[info exists Snit_components($compName)]} {
set compCmd $Snit_components($compName)
} elseif {[info exists Snit_typecomponents($compName)]} {
set compCmd $Snit_typecomponents($compName)
} else {
error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\""
}
lappend subList %c [list $compCmd]
}
# Note: The cached command will execute faster if it's
# already a list.
set command {}
foreach subpattern $pattern {
lappend command [string map $subList $subpattern]
}
# NEXT, if the actual command name isn't fully qualified,
# assume it's global.
set cmd [lindex $command 0]
if {[string index $cmd 0] ne ":"} {
set command [lreplace $command 0 0 "::$cmd"]
}
# NEXT, update the ensemble map.
set map [namespace ensemble configure $eCmd -map]
dict append map $method $command
namespace ensemble configure $eCmd -map $map
return [list ]
}
# Clears all instance command caches
proc ::snit::RT.ClearInstanceCaches {selfns} {
# WHD: clear ensemble -map
if {![info exists ${selfns}::Snit_instance]} {
# Component variable set prior to constructor
# via the "variable" type definition statement.
return
}
set self [set ${selfns}::Snit_instance]
namespace ensemble configure $self -map {}
unset -nocomplain -- ${selfns}::Snit_cgetCache
unset -nocomplain -- ${selfns}::Snit_configureCache
unset -nocomplain -- ${selfns}::Snit_validateCache
}
#-----------------------------------------------------------------------
# Component Installation
# Implements %TYPE%::installhull. The variables self and selfns
# must be defined in the caller's context.
#
# Installs the named widget as the hull of a
# widgetadaptor. Once the widget is hijacked, its new name
# is assigned to the hull component.
proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
variable ${type}::Snit_info
variable ${type}::Snit_optionInfo
upvar 1 self self
upvar 1 selfns selfns
namespace upvar $selfns \
hull hull \
options options
# FIRST, make sure we can do it.
if {!$Snit_info(isWidget)} {
error "installhull is valid only for snit::widgetadaptors"
}
if {[info exists ${selfns}::Snit_instance]} {
error "hull already installed for $type $self"
}
# NEXT, has it been created yet? If not, create it using
# the specified arguments.
if {"using" == $using} {
# FIRST, create the widget
set cmd [linsert $args 0 $widgetType $self]
set obj [uplevel 1 $cmd]
# NEXT, for each option explicitly delegated to the hull
# that doesn't appear in the usedOpts list, get the
# option database value and apply it--provided that the
# real option name and the target option name are different.
# (If they are the same, then the option database was
# already queried as part of the normal widget creation.)
#
# Also, we don't need to worry about implicitly delegated
# options, as the option and target option names must be
# the same.
if {[info exists Snit_optionInfo(delegated-hull)]} {
# FIRST, extract all option names from args
set usedOpts {}
set ndx [lsearch -glob $args "-*"]
foreach {opt val} [lrange $args $ndx end] {
lappend usedOpts $opt
}
foreach opt $Snit_optionInfo(delegated-hull) {
set target [lindex $Snit_optionInfo(target-$opt) 1]
if {"$target" == $opt} {
continue
}
set result [lsearch -exact $usedOpts $target]
if {$result != -1} {
continue
}
set dbval [RT.OptionDbGet $type $self $opt]
$obj configure $target $dbval
}
}
} else {
set obj $using
if {$obj ne $self} {
error \
"hull name mismatch: \"$obj\" != \"$self\""
}
}
# NEXT, get the local option defaults.
foreach opt $Snit_optionInfo(local) {
set dbval [RT.OptionDbGet $type $self $opt]
if {"" != $dbval} {
set options($opt) $dbval
}
}
# NEXT, do the magic
set i 0
while 1 {
incr i
set newName "::hull${i}$self"
if {![llength [info commands $newName]]} {
break
}
}
rename ::$self $newName
RT.MakeInstanceCommand $type $selfns $self
# Note: this relies on RT.ComponentTrace to do the dirty work.
set hull $newName
return
}
# Implements %TYPE%::install.
#
# Creates a widget and installs it as the named component.
# It expects self and selfns to be defined in the caller's context.
proc ::snit::RT.install {type compName "using" widgetType winPath args} {
variable ${type}::Snit_optionInfo
variable ${type}::Snit_info
upvar 1 self self
upvar 1 selfns selfns
namespace upvar ${selfns} \
$compName comp \
hull hull
# We do the magic option database stuff only if $self is
# a widget.
if {$Snit_info(isWidget)} {
if {"" == $hull} {
error "tried to install \"$compName\" before the hull exists"
}
# FIRST, query the option database and save the results
# into args. Insert them before the first option in the
# list, in case there are any non-standard parameters.
#
# Note: there might not be any delegated options; if so,
# don't bother.
if {[info exists Snit_optionInfo(delegated-$compName)]} {
set ndx [lsearch -glob $args "-*"]
foreach opt $Snit_optionInfo(delegated-$compName) {
set dbval [RT.OptionDbGet $type $self $opt]
if {"" != $dbval} {
set target [lindex $Snit_optionInfo(target-$opt) 1]
set args [linsert $args $ndx $target $dbval]
}
}
}
}
# NEXT, create the component and save it.
set cmd [concat [list $widgetType $winPath] $args]
set comp [uplevel 1 $cmd]
# NEXT, handle the option database for "delegate option *",
# in widgets only.
if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} {
# FIRST, get the list of option specs from the widget.
# If configure doesn't work, skip it.
if {[catch {$comp configure} specs]} {
return
}
# NEXT, get the set of explicitly used options from args
set usedOpts {}
set ndx [lsearch -glob $args "-*"]
foreach {opt val} [lrange $args $ndx end] {
lappend usedOpts $opt
}
# NEXT, "delegate option *" matches all options defined
# by this widget that aren't defined by the widget as a whole,
# and that aren't excepted. Plus, we skip usedOpts. So build
# a list of the options it can't match.
set skiplist [concat \
$usedOpts \
$Snit_optionInfo(except) \
$Snit_optionInfo(local) \
$Snit_optionInfo(delegated)]
# NEXT, loop over all of the component's options, and set
# any not in the skip list for which there is an option
# database value.
foreach spec $specs {
# Skip aliases
if {[llength $spec] != 5} {
continue
}
set opt [lindex $spec 0]
if {[lsearch -exact $skiplist $opt] != -1} {
continue
}
set res [lindex $spec 1]
set cls [lindex $spec 2]
set dbvalue [option get $self $res $cls]
if {"" != $dbvalue} {
$comp configure $opt $dbvalue
}
}
}
return
}
#-----------------------------------------------------------------------
# Method/Variable Name Qualification
# Implements %TYPE%::variable. Requires selfns.
proc ::snit::RT.variable {varname} {
upvar 1 selfns selfns
if {![string match "::*" $varname]} {
uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
} else {
# varname is fully qualified; let the standard
# "variable" command handle it.
uplevel 1 [list ::variable $varname]
}
}
# Fully qualifies a typevariable name.
#
# This is used to implement the mytypevar command.
proc ::snit::RT.mytypevar {type name} {
return ${type}::$name
}
# Fully qualifies an instance variable name.
#
# This is used to implement the myvar command.
proc ::snit::RT.myvar {name} {
upvar 1 selfns selfns
return ${selfns}::$name
}
# Use this like "list" to convert a proc call into a command
# string to pass to another object (e.g., as a -command).
# Qualifies the proc name properly.
#
# This is used to implement the "myproc" command.
proc ::snit::RT.myproc {type procname args} {
set procname "${type}::$procname"
return [linsert $args 0 $procname]
}
# DEPRECATED
proc ::snit::RT.codename {type name} {
return "${type}::$name"
}
# Use this like "list" to convert a typemethod call into a command
# string to pass to another object (e.g., as a -command).
# Inserts the type command at the beginning.
#
# This is used to implement the "mytypemethod" command.
proc ::snit::RT.mytypemethod {type args} {
return [linsert $args 0 $type]
}
# Use this like "list" to convert a method call into a command
# string to pass to another object (e.g., as a -command).
# Inserts the code at the beginning to call the right object, even if
# the object's name has changed. Requires that selfns be defined
# in the calling context, eg. can only be called in instance
# code.
#
# This is used to implement the "mymethod" command.
proc ::snit::RT.mymethod {args} {
upvar 1 selfns selfns
return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
}
# Calls an instance method for an object given its
# instance namespace and remaining arguments (the first of which
# will be the method name.
#
# selfns The instance namespace
# args The arguments
#
# Uses the selfns to determine $self, and calls the method
# in the normal way.
#
# This is used to implement the "mymethod" command.
proc ::snit::RT.CallInstance {selfns args} {
namespace upvar $selfns Snit_instance self
set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
if {$retval} {
if {$retval == 1} {
global errorInfo
global errorCode
return -code error -errorinfo $errorInfo \
-errorcode $errorCode $result
} else {
return -code $retval $result
}
}
return $result
}
# Looks for the named option in the named variable. If found,
# it and its value are removed from the list, and the value
# is returned. Otherwise, the default value is returned.
# If the option is undelegated, it's own default value will be
# used if none is specified.
#
# Implements the "from" command.
proc ::snit::RT.from {type argvName option {defvalue ""}} {
namespace upvar $type Snit_optionInfo Snit_optionInfo
upvar $argvName argv
set ioption [lsearch -exact $argv $option]
if {$ioption == -1} {
if {"" == $defvalue &&
[info exists Snit_optionInfo(default-$option)]} {
return $Snit_optionInfo(default-$option)
} else {
return $defvalue
}
}
set ivalue [expr {$ioption + 1}]
set value [lindex $argv $ivalue]
set argv [lreplace $argv $ioption $ivalue]
return $value
}
#-----------------------------------------------------------------------
# Type Destruction
# Implements the standard "destroy" typemethod:
# Destroys a type completely.
#
# type The snit type
proc ::snit::RT.typemethod.destroy {type} {
variable ${type}::Snit_info
# FIRST, destroy all instances
foreach selfns [namespace children $type "${type}::Snit_inst*"] {
if {![namespace exists $selfns]} {
continue
}
namespace upvar $selfns Snit_instance obj
if {$Snit_info(isWidget)} {
destroy $obj
} else {
if {[llength [info commands $obj]]} {
$obj destroy
}
}
}
# NEXT, get rid of the type command.
rename $type ""
# NEXT, destroy the type's data.
namespace delete $type
}
#-----------------------------------------------------------------------
# Option Handling
# Implements the standard "cget" method
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# option The name of the option
proc ::snit::RT.method.cget {type selfns win self option} {
if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
if {[llength $command] == 0} {
return -code error "unknown option \"$option\""
}
}
uplevel 1 $command
}
# Retrieves and caches the command that implements "cget" for the
# specified option.
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# option The name of the option
proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
variable ${type}::Snit_optionInfo
variable ${selfns}::Snit_cgetCache
if {[info exists Snit_optionInfo(islocal-$option)]} {
# We know the item; it's either local, or explicitly delegated.
if {$Snit_optionInfo(islocal-$option)} {
# It's a local option. If it has a cget method defined,
# use it; otherwise just return the value.
if {$Snit_optionInfo(cget-$option) eq ""} {
set command [list set ${selfns}::options($option)]
} else {
# WHD: Snit 2.0 code -- simpler, no slower.
set command [list \
$self \
{*}$Snit_optionInfo(cget-$option) \
$option]
}
set Snit_cgetCache($option) $command
return $command
}
# Explicitly delegated option; get target
set comp [lindex $Snit_optionInfo(target-$option) 0]
set target [lindex $Snit_optionInfo(target-$option) 1]
} elseif {$Snit_optionInfo(starcomp) ne "" &&
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
# Unknown option, but unknowns are delegated; get target.
set comp $Snit_optionInfo(starcomp)
set target $option
} else {
return ""
}
# Get the component's object.
set obj [RT.Component $type $selfns $comp]
set command [list $obj cget $target]
set Snit_cgetCache($option) $command
return $command
}
# Implements the standard "configurelist" method
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# optionlist A list of options and their values.
proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
variable ${type}::Snit_optionInfo
foreach {option value} $optionlist {
# FIRST, get the configure command, caching it if need be.
if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
set command [snit::RT.CacheConfigureCommand \
$type $selfns $win $self $option]
if {[llength $command] == 0} {
return -code error "unknown option \"$option\""
}
}
# NEXT, if we have a type-validation object, use it.
# TBD: Should test (islocal-$option) here, but islocal
# isn't defined for implicitly delegated options.
if {[info exists Snit_optionInfo(typeobj-$option)]
&& $Snit_optionInfo(typeobj-$option) ne ""} {
if {[catch {
$Snit_optionInfo(typeobj-$option) validate $value
} result]} {
return -code error "invalid $option value: $result"
}
}
# NEXT, the caching the configure command also cached the
# validate command, if any. If we have one, run it.
set valcommand [set ${selfns}::Snit_validateCache($option)]
if {[llength $valcommand]} {
lappend valcommand $value
uplevel 1 $valcommand
}
# NEXT, configure the option with the value.
lappend command $value
uplevel 1 $command
}
return
}
# Retrieves and caches the command that stores the named option.
# Also stores the command that validates the name option if any;
# If none, the validate command is "", so that the cache is always
# populated.
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# option An option name
proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
variable ${type}::Snit_optionInfo
variable ${selfns}::Snit_configureCache
variable ${selfns}::Snit_validateCache
if {[info exist Snit_optionInfo(islocal-$option)]} {
# We know the item; it's either local, or explicitly delegated.
if {$Snit_optionInfo(islocal-$option)} {
# It's a local option.
# If it's readonly, it throws an error if we're already
# constructed.
if {$Snit_optionInfo(readonly-$option)} {
if {[set ${selfns}::Snit_iinfo(constructed)]} {
error "option $option can only be set at instance creation"
}
}
# If it has a validate method, cache that for later.
if {$Snit_optionInfo(validate-$option) ne ""} {
# WHD: Snit 2.0 code -- simpler, no slower.
set command [list \
$self \
{*}$Snit_optionInfo(validate-$option) \
$option]
set Snit_validateCache($option) $command
} else {
set Snit_validateCache($option) ""
}
# If it has a configure method defined,
# cache it; otherwise, just set the value.
if {$Snit_optionInfo(configure-$option) eq ""} {
set command [list set ${selfns}::options($option)]
} else {
# WHD: Snit 2.0 code -- simpler, no slower.
set command [list \
$self \
{*}$Snit_optionInfo(configure-$option) \
$option]
}
set Snit_configureCache($option) $command
return $command
}
# Delegated option: get target.
set comp [lindex $Snit_optionInfo(target-$option) 0]
set target [lindex $Snit_optionInfo(target-$option) 1]
} elseif {$Snit_optionInfo(starcomp) != "" &&
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
# Unknown option, but unknowns are delegated.
set comp $Snit_optionInfo(starcomp)
set target $option
} else {
return ""
}
# There is no validate command in this case; save an empty string.
set Snit_validateCache($option) ""
# Get the component's object
set obj [RT.Component $type $selfns $comp]
set command [list $obj configure $target]
set Snit_configureCache($option) $command
return $command
}
# Implements the standard "configure" method
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# args A list of options and their values, possibly empty.
proc ::snit::RT.method.configure {type selfns win self args} {
# If two or more arguments, set values as usual.
if {[llength $args] >= 2} {
::snit::RT.method.configurelist $type $selfns $win $self $args
return
}
# If zero arguments, acquire data for each known option
# and return the list
if {[llength $args] == 0} {
set result {}
foreach opt [RT.method.info.options $type $selfns $win $self] {
# Refactor this, so that we don't need to call via $self.
lappend result [RT.GetOptionDbSpec \
$type $selfns $win $self $opt]
}
return $result
}
# They want it for just one.
set opt [lindex $args 0]
return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
}
# Retrieves the option database spec for a single option.
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# option The name of an option
#
# TBD: This is a bad name. What it's returning is the
# result of the configure query.
proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
variable ${type}::Snit_optionInfo
namespace upvar $selfns \
Snit_components Snit_components \
options options
if {[info exists options($opt)]} {
# This is a locally-defined option. Just build the
# list and return it.
set res $Snit_optionInfo(resource-$opt)
set cls $Snit_optionInfo(class-$opt)
set def $Snit_optionInfo(default-$opt)
return [list $opt $res $cls $def \
[RT.method.cget $type $selfns $win $self $opt]]
} elseif {[info exists Snit_optionInfo(target-$opt)]} {
# This is an explicitly delegated option. The only
# thing we don't have is the default.
set res $Snit_optionInfo(resource-$opt)
set cls $Snit_optionInfo(class-$opt)
# Get the default
set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
set comp $Snit_components($logicalName)
set target [lindex $Snit_optionInfo(target-$opt) 1]
if {[catch {$comp configure $target} result]} {
set defValue {}
} else {
set defValue [lindex $result 3]
}
return [list $opt $res $cls $defValue [$self cget $opt]]
} elseif {$Snit_optionInfo(starcomp) ne "" &&
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
set logicalName $Snit_optionInfo(starcomp)
set target $opt
set comp $Snit_components($logicalName)
if {[catch {set value [$comp cget $target]} result]} {
error "unknown option \"$opt\""
}
if {![catch {$comp configure $target} result]} {
# Replace the delegated option name with the local name.
return [::snit::Expand $result $target $opt]
}
# configure didn't work; return simple form.
return [list $opt "" "" "" $value]
} else {
error "unknown option \"$opt\""
}
}
#-----------------------------------------------------------------------
# Type Introspection
# Implements the standard "info" typemethod.
#
# type The snit type
# command The info subcommand
# args All other arguments.
proc ::snit::RT.typemethod.info {type command args} {
global errorInfo
global errorCode
switch -exact $command {
args -
body -
default -
typevars -
typemethods -
instances {
# TBD: it should be possible to delete this error
# handling.
set errflag [catch {
uplevel 1 [linsert $args 0 \
::snit::RT.typemethod.info.$command $type]
} result]
if {$errflag} {
return -code error -errorinfo $errorInfo \
-errorcode $errorCode $result
} else {
return $result
}
}
default {
error "\"$type info $command\" is not defined"
}
}
}
# Returns a list of the type's typevariables whose names match a
# pattern, excluding Snit internal variables.
#
# type A Snit type
# pattern Optional. The glob pattern to match. Defaults
# to *.
proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
set result {}
foreach name [info vars "${type}::$pattern"] {
set tail [namespace tail $name]
if {![string match "Snit_*" $tail]} {
lappend result $name
}
}
return $result
}
# Returns a list of the type's methods whose names match a
# pattern. If "delegate typemethod *" is used, the list may
# not be complete.
#
# type A Snit type
# pattern Optional. The glob pattern to match. Defaults
# to *.
proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
variable ${type}::Snit_typemethodInfo
# FIRST, get the explicit names, skipping prefixes.
set result {}
foreach name [array names Snit_typemethodInfo -glob $pattern] {
if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
lappend result $name
}
}
# NEXT, add any from the cache that aren't explicit.
# WHD: fixed up to use newstyle method cache/list of subcommands.
if {[info exists Snit_typemethodInfo(*)]} {
# First, remove "*" from the list.
set ndx [lsearch -exact $result "*"]
if {$ndx != -1} {
set result [lreplace $result $ndx $ndx]
}
# Next, get the type's -map
array set typemethodCache [namespace ensemble configure $type -map]
# Next, get matching names from the cache that we don't already
# know about.
foreach name [array names typemethodCache -glob $pattern] {
if {[lsearch -exact $result $name] == -1} {
lappend result $name
}
}
}
return $result
}
# $type info args
#
# Returns a method's list of arguments. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.typemethod.info.args {type method} {
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
#parray Snit_typemethodInfo
if {![info exists Snit_typemethodInfo($method)]} {
return -code error "Unknown typemethod \"$method\""
}
foreach {flag cmd component} $Snit_typemethodInfo($method) break
if {$flag} {
return -code error "Unknown typemethod \"$method\""
}
if {$component != ""} {
return -code error "Delegated typemethod \"$method\""
}
set map [list %m $method %j [join $method _] %t $type]
set theproc [lindex [string map $map $cmd] 0]
return [lrange [::info args $theproc] 1 end]
}
# $type info body
#
# Returns a method's body. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.typemethod.info.body {type method} {
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
#parray Snit_typemethodInfo
if {![info exists Snit_typemethodInfo($method)]} {
return -code error "Unknown typemethod \"$method\""
}
foreach {flag cmd component} $Snit_typemethodInfo($method) break
if {$flag} {
return -code error "Unknown typemethod \"$method\""
}
if {$component != ""} {
return -code error "Delegated typemethod \"$method\""
}
set map [list %m $method %j [join $method _] %t $type]
set theproc [lindex [string map $map $cmd] 0]
return [RT.body [::info body $theproc]]
}
# $type info default
#
# Returns a method's list of arguments. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.typemethod.info.default {type method aname dvar} {
upvar 1 $dvar def
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
#parray Snit_methodInfo
if {![info exists Snit_typemethodInfo($method)]} {
return -code error "Unknown typemethod \"$method\""
}
foreach {flag cmd component} $Snit_typemethodInfo($method) break
if {$flag} {
return -code error "Unknown typemethod \"$method\""
}
if {$component != ""} {
return -code error "Delegated typemethod \"$method\""
}
set map [list %m $method %j [join $method _] %t $type]
set theproc [lindex [string map $map $cmd] 0]
return [::info default $theproc $aname def]
}
# Returns a list of the type's instances whose names match
# a pattern.
#
# type A Snit type
# pattern Optional. The glob pattern to match
# Defaults to *
#
# REQUIRE: type is fully qualified.
proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
set result {}
foreach selfns [namespace children $type "${type}::Snit_inst*"] {
namespace upvar $selfns Snit_instance instance
if {[string match $pattern $instance]} {
lappend result $instance
}
}
return $result
}
#-----------------------------------------------------------------------
# Instance Introspection
# Implements the standard "info" method.
#
# type The snit type
# selfns The instance's instance namespace
# win The instance's original name
# self The instance's current name
# command The info subcommand
# args All other arguments.
proc ::snit::RT.method.info {type selfns win self command args} {
switch -exact $command {
args -
body -
default -
type -
vars -
options -
methods -
typevars -
typemethods {
set errflag [catch {
uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
$type $selfns $win $self]
} result]
if {$errflag} {
global errorInfo
return -code error -errorinfo $errorInfo $result
} else {
return $result
}
}
default {
# error "\"$self info $command\" is not defined"
return -code error "\"$self info $command\" is not defined"
}
}
}
# $self info type
#
# Returns the instance's type
proc ::snit::RT.method.info.type {type selfns win self} {
return $type
}
# $self info typevars
#
# Returns the instance's type's typevariables
proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
return [RT.typemethod.info.typevars $type $pattern]
}
# $self info typemethods
#
# Returns the instance's type's typemethods
proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
return [RT.typemethod.info.typemethods $type $pattern]
}
# Returns a list of the instance's methods whose names match a
# pattern. If "delegate method *" is used, the list may
# not be complete.
#
# type A Snit type
# selfns The instance namespace
# win The original instance name
# self The current instance name
# pattern Optional. The glob pattern to match. Defaults
# to *.
proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
variable ${type}::Snit_methodInfo
# FIRST, get the explicit names, skipping prefixes.
set result {}
foreach name [array names Snit_methodInfo -glob $pattern] {
if {[lindex $Snit_methodInfo($name) 0] != 1} {
lappend result $name
}
}
# NEXT, add any from the cache that aren't explicit.
# WHD: Fixed up to use newstyle method cache/list of subcommands.
if {[info exists Snit_methodInfo(*)]} {
# First, remove "*" from the list.
set ndx [lsearch -exact $result "*"]
if {$ndx != -1} {
set result [lreplace $result $ndx $ndx]
}
# Next, get the instance's -map
set self [set ${selfns}::Snit_instance]
array set methodCache [namespace ensemble configure $self -map]
# Next, get matching names from the cache that we don't already
# know about.
foreach name [array names methodCache -glob $pattern] {
if {[lsearch -exact $result $name] == -1} {
lappend result $name
}
}
}
return $result
}
# $self info args
#
# Returns a method's list of arguments. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.method.info.args {type selfns win self method} {
upvar ${type}::Snit_methodInfo Snit_methodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
#parray Snit_methodInfo
if {![info exists Snit_methodInfo($method)]} {
return -code error "Unknown method \"$method\""
}
foreach {flag cmd component} $Snit_methodInfo($method) break
if {$flag} {
return -code error "Unknown method \"$method\""
}
if {$component != ""} {
return -code error "Delegated method \"$method\""
}
set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
set theproc [lindex [string map $map $cmd] 0]
return [lrange [::info args $theproc] 4 end]
}
# $self info body
#
# Returns a method's body. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.method.info.body {type selfns win self method} {
upvar ${type}::Snit_methodInfo Snit_methodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
#parray Snit_methodInfo
if {![info exists Snit_methodInfo($method)]} {
return -code error "Unknown method \"$method\""
}
foreach {flag cmd component} $Snit_methodInfo($method) break
if {$flag} {
return -code error "Unknown method \"$method\""
}
if {$component != ""} {
return -code error "Delegated method \"$method\""
}
set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
set theproc [lindex [string map $map $cmd] 0]
return [RT.body [::info body $theproc]]
}
# $self info default
#
# Returns a method's list of arguments. does not work for delegated
# methods, nor for the internal dispatch methods of multi-word
# methods.
proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
upvar 1 $dvar def
upvar ${type}::Snit_methodInfo Snit_methodInfo
# Snit_methodInfo: method -> list (flag cmd component)
# flag : 1 -> internal dispatcher for multi-word method.
# 0 -> regular method
#
# cmd : template mapping from method to command prefix, may
# contain placeholders for various pieces of information.
#
# component : is empty for normal methods.
if {![info exists Snit_methodInfo($method)]} {
return -code error "Unknown method \"$method\""
}
foreach {flag cmd component} $Snit_methodInfo($method) break
if {$flag} {
return -code error "Unknown method \"$method\""
}
if {$component != ""} {
return -code error "Delegated method \"$method\""
}
set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
set theproc [lindex [string map $map $cmd] 0]
return [::info default $theproc $aname def]
}
# $self info vars
#
# Returns the instance's instance variables
proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
set result {}
foreach name [info vars "${selfns}::$pattern"] {
set tail [namespace tail $name]
if {![string match "Snit_*" $tail]} {
lappend result $name
}
}
return $result
}
# $self info options
#
# Returns a list of the names of the instance's options
proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
variable ${type}::Snit_optionInfo
# First, get the local and explicitly delegated options
set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
# If "configure" works as for Tk widgets, add the resulting
# options to the list. Skip excepted options
if {$Snit_optionInfo(starcomp) ne ""} {
namespace upvar $selfns Snit_components Snit_components
set logicalName $Snit_optionInfo(starcomp)
set comp $Snit_components($logicalName)
if {![catch {$comp configure} records]} {
foreach record $records {
set opt [lindex $record 0]
if {[lsearch -exact $result $opt] == -1 &&
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
lappend result $opt
}
}
}
}
# Next, apply the pattern
set names {}
foreach name $result {
if {[string match $pattern $name]} {
lappend names $name
}
}
return $names
}
proc ::snit::RT.body {body} {
regsub -all ".*# END snit method prolog\n" $body {} body
return $body
}
#-- From validate.tcl
#-----------------------------------------------------------------------
# TITLE:
# validate.tcl
#
# AUTHOR:
# Will Duquette
#
# DESCRIPTION:
# Snit validation types.
#
#-----------------------------------------------------------------------
namespace eval ::snit:: {
namespace export \
boolean \
double \
enum \
fpixels \
integer \
listtype \
pixels \
stringtype \
window
}
#-----------------------------------------------------------------------
# snit::boolean
snit::type ::snit::boolean {
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {![string is boolean -strict $value]} {
return -code error -errorcode INVALID \
"invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
# None needed; no options
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
$type validate $value
}
}
#-----------------------------------------------------------------------
# snit::double
snit::type ::snit::double {
#-------------------------------------------------------------------
# Options
# -min value
#
# Minimum value
option -min -default "" -readonly 1
# -max value
#
# Maximum value
option -max -default "" -readonly 1
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {![string is double -strict $value]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", expected double"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
if {"" != $options(-min) &&
![string is double -strict $options(-min)]} {
return -code error \
"invalid -min: \"$options(-min)\""
}
if {"" != $options(-max) &&
![string is double -strict $options(-max)]} {
return -code error \
"invalid -max: \"$options(-max)\""
}
if {"" != $options(-min) &&
"" != $options(-max) &&
$options(-max) < $options(-min)} {
return -code error "-max < -min"
}
}
#-------------------------------------------------------------------
# Public Methods
# Fixed method for the snit::double type.
# WHD, 6/7/2010.
method validate {value} {
$type validate $value
if {("" != $options(-min) && $value < $options(-min)) ||
("" != $options(-max) && $value > $options(-max))} {
set msg "invalid value \"$value\", expected double"
if {"" != $options(-min) && "" != $options(-max)} {
append msg " in range $options(-min), $options(-max)"
} elseif {"" != $options(-min)} {
append msg " no less than $options(-min)"
} elseif {"" != $options(-max)} {
append msg " no greater than $options(-max)"
}
return -code error -errorcode INVALID $msg
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::enum
snit::type ::snit::enum {
#-------------------------------------------------------------------
# Options
# -values list
#
# Valid values for this type
option -values -default {} -readonly 1
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
# No -values specified; it's always valid
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
$self configurelist $args
if {[llength $options(-values)] == 0} {
return -code error \
"invalid -values: \"\""
}
}
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
if {[lsearch -exact $options(-values) $value] == -1} {
return -code error -errorcode INVALID \
"invalid value \"$value\", should be one of: [join $options(-values) {, }]"
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::fpixels
snit::type ::snit::fpixels {
#-------------------------------------------------------------------
# Options
# -min value
#
# Minimum value
option -min -default "" -readonly 1
# -max value
#
# Maximum value
option -max -default "" -readonly 1
#-------------------------------------------------------------------
# Instance variables
variable min "" ;# -min, no suffix
variable max "" ;# -max, no suffix
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {[catch {winfo fpixels . $value} dummy]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", expected fpixels"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
if {"" != $options(-min) &&
[catch {winfo fpixels . $options(-min)} min]} {
return -code error \
"invalid -min: \"$options(-min)\""
}
if {"" != $options(-max) &&
[catch {winfo fpixels . $options(-max)} max]} {
return -code error \
"invalid -max: \"$options(-max)\""
}
if {"" != $min &&
"" != $max &&
$max < $min} {
return -code error "-max < -min"
}
}
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
$type validate $value
set val [winfo fpixels . $value]
if {("" != $min && $val < $min) ||
("" != $max && $val > $max)} {
set msg "invalid value \"$value\", expected fpixels"
if {"" != $min && "" != $max} {
append msg " in range $options(-min), $options(-max)"
} elseif {"" != $min} {
append msg " no less than $options(-min)"
}
return -code error -errorcode INVALID $msg
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::integer
snit::type ::snit::integer {
#-------------------------------------------------------------------
# Options
# -min value
#
# Minimum value
option -min -default "" -readonly 1
# -max value
#
# Maximum value
option -max -default "" -readonly 1
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {![string is integer -strict $value]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", expected integer"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
if {"" != $options(-min) &&
![string is integer -strict $options(-min)]} {
return -code error \
"invalid -min: \"$options(-min)\""
}
if {"" != $options(-max) &&
![string is integer -strict $options(-max)]} {
return -code error \
"invalid -max: \"$options(-max)\""
}
if {"" != $options(-min) &&
"" != $options(-max) &&
$options(-max) < $options(-min)} {
return -code error "-max < -min"
}
}
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
$type validate $value
if {("" != $options(-min) && $value < $options(-min)) ||
("" != $options(-max) && $value > $options(-max))} {
set msg "invalid value \"$value\", expected integer"
if {"" != $options(-min) && "" != $options(-max)} {
append msg " in range $options(-min), $options(-max)"
} elseif {"" != $options(-min)} {
append msg " no less than $options(-min)"
}
return -code error -errorcode INVALID $msg
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::list
snit::type ::snit::listtype {
#-------------------------------------------------------------------
# Options
# -type type
#
# Specifies a value type
option -type -readonly 1
# -minlen len
#
# Minimum list length
option -minlen -readonly 1 -default 0
# -maxlen len
#
# Maximum list length
option -maxlen -readonly 1
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {[catch {llength $value} result]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", expected list"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
if {"" != $options(-minlen) &&
(![string is integer -strict $options(-minlen)] ||
$options(-minlen) < 0)} {
return -code error \
"invalid -minlen: \"$options(-minlen)\""
}
if {"" == $options(-minlen)} {
set options(-minlen) 0
}
if {"" != $options(-maxlen) &&
![string is integer -strict $options(-maxlen)]} {
return -code error \
"invalid -maxlen: \"$options(-maxlen)\""
}
if {"" != $options(-maxlen) &&
$options(-maxlen) < $options(-minlen)} {
return -code error "-maxlen < -minlen"
}
}
#-------------------------------------------------------------------
# Methods
method validate {value} {
$type validate $value
set len [llength $value]
if {$len < $options(-minlen)} {
return -code error -errorcode INVALID \
"value has too few elements; at least $options(-minlen) expected"
} elseif {"" != $options(-maxlen)} {
if {$len > $options(-maxlen)} {
return -code error -errorcode INVALID \
"value has too many elements; no more than $options(-maxlen) expected"
}
}
# NEXT, check each value
if {"" != $options(-type)} {
foreach item $value {
set cmd $options(-type)
lappend cmd validate $item
uplevel \#0 $cmd
}
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::pixels
snit::type ::snit::pixels {
#-------------------------------------------------------------------
# Options
# -min value
#
# Minimum value
option -min -default "" -readonly 1
# -max value
#
# Maximum value
option -max -default "" -readonly 1
#-------------------------------------------------------------------
# Instance variables
variable min "" ;# -min, no suffix
variable max "" ;# -max, no suffix
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {[catch {winfo pixels . $value} dummy]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", expected pixels"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
if {"" != $options(-min) &&
[catch {winfo pixels . $options(-min)} min]} {
return -code error \
"invalid -min: \"$options(-min)\""
}
if {"" != $options(-max) &&
[catch {winfo pixels . $options(-max)} max]} {
return -code error \
"invalid -max: \"$options(-max)\""
}
if {"" != $min &&
"" != $max &&
$max < $min} {
return -code error "-max < -min"
}
}
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
$type validate $value
set val [winfo pixels . $value]
if {("" != $min && $val < $min) ||
("" != $max && $val > $max)} {
set msg "invalid value \"$value\", expected pixels"
if {"" != $min && "" != $max} {
append msg " in range $options(-min), $options(-max)"
} elseif {"" != $min} {
append msg " no less than $options(-min)"
}
return -code error -errorcode INVALID $msg
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::stringtype
snit::type ::snit::stringtype {
#-------------------------------------------------------------------
# Options
# -minlen len
#
# Minimum list length
option -minlen -readonly 1 -default 0
# -maxlen len
#
# Maximum list length
option -maxlen -readonly 1
# -nocase 0|1
#
# globs and regexps are case-insensitive if -nocase 1.
option -nocase -readonly 1 -default 0
# -glob pattern
#
# Glob-match pattern, or ""
option -glob -readonly 1
# -regexp regexp
#
# Regular expression to match
option -regexp -readonly 1
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
# By default, any string (hence, any Tcl value) is valid.
return $value
}
#-------------------------------------------------------------------
# Constructor
constructor {args} {
# FIRST, get the options
$self configurelist $args
# NEXT, validate -minlen and -maxlen
if {"" != $options(-minlen) &&
(![string is integer -strict $options(-minlen)] ||
$options(-minlen) < 0)} {
return -code error \
"invalid -minlen: \"$options(-minlen)\""
}
if {"" == $options(-minlen)} {
set options(-minlen) 0
}
if {"" != $options(-maxlen) &&
![string is integer -strict $options(-maxlen)]} {
return -code error \
"invalid -maxlen: \"$options(-maxlen)\""
}
if {"" != $options(-maxlen) &&
$options(-maxlen) < $options(-minlen)} {
return -code error "-maxlen < -minlen"
}
# NEXT, validate -nocase
if {[catch {snit::boolean validate $options(-nocase)} result]} {
return -code error "invalid -nocase: $result"
}
# Validate the glob
if {"" != $options(-glob) &&
[catch {string match $options(-glob) ""} dummy]} {
return -code error \
"invalid -glob: \"$options(-glob)\""
}
# Validate the regexp
if {"" != $options(-regexp) &&
[catch {regexp $options(-regexp) ""} dummy]} {
return -code error \
"invalid -regexp: \"$options(-regexp)\""
}
}
#-------------------------------------------------------------------
# Methods
method validate {value} {
# Usually we'd call [$type validate $value] here, but
# as it's a no-op, don't bother.
# FIRST, validate the length.
set len [string length $value]
if {$len < $options(-minlen)} {
return -code error -errorcode INVALID \
"too short: at least $options(-minlen) characters expected"
} elseif {"" != $options(-maxlen)} {
if {$len > $options(-maxlen)} {
return -code error -errorcode INVALID \
"too long: no more than $options(-maxlen) characters expected"
}
}
# NEXT, check the glob match, with or without case.
if {"" != $options(-glob)} {
if {$options(-nocase)} {
set result [string match -nocase $options(-glob) $value]
} else {
set result [string match $options(-glob) $value]
}
if {!$result} {
return -code error -errorcode INVALID \
"invalid value \"$value\""
}
}
# NEXT, check regexp match with or without case
if {"" != $options(-regexp)} {
if {$options(-nocase)} {
set result [regexp -nocase -- $options(-regexp) $value]
} else {
set result [regexp -- $options(-regexp) $value]
}
if {!$result} {
return -code error -errorcode INVALID \
"invalid value \"$value\""
}
}
return $value
}
}
#-----------------------------------------------------------------------
# snit::window
snit::type ::snit::window {
#-------------------------------------------------------------------
# Type Methods
typemethod validate {value} {
if {![winfo exists $value]} {
return -code error -errorcode INVALID \
"invalid value \"$value\", value is not a window"
}
return $value
}
#-------------------------------------------------------------------
# Constructor
# None needed; no options
#-------------------------------------------------------------------
# Public Methods
method validate {value} {
$type validate $value
}
}
#-- From shistory.tmp
package require snit
namespace eval ::dgtools {}
snit::type ::dgtools::shistory {
option -home ""
variable index -1
variable history
constructor {args} {
$self configurelist $args
set history [list]
}
method back {} {
incr index -1
return [lindex $history $index]
}
method canBackward {} {
if {$index > 0} {
return true
} else {
return false
}
}
method canFirst {} {
if {$index == 0} {
return false
} else {
return true
}
}
method canForward {} {
if {[llength $history] > [expr {$index+1}]} {
return true
} else {
return false
}
}
method canLast {} {
if {$index == [expr {[llength $history] -1}]} {
return false
} else {
return true
}
}
method current {} {
return [lindex $history $index]
}
method first {} {
set index 0
return [lindex $history $index]
}
method forward {} {
incr index +1
return [lindex $history $index]
}
method getHistory {} {
return $history
}
method insert {item} {
set item [regsub {/$} $item ""]
if {$item ne [lindex $history $index]} {
incr index
if {$item ne [lindex $history $index]} {
set history [linsert $history $index $item]
} else {
incr index -1
}
}
return $item
}
method home {} {
return $options(-home)
}
method resetHistory {} {
set index -1
set history [list]
}
method last {} {
set index [llength $history]
incr index -1
return [lindex $history $index]
}
}
package provide dgtools::shistory 0.2
if {[info exists argv0] && $argv0 eq [info script] && [regexp {shistory} $argv0]} {
set dpath dgtools
set pfile [file rootname [file tail [info script]]]
package require dgtools::dgtutils
source [file join [file dirname [info script]] dgtutils.tcl]
if {[llength $argv] == 1 && [lindex $argv 0] eq "--version"} {
puts [dgtools::getVersion [info script]]
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--test"} {
package require tcltest
set argv [list]
tcltest::test dummy-1.1 {
Calling my proc should always return a list of at least length 3
} -body {
set result 1
} -result {1}
tcltest::test history-1.1 {
Starting a history
} -body {
set sh [::dgtools::shistory %AUTO% -home h]
return [$sh home]
} -result {h}
tcltest::test history-1.2 {
insert a value
} -body {
$sh insert a
return [$sh current]
} -result {a}
tcltest::test history-1.3 {
insert a value repeated
} -body {
$sh insert a
$sh insert a
$sh insert a
llength [$sh getHistory]
} -result {1}
tcltest::test history-1.4 {
can back with 1 item
} -body {
$sh canBackward
} -result {false}
tcltest::test history-1.5 {
can back with 2 items
} -body {
$sh insert b
$sh canBackward
} -result {true}
tcltest::test history-1.6 {
can forward at the end?
} -body {
$sh canForward
} -result {false}
tcltest::test history-1.7 {
can forward if going back?
} -body {
$sh back
$sh canForward
} -result {true}
tcltest::test history-1.8 {
insert in the middle
} -body {
$sh insert c
$sh insert c
$sh getHistory
} -result {a c b}
tcltest::test history-1.9 {
check first
} -body {
$sh first
} -result {a}
tcltest::test history-1.10 {
canBackward at first
} -body {
$sh canBackward
} -result {false}
tcltest::test history-1.11 {
canForward at first
} -body {
$sh canForward
} -result {true}
tcltest::test history-1.12 {
canForward at end
} -body {
$sh last
$sh canForward
} -result {false}
tcltest::test history-1.13 {
canBackward at last
} -body {
$sh canBackward
} -result {true}
tcltest::cleanupTests
} elseif {[llength $argv] == 1 && ([lindex $argv 0] eq "--license" || [lindex $argv 0] eq "--man" || [lindex $argv 0] eq "--html" || [lindex $argv 0] eq "--markdown")} {
dgtools::manual [lindex $argv 0] [info script]
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--install"} {
dgtools::install [info script]
} else {
puts "\n -------------------------------------"
puts " The dgtools::[file rootname [file tail [info script]]] package for Tcl"
puts " -------------------------------------\n"
puts "Copyright (c) 2019 Dr. Detlef Groth, E-mail: detlef(at)dgroth(dot)de\n"
puts "License: MIT - License see manual page"
puts "\nThe dgtools::[file rootname [file tail [info script]]] package provides a list with text entries which can used as"
puts "history data structure for programmers of the Tcl/Tk Programming language"
puts ""
puts "Usage: [info nameofexe] [info script] option\n"
puts " Valid options are:\n"
puts " --help : printing out this help page"
puts " --test : running some test code"
puts " --license : printing the license to the terminal"
puts " --install : install shistory as Tcl module"
puts " --man : printing the man page in pandoc markdown to the terminal"
puts " --markdown: printing the man page in simple markdown to the terminal"
puts " --html : printing the man page in html code to the terminal"
puts " if the Markdown package from tcllib is available"
puts " --version : printing the package version to the terminal"
puts ""
puts " The --man option can be used to generate the documentation pages as well with"
puts " a command like: "
puts ""
puts " tclsh [file tail [info script]] --man | pandoc -t html -s > temp.html\n"
}
}
#-- From dgwutils.tmp
package provide dgw::dgwutils 0.2
namespace eval dgw {
variable htmltemplate {
<!DOCTYPE html>
<html>
<head>
<meta http-equiv="Content-Security-Policy" content="default-src 'self' data: ; script-src 'self' 'nonce-d717cfb5d902616b7024920ae20346a8494f7832145c90e0' ; style-src 'self' 'unsafe-inline'" />
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<meta name="title" content="$document(title)">
<meta name="author" content="$document(author)">
<title>$document(title)</title>
<style>
body {
margin-left: 5%; margin-right: 5%;
font-family: Palatino, "Palatino Linotype", "Palatino LT STD", "Book Antiqua", Georgia, serif;
}
pre {
padding-top: 1ex;
padding-bottom: 1ex;
padding-left: 2ex;
padding-right: 1ex;
width: 100%;
color: black;
background: #ffefdf;
border-top: 1px solid #6A6A6A;
border-bottom: 1px solid #6A6A6A;
font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace;
}
pre.synopsis {
background: #ddefff;
}
code {
font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace;
}
h1 {
font-family: sans-serif;
font-size: 120%;
background: transparent;
text-align: center;
}
h3 {
font-family: sans-serif;
font-size: 110%;
background: transparent;
text-align: center;
}
h2 {
margin-top: 1em;
font-family: sans-serif;
font-size: 110%;
color: #005A9C;
text-align: left;
background-color: #eeeeee;
padding: 0.4em;
}
</style>
</head>
<body>
<div class="title"><h1>$document(title)</h1></div>
<div class="author"><h3>$document(author)</h3></div>
<div class="date"><h3>$document(date)</h3></div>
}
}
proc dgw::displayCode {fname} {
destroy .
set filename $fname
if [catch {open $filename r} infh] {
puts stderr "Cannot open $filename: $infh"
exit
} else {
set flag false
while {[gets $infh line] >= 0} {
if {[regexp {^\s+# DEMO START} $line]} {
set flag true
} elseif {[regexp {^\s+# DEMO END} $line]} {
break
} elseif {$flag} {
puts [string range $line 6 end]
}
}
close $infh
}
}
proc dgw::getVersion {fname} {
set basename [file rootname [file tail $fname]]
return [package present dgw::$basename]
}
proc dgw::runExample {fname {eval true}} {
set filename $fname
set example false
set excode false
set code ""
if [catch {open $filename r} infh] {
puts stderr "Cannot open $filename: $infh"
exit
} else {
while {[gets $infh line] >= 0} {
if {[regexp -nocase {^\s*#'\s+#{2,3}\s.+Example} $line]} {
set example true
} elseif {$example && [regexp {^\s*#'\s+```} $line]} {
set example false
set excode true
} elseif {$excode && [regexp {^\s*#'\s+```} $line]} {
if {$eval} {
namespace eval :: $code
} else {
return $code
}
break
} elseif {$excode && [regexp {^\s*#'\s(.+)} $line -> c]} {
append code "$c\n"
}
}
close $infh
}
return $code
}
proc dgw::manual {mode filename} {
variable htmltemplate
destroy .
set basename [file tail [file rootname $filename]]
set version [package provide dgw::$basename]
set markdown ""
if {$mode eq "--html"} {
if {[package version Markdown] eq ""} {
error "Error: For html mode you need package Markdown from tcllib. \nDownload and install tcllib from http://core.tcl.tk"
} else {
package require Markdown
}
}
if [catch {open $filename r} infh] {
puts stderr "Cannot open $filename: $infh"
exit
} else {
set flag false
while {[gets $infh line] >= 0} {
if {$mode eq "--license"} {
if {[regexp {^# LICENSE START} $line]} {
set flag true
continue
} elseif {$flag && [regexp {^\s*#' +#include +"(.*)"} $line -> include]} {
if [catch {open $include r} iinfh] {
puts stderr "Cannot open $filename: $include"
exit 0
} else {
while {[gets $iinfh iline] >= 0} {
set md $iline
set md [regsub -all {<.+?>} $md ""]
set md [regsub -all {^\s*## (.+)} $md "\\1\n[string repeat - 15]"]
set md [regsub -all {__PKGNAME__} $md dgw::$basename]
set md [regsub -all {__BASENAME__} $md $basename]
set md [regsub -all {__PKGVERSION__} $md $version]
set md [regsub -all {__DATE__} $md [clock format [clock seconds] -format "%Y-%m-%d"]]
puts "$md"
}
close $iinfh
}
} elseif {$flag && [regexp {^# LICENSE END} $line]} {
puts ""
break
} elseif {$flag} {
set line [regsub -all {__PKGNAME__} $line dgw::$basename]
set line [regsub -all {__BASENAME__} $line $basename]
set line [regsub -all {__PKGVERSION__} $line $version]
set line [regsub -all {__DATE__} $line [clock format [clock seconds] -format "%Y-%m-%d"]]
puts [string range $line 2 end]
}
} else {
if {[regexp {^\s*#' +#include +"(.*)"} $line -> include]} {
puts "including $include"
if [catch {open $include r} iinfh] {
puts stderr "Cannot open $filename: $include"
exit 0
} else {
while {[gets $iinfh iline] >= 0} {
set md "$iline"
set md [regsub -all {__PKGNAME__} $md dgw::$basename]
set md [regsub -all {__BASENAME__} $md $basename]
set md [regsub -all {__PKGVERSION__} $md $version]
set md [regsub -all {__DATE__} $md [clock format [clock seconds] -format "%Y-%m-%d"]]
if {$mode eq "--man"} {
puts "$md"
} else {
append markdown "$md\n"
}
}
close $iinfh
}
} elseif {[regexp {^\s*#' ?(.*)} $line -> md]} {
set md [regsub -all {__PKGNAME__} $md dgw::$basename]
set md [regsub -all {__BASENAME__} $md $basename]
set md [regsub -all {__PKGVERSION__} $md $version]
set md [regsub -all {__DATE__} $md [clock format [clock seconds] -format "%Y-%m-%d"]]
if {$mode eq "--man"} {
puts "$md"
} else {
append markdown "$md\n"
}
}
}
}
close $infh
if {$mode eq "--html" || $mode eq "--markdown"} {
set titleflag false
array set document [list title "Documentation" author "NN" date [clock format [clock seconds] -format "%Y-%m-%d"]]
set mdhtml ""
set indent ""
set header $htmltemplate
foreach line [split $markdown "\n"] {
if {$titleflag && [regexp {^---} $line]} {
set titleflag false
set header [subst -nobackslashes -nocommands $header]
} elseif {$titleflag} {
if {[regexp {^([a-z]+): +(.+)} $line -> key value]} {
set document($key) $value
}
} elseif {[regexp {^---} $line]} {
set titleflag true
} elseif {[regexp {^```} $line] && $indent eq ""} {
append mdhtml "\n"
set indent " "
} elseif {[regexp {^```} $line] && $indent eq " "} {
set indent ""
append mdhtml "\n"
} else {
append mdhtml "$indent$line\n"
}
}
if {$mode eq "--html"} {
set htm [Markdown::convert $mdhtml]
set html ""
set synopsis false
foreach line [split $htm "\n"] {
if {[regexp {^<h2>} $line]} {
set synopsis false
}
if {[regexp -nocase {^<h2>.*SYNOPSIS} $line]} {
set synopsis true
}
if {$synopsis && [regexp {<pre>} $line]} {
set line [regsub {<pre>} $line "<pre class='synopsis'>"]
}
append html "$line\n"
}
set out [open [file rootname $filename].html w 0644]
puts $out $header
puts $out $html
puts $out "</body>\n</html>"
close $out
puts stderr "Success: file [file rootname $filename].html was written!"
} else {
puts $mdhtml
}
}
}
}
proc dgw::install {filename} {
destroy .
set dpath dgw
set pfile [file rootname [file tail $filename]]
set done false
foreach dir [tcl::tm::path list] {
if {[file writable $dir]} {
puts "\nWriteable Tcl module path is: $dir"
set ddir [file join $dir $dpath]
if {![file exists $ddir]} {
file mkdir $ddir
}
set fname [file join $dir $dpath $pfile-[package provide ${dpath}::$pfile].tm]
file copy -force [info script] $fname
puts "Done: ${dpath}::$pfile Tcl module installed to ${fname}!\n"
puts "To test your installation try:\n"
puts "\$ tclsh"
puts "% package require ${dpath}::$pfile\n"
set done true
break
}
}
if {!$done} {
puts "Error: No writable Tcl module path found!"
puts "Create an environment variable TCL8_6_TM_PATH pointing to a directory where you can write files in."
puts "In Linux for a bash shell you can do this for instance with: export TCL8_6_TM_PATH=/home/user/.local/lib/tcl8.6"
puts "To make this permanent add this line to your .bashrc file!"
}
}
#-- From hyperhelp.tcl
#!/bin/sh
# The next line executes Tcl with the script \
exec tclsh "$0" "$@"
#' ---
#' title: __PKGNAME__ __PKGVERSION__
#' author: Dr. Detlef Groth, Schwielowsee, Germany
#' documentclass: scrartcl
#' geometry:
#' - top=20mm
#' - right=20mm
#' - left=20mm
#' - bottom=30mm
#' ---
#'
#'
#' ## NAME
#'
#' **dgw::hyperhelp** - a help system with hypertext facilitites and table of contents
#'
#'
#' ## <a name='toc'></a>TABLE OF CONTENTS
#'
#' - [SYNOPSIS](#synopsis)
#' - [DESCRIPTION](#description)
#' - [COMMAND](#command)
#' - [METHODS](#methods)
#' - [EXAMPLE](#example)
#' - [MARKUP LANGUAGE](#formatting)
#' - [INSTALLATION](#install)
#' - [SEE ALSO](#see)
#' - [CHANGES](#changes)
#' - [TODO](#todo)
#' - [AUTHOR](#authors)
#' - [LICENSE AND COPYRIGHT](#license)
#'
#'
#' ## <a name='synopsis'>SYNOPSIS</a>
#'
#' Usage as package:
#'
#' ```
#' package require dgw::hyperhelp
#' dgw::hyperhelp pathName -helpfile filename ?-option value ...?
#' pathName help topic
#' ```
#'
#' Usage as command line application:
#'
#' ```
#' tclsh hyperhelp.tcl filename ?--commandsubst true?
#' ```
#'
#' ## <a name='description'>DESCRIPTION</a>
#'
#' The **dgw::hyperhelp** package is hypertext help system which can be easily embedded into Tk applications. It is based on code
#' of the Tclers Wiki mainly be Keith Vetter see the [Tclers-Wiki](https://wiki.tcl-lang.org/page/A+Hypertext+Help+System)
#' The difference of this package to the wiki code is, that it works on external files, provides some `subst` support for variables
#' and commands as well as a browser like toolbar. It can be as well used as standalone applications for browsing the help files.
#' Markup syntax was modified towards Markdown to simplify writing help pages as this is a common documentation language.
#' In practice you can create a document which is a valid Markdown document and at the same time an usable help file.
#' The file [hyperhelp-markdown-sample.md](hyperhelp-markdown-sample.md) gives an example for such a file.
package require Tk
package require tile
#if {[catch {package require dgtools::shistory}]} {
# tcl::tm::path add [file join [file dirname [info script]] .. libs]
# lappend auto_path [file join [file dirname [info script]] .. libs]
#}
#interp alias {} ::button {} ::ttk::button
set haveTile078 1
package require dgtools::shistory
#proc thingy name {proc $name args "namespace eval $name \$args"}
#thingy hist
#'
#' ## <a name='command'>COMMAND</a>
#'
#' **dgw::hyperhelp** *pathName -helpfile fileName ?-option value ...?*
#'
#' > creates a new *hyperhelp* widget using the given widget *pathName* and with the given *fileName*.
#'
#' ## <a name='options'>OPTIONS</a>
#'
#' The **dgw::hyperhelp** snit widget supports the following options which
#' should be set only at widget creation:
namespace eval dgw { }
snit::widget ::dgw::hyperhelp {
variable W ;# Various widgets
variable pages ;# All the help pages
variable alias ;# Alias to help pages
variable state
variable font "Times New Roman"
variable var
variable sh
variable npages 0
variable ptitle ""
variable fonts
variable sentry
#'
#' __-bottomnavigation__ _boolean_
#'
#' > Configures the hyperhelp widget if at the bottom of each help page a textual navigation line should be displayed. Default *false*.
option -bottomnavigation false
#'
#' __-commandsubst__ _boolean_
#'
#' > Configures the hyperhelp widget to do substitutions using Tcl commands within the text.
#' This might give some security issues if you load help files from dubious sources,
#' although for this most critical commands like file, exec and socket are disaable even if this option is set to true.
#' Default: false
option -commandsubst false
#'
#' __-dismissbutton__ _boolean_
#'
#' > Configures the hyperhelp widget to display at the button a "Dismiss" button. Useful if the help page is direct parent in a toplevel to destroy this toplevel. Default: *false*.
option -dismissbutton false
#'
#' __-font__ _fontname_
#'
#' > Configures the hyperhelp widget to use the given font.
#' Fontnames should be given as `[list fontname size]` such as for example
#' `\[list {Linux Libertine} 12\]`. If no fontname is given the hyperhelp widget
#' tries out a few standard font names on Linux and Windows System.
#' If none of those fonts is found, it falls back to "Times New Roman" which should be available on all platforms.
option -font ""
#'
#' __-helpfile__ _fileName_
#'
#' > Configures the hyperhelp widget with the given helpfile
#' option to be displayed within the widget.
option -helpfile ""
#'
#' __-toctree__ _boolean_
#'
#' > Should the toc tree widget on the left be displayed.
#' For simple help pages, consisting only of one, two, three pages the
#' treeview widget might be overkill. Please note, that this widget is also
#' not shown if there is no table of contents page, regardless of the _-toctree_ option.
#' Must be set at creation time currently.
#' Default: *true*
option -toctree true
#'
#' __-toolbar__ _boolean_
#'
#' > Should the toolbar on top be displayed. For simple help pages,
#' consisting only of one, two pages the toolbar might be overkill.
#' Must be set at creation time currently.
#' Default: *true*
option -toolbar true
constructor {args} {
$self configurelist $args
#parray options
set font ""
if {$options(-font) eq ""} {
set ff [font families]
set size 12
foreach f [list {Linux Libertine} {Alegreya} {Constantia} {Georgia} {Palatino Linotype} {Times New Roman} {Cambria}] {
set idx [lsearch -exact $ff $f]
if { $idx > -1} {
set options(-font) [list [lindex $f $idx] 12]
set font $f ;#[list $f 12]
break
}
}
if {$font eq ""} {
set options(-font) [list "Times New Roman" 12]
set font "Times New Roman"
}
} else {
set font [lindex $options(-font) 0]
set size [lindex $options(-font) 1]
}
set fonts(fixed) [font create -family "Courier" -size [expr {$size-1}]]
set fonts(std) [font create -family $font -size $size]
set fonts(italic) [font create -family $font -size $size -slant italic]
set fonts(bold) [font create -family $font -size $size -weight bold]
set fonts(hdr) [font create -family $font -size [expr {$size+4}]]
set fonts(hdr3) [font create -family $font -size [expr {$size+4}]]
set font $fonts(std)
array unset var
array unset pages
set pages(ERROR!) "page does not exists"
array unset alias
array unset state
array set state {seen {} current {} all {} allTOC {} haveTOC 0}
array set W {top .helpSystem main "" tree ""}
array set alias {index Index previous Previous back Back forward Forward
search Search history History next Next}
array set var [list]
set sh [::dgtools::shistory %AUTO% -home ""]
set W(top) $win
$self ReadHelpFiles
$self Help
}
onconfigure -font value {
#puts "configuring font"
set f [lindex $value 0]
foreach fnt [array names fonts] {
font configure $fonts($fnt) -family $fnt
}
set options(-font) $value
}
## BON HELP
##+##########################################################################
#
# Help Section
#
# Based on https://wiki.tcl-lang.org/1194
#
# AddPage title aliases text -- register a hypertext page
# Help ?title? -- bring up a toplevel showing the specified page
# or a index of titles, if not specified
#
# Hypertext pages are in a subset of Wiki format:
# indented lines come in fixed font without evaluation;
# blank lines break paragraphs
# a line starting with " * " gets a bullet
# a line starting with " - " gets a dash
# a line starting with " 1 " will be a numbered list
# repeating the initial *,- or "1" will indent the list
# a line starting with " | " will be an indented block paragraph (one level only)
#
# text enclosed by '''<text>''' is embolden
# text enclosed by ''<text>'' is italics
# all lines without leading blanks are displayed without explicit
# linebreak (but possibly word-wrapped)
# a link is the title of another page in brackets (see examples at
# end). Links are displayed underlined and blue (or purple if they
# have been visited before), and change the cursor to a pointing
# hand. Clicking on a link of course brings up that page.
#
# In addition, you get "Index", "Search" (case-insensitive regexp in
# titles and full text), "History", and "Back" links at the bottom of
# pages.
##+##########################################################################
#
# Help -- initializes and creates the help dialog
#
#'
#' ## <a name='methods'>METHODS</a>
#'
#' The *hyperhelp* widget provides the following methods:
#'
#' *pathName* **help** *topic*
#'
#' > Displays the given topic within widget. If the page does not exists an error page is shown.
method help {{title ""}} {
$self DoDisplay
#raise $W(top)
$self Show $title
set ptitle $title
}
method Help {{title ""}} {
$self help $title
}
#'
#' *pathName* **getTitle**
#'
#' > Returns the current topic shown in the hyperhelp browser.
method getTitle {} {
return $ptitle
}
#'
#' *pathName* **getPages**
#'
#' > Returns the page names for the current help file.
method getPages {} {
return [array names pages]
}
##+##########################################################################
#
# ReadHelpFiles -- reads "help.txt" in the packages directory
# and creates all the help pages.
#
method ReadHelpFiles {} {
set fname $options(-helpfile)
#set fname [file join $dir help.txt]
set fin [open $fname r]
set data [read $fin] ; list
close $fin
# remove pandoc header
regsub -- {^-{3,}\s*\ntitle:.+?\n---\n} $data "" data
regsub -all -line {^-{5,}$} $data \x01 data
regsub -all -line {^\#\s.*$\n} $data {} data
regsub -all -line {^ {4,5}([-+*]) } $data " \\1\\1 " data
set t [clock seconds]
set cmds [list file open exec send socket]
foreach cmd $cmds {
rename ::$cmd ::${cmd}.orig$t
}
set x 0
foreach section [split $data \x01] {
set section [regsub -all {^(\s*)## +<a name=["']([^>]+)['"]>\s*([^<]+)\s*</a>} $section "title: \\3\nalias: \\2"]
set n [regexp -line {^(title:|##)\s*(.*?) *$} $section => => title]
if {! $n} {
tk_messageBox -title "Error!" -icon error -message "Bad help section\n'[string range $section 0 400]'" -type ok
continue
}
#puts "'${title}'"
set n [regexp -line {^icon:\s*(.*?) *$} $section => icon]
if {! $n} {
set var("icon,$title") filenew16
} else {
set var("icon,$title") $icon
}
if {[incr x] == 1} {
set var(home) $title
$sh configure -home $title
}
set npages $x
set aliases {}
foreach {. ali} [regexp -all -line -inline {^alias:\s*(.*?) *$} $section] {
if {$ali eq "Home" || $ali eq "home"} {
set var(home) $ali
}
lappend aliases $ali
}
# make subst more save
# did not got interp alias to work
regsub -all -line {^(title:|alias:|icon:).*$\n} $section {} section
regsub -all {\[\[} $section "````" section
regsub -all {\]\]} $section "´´´´" section
regsub -all {\[} $section "``" section
regsub -all {\]} $section "´´" section
regsub -all {````} $section "\[" section
regsub -all {´´´´} $section "\]" section
#set i [interp create -safe]
#interp eval $i package require tdbc
# not available in save interpr
#interp eval $i [list subst "$section"]
set sect ""
foreach line [split $section "\n"] {
if {$options(-commandsubst)} {
catch { set line [subst $line] }
} else {
catch { set line [subst -nocommands $line] }
}
set line [regsub -all {\[([^]]+)\]} $line "(Error: \\1)"]
append sect "$line\n"
}
set section $sect
#interp eval $i set section $section
#$i eval subst $section
regsub -all {``} $section "\[" section
regsub -all {´´} $section "\]" section
#puts "adding $title"
$self AddPage $title $aliases $section
}
foreach cmd $cmds {
rename ::${cmd}.orig$t ::$cmd
}
if {$x > 1} {
# todo catch nox existing display
$self BuildTOC
}
if {$x == 1} {
#pack forget $win.status
}
}
##+##########################################################################
#
# AddPage -- Adds another page to the help system
#
method AddPage {title aliases body} {
regsub -all {\n } $body "\n" body
set title [string trim $title]
set body [string trim $body "\n"]
regsub -all {\\\n} $body {} body ;# Remove escaped lines
regsub -all {[ \t]+\n} $body "\n" body ;# Remove trailing spaces
regsub -all {([^\n])\n([^\s])} $body {\1 \2} body ;# Unwrap paragraphs
set pages($title) $body
lappend aliases [string tolower $title]
foreach name $aliases { set alias([string tolower $name]) $title }
if {[lsearch $state(all) $title] == -1} {
set state(all) [lsort [lappend state(all) $title]]
}
}
typeconstructor {
image create photo acthelp16 -data {
R0lGODlhEAAQAIMAAPwCBAQ6XAQCBCyCvARSjAQ+ZGSm1ARCbEyWzESOxIy6
3ARalAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAQ/EEgQqhUz00GE
Jx2WFUY3BZw5HYh4cu6mSkEy06B72LHkiYFST0NRLIaa4I0oQyZhTKInSq2e
AlaaMAuYEv0RACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24g
Mi41DQqpIERldmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZl
ZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29tADs=
}
image create photo bookmark -data {
R0lGODlhEAAQAIQAAPwCBCwqLLSytLy+vERGRFRWVDQ2NKSmpAQCBKyurMTG
xISChJyanHR2dIyKjGxubHRydGRmZIyOjFxeXHx6fAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAVbICACwWie
Y1CibCCsrBkMb0zchSEcNYskCtqBBzshFkOGQFk0IRqOxqPBODRHCMhCQKte
Rc9FI/KQWGOIyFYgkDC+gPR4snCcfRGKOIKIgSMQE31+f4OEYCZ+IQAh/mhD
cmVhdGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENv
ciAxOTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3
LmRldmVsY29yLmNvbQA7
}
image create photo bell -data {
R0lGODlhDwAOAIIAAPwCBISCBPz+BIQCBMTCxISChPz+/AQCBCH5BAEAAAAA
LAAAAAAPAA4AAAM+CLrR+zCIAWsgLVRGRBhOVQiG94WPVAbHaZHYAWqRYLbg
e88RsbInGuBCEhRYrZYm4xk4nYdoKzKIbiKHawIAIf5oQ3JlYXRlZCBieSBC
TVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4
LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5j
b20AOw==
}
image create photo idea -data {
R0lGODlhEAAQAIMAAPwCBAQCBPz+BPzerPz+xPyqXPz+/ISChFxaXKSipDQy
NAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAARMEEgZap14BjG6
CJkmEMVQCF+4mQPBpthWtuYJxkJJGK6dbQRCgMBB3XCDzQamMhpDGlvuCFUy
oQDLBUsJHBDUKuKQCKsUCIVZtc34IwAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lG
IFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCBy
aWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7
}
image create photo reload-16 -data {
R0lGODlhEAAQAIUAAPwCBCRaJBxWJBxOHBRGBCxeLLTatCSKFCymJBQ6BAwm
BNzu3AQCBAQOBCRSJKzWrGy+ZDy+NBxSHFSmTBxWHLTWtCyaHCSSFCx6PETK
NBQ+FBwaHCRKJMTixLy6vExOTKyqrFxaXDQyNDw+PBQSFHx6fCwuLJyenDQ2
NISChLSytJSSlFxeXAwODCQmJBweHAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaB
QIBQGBAMBALCcCksGA4IQkJBUDIDC6gVwGhshY5HlMn9DiCRL1MyYE8iiapa
SKlALBdMRiPckDkdeXt9HgxkGhWDXB4fH4ZMGnxcICEiI45kQiQkDCUmJZsk
mUIiJyiPQgyoQwwpH35LqqgMKiEjq5obqh8rLCMtowAkLqovuH5BACH+aENy
ZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29y
IDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cu
ZGV2ZWxjb3IuY29tADs=
}
image create photo klipper-16 -data {
R0lGODlhEAAQAIYAAPwCBFQyDEwuFEQuDISGhFRSVEQqFEQuFPz+/PTy7Nze
3PT29Ozu7DQyNJx6VIxuRIRiLEwuDIxSFHxSHKSipLSytGRiZGRCHDwmFOzm
3HxOHIRWHOTazHRCFHxOFEwyFNTKvHROHFxeXJRqLIxWFFw6DFQ2DNTCrIRa
JJxuPMSynHRKHIxqRMSqjGRGHMSifJxeFKyGXHxKFLyaXKyObGxGFEwyDKyO
XIxeHKSOdFQ6FIx2THRKFFw+FKx6NKRmFKxuFLyCPLyOTLyabLSefLyijFw6
FJRmJIxWHHRGFFQ2FAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAA
LAAAAAAQABAAAAfFgAAAAQIDBAWIiAMGA4IABwgJCgUICwwKDQ4PEBGCEQsS
EwUUFQQWDRepGJ4ZEggIDbENrxobAZ4cHa+7uxAeH4IGICEIIsbGFggjJCWC
JicovLwpIcAAGCorCBbc3AoILB2rgy2u0q8OLrcAJS8wr8nJrzEy6yUz79si
vDQ1jQA2buB4tU8eghw6xgnYwePcqxcdbAjq4eMHECA+ggiZMYRIESPjShyB
gQPJBB48OsiokaTDOoACItgwYULJhw8BbIzzEwgAIf5oQ3JlYXRlZCBieSBC
TVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4
LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5j
b20AOw==
}
image create photo fileopen16 -data {
R0lGODlhEAAQAIUAAPwCBAQCBOSmZPzSnPzChPzGhPyuZEwyHExOTFROTFxa
VFRSTMSGTPT29Ozu7Nze3NTS1MzKzMTGxLy6vLS2tLSytDQyNOTm5OTi5Ly+
vKyqrKSmpIyOjLR+RNTW1MzOzJyenGxqZBweHKSinJSWlExKTMTCxKyurGxu
bBQSFAwKDJyanERCRERGRAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaR
QIBwGCgGhkhkEWA8HpNPojFJFU6ryitTiw0IBgRBkxsYFAiGtDodDZwPCERC
EV8sEk0CI9FoOB4BEBESExQVFgEEBw8PFxcYEBIZGhscCEwdCxAPGA8eHxkU
GyAhIkwHEREQqxEZExUjJCVWCBAZJhEmGRUnoygpQioZGxsnxsQrHByzQiJx
z3EsLSwWpkJ+QQAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9u
IDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2
ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7
}
image create photo actreload16 -data {
R0lGODlhEAAQAIUAAPwCBCRaJBxWJBxOHBRGBCxeLLTatCSKFCymJBQ6BAwm
BNzu3AQCBAQOBCRSJKzWrGy+ZDy+NBxSHFSmTBxWHLTWtCyaHCSSFCx6PETK
NBQ+FBwaHCRKJMTixLy6vExOTKyqrFxaXDQyNDw+PBQSFHx6fCwuLJyenDQ2
NISChLSytJSSlFxeXAwODCQmJBweHAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaB
QIBQGBAMBALCcCksGA4IQkJBUDIDC6gVwGhshY5HlMn9DiCRL1MyYE8iiapa
SKlALBdMRiPckDkdeXt9HgxkGhWDXB4fH4ZMGnxcICEiI45kQiQkDCUmJZsk
mUIiJyiPQgyoQwwpH35LqqgMKiEjq5obqh8rLCMtowAkLqovuH5BACH+aENy
ZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29y
IDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cu
ZGV2ZWxjb3IuY29tADs=
}
image create photo start-16 -data {
R0lGODlhEAAQAIUAAPwCBBRSdBRObCQ2TAQCBBxObISevNzu/BRGZPz6/FzC
3Pz+/HTS5ByyzJze7Mzq9ITC3AQWLAyWvBSavFyuxAwaLAQSHBRWfBSOrDzW
5AyixCS61ETW3CzG1AQeLAweLAxefBSStEze7CSWtCyatBSCnAwmPBRWdByi
xAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZr
QIBwSCwah4HjUTBQEogFw/M4BQgMh2pxijAkFAhBYJwUPq8LRsPxWDwgkSHh
elA0JJIJnlKRWy4YGRoSGxwcHRsecgAfICEiGhMjJBglVVMRgBkgJp0El0MR
JyhaRFqipUoAFqmqrapHfkEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8g
dmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRz
IHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
}
image create photo navback16 -data {
R0lGODlhEAAQAIUAAPwCBBRSdBRObCQ2TBxObISevAQCBNzu/BRGZPz6/FzC
3Pz+/HTS5ByyzJze7Mzq9ITC3AQWLAyWvBSavFyuxAwaLAwSHBRafBSOrDzW
5AyixCS61ETW3CzG1AQeLAweLAxefBSStEze7CSWtCyatBSCnBRWfAwmPBRW
dByixAQSHAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZi
QIBwSCwah4HjUTBQFgkFg3MoKBykU0QhoUAIAuAksbpgNByPxQMSGVsVDYlk
IqdUiJYLJqORbDgcHRseRR8gISIaEyMkGCVYRBEmeyAnlgaQkSgpmU4RAZ1O
KqFOpFNGfkEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAy
LjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRzIHJlc2VydmVk
Lg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
}
image create photo finish-16 -data {
R0lGODlhEAAQAIUAAPwCBAwyTBRObAw2VDR+nAQCBCRKZOzy/KTe7Pz+/KTK
3Nzu/Lze7FS+1AyexAyuzBSavAyOtBSmzOTy/BRqjNTm9IzO5ETS3ETa5By6
1AyixByixBRmjAQGDBxCXGSivCySrCSWtBTC3AQOHAQWHAxWdEze7AQKFBRC
XAwqPAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZt
QIBwSCwahYGjUjBQGgWE5LCgNBwITSFVKOgKDAZEIqodChSLw4HRcIyTW4Dg
0HhAIhGIZEIJxA0VFhcYGRAaGBscHXEeHyAhIQ4iiBwjAHEBJCMjJCUmiSdl
RyigU0oolURxRSmrTpevsUN+QQAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lGIFBy
byB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCByaWdo
dHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7
}
image create photo navforward16 -data {
R0lGODlhEAAQAIUAAPwCBAwyTBRObAw2VDR+nCRKZOzy/KTe7Pz+/KTK3Nzu
/Lze7FS+1AyexAyuzBSavAyOtBSmzOTy/BRqjNTm9IzO5ETS3ETa5By61Ayi
xByixBRmjAQGDBxCXGSivCySrCSWtBTC3AQOHAQWHAxWdEze7AQKFBRCXAwq
PAQCBAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZj
QIBwSCwahYGjUjBQGgWEpHNYMBCaT4G2UDggos+EwmBYMBpf6VBgYDgeEMgj
IpmoAQVKxXLBPDIXGhscRB0eHyAgDSGBGyJFASMiIiMkJYImUwAnmJqbjp4A
KCmhAKSlTn5BACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24g
Mi41DQqpIERldmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZl
ZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29tADs=
}
image create photo navhome16 -data {
R0lGODlhEAAQAIUAAPwCBDw6PBQWFCQiJAQCBFxeXMTCxJyanDwyLDQqLFRS
VLSytJSSlISChCQmJERGRFRWVGxubKSmpJyenGRmZLy+vOzq7OTi5Ly6vGRi
ZPTy9Pz6/OTm5ExOTPT29BwaHNza3NS6tJRqRGQqBNy6pIyKjDwGBPTe1JSW
lDQyNOTGrNRiBGwmBIRaLNymdLxWBHxGFNySXCwqLKyqrNR6LKxGBNTS1NTW
1Jw+BEweDDQ2NAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAao
QIBwCAgIiEjAgAAoGA6I5DBBUBgWjIZDqnwYGgVIoTGQQgyRiGRCgZCR1nTF
csFkHm9hBp2paDYbHAsZHW9eERkYGh4eGx4ag3gfSgMTIBshIiMkGyAlCCZT
EpciJyQjGxcoKUQBEhcbIiorLB4XEltDrhcaLS4vtbcJra8bMDHAGrcyrTMX
HjA0NSypEsO6EzY3IzU4OdoTzK0BCAkDMgkIOjJlAH5BACH+aENyZWF0ZWQg
YnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29yIDE5OTcs
MTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxj
b3IuY29tADs=
}
image create photo nav1leftarrow16 -data {
R0lGODlhEAAQAIAAAP///wAAACH5BAEAAAAALAAAAAAQABAAAAIdhI+pyxqd
woNGTmgvy9px/IEWBWRkKZ2oWrKu4hcAIf5oQ3JlYXRlZCBieSBCTVBUb0dJ
RiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwg
cmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
}
image create photo nav1rightarrow16 -data {
R0lGODlhEAAQAIAAAPwCBAQCBCH5BAEAAAAALAAAAAAQABAAAAIdhI+pyxCt
woNHTmpvy3rxnnwQh1mUI52o6rCu6hcAIf5oQ3JlYXRlZCBieSBCTVBUb0dJ
RiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwg
cmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
}
image create photo playend16 -data {
R0lGODlhEAAQAIAAAPwCBAQCBCH5BAEAAAAALAAAAAAQABAAAAIjhI+py8Eb
3ENRggrxjRnrVIWcIoYd91FaenysMU6wTNeLXwAAIf5oQ3JlYXRlZCBieSBC
TVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4
LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5j
b20AOw==
}
image create photo playstart16 -data {
R0lGODlhEAAQAIAAAPwCBAQCBCH5BAEAAAAALAAAAAAQABAAAAIjhI+pyxud
wlNyguqkqRZh3h0gl43hpoElqlHt9UKw7NG27BcAIf5oQ3JlYXRlZCBieSBC
TVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4
LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5j
b20AOw==
}
image create photo history -data {
R0lGODlhEAAQAIUAAPwCBEQ2LEw6POTSrOzWtNS2lAQCBOzatPTm3PTq3Myy
jEw+NOzm1Pz29Pz+/Pz6/Pz27FRGPFxKRPTu3Pzy7Pz69Pz67KSGbPzy3Pzu
3PTizPzu1Pzq1PTmzOzaxPTixPTmxOzWvOTOtKyWdOTGpOTStNS+nIRmVLym
hNzCnOzavLyefAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaH
QIBwGCgOj0jBgFAwGJDJAyJBUDihwgWj4XhAqhEJNDKhVLwUSUDyPJIrlgYl
LSG0hYELhgLJTBJOd1kaGxgYHB0egkQfHBwgHyEigkUBIwMkBwcEJSZ3ARYW
JCcnKCYpJJ5HAQUqFhSjJysoKItOCgehJBISI4tCtyERa79HTrx2WEiBUH5B
ACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERl
dmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6
Ly93d3cuZGV2ZWxjb3IuY29tADs=
}
image create photo help -data {
R0lGODlhEAAQAIEAAPwCBAQChAQCBAAAACH5BAEAAAAALAAAAAAQABAAAAIz
hH+hIeiwVmtOUcjENaxqjVjhByaBSZZVl24Y1V6iEVMzkD4bqD700bshgh1f
zwd0IfwFACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41
DQqpIERldmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4N
Cmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29tADs=
}
image create photo hinfo -data {
R0lGODlhEAAQAIYAAPwCBBQ+XBRCZAw+XAw6XBRCXCRObCxihCxqjCRijBRS
fAwyVCxehDx6nER+pPz+/BxKZAwmPFyWtGyevCRSbBxWfAxGbHSqxGSatCxu
lBxahBRKbAQiNEyKrBRKdAw6ZAwiNESSLCyCDBxWBDRulBwyRHS6ZDSWHCyK
FDQyNCxqlAQmRAwiPMzalPyCBMQCBCx+DAwuRBQqPITCdFxaXCyOFAQeNAwm
RAxKdPz6/GyyVMTCxKSirAQCBGzKZAwqTAweNFyuRDyeJFzCTITOdAQiPAQa
NHzCbES6NEy6PESyNDyqLDymJPz+xAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAA
LAAAAAAQABAAAAfBgACCAAECAwSDiYMFBgcICQoLC4qCBQwNDg8PEJERlAYN
EhOaFBUWnokBBw4SFxgOGRobCxyJBQkNHZoPpR4fICEiIiMBCSSYmgoKFgsl
JicoKQQKCSoZmgW+KywtLi8pMDEbFRqaAcwyMyc0NSkiNjc4ObsrKyU6Ozw9
7j4lNhGSfsgAEkQIDxr7YAwh0qKIDSM2jgRpgbDHPhFIMiZRsoTJkhMgobUD
MKKkySYjUKockYJSypcrWypKQbOmTT+BAAAh/mhDcmVhdGVkIGJ5IEJNUFRv
R0lGIFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFs
bCByaWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7
}
image create photo sheet -data {
R0lGODlhEAAQAIIAAPwCBAQCBAT+/Pz+/KSipPz+BAAAAAAAACH5BAEAAAAA
LAAAAAAQABAAAANFCBDc7iqIKUW98WkWpx1DAIphR41ouWya+YVpoBAaCKtM
oRfsyue8WGC3YxBii5+RtiEWmASFdDVs6GRTKfCa7UK6AH8CACH+aENyZWF0
ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29yIDE5
OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2
ZWxjb3IuY29tADs=
}
image create photo folder -data {
R0lGODlhEAAQAIYAAPwCBAQCBExKTBwWHMzKzOzq7ERCRExGTCwqLARqnAQ+
ZHR2dKyqrNTOzHx2fCQiJMTi9NTu9HzC3AxmnAQ+XPTm7Dy67DymzITC3IzG
5AxypHRydKymrMzOzOzu7BweHByy9AyGtFyy1IzG3NTu/ARupFRSVByazBR6
rAyGvFyuzJTK3MTm9BR+tAxWhHS61MTi7Pz+/IymvCxulBRelAx2rHS63Pz6
/PTy9PTu9Nza3ISitBRupFSixNTS1CxqnDQyNMzGzOTi5MTCxMTGxGxubGxq
bLy2vLSutGRiZLy6vLSytKyurDQuNFxaXKSipDw6PAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAA
LAAAAAAQABAAAAfDgACCAAECg4eIAAMEBQYHCImDBgkKCwwNBQIBBw4Bhw8Q
ERITFJYEFQUFnoIPFhcYoRkaFBscHR4Ggh8gIRciEiMQJBkltCa6JyUoKSkX
KhIrLCQYuQAPLS4TEyUhKb0qLzDVAjEFMjMuNBMoNcw21QY3ODkFOjs82RM1
PfDzFRU3fOggcM7Fj2pAgggRokOHDx9DhhAZUqQaISBGhjwMEvEIkiIHEgUA
kgSJkiNLmFSMJChAEydPGBSBwvJQgAc0/QQCACH+aENyZWF0ZWQgYnkgQk1Q
VG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29yIDE5OTcsMTk5OC4g
QWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29t
ADs=
}
image create photo book -data {
R0lGODlhEAAQAIQAAPwCBAQCBDyKhDSChGSinFSWlEySjCx+fHSqrGSipESO
jCR6dKTGxISytIy6vFSalBxydAQeHHyurAxubARmZCR+fBx2dDyKjPz+/MzK
zLTS1IyOjAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAVkICCOZGmK
QXCWqTCoa0oUxnDAZIrsSaEMCxwgwGggHI3E47eA4AKRogQxcy0mFFhgEW3M
CoOKBZsdUrhFxSUMyT7P3bAlhcnk4BoHvb4RBuABGHwpJn+BGX1CLAGJKzmK
jpF+IQAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9uIDIuNQ0K
qSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2ZWQuDQpo
dHRwOi8vd3d3LmRldmVsY29yLmNvbQA7}
image create photo bookopen -data {
R0lGODlhEAAQAIUAAPwCBAQCBExCNGSenHRmVCwqJPTq1GxeTHRqXPz+/Dwy
JPTq3Ny+lOzexPzy5HRuVFSWlNzClPTexIR2ZOzevPz29AxqbPz6/IR+ZDyK
jPTy5IyCZPz27ESOjJySfDSGhPTm1PTizJSKdDSChNzWxMS2nIR6ZKyijNzO
rOzWtIx+bLSifNTGrMy6lIx+ZCRWRAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAae
QEAAQCwWBYJiYEAoGAFIw0E5QCScAIVikUgQqNargtFwdB9KSDhxiEjMiUlg
HlB3E48IpdKdLCxzEAQJFxUTblwJGH9zGQgVGhUbbhxdG4wBHQQaCwaTb10e
mB8EBiAhInp8CSKYIw8kDRSfDiUmJ4xCIxMoKSoRJRMrJyy5uhMtLisTLCQk
C8bHGBMj1daARgEjLyN03kPZc09FfkEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJ
RiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwg
cmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
}
image create photo filenew16 -data {
R0lGODlhEAAQAIUAAPwCBFxaXNze3Ly2rJyanPz+/Ozq7GxqbPz6/GxubNTK
xDQyNIyKhHRydERCROTi3PT29Pz29Pzy7PTq3My2pPzu5PTi1NS+rPTq5PTe
zMyynPTm1Pz69OzWvMyqjPTu5PTm3OzOtOzGrMSehNTCtNS+tAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZ/
QAAgQCwWhUhhQMBkDgKEQFIpKFgLhgMiOl1eC4iEYrtIer+MxsFRRgYe3wLk
MWC0qXE5/T6sfiMSExR8Z1YRFRMWF4RwYIcYFhkahH6AGBuRk2YCCBwSFZgd
HR6UgB8gkR0hpJsSGCAZoiEiI4QKtyQlFBQeHrVmC8HCw21+QQAh/mhDcmVh
dGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAx
OTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRl
dmVsY29yLmNvbQA7
}
image create photo textfile -data {
R0lGODlhEAAQAIUAAPwCBFxaXNze3Ly2rJSWjPz+/Ozq7GxqbJyanPT29HRy
dMzOzDQyNIyKjERCROTi3Pz69PTy7Pzy7PTu5Ozm3LyqlJyWlJSSjJSOhOzi
1LyulPz27PTq3PTm1OzezLyqjIyKhJSKfOzaxPz29OzizLyidIyGdIyCdOTO
pLymhOzavOTStMTCtMS+rMS6pMSynMSulLyedAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaQ
QIAQECgajcNkQMBkDgKEQFK4LFgLhkMBIVUKroWEYlEgMLxbBKLQUBwc52Hg
AQ4LBo049atWQyIPA3pEdFcQEhMUFYNVagQWFxgZGoxfYRsTHB0eH5UJCJAY
ICEinUoPIxIcHCQkIiIllQYEGCEhJicoKYwPmiQeKisrKLFKLCwtLi8wHyUl
MYwM0tPUDH5BACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24g
Mi41DQqpIERldmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZl
ZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29tADs=
}
}
##+##########################################################################
#
# DoDisplay -- Creates our help display. If we have tile 0.7.8 then
# we will also have a TOC pane.
#
method DoDisplay {} {
set W(top) $win
set TOP $win
#wm title $TOP "Help"
#wm transient $TOP .
if {[winfo exists $TOP.status]} {
return
}
frame $TOP.status
if {$options(-toolbar) && $npages > 1} {
pack $TOP.status -side top -expand false -anchor n
}
pack [button $TOP.status.refresh -image reload-16 -relief groove -borderwidth 2\
-command [mymethod Refresh]] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
pack [button $TOP.status.home -image navhome16 -relief groove -borderwidth 2\
-command [mymethod Show]] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
pack [button $TOP.status.index -image klipper-16 -relief groove -borderwidth 2 \
-command [mymethod Show index]] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
#pack [button $TOP.status.first -image start-16 -relief groove -borderwidth 2 -state disabled] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
pack [button $TOP.status.backward -image navback16 -relief groove -borderwidth 2 \
-command [mymethod Show Back] -state disabled] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
set W(backward) $TOP.status.backward
pack [button $TOP.status.forward -image navforward16 -relief groove -borderwidth 2 -state disabled \
-command [mymethod Show Forward]] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
set W(forward) $TOP.status.forward
# pack [button $TOP.status.last -image finish-16 -relief groove -borderwidth 2 -state disabled] -padx 3 -pady 4 -side left -ipadx 2 -ipady 2
pack [ttk::separator $TOP.status.sep -orient vertical] -side left -expand false -padx 5 -fill y -pady 3
# pack [button $TOP.status.bl -image playstart16 -command { puts First } -relief groove -borderwidth 2] -side left -padx 2
pack [button $TOP.status.bb -image nav1leftarrow16 -command [mymethod Show Previous] -relief groove -borderwidth 2] -side left -padx 2
pack [button $TOP.status.bf -image nav1rightarrow16 -command [mymethod Show Next] -relief groove -borderwidth 2] -side left -padx 2
#pack [button $TOP.status.b1 -image playend16 -command { puts Last } -relief groove -borderwidth 2] -side left -padx 2
pack [entry $TOP.status.e -textvar [myvar state(search)]] -side left -padx 5
set sentry $TOP.status.e
bind $TOP.status.e <Return> [mymethod DoToolSearch]
pack [button $TOP.status.be -text Search! -command [mymethod DoToolSearch]] -side left -padx 5
frame $TOP.bottom -bd 2 -relief ridge
button $TOP.b -text "Dismiss" -command [list destroy [winfo parent $TOP]]
if {$options(-dismissbutton)} {
pack $TOP.bottom -side bottom -fill both
pack $TOP.b -side bottom -expand 1 -pady 10 -in $TOP.bottom
}
set P $TOP.p
if {$::haveTile078} { ;# Need tags on treeview
set state(haveTOC) 1
::ttk::panedwindow $P -orient horizontal
pack $P -side top -fill both -expand 1
frame $P.toc -relief ridge
frame $P.help -bd 2 -relief ridge
$self CreateTOC $P.toc
$self CreateHelp $P.help
if {$options(-toctree) && $npages > 1 && [llength [$W(tree) children ""]] > 0} {
$P add $P.toc
}
$P add $P.help
} else {
set state(haveTOC) 0
frame $P
pack $P -side top -fill both -expand 1
$self CreateHelp $P
}
#bind $TOP <Map> [list apply { TOP {
# bind $TOP <Map> {}
# CenterWindow $TOP
#}} $TOP]
#pack $fr -side top -fill both -expand true
}
##+##########################################################################
#
# CreateTOC -- Creates a TOC display from tile's treeview widget
#
method CreateTOC {TOC} {
set W(tree) $TOC.tree
ttk::scrollbar $TOC.sby -orient vert -command "$W(tree) yview"
#scrollbar $TOC.sbx -orient hori -command "$W(tree) xview"
::ttk::treeview $W(tree) -padding {2 2 2 2} -selectmode browse \
-yscrollcommand "$TOC.sby set" ;#$ -xscrollcommand "$TOC.sbx set"
# todo: must be recalled after font changes !! (Done)
ttk::style configure Treeview \
-rowheight [expr {[font metrics $font -linespace] + 5}]
ttk::style configure Treeview.Item \
-padding {2 3 2 2}
#$W(tree) configure -rowheight 20
grid $W(tree) $TOC.sby -sticky news
#grid $TOC.sbx -sticky ew
grid rowconfigure $TOC 0 -weight 1
grid columnconfigure $TOC 0 -weight 1
$W(tree) heading #0 -text "Table of Contents"
$W(tree) tag configure link -foreground blue
# NB. binding to buttonpress sometimes "misses" clicks
$W(tree) tag bind link <Key-Return> [mymethod ButtonPress]
$W(tree) tag bind link <Button-1> [mymethod ButtonPress]
$W(tree) tag bind link <<TreeviewSelect>> [mymethod ButtonPress]
bind $W(tree) <<TreeviewOpen>> [mymethod TreeviewUpdateImages true]
bind $W(tree) <<TreeviewClose>> [mymethod TreeviewUpdateImages false]
$self BuildTOC
}
##+##########################################################################
#
# CreateHelp -- Creates our main help widget
#
method CreateHelp {w} {
set W(main) $w.t ;# normal
text $w.t -border 5 -relief flat -wrap word -state disabled -width 60 \
-yscrollcommand "$w.s set" -padx 5 -font $fonts(std)
$W(tree) tag configure std -font [$W(main) cget -font]
ttk::scrollbar $w.s -orient vert -command "$w.t yview"
pack $w.s -fill y -side right
pack $w.t -fill both -expand 1 -side left
$w.t tag config link -foreground blue -underline 1
$w.t tag config seen -foreground purple4 -underline 1
$w.t tag bind link <Enter> "$w.t config -cursor hand2"
$w.t tag bind link <Leave> "$w.t config -cursor {}"
$w.t tag bind link <1> [mymethod Click $w.t %x %y]
$w.t tag config hdr -font $fonts(hdr)
$w.t tag config hdr3 -font $fonts(hdr3)
$w.t tag config hr -justify center
$w.t tag config fix -font $fonts(fixed)
$w.t tag config bold -font $fonts(bold)
$w.t tag config italic -font $fonts(italic)
set l1 [font measure $font " "]
set l2 [font measure $font " \u2022 "]
set l3 [font measure $font " \u2013 "]
set l3 [expr {$l2 + ($l2 - $l1)}]
$w.t tag config bullet -lmargin1 $l1 -lmargin2 $l2
$w.t tag config number -lmargin1 $l1 -lmargin2 $l2
$w.t tag config dash -lmargin1 $l1 -lmargin2 $l2
$w.t tag config bar -lmargin1 $l2 -lmargin2 $l2
# this should not work as the widget is disabled
# bind $w.t <n> [list ::Help::Next $w.t 1]
# bind $w.t <p> [list ::Help::Next $w.t -1]
# bind $w.t <b> [list ::Help::Back $w.t]
# bind $w.t <Key-space> [bind Text <Key-Next>]
# Create the bitmap for our bullet
if {0 && [lsearch [image names] bullet] == -1} {
image create bitmap bullet -data {
#define bullet_width 11
#define bullet_height 9
static char bullet_bits[] = {
0x00,0x00, 0x00,0x00, 0x70,0x00, 0xf8,0x00, 0xf8,0x00,
0xf8,0x00, 0x70,0x00, 0x00,0x00, 0x00,0x00
};
}
}
# bindings
# foreach tag [$w.t tag names] {
# puts $tag
# $w.t tag bind $tag <KeyPress> { puts %K }
# }
#bind $w.t <KeyPress> {
# puts %K
#}
# but this should work as is bind on the toplevel
# some keys are reserved for navigation of the toc widget
# such us Left, Right, Up, Down
if {[info exists W(top)] && [winfo exists $W(top)]} {
bind $w.t <Enter> [mymethod Bindings %W true]
bind $w.t <Leave> [mymethod Bindings %W false]
wm protocol [winfo toplevel $w.t] WM_DELETE_WINDOW [mymethod DestroyToplevel]
}
}
method DestroyToplevel {} {
$self Bindings $W(main) false
destroy [winfo toplevel $W(top)]
}
method Bindings {w on} {
if {$on} {
bind all <Key-space> [list tk::TextScrollPages $w +1 ]
bind all <Key-BackSpace> [list tk::TextScrollPages $w -1 ]
bind all <Key-Next> [list tk::TextScrollPages $w +1 ]
bind all <Key-Prior> [list tk::TextScrollPages $w -1 ]
bind all <Control-k> [list tk::TextScrollPages $w -1 ]
bind all <Control-j> [list tk::TextScrollPages $w +1 ]
bind all <Control-b> [list tk::TextScrollPages $w -1 ]
bind all <Control-space> [list tk::TextScrollPages $w +1 ]
bind all <Control-h> [mymethod Show Back]
bind all <Alt-Left> [mymethod Show Back]
bind all <Control-l> [mymethod Show Forward]
bind all <Alt-Right> [mymethod Show Forward]
bind all <n> [mymethod Next $w 1]
bind all <p> [mymethod Next $w -1]
bind all <b> [mymethod Back $w]
bind all <Control-plus> [mymethod changeFontSize +2]
bind all <Control-minus> [mymethod changeFontSize -2]
} else {
bind all <Key-space> {}
bind all <Key-BackSpace> {}
bind all <Key-Next> {}
bind all <Key-Prior> {}
bind all <Control-k> {}
bind all <Control-j> {}
bind all <Control-b> {}
bind all <Control-space> {}
bind all) <Control-h> {}
bind all <Alt-Left> {}
bind all <Control-l> {}
bind all <Alt-Right> {}
bind all <n> {}
bind all <p> {}
bind all <b> {}
bind all <Control-plus> {}
bind all <Control-minus> {}
}
}
method changeFontSize {i} {
#set size [font configure $font -size]
#if {$size < 0} {
# # pixel
# incr size [expr {$i*-1}]
#} else {
# incr size $i
#}
#font configure $font -size $size
foreach fnt [array names fonts] {
font configure $fonts($fnt) -size [expr {[font configure $fonts($fnt) -size] + $i}]
}
#set font
#$W(tree) tag configure std -font $font
ttk::style configure Treeview \
-rowheight [expr {[ttk::style configure Treeview -rowheight] + $i}]
}
##+##########################################################################
#
# Click -- Handles clicking a link on the help page
#
method Click {w x y} {
set range [$w tag prevrange link "[$w index @$x,$y] + 1 char"]
if {[llength $range]} { $self Show [eval $w get $range]}
}
##+##########################################################################
#
# Back -- Goes back in help history
#
method Back {w} {
if {[$sh canBackward]} {
set back [$sh back]
$self Show $back
}
}
#
# Forward -- Goes forward in help history
method Forward {w} {
if {[$sh canForward]} {
set forw [$sh forward]
$self Show $forw
}
}
##+##########################################################################
#
# Next -- Goes to next help page
#
method Next {w dir} {
set what $state(all)
if {$state(allTOC) ne {}} {set what $state(allTOC)} ;# TOC order if we can
set n [lsearch -exact $what $state(current)]
set n [expr {($n + $dir) % [llength $what]}]
set next [lindex $what $n]
$self Show $next
}
##+##########################################################################
#
# ::Help::Listpage -- Puts up a help page with a bunch of links (all or history)
#
method Listpage {w llist} {
foreach i $llist {$w insert end \n; $self Showlink $w $i}
}
##+##########################################################################
#
# Search -- Creates search help page
#
method Search {w} {
if {$options(-toolbar)} {
focus $sentry
} else {
$w insert end "\nSearch phrase: "
entry $w.e -textvar [myvar state(search)]
$w window create end -window $w.e
focus $w.e
#$w.e select range 0 end
$w.e icursor end
bind $w.e <Return> [mymethod DoToolSearch]
button $w.b -text Search! -command [mymethod DoToolSearch]
$w insert end " "
$w window create end -window $w.b
}
}
##+##########################################################################
#
# DoSearch -- Does actual help search
#
method DoToolSearch {} {
$W(main) config -state normal
$W(main) delete 1.0 end
$self Search $W(main)
$self DoSearch $W(main)
$W(main) config -state disabled
}
method DoSearch {w} {
$w config -state normal
$w insert end "\n\nSearch results for '$state(search)':\n"
foreach i $state(all) {
if {[regexp -nocase $state(search) $i]} { ;# Found in title
$w insert end \n
$self Showlink $w $i
} elseif {[regexp -nocase -indices -- $state(search) $pages($i) pos]} {
set p1 [expr {[lindex $pos 0]-20}]
set p2 [expr {[lindex $pos 1]+20}]
regsub -all \n [string range $pages($i) $p1 $p2] " " context
$w insert end \n
$self Showlink $w $i
$w insert end " - ...$context..."
}
}
$w config -state disabled ;#normal
}
##+##########################################################################
#
# Showlink -- Displays link specially
#
method Showlink {w link {tag {}}} {
if {[regexp {(\.png|\.gif)$} $link]} {
set imgName [file tail [file rootname $link]]
set imgFile [file join [file dirname $options(-helpfile)] $link]
if {[file exists $imgFile]} {
image create photo $imgName -file $imgFile
#puts "Image:'$link'"
$w image create end -image $imgName
} else {
$w insert end "(Error: file $link does not exists)"
}
} else {
set tag [concat $tag link]
set title [$self FindPage $link]
if {[lsearch -exact $state(seen) $title] > -1} {
lappend tag seen
}
$w insert end $link $tag
}
}
##+##########################################################################
#
# FindPage -- Finds actual pages given a possible alias
#
method FindPage {title} {
if {[info exists pages($title)]} { return $title }
set title2 [string tolower $title]
if {[info exists alias($title2)]} { return $alias($title2) }
return "ERROR!"
}
##+##########################################################################
#
# Show -- Shows help or meta-help page
#
method Show {{title ""}} {
set title [string trim $title]
if {$title eq ""} {
set title $var(home)
}
set w $W(main)
set title [$self FindPage $title]
if {[lsearch -exact $state(seen) $title] == -1} {lappend state(seen) $title}
$w config -state normal
$w delete 1.0 end
$w insert end $title hdr "\n"
set next 0 ;# Some pages have no next page
switch -- $title {
Back { $self Back $w; return}
Forward { $self Forward $w; return}
History { $self Listpage $w [$sh getHistory]}
Next { $self Next $w 1; return}
Previous { $self Next $w -1; return}
Index { $self Listpage $w $state(all)}
Search { $self Search $w}
default { $self ShowPage $w $title ; set next 1 }
}
# Add bottom of the page links
if {$options(-bottomnavigation)} {
$w insert end \n------\n {}
if {! $state(haveTOC) && [info exists alias(toc)]} {
$w insert end TOC link " - " {}
}
$w insert end Index link " - " {} Search link
if {$next} {
$w insert end " - " {} Previous link " - " {} Next link
}
if {[llength [$sh getHistory]]} {
$w insert end " - " {} History link " - " {} Back link
}
$w insert end \n
}
$sh insert $title
if {[$sh canBackward]} {
$W(backward) configure -state active
} else {
$W(backward) configure -state disabled
}
if {[$sh canForward]} {
$W(forward) configure -state active
} else {
$W(forward) configure -state disabled
}
$w config -state disabled ;#disabled
set state(current) $title
}
##+##########################################################################
#
# ShowPage -- Shows a text help page, doing wiki type transforms
#
method ShowPage {w title} {
set endash \u2013
set emdash \u2014
set bullet \u2022
$w insert end \n ;# Space down from the title
if {! [info exists pages($title)]} {
set lines [list "This help page is missing." "" "See \[Index\] for a list of existing pages!"]
} else {
# image fix
set txt [regsub -all {([^ ]{3}!)\[.*?\]\((.+?)\)} $pages($title) "\\1\[\\2\]"]
# link fix
set txt [regsub -all {([^!])\[(.*?)\]\((.+?)\)} $txt "\\1\[\\2\]"]
set txt [regsub -all {\n!} $txt "\n"]
set lines [split $txt \n]
}
set ind ""
foreach line $lines {
set tag {}
set op1 ""
if {[regexp -line {^[-_]{3,4}\s*$} $line]} {
$w insert end "[string repeat _ 30]\n" hr
continue
} elseif {[regexp -line {^[#]{3,5}\s(.+)} $line -> txt]} {
$w insert end "$txt\n" hdr3
continue
} elseif {[regexp -line {^>\s*$} $line]} {
set ind " | "
$w insert end "\n"
continue
} elseif {[regexp -line {^>(\s+[-*].+)} $line -> rest]} {
set ind " |"
set line $rest
#puts $line
#continue
} elseif {[regexp -line {^>\s([A-Z0-9a-z].+)} $line -> rest]} {
#puts $line
set ind " | "
set line $rest
#continue
} elseif {[regexp {^\s*$} $line]} {
set ind ""
}
set line "$ind$line"
if {[regexp -line {^ +\|*\s*([-1*|]+)\s+(.*)} $line -> op txt]} {
set ind2 ""
if {[regexp -line {^ +\|} $line ]} {
set ind2 " "
}
set op1 [string index $op 0]
set lvl [expr {[string length $op] - 1}]
set indent $ind2[string repeat " " $lvl]
if {$op1 eq "1"} { ;# Number
if {! [info exists number($lvl)]} { set number($lvl) 0 }
set tag number
incr number($lvl)
$w insert end "$indent $number($lvl). " $tag
} elseif {$op1 eq "*"} { ;# Bullet
set tag bullet
$w insert end "$indent $bullet " $tag
} elseif {$op1 eq "-"} { ;# Dash
set tag dash
$w insert end "$indent $endash " $tag
} elseif {$op1 eq "|"} { ;# Bar
set tag bar
}
set line $txt
} elseif {[string match " *" $line]} { ;# Line beginning w/ a space
$w insert end "$line\n" fix
unset -nocomplain number
continue
}
if {$op1 ne "1"} {unset -nocomplain number}
while {1} { ;# Look for markups
set link0 [set bold0 [set ital0 $line]]
set n1 [regexp {^(.*?)[[](.*?)[]](.*$)} $line -> link0 link link1]
set n2 [regexp {^(.*?)('{3}|[*]{2})(.*?)('{3}|[*]{2})(\s*.*$)} $line -> bold0 x bold y bold1]
set n3 [regexp {^(.*?)('{2}|[*]{1})([^\s].*?)('{2}|[*]{1})(\s*.*$)} $line -> ital0 x ital y ital1]
set n4 [regexp {^(.*?)`(.*?)`(\s*.*$)} $line -> tt0 tt tt1]
if {$n4} {
set len4 [expr {$n4 ? [string length $tt0] : 9999}]
}
if {$n1 == 0 && $n2 == 0 && $n3 == 0 && $n4 == 0} break
set len1 [expr {$n1 ? [string length $link0] : 9999}]
set len2 [expr {$n2 ? [string length $bold0] : 9999}]
set len3 [expr {$n3 ? [string length $ital0] : 9999}]
set len4 [expr {$n4 ? [string length $tt0] : 9999}]
set l1 [lindex [lsort -integer [list $len1 $len2 $len3 $len4]] 0]
if {false} {
if {$len1 < $len3} {
$w insert end $link0 $tag
$self Showlink $w $link $tag
set line $link1
} elseif {$len2 <= $len3} {
$w insert end $bold0 $tag $bold [concat $tag bold]
set line $bold1
} else {
$w insert end $ital0 $tag $ital [concat $tag italic]
set line $ital1
}
}
if {$len1 == $l1} {
$w insert end $link0 $tag
$self Showlink $w $link $tag
set line $link1
} elseif {$len2 == $l1} {
$w insert end $bold0 $tag $bold [concat $tag bold]
set line $bold1
} elseif {$len3 == $l1} {
$w insert end $ital0 $tag $ital [concat $tag italic]
set line $ital1
} else {
$w insert end $tt0 $tag $tt [concat $tag fix]
set line $tt1
}
#$w insert end $ital0 $tag $ital [concat $tag italic]
#set line $ital1
# else
# $w insert end $tt0 $tag $tt1 [concat $tag fix]
# set line $tt1
#
}
$w insert end "$line\n" $tag
}
}
##+##########################################################################
#
# BuildTOC -- Fills in our TOC widget based on a TOC page
#
method BuildTOC {} {
set state(allTOC) {} ;# All pages in TOC ordering
if {! [winfo exists $W(tree)]} return
set tocData $pages([$self FindPage toc])
$W(tree) delete [$W(tree) child {}]
#$W(tree) configure -padding {50 10 2 2}
unset -nocomplain parent
set parent() {}
regsub -all {'{2,}} $tocData {} tocData
regsub -all {\(#.+?\)} $tocData "" tocData
regsub -all { {4,5}([-*+]) } $tocData " \\1\\1 " tocData
#puts $tocData
foreach line [split $tocData \n] {
set n [regexp {^\s*([-*]+)\s*(.*)} $line => dashes txt]
if {! $n} continue
set isLink [regexp {^\[(.*)\]$} $txt => txt]
set pDashes [string range $dashes 1 end]
if {[info exists var("icon,$txt")]} {
set icon $var("icon,$txt")
} else {
set icon filenew16
}
set parent($dashes) [$W(tree) insert $parent($pDashes) end -text " $txt" -tag std -image $icon]
if {$parent($pDashes) ne ""} {
$W(tree) item $parent($pDashes) -image book
}
if {$isLink} {
$W(tree) item $parent($dashes) -tag [list link std]
set ptitle [$self FindPage $txt]
if {[lsearch $state(allTOC) $ptitle] == -1} {
lappend state(allTOC) $ptitle
}
}
}
}
##+##########################################################################
#
# ButtonPress -- Handles clicking on a TOC link
# !!! Sometimes misses clicks, so we're using TreeviewSelection instead
#
method ButtonPress {} {
set id [$W(tree) selection]
set title [$W(tree) item $id -text]
$self Show $title
}
##+##########################################################################
#
# TreeviewSelection -- Handles clicking on any item in the TOC
#
method TreeviewSelection {} {
set id [$W(tree) selection]
set title [$W(tree) item $id -text]
set tag [$W(tree) item $id -tag]
if {$tag eq "link"} {
$self Show $title
} else { ;# Make all children visible
set last [lindex [$W(tree) children $id] end]
if {$last ne {} && [$W(tree) item $id -open]} {
$W(tree) see $last
}
}
}
##+###########################################################################
#
# TreeviewUpdateImages -- check if children are visible and update icon
#
method TreeviewUpdateImages {open} {
# event fires before
# the children are indeed displayed or hided
set item [$W(tree) focus]
if {$open} {
if {[llength [$W(tree) children $item]] > 0} {
$W(tree) item $item -image bookopen
}
} else {
if {[llength [$W(tree) children $item]] > 0} {
$W(tree) item $item -image book
}
}
}
method CenterWindow {w} {
wm withdraw $w
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
}
##+##########################################################################
#
# Refresh -- resets all help info and updates widget
#
method Refresh {} {
set current $state(current)
array unset pages
set pages(ERROR!) "page does not exists"
array unset state
array set state {seen {} current {} all {} allTOC {} haveTOC 0}
array unset alias
foreach title {Back History Next Previous Index Search} {
set alias([string tolower $title]) $title
}
$sh resetHistory
$self ReadHelpFiles
$self Show $current
}
##+##########################################################################
#
# Sanity -- Checks for missing help links
#
method Sanity {} {
set missing {}
foreach page $state(all) {
set m [$self CheckLinks $page]
if {$m ne {}} {
set missing [concat $missing $m]
}
}
return $missing
}
##+##########################################################################
#
# CheckLinks -- Checks one page for missing help links
#
method CheckLinks {title} {
set missing {}
set title [$self FindPage $title]
foreach {. link} [regexp -all -inline {\[(.*?)\]} $pages($title)] {
if {! [info exists alias([string tolower $link])]} {
lappend missing $link
}
}
return $missing
}
method WIKIFIX {txt} {
regsub -all {\n } $txt "\n" txt
return $txt
}
}
## EON HELP
package provide dgw::hyperhelp 0.8.1
#'
#' ## <a name='example'>EXAMPLE</a>
#'
#' ```
#' package require dgw::hyperhelp
#' set helpfile [file join [file dirname [info script]] hyperhelp-docu.txt]
#' set hhelp [dgw::hyperhelp .help -helpfile $helpfile]
#' pack $hhelp -side top -fill both -expand true
#' $hhelp help overview
#' ```
#'
#' ## <a name='formatting'>MARKUP LANGUAGE</a>
#'
#' The Markup language of the hyperhelp widget is similar to Tclers Wiki and Markdown markup.
#' Here are the most important markup commands. For a detailed description have a look at the
#' file `hyperhelp-docu.txt` which contains the hyperhelp documentation with detailed markup rules.
#'
#' *Page structure:*
#'
#' A help page in the help file is basically started with the title tag at the beginning of a line and adds with 6 dashes. See here an example for three help pages.
#' To shorten links in the document later as well an `alias` can be given afterwards. There is also support for Markdown headers as the last page shows.
#'
#'
#' title: Hyperhelp Title Page
#' alias: main
#'
#' Free text can be written here with standard *Markdown*
#' or ''Wiki'' syntax markup.
#'
#' ------
#' title: Other Page title
#' alias: other
#' icon: acthelp16
#'
#' Follows more text for the second help page. You can link
#' to the [main] page here also.
#' ------
#'
#' ## <a name="aliasname">Page title</a>
#'
#' Text for the next page after this Markdown like header, the anchor is now an alis
#' which can be used for links like here [aliasname], the link [Page title] points to the same page.
#'
#' For the second page an other icon than the standard file icon was given for the help page. This icon is
#' used for the treeview widget on the left displayed left of the page title.
#' The following icons are currently available: acthelp16, bookmark, idea, navhome16, help, sheet, folder, textfile.
#'
#' *"Table of Contents" page:*
#'
#' There is a special page called "Table of Contents". The unnumbered list, probably nested, of this page will be used
#' for the navigation outline tree on the left. Below is the example for the contents page which
#' comes with the hyperhelp help file "hyperhelp-docu.txt". The "Table of Contents" page should be the first page
#' in your documentation. Please indent only with standard Markdown syntax compatible, so two spaces
#' for first level and four spaces for second level.
#'
#' title: Table of Contents
#' alias: TOC
#' - [Welcome to the Help System]
#' - [What's New]
#' - Formatting
#' - [Basic Formatting]
#' - [Aliases]
#' - [Lists]
#' - [Substitutions]
#' - [Images]
#' - [Code Blocks]
#' - [Indentation]
#' - [Creating the TOC]
#' - [Key Bindings]
#' - [To Do]
#'
#' -------
#
#'
#' *Font styles:*
#'
#' > - '''bold''' - **bold** (Wiki syntax), \*\*bold\*\* - **bold** (Markdown syntax)
#' - ''italic'' - *italic* (Wiki syntax), \*italic\* - *italic* (Markdown syntax)
#' - \`code\` - `code`
#'
#' *Links:*
#'
#' > - hyperlinks to other help pages within the same document are created using brackets: `[overview]` -> [overview](#overview)
#' - image links, where images will be embedded and shown `[image.png]`
#' - also image display and hyperlinks in Markdown format are supported. Therefore `` displays an image and
#' `[Page title](#alias)` creates a link to the page "Page title"
#'
#' *Code blocks:*
#'
#' > - code blocks are started by indenting a line with three spaces
#' - the block continues until less than three leading whitespace character are found on the text
#'
#' *Indentation:*
#'
#' > - indented blocks are done by using the pipe symbol `|` or the greater symbol as in Markdown syntax
#' - indenting ends on lines without whitespaces as can be seen the following example
#'
#'
#' > * indented one with `code text`
#' * indented two with **bold text**
#' * indented three with *italic text*
#'
#' this text is again unindented
#'
#'
#' *Substitutions:*
#'
#' > - you can substitute variables and commands within the help page
#' - command substition is done using double brackets like in `[[package require dgw::hyperhelp]]` would embed the package version of the hyperhelp package
#' - variable substitution is done using the Dollar variable prefix, for instance `$::tcl_patchLevel` would embed the actual Tcl version
#' - caution: be sure to not load files from unknown sources, command substitution should not work with commands like `file`, `exec` or `socket`.
#' But anyway only use your own help files
#'
#' *Lists:*
#'
#' > - support for list and nested lists using the standard `* item` and `** subitem`` syntax
#' - numbered lists can be done with starting a line with `1. ` followed by a white space such as in ` 1. item` and ` 11. subitem`
#' - dashed lists can be done with single and double dashes
#'
#' *Key bindings:*
#'
#' > The hyperhelp window provides some standard key bindings to navigate the content:
#'
#' > * space, next: scroll down
#' * backspace, prior: scroll up
#' * Ctrl-k, Ctrl-j: scroll in half page steps up and down
#' * Ctrl-space, Ctrl-b: scroll down or up
#' * Ctrl-h, Alt-Left, b: browse back history if possible
#' * Ctrl-l, Alt-Right: browse forward in history if possible
#' * n, p: browse forward or backward in page order
#' * Control-Plus, Control-Minus changes in font-size
#' * Up, Down, Left, Right etc are used for navigation in the treeview widget
#'
#'
#' ## <a name='install'>INSTALLATION</a>
#'
#' Installation is easy you can install and use the **__PKGNAME__** package if you have a working install of:
#'
#' - the snit package which can be found in [tcllib - https://core.tcl-lang.org/tcllib](https://core.tcl-lang.org/tcllib)
#' - the dgtools::shistory package which can be found at the same side as the dgw::hyperhelp package
#'
#' For installation you copy the complete *dgw* and the *dgtools* folder into a path
#' of your *auto_path* list of Tcl or you append the *auto_path* list with the parent dir of the *dgw* directory.
#' Alternatively you can install the package as a Tcl module by creating a file dgw/__BASENAME__-__PKGVERSION__.tm in your Tcl module path.
#' The latter in many cases can be achieved by using the _--install_ option of __BASENAME__.tcl.
#' Try "tclsh __BASENAME__.tcl --install" for this purpose. Please note, that in the latter case you must redo this
#' for the `dgtools::shistory` package.
#'
#' ## <a name='demo'>DEMO</a>
#'
#' Example code for this package can be executed by running this file using the following command line:
#'
#' ```
#' $ wish __BASENAME__.tcl --demo
#' ```
#' The example code used for this demo can be seen in the terminal by using the following command line:
#'
#' ```
#' $ wish __BASENAME__.tcl --code
#' ```
#'
#' ## <a name='docu'>DOCUMENTATION</a>
#'
#' The script contains embedded the documentation in Markdown format.
#' To extract the documentation you need that the dgwutils.tcl file is in
#' the same directory with the file `__BASENAME__.tcl`.
#' Then you can use the following command lines:
#'
#' ```
#' $ tclsh __BASENAME__.tcl --markdown
#' ```
#'
#' This will extract the embedded manual pages in standard Markdown format. You can as well use this markdown output directly to create html pages for the documentation by using the *--html* flag.
#'
#' ```
#' $ tclsh __BASENAME__.tcl --html
#' ```
#'
#' This will directly create a HTML page `__BASENAME__.html` which contains the formatted documentation.
#' Github-Markdown can be extracted by using the *--man* switch:
#'
#' ```
#' $ tclsh __BASENAME__.tcl --man
#' ```
#'
#' The output of this command can be used to feed a markdown processor for conversion into a
#' html or pdf document. If you have pandoc installed for instance, you could execute the following commands:
#'
#' ```
#' tclsh ../__BASENAME__.tcl --man > __BASENAME__.md
#' pandoc -i __BASENAME__.md -s -o __BASENAME__.html
#' pandoc -i __BASENAME__.md -s -o __BASENAME__.tex
#' pdflatex __BASENAME__.tex
#' ```
#'
#' ## <a name='see'>SEE ALSO</a>
#'
#' - [dgw - package](http://chiselapp.com/user/dgroth/repository/tclcode/index)
#' - [shtmlview - package](http://chiselapp.com/user/dgroth/repository/tclcode/index)
#'
#' ## <a name='todo'>TODO</a>
#'
#' * some more template files (done)
#' * tests (done, could be more)
#' * github url
#'
#' ## <a name='changes'>CHANGES</a>
#'
#' - 2020-02-01 Release 0.5 - first published version
#' - 2020-02-05 Release 0.6 - catching errors for missing images and wrong Tcl code inside substitutions
#' - 2020-02-07 Release 0.7
#' - options _-toolbar_, _-toctree_ for switchable display
#' - single page, automatic hiding of toctree and toolbar
#' - outline widget only shown if TOC exists
#' - adding Control-Plus, Control-Minus for font changes
#' - fix indentation and italic within indentation is now possible
#' - basic Markdown support
#' - 2020-02-16 Release 0.8.0
#' - fix for Ctrl.j, Ctrk-k keys
#' - disabled default command substitutions
#' - 2020-02-19 Release 0.8.1
#' - removed bug in the within page search
#' - insertion cursors for search remains in the widget
#' - fixed bug in help page
#'
#' ## <a name='authors'>AUTHOR(s)</a>
#'
#' The *__PKGNAME__* package was written by Dr. Detlef Groth, Schwielowsee, Germany using Keith Vetters code from the Tclers Wiki as starting point.
#'
#' ## <a name='license'>LICENSE AND COPYRIGHT</a>
#'
#' The __PKGNAME__ package version __PKGVERSION__
#'
#' Copyright (c) 2019-20 Dr. Detlef Groth, E-mail: <detlef(at)dgroth(dot)de>
#' This library is free software; you can use, modify, and redistribute it
#' for any purpose, provided that existing copyright notices are retained
#' in all copies and that this notice is included verbatim in any
#' distributions.
#'
#' This software is distributed WITHOUT ANY WARRANTY; without even the
#' implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#'
if {[info exists argv0] && $argv0 eq [info script] && [regexp hyperhelp $argv0]} {
set dpath dgw
set pfile [file rootname [file tail [info script]]]
package require dgw::dgwutils
#source [file join [file dirname [info script]] dgwutils.tcl]
if {[llength $argv] >= 1 && [file exists [lindex $argv 0]]} {
set sub false
# todo deal with --option and topic
if {[llength $argv] > 1 && [lindex $argv 1] eq "--commandsubst"} {
set sub true
}
set hhelp [dgw::hyperhelp .win -helpfile [lindex $argv 0] -commandsubst $sub] ;#-font [{Alegreya 12}]
if {[llength $argv] == 2 && !$sub} {
$hhelp Help [lindex $argv 1]
} elseif {[llength $argv] == 3} {
$hhelp Help [lindex $argv 2]
}
pack .win -side top -fill both -expand true
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--version"} {
puts [dgw::getVersion [info script]]
destroy .
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--demo"} {
dgw::runExample [info script]
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--code"} {
puts [dgw::runExample [info script] false]
destroy .
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--test"} {
package require tcltest
set argv [list]
tcltest::test dummy-1.1 {
Calling my proc should always return a list of at least length 3
} -body {
set result 1
} -result {1}
tcltest::test gui-2.1 {
starting hyperhelp
} -body {
package require dgw::hyperhelp
set helpfile [file join [file dirname [info script]] hyperhelp-docu.txt]
set hhelp [dgw::hyperhelp .help -helpfile $helpfile]
pack $hhelp -side top -fill both -expand true
$hhelp help "What's New"
$hhelp help "overview"
$hhelp help "toc"
$hhelp help "What's New"
set result [$hhelp getTitle]
$hhelp help "What's New"
set pages [$hhelp getPages]
foreach page $pages {
$hhelp help $page
update idletasks
after 500
}
$hhelp help "What's New"
destroy .help
set result
} -result {What's New}
tcltest::test gui-2.2 {
simple on page side
} -body {
package require dgw::hyperhelp
set helpfile [file join [file dirname [info script]] hyperhelp-onepage-sample.txt]
set hhelp [dgw::hyperhelp .help -helpfile $helpfile]
pack $hhelp -side top -fill both -expand true
set result [$hhelp getTitle]
set pages [$hhelp getPages]
foreach page $pages {
$hhelp help $page
update idletasks
after 500
}
destroy .help
set result 1
} -result {1}
tcltest::test gui-2.3 {
notoc test with several pages
} -body {
package require dgw::hyperhelp
set helpfile [file join [file dirname [info script]] hyperhelp-notoc-sample.txt]
set hhelp [dgw::hyperhelp .help -helpfile $helpfile]
pack $hhelp -side top -fill both -expand true
set result [$hhelp getTitle]
set pages [$hhelp getPages]
foreach page $pages {
$hhelp help $page
update idletasks
after 500
}
destroy .help
set result 1
} -result {1}
tcltest::test gui-2.4 {
markdown test
} -body {
package require dgw::hyperhelp
set helpfile [file join [file dirname [info script]] hyperhelp-markdown-sample.md]
set hhelp [dgw::hyperhelp .help -helpfile $helpfile]
pack $hhelp -side top -fill both -expand true
set result [$hhelp getTitle]
set pages [$hhelp getPages]
foreach page $pages {
$hhelp help $page
update idletasks
after 500
}
destroy .help
set result 1
} -result {1}
tcltest::cleanupTests
destroy .
} elseif {[llength $argv] == 1 && ([lindex $argv 0] eq "--license" || [lindex $argv 0] eq "--man" || [lindex $argv 0] eq "--html" || [lindex $argv 0] eq "--markdown")} {
dgw::manual [lindex $argv 0] [info script]
} elseif {[llength $argv] == 1 && [lindex $argv 0] eq "--install"} {
dgw::install [info script]
} else {
destroy .
puts "\n -------------------------------------"
puts " The ${dpath}::$pfile package for Tcl"
puts " -------------------------------------\n"
puts "Copyright (c) 2019 Dr. Detlef Groth, E-mail: detlef(at)dgroth(dot)de\n"
puts "License: MIT - License see manual page"
puts "\nThe ${dpath}::$pfile package provides a help viewer widget with hyperhelp"
puts "text facilities and a browser like toolbar"
puts ""
puts "Usage: [info nameofexe] [info script] option|filename\n"
puts " filename is a help file with hyperhelp markup"
puts " Valid options are:\n"
puts " --help : printing out this help page"
puts " --demo : runs a small demo application."
puts " --code : shows the demo code."
puts " --test : running some test code"
puts " --license : printing the license to the terminal"
puts " --install : install ${dpath}::$pfile as Tcl module"
puts " --man : printing the man page in pandoc markdown to the terminal"
puts " --markdown: printing the man page in simple markdown to the terminal"
puts " --html : printing the man page in html code to the terminal"
puts " if the Markdown package from tcllib is available"
puts ""
puts " The --man option can be used to generate the documentation pages as well with"
puts " a command like: "
puts ""
puts " tclsh [file tail [info script]] --man | pandoc -t html -s > temp.html\n"
}
if {[lindex $argv 0] eq "demo"} {
panedwindow .pw
set hfile [file join [file dirname [info script]] help.txt]
set hhelp [hyperhelp::hyperhelp .pw.win -helpfile $hfile]
$hhelp Help overview
set hhelp2 [hyperhelp::hyperhelp .pw.win2 -helpfile $hfile]
$hhelp2 Help overview
pack .pw -side left -fill both -expand yes
.pw add $hhelp $hhelp2
}
}
package provide hyperhelp 0.8.1
#-- End of script section