IDETclParser.xotcl
@ Component IDETclParser {
description {This component provide classes for parsing und syntax check of
xotcl/tcl source code.
The base Classes are PrsContext and TclParser
For Parse a xotcl method use
set context [PrsContext new]
$context parseAndCheck $wholeMethodBody
if {[$context hasErrors]} {
puts [$context errors]
}
The Parser (TclParer) build a parse tree form tcl base element
PrsElement (Root)
The Checking funktionality is programed in Class PrsContext
}
}
package provide IDETclParser 0.86
namespace eval ::tlog {}
@ tclproc tlog::debug idemeta struct IDETclParser tlog
proc tlog::debug message {
}
@ tclproc tlog::error idemeta struct IDETclParser tlog
proc tlog::error message {
puts "error: $message"
}
@ tclproc tlog::info idemeta struct IDETclParser tlog
proc tlog::info message {
}
@ tclproc tlog::ldebug idemeta struct IDETclParser tlog
proc tlog::ldebug message {
}
@ tclproc tlog::lerror idemeta struct IDETclParser tlog
proc tlog::lerror message {
puts "error: [uplevel subst $message]"
}
@ tclproc tlog::linfo idemeta struct IDETclParser tlog
proc tlog::linfo message {
}
@ tclproc tlog::ltrace idemeta struct IDETclParser tlog
proc tlog::ltrace message {
}
@ tclproc tlog::lwarn idemeta struct IDETclParser tlog
proc tlog::lwarn message {
puts "warn: [uplevel subst $message]"
}
@ tclproc tlog::setLogLevel idemeta struct IDETclParser tlog
proc tlog::setLogLevel level {
set levels {error warn info debug trace}
set logLevel [lsearch $levels $level]
if {$logLevel<0} {
error "unknown log level suported levels are: $levels"
}
for {set i 0} {$i<[llength $levels]} {incr i} {
set levelName [lindex $levels $i]
if {$i<=$logLevel} {
proc ::tlog::$levelName {message} "puts \"$levelName: \$message\""
proc ::tlog::l$levelName {message} "puts \"$levelName: \[uplevel \[list subst \$message\]\]\""
} else {
proc ::tlog::$levelName {message} ""
proc ::tlog::l$levelName {message} ""
}
}
}
@ tclproc tlog::trace idemeta struct IDETclParser tlog
proc tlog::trace message {
}
@ tclproc tlog::warn idemeta struct IDETclParser tlog
proc tlog::warn message {
puts "warn: $message"
}
namespace eval ::ttype {}
@ tclproc ttype::commandoptions idemeta struct IDETclParser ttype
proc ttype::commandoptions descs {
set options [list]
foreach d [lrange $descs 1 end] {
set firstArgument [lindex $d 1]
lassign [ttype::getArgDesc $firstArgument] mult type
if {[lindex $type 0] eq "option"} {
foreach {opt opttype} [lrange $type 1 end] {
lappend options $opt
}
}
}
return $options
}
@ tclproc ttype::getArgDesc idemeta struct IDETclParser ttype
proc ttype::getArgDesc argDesc {
set type unknown
set mult {}
set typeindex 0
if {[lindex $argDesc 0] in {* ? +}} {
set mult [lindex $argDesc 0]
set typeindex 1
}
if {[llength $argDesc]>=$typeindex+1} {
set type [lindex $argDesc $typeindex]
}
list $mult $type
}
@ tclproc ttype::isColor idemeta struct IDETclParser ttype
proc ttype::isColor color {
expr {[regexp {^#[0-9A-F]{6}$} $color] || $color in {gray60 gray70 gray80 gray85 gray90 gray95 snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 purple2 purple3 purple4 MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 thistle4}}
}
@ tclproc ttype::isRefType idemeta struct IDETclParser ttype
proc ttype::isRefType type {
expr {[lindex $type 0] in {wref setref ref gref setgref}}
}
@ tclproc ttype::isSimpleDesc idemeta struct IDETclParser ttype
proc ttype::isSimpleDesc descs {
expr {[llength $descs]==2 &&
[llength [lindex $descs 0]]==1 &&
[llength [lindex $descs 1]]==1 &&
[string is integer [lindex $descs 0]] &&
[string is integer [lindex $descs 1]]}
}
@ tclproc ttype::subcommands idemeta struct IDETclParser ttype
proc ttype::subcommands descs {
set subcommands [list]
foreach d [lrange $descs 1 end] {
if {[lindex $d 1 0 0] eq "const"} {
lappend subcommands [lindex $d 1 0 1]
}
}
return $subcommands
}
Class ChainSignatureRepository
@ ChainSignatureRepository idemeta categories {api-oo api}
@ ChainSignatureRepository idemeta categoriesMethods {{getClassParameters isXotclMetaClass getMethodDescriptionForObject registerObject isXotclObject getMethodDescriptionForClasses getFullObjectName getClassesForObject isXotclClass registerMethod getClassSuperclassesFromFullName getFullHeritage} {getVariableType registerProc updateSignatureTypes registerVariable}}
@ ChainSignatureRepository idemeta component IDETclParser
ChainSignatureRepository instproc addNamespaceExport {namespace exportList} {
my instvar writeRepository
$writeRepository addNamespaceExport $namespace $exportList
}
ChainSignatureRepository instproc addNamespaceImport {namespace importList} {
my instvar writeRepository repositoryChain
set realImport [list]
foreach imp $importList {
foreach repo $repositoryChain {
set resolvedImports [$repo resolveImportPattern $imp]
if {[llength $resolvedImports]>0} {
foreach i $resolvedImports {
lappend realImport $i
}
break
}
}
}
$writeRepository addNamespaceImportBase $namespace $realImport
}
ChainSignatureRepository instproc canAssignType {requiredType isType} {
my instvar repositoryChain
if {![PrsCheckerOptions checkTypes]} {
return 1
}
foreach r $repositoryChain {
set desc [$r canAssignType $requiredType $isType]
if {$desc} {
return $desc
}
}
return 0
}
ChainSignatureRepository instproc createNoUpdateCache {} {
my instvar repositoryChain noUpdateCache
set noUpdateCache [list]
foreach r [lrange $repositoryChain 0 end-1] {
if {[$r exists methodsArr]} {
lappend noUpdateCache {*}[$r array names methodsArr]
}
if {[$r exists commandsArr]} {
lappend noUpdateCache {*}[$r array names commandsArr]
}
}
set noUpdateCache [lsort $noUpdateCache]
}
ChainSignatureRepository instproc getClassParameters {class {namespace {}}} {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getClassParameters $class $namespace]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc getClassSuperclassesFromFullName fullName {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getClassSuperclassesFromFullName $fullName]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc getClassesForObject {object {namespace {}}} {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getClassesForObject $object $namespace]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc getCommandDescription {name {namespace {}}} {
my instvar repositoryChain
set oname [my getOriginName $name $namespace]
if {$oname ne ""} {
set name $oname
}
foreach r $repositoryChain {
set desc [$r getCommandDescription $name $namespace]
if {$desc ne ""} {
return $desc
}
}
if {$namespace ne "" && [string range $name 0 1] ne "::" } {
foreach r $repositoryChain {
set desc [$r getCommandDescription $name {}]
if {$desc ne ""} {
return $desc
}
}
}
return
}
ChainSignatureRepository instproc getCoreRepository {} {
my instvar repositoryChain writeRepository
lindex $repositoryChain 0
}
ChainSignatureRepository instproc getFullHeritage {class {namespace {}}} {
my getFullHeritageReq [my getFullObjectName $class $namespace]
}
ChainSignatureRepository instproc getFullHeritageReq class {
set hlist [list $class]
foreach s [my getClassSuperclassesFromFullName $class] {
if {$s ni $hlist} {
lappend hlist $s
foreach c [my getFullHeritageReq $s] {
if {$c ni $hlist} {
lappend hlist $c
}
}
}
}
return $hlist
}
ChainSignatureRepository instproc getFullName {namespace name} {
my instvar writeRepository
$writeRepository getFullName $namespace $name
}
ChainSignatureRepository instproc getFullObjectName {object {namespace {}}} {
my instvar repositoryChain
set oname [my getOriginName $object $namespace]
if {$oname ne ""} {
set object $oname
}
foreach r $repositoryChain {
set desc [$r getFullObjectName $object $namespace]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc getMethodDescription fname {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getMethodDescription $fname]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc getMethodDescriptionForClasses {classes method {namespace {}} {object {}}} {
my instvar xotclArr writeRepository
foreach cl $classes {
set fullCl [my getFullObjectName $cl $namespace]
foreach c [my getFullHeritage $fullCl] {
set fname [list $c instproc $method]
set desc [my getMethodDescription $fname]
if {$desc ne ""} {
if {$c eq "::xotcl::Class" && $method in {new alloc create}} {
lset desc 1 0 [list [list xotcl $object]]
}
return $desc
}
set desc [$writeRepository getMethodDescFromIntro $c inst $method]
if {$desc ne "" } {
return $desc
}
foreach param [$writeRepository getClassParameters $c] {
set paramName [lindex $param 0]
if {$paramName eq $method} {
set type [my getVariableType $fullCl instproc $paramName $namespace]
if {$type eq ""} {
set type unknown
}
return [list $c [list [list $type parameter] [list ? $type]]]
}
}
}
}
return
}
ChainSignatureRepository instproc getMethodDescriptionForObject {object method {namespace {}}} {
my instvar writeRepository
set fobject [my getFullObjectName $object $namespace]
set fname [list $fobject proc $method]
set desc [my getMethodDescription $fname]
if {$desc ne ""} {
return $desc
}
set desc [$writeRepository getMethodDescFromIntro $object {} $method]
if {$desc ne ""} {
return $desc
}
my getMethodDescriptionForClasses [list [my getXotclClassForObject $object]] $method $namespace $fobject
}
ChainSignatureRepository instproc getOriginName {name namespace} {
my instvar repositoryChain
foreach r $repositoryChain {
set oname [$r getOriginName $name $namespace]
if {$oname ne ""} {
return $oname
}
}
return
}
ChainSignatureRepository instproc getVariableType {class stype name {namespace {}}} {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getVariableType $class $stype $name $namespace]
if {$desc ne ""} {
return $desc
}
}
if {$stype eq "global" && $namespace ne "" && [string range $name 0 1] ne "::"} {
foreach r $repositoryChain {
set desc [$r getVariableType $class $stype $name {}]
if {$desc ne ""} {
return $desc
}
}
}
return
}
ChainSignatureRepository instproc getWriteRepository {} {
my set writeRepository
}
ChainSignatureRepository instproc getXotclClassForObject {object {namespace {}}} {
my instvar repositoryChain
foreach r $repositoryChain {
set desc [$r getXotclClassForObject $object $namespace]
if {$desc ne ""} {
return $desc
}
}
return
}
ChainSignatureRepository instproc init {repositories twriteRepository} {
my instvar repositoryChain writeRepository
set repositoryChain $repositories
set writeRepository $twriteRepository
my createNoUpdateCache
}
ChainSignatureRepository instproc initNewCreateMethods {} {
my instvar writeRepository
$writeRepository initNewCreateMethods
}
ChainSignatureRepository instproc isXotclClass {class {namespace {}}} {
my instvar repositoryChain
set oname [my getOriginName $class $namespace]
if {$oname ne ""} {
set class $oname
}
foreach r $repositoryChain {
set desc [$r isXotclClass $class $namespace]
if {$desc} {
return $desc
}
}
return 0
}
ChainSignatureRepository instproc isXotclMetaClass {class {namespace {}}} {
my instvar repositoryChain
set oname [my getOriginName $class $namespace]
if {$oname ne ""} {
set class $oname
}
foreach r $repositoryChain {
set desc [$r isXotclMetaClass $class $namespace]
if {$desc} {
return $desc
}
}
return 0
}
ChainSignatureRepository instproc isXotclObject {object {namespace {}}} {
my instvar repositoryChain
set oname [my getOriginName $object $namespace]
if {$oname ne ""} {
set object $oname
}
foreach r $repositoryChain {
set desc [$r isXotclObject $object $namespace]
if {$desc} {
return $desc
}
}
return 0
}
ChainSignatureRepository instproc loadRepoForPackage packageName {
[my getCoreRepository] loadRepoForPackage $packageName
}
ChainSignatureRepository instproc registerMethod {class type name desc {namespace {}}} {
my instvar writeRepository
$writeRepository registerMethod $class $type $name $desc $namespace
}
ChainSignatureRepository instproc registerObject {name creator superclasses parameters {namespace {}}} {
my instvar writeRepository
$writeRepository registerObject $name $creator $superclasses $parameters $namespace
}
ChainSignatureRepository instproc registerProc {cmdName desc {namespace {}}} {
my instvar writeRepository
$writeRepository registerProc $cmdName $desc $namespace
}
ChainSignatureRepository instproc registerVariable {class stype name namespace type {override 0}} {
my instvar writeRepository
$writeRepository registerVariable $class $stype $name $namespace $type $override
}
ChainSignatureRepository instproc updateSignatureTypes {desc types} {
my instvar writeRepository noUpdateCache
if {[lsearch -sorted $noUpdateCache [lindex $desc 0]]<0} {
$writeRepository updateSignatureTypes $desc $types
}
}
Class SignatureRepository
@ SignatureRepository idemeta categories {api private api-adds api-oo persistance resolving-types}
@ SignatureRepository idemeta categoriesMethods {{addNamespaceExport getCommandDescription getFullName addNamespaceImport canAssignType registerProc updateSignatureTypes registerVariable} {resolveImportPattern getXotclClassForObject addNamespaceImportBase getFullHeritageReq getFullObjectNameBase initNewCreateMethodsForClass} {getOriginName getMethodDescription setReposDir resolveTypes getStat loadRepoForPackage} {getClassParameters getMethodDescriptionForObject isXotclObject getFullObjectName getFullHeritage getMethodDescriptionForClasses isXotclClass isXotclMetaClass registerObject registerMethod} {safeRepository loadRepository} {resolveSignatures resolveLinkedTypes resolveVariables}}
@ SignatureRepository idemeta component IDETclParser
SignatureRepository instproc addNamespaceExport {namespace exportList} {
my instvar namespaceExport
if {$namespace eq "" || $namespace eq "::"} return
if {![catch {set namespaceExport($namespace)} exports]} {
foreach e $exportList {
if {$e ni $exports} {
lappend namespaceExport($namespace) $e
}
}
} else {
set namespaceExport($namespace) $exportList
}
}
SignatureRepository instproc addNamespaceImport {namespace importList} {
my instvar namespaceImport
set realImport [list]
foreach imp $importList {
foreach i [my resolveImportPattern $imp] {
lappend realImport $i
}
}
if {[catch {set namespaceImport($namespace)} importList]} {
set namespaceImport($namespace) $realImport
} else {
set namespaceImport($namespace) [lsort -unique [concat $importList $realImport]]
}
return
}
SignatureRepository instproc addNamespaceImportBase {namespace realImportList} {
my instvar namespaceImport
if {[catch {set namespaceImport($namespace)} importList]} {
set namespaceImport($namespace) $realImportList
} else {
set namespaceImport($namespace) [lsort -unique [concat $importList $realImportList]]
}
return
}
SignatureRepository instproc canAssignType {requiredType isType} {
my instvar repository
set isType0 [lindex $isType 0]
set requiredType0 [lindex $requiredType 0]
if {$isType0 in {unknown def}} {
return 1
}
if {[lindex $requiredType 0] eq "new"} {
set requiredType [lrange $requiredType 1 end]
}
if {$requiredType0 eq "unknown" && $isType0 ne "array"} {
return 1
}
if {$requiredType eq $isType} {
return 1
}
if {$requiredType eq "index" && $isType0 in {int numeric}} {
return 1
}
if {$requiredType in {body script} && $isType0 in {string list}} {
return 1
}
if {$requiredType eq "int" && $isType0 in {numeric index boolean}} {
return 1
}
if {$requiredType eq "numeric" && $isType0 in {int double index pixel}} {
return 1
}
if {$requiredType eq "pixel" && $isType0 in {numeric int index}} {
return 1
}
if {$requiredType eq "double" && $isType0 in {int numberic}} {
return 1
}
if {$requiredType eq "boolean" && $isType0 in {int numberic}} {
return 1
}
if {$requiredType eq "texpr" && $isType0 in {int numeric boolean}} {
return 1
}
if {$requiredType0 eq "string" && $isType0 ne "array"} {
return 1
}
if {$requiredType eq "elem" && $isType0 ne "array"} {
return 1
}
if {$requiredType0 eq "class" && $isType0 in {tk xotcl}} {
return 1
}
if {$isType0 eq "string" && $requiredType0 eq [lindex $isType 1]} {
return 1
}
if {$isType0 eq "string" && $requiredType0 in {list tk xotcl class} && [lindex $isType 1] eq "empty"} {
return 1
}
if {[lindex $requiredType 0] eq "xotcl" && $isType eq "string"} {
return 1
}
if {[lindex $requiredType 0] in {xotcl class tk} && $isType0 in {xotcl class tk}} {
if {[llength $isType]==1} {
return 1
}
if {[lindex $requiredType 1] in [my getFullHeritage [lindex $isType 1]]} {
return 1
}
}
if {[lindex $requiredType 0] eq "enum" && $isType0 eq "string"} {
return 1
}
if {$requiredType eq "color" && $isType0 eq "string"} {
return 1
}
if {$requiredType0 in {list array tk xotcl class} && $isType0 eq $requiredType0 && [llength $isType]==1} {
return 1
}
if {[llength $requiredType]==1 && [llength $isType]>1 && [lindex $requiredType 0] eq $isType0} {
return 1
}
if {[lindex $requiredType 0] in {array list} && [lindex $requiredType 0] eq [lindex $isType 0] && [lindex $isType 1] eq "unknown"} {
return 1
}
return 0
}
SignatureRepository instproc convertDesc desc {
if {[llength $desc]==2 &&
[llength [lindex $desc 0]]==1 &&
[llength [lindex $desc 1]]==1} {
return $desc
}
lassign $desc min max options types subcommands
if {[llength $subcommands]>0} {
set ret [list]
foreach s $subcommands {
lappend ret [my convertSubcommandDesc $s]
}
return $ret
}
set rtypes [list]
if {[llength $types]==0} {
lappend rtypes unknown
if {[llength $options]>0} {
lappend rtypes [list ? [concat option $options]]
}
for {set i 0} {$i<$min} {incr i} {
lappend rtypes unknown
}
if {$max<0} {
lappend rtypes [list * unknown]
} else {
for {set i 0} {$i<$max} {incr i} {
lappend rtypes [list ? unknown]
}
}
} else {
lappend rtypes [lindex $types 0]
if {[llength $options]>0} {
lappend rtypes [list ? [concat option $options]]
}
lappend rtypes {*}[lrange $types 1 end]
}
list $rtypes
}
SignatureRepository instproc convertSubcommandDesc desc {
set rtypes [list]
lassign $desc subcommand min max options types subcommands
if {[llength $types]==0} {
lappend rtypes unknown
lappend rtypes [list [list const $subcommand]]
if {[llength $options]>0} {
lappend rtypes [list ? [concat option $options]]
}
for {set i 0} {$i<$min} {incr i} {
lappend rtypes unknown
}
if {$max<0} {
lappend rtypes [list * unknown]
} else {
for {set i 0} {$i<$max} {incr i} {
lappend rtypes [list ? unknown]
}
}
} else {
lappend rtypes [lindex $types 0]
lappend rtypes [list [list const $subcommand]]
if {[llength $options]>0} {
lappend rtypes [list ? [concat option $options]]
}
lappend rtypes {*}[lrange $types 1 end]
}
return $rtypes
}
SignatureRepository instproc getClassParameters {class {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectNameBase $class $namespace]
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [lindex $desc 2]
} else {
return
}
}
SignatureRepository instproc getClassSuperclasses {class {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectNameBase $class $namespace]
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [lindex $desc 1]
} else {
return
}
}
SignatureRepository instproc getClassSuperclassesFromFullName fullName {
my instvar xotclObjectsArr
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [lindex $desc 1]
} else {
return
}
}
SignatureRepository instproc getClassesForObject {object {namespace {}}} {
set fullName [my getFullObjectName $object $namespace]
if {$fullName eq ""} {
return
}
my instvar xotclObjectsArr
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [my getFullHeritageReq [lindex $desc 0 0]]
}
return
}
SignatureRepository instproc getCommandDescription {name {namespace {}}} {
my getCommandDescriptionBase $name $namespace
}
SignatureRepository instproc getCommandDescriptionBase {name {namespace {}}} {
my instvar commandsArr
set fullName [my getFullName $namespace $name]
if {![catch {set commandsArr($fullName)} desc]} {
return [linsert $desc 0 $fullName]
}
return
}
SignatureRepository instproc getFullHeritage {class {namespace {}}} {
set fullName [my getFullObjectName $class $namespace]
if {$fullName eq ""} {
return
}
my getFullHeritageReq $fullName
}
SignatureRepository instproc getFullHeritageReq class {
my instvar xotclObjectsArr
set hlist [list $class]
if {![catch {set xotclObjectsArr($class)} desc]} {
set superclases [lindex $desc 1]
foreach s $superclases {
if {$s ni $hlist} {
lappend hlist $s
foreach c [my getFullHeritageReq $s] {
if {$c ni $hlist} {
lappend hlist $c
}
}
}
}
}
return $hlist
}
SignatureRepository instproc getFullName {namespace name} {
if {[string range $name 0 1] eq "::"} {
return $name
}
return "${namespace}::$name"
}
SignatureRepository instproc getFullObjectName {object {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectNameBase $object $namespace]
if {[info exists xotclObjectsArr($fullName)]} {
return $fullName
} else {
if {$namespace ne "" && [string range $object 0 1] ne "::"} {
set fullName [my getFullObjectNameBase $object {}]
if {[info exists xotclObjectsArr($fullName)]} {
return $fullName
}
}
return
}
}
SignatureRepository instproc getFullObjectNameBase {object {namespace {}}} {
if {[namespace tail $object] eq $object} {
set fobject ::$object
} else {
set fobject $object
}
if {$fobject eq "::Class"} {
return ::xotcl::Class
} elseif {$fobject eq "::Object"} {
return ::xotcl::Object
}
my getFullName $namespace $object
}
SignatureRepository instproc getMethodDescFromIntro {object type method} {
return
}
SignatureRepository instproc getMethodDescription fname {
my instvar methodsArr
if {[catch {set methodsArr($fname)} desc]} {
return
} else {
return [linsert $desc 0 $fname]
}
}
SignatureRepository instproc getMethodDescriptionForClasses {classes method {namespace {}} {object {}}} {
my instvar methodsArr
foreach cl $classes {
set fullCl [my getFullObjectName $cl $namespace]
foreach c [my getFullHeritage $cl] {
set fname [list $c instproc $method]
set desc [my getMethodDescription $fname]
if {$desc ne ""} {
if {$c eq "::xotcl::Class" && $method in {new alloc create}} {
lset desc 1 0 [list xotcl $object]
}
return $desc
}
set desc [my getMethodDescFromIntro $c inst $method]
if {$desc ne "" } {
return $desc
}
}
}
return
}
SignatureRepository instproc getMethodDescriptionForObject {object method {namespace {}}} {
my instvar methodsArr
set fname [list [my getFullObjectName $object $namespace] proc $method]
set desc [my getMethodDescription $fname]
if {$desc ne ""} {
return $desc
}
set desc [my getMethodDescFromIntro $object {} $method]
if {$desc ne ""} {
return $desc
}
my getMethodDescriptionForClasses [list [my getXotclClassForObject $object]] $method $namespace [my getFullObjectName $object $namespace]
}
SignatureRepository instproc getOriginName {name namespace} {
my instvar namespaceImport
if {![catch {set namespaceImport($namespace)} importList]} {
foreach n $importList {
if {[namespace tail $n] eq $name} {
return $n
}
}
}
if {![catch {set namespaceImport()} importList]} {
foreach n $importList {
if {[namespace tail $n] eq $name} {
return $n
}
}
}
return
}
SignatureRepository instproc getStat {} {
my instvar xotclObjectsArr commandsArr methodsArr variableArr
set ret ""
if {[array exists commandsArr]} {
append ret "commands: [llength [array names commandsArr]]"
}
if {[array exists xotclObjectsArr]} {
append ret " objects: [llength [array names xotclObjectsArr]]"
}
if {[array exists methodsArr]} {
append ret " methods: [llength [array names methodsArr]]"
}
if {[array exists variableArr]} {
append ret " variables: [llength [array names variableArr]]"
}
append ret "\n"
set params 0
set unknowns 0
if {[array exists methodsArr]} {
foreach {key value} [array get methodsArr] {
foreach desc $value {
foreach p $desc {
if {[lindex $p 0 0] eq "unknown"} {
incr unknowns
}
incr params
}
}
}
}
if {[array exists commandsArr]} {
foreach {key value} [array get commandsArr] {
foreach desc $value {
foreach p $desc {
if {[lindex $p 0 0] eq "unknown"} {
incr unknowns
}
incr params
}
}
}
}
set variables 0
set unknownVariables 0
if {[array exists variableArr]} {
foreach {key value} [array get variableArr] {
incr variables
if {[lindex $value 0] eq "unknown"} {
incr unknownVariables
}
}
}
append ret "signature params $params unknown: $unknowns"
if {$params>0} {
append ret " [format %.2f [expr {double($unknowns)/$params*100}]]%"
}
if {$variables>0} {
append ret " unknown variables [format %.2f [expr {double($unknownVariables)/$variables*100}]]%"
}
return $ret
}
SignatureRepository instproc getVariableType {class stype name {namespace {}}} {
my instvar variableArr
if {$stype eq "global"} {
set name [my getFullName $namespace $name]
} else {
set class [my getFullObjectName $class $namespace]
}
set fname [list $class $stype $name]
if {![catch {set variableArr($fname)} type]} {
return $type
}
if {$stype in {instproc subobject} && [my isXotclClass $class]} {
foreach c [my getFullHeritage $class] {
set fname [list $c $stype $name]
if {![catch {set variableArr($fname)} type]} {
return $type
}
}
}
return
}
SignatureRepository instproc getXotclClassForObject {object {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectName $object $namespace]
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [lindex $desc 0]
} else {
return
}
}
SignatureRepository instproc initNewCreateMethods {} {
my instvar methodsArr xotclObjectsArr
foreach obj [array names xotclObjectsArr] {
if {[my isXotclClass $obj] && "::xotcl::Object" in [my getFullHeritage $obj]} {
set fnameCreate [list $obj proc create]
set descCreate [my getMethodDescription $fnameCreate]
set fnameNew [list $obj proc new]
set descNew [my getMethodDescription $fnameNew]
if {$descCreate eq "" || $descNew eq ""} {
my initNewCreateMethodsForClass $obj
}
}
}
}
SignatureRepository instproc initNewCreateMethodsForClass class {
my instvar methodsArr xotclObjectsArr linkTypes
set initDesc [my getMethodDescriptionForClasses [list $class] init]
set call [list]
lappend call [list [list xotcl $class] "create instance of $class"]
set options [list option]
lappend options -volatile {}
lappend options -childof xotcl
foreach c [my getFullHeritage $class] {
foreach p [my getClassParameters $c] {
set type [my getVariableType $class instproc $p]
set type0 [lindex $type 0]
if {$type0 eq "" || $type0 eq "def"} {
set type [list unknown]
}
lappend options -$p $type
}
}
lappend call [list ? $options]
set fullNameInit [lindex $initDesc 0]
set fullNameNew [list $class proc new]
set fullNameCreate [list $class proc create]
if {$initDesc ne ""} {
set i 1
foreach p [lrange [lindex $initDesc 1] 1 end] {
lappend call $p
lappend linkTypes [list [list $fullNameInit $i] [list $fullNameNew [expr {$i+1}]]]
lappend linkTypes [list [list $fullNameInit $i] [list $fullNameCreate [expr {$i+2}]]]
}
}
set newDesc [list $call]
set createDesc [list [linsert $call 1 [list string "instance name"]]]
set methodsArr($fullNameNew) $newDesc
set methodsArr($fullNameCreate) $createDesc
foreach p [my getClassParameters $class] {
set type [my getVariableType $class instproc $p]
set type0 [lindex $type 0]
if {$type0 eq "" || $type0 eq "def"} {
set type [list unknown]
}
set methodsArr([list $class instproc $p]) [list [list [list $type] [list ? $type $p]]]
}
}
SignatureRepository instproc isXotclClass {name {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectName $name $namespace]
if {$fullName eq ""} {
return 0
}
if {![catch {set xotclObjectsArr($fullName)} desc]} {
return [expr {[lindex $desc 0] in {Class ::xotcl::Class ::itcl::class}}]
} else {
return 0
}
}
SignatureRepository instproc isXotclMetaClass {name {namespace {}}} {
expr {$name in {::Class Class ::xotcl::Class} || "::xotcl::Class" in [my getFullHeritage $name $namespace]}
}
SignatureRepository instproc isXotclObject {name {namespace {}}} {
my instvar xotclObjectsArr
set fullName [my getFullObjectName $name $namespace]
expr {$fullName ne ""}
}
SignatureRepository instproc loadRepoForPackage packageName {
my instvar reposDir knownPackages
if {![info exists reposDir]} {
set reposDir [file join [PrsCheckerOptions getRootDir] repos]
}
if {$packageName in {Tcl Tk msgcat XOTcl Itcl}} {
return
}
if {[info exists knownPackages] && $packageName in $knownPackages} {
return
}
set repoName [file join $reposDir $packageName.repo]
if {[file readable $repoName]} {
puts "loading repo for $repoName"
my loadRepository $repoName
} else {
tlog::info "can not load signature repository for package $packageName"
}
lappend knownPackages $packageName
}
SignatureRepository instproc loadRepository file {
set in [open $file r]
set wholeLine ""
while {[gets $in line]>=0} {
append wholeLine $line \n
if {[info complete $wholeLine]} {
set cmdName [lindex $wholeLine 0]
if {$cmdName in {registerVariable registerObject registerMethod registerProc addNamespaceExport addNamespaceImport}} {
if {[catch {my $cmdName {*}[lrange $wholeLine 1 end]} res]} {
puts "error by loading $cmdName [lrange $wholeLine 1 end]"
error $res
}
}
set wholeLine ""
}
}
close $in
}
SignatureRepository instproc mergeDescTypes {istypes newtypes} {
my instvar linkTypes
set needUpdate 0
set mergedTypes [list]
foreach i $istypes n $newtypes {
set itype [lindex $i 0]
set ntype [lindex $n 0]
set itype0 [lindex $itype 0]
set ntype0 [lindex $ntype 0]
if {$itype0 in {* ? +}} {
set itype [lindex $i 1]
}
if {$ntype0 in {* ? +}} {
set ntype [lindex $n 1]
}
if {$itype0 eq "unknown" && [llength $itype]>1 && $ntype0 eq "unknown" && [llength $ntype]>0 && $ntype ne $itype} {
lappend linkTypes [list [lindex $itype 1] [lindex $ntype 1]]
}
if {$itype0 in {unknown def} && $ntype0 ni {unknown def}} {
set needUpdate 1
lappend mergedTypes $n
} elseif {$itype0 in {xotcl class} && $ntype0 eq $itype0 && [lindex $ntype 1] ne [lindex $itype 1]} {
set needUpdate 1
lappend mergedTypes [my mergeOOTypes $i $ntype]
} else {
lappend mergedTypes $i
}
}
if {$needUpdate} {
return $mergedTypes
} else {
return
}
}
SignatureRepository instproc mergeOOTypes {istypeWithName newtype} {
set classes [my getFullHeritage [lindex $istypeWithName 0 1]]
set tclasses [my getFullHeritage [lindex $newtype 1]]
set i 0
set bclass [lindex $istypeWithName 0 0]
foreach c $classes {
if {$c in $tclasses} {
lappend bclass $c
break
}
}
return [list $bclass [lindex $istypeWithName 1]]
}
SignatureRepository instproc mergeTypes {istypes newtypes} {
my instvar linkTypes
set needUpdate 0
set mergedTypes $istypes
foreach ntypeIndex $newtypes {
lassign $ntypeIndex ntype index
set i [lindex $istypes $index]
set itype [lindex $i 0]
set itype0 [lindex $itype 0]
if {$itype0 in {* ? +}} {
return
}
if {$itype0 in {xotcl class}} {
}
set ntype0 [lindex $ntype 0]
if {$itype0 eq "unknown" && [llength $itype]>1 && $ntype0 eq "unknown" && [llength $ntype]>0 && $ntype ne $itype} {
lappend linkTypes [list [lindex $itype 1] [lindex $ntype 1]]
}
if {$itype0 in {unknown def} && $ntype0 ni {unknown def}} {
set needUpdate 1
lset mergedTypes $index [list $ntype [lindex $i 1]]
} elseif {$itype0 in {xotcl class} && $ntype0 eq $itype0 && [lindex $ntype 1] ne [lindex $itype 1]} {
set needUpdate 1
lset mergedTypes $index [my mergeOOTypes $i $ntype]
}
}
if {$needUpdate} {
return $mergedTypes
} else {
return
}
}
SignatureRepository instproc registerMethod {class type name desc {namespace {}}} {
my instvar commandsArr methodsArr
tlog::ltrace {registering method $class $type $name <= $desc}
if {$class eq ""} {
error "no class"
}
if {$type eq "proc" && $class eq ""} {
set commandsArr($name) $desc
} else {
set fullName [list [my getFullObjectNameBase $class $namespace] $type $name]
if {[catch {set methodsArr($fullName)} idesc]} {
set methodsArr($fullName) $desc
} else {
if {[llength $desc]==1 && [llength $idesc]==1} {
set mergedDesc [my mergeDescTypes [lindex $idesc 0] [lindex $desc 0]]
if {[llength $mergedDesc]>0} {
tlog::ldebug {update by register method $fullName new='$desc' old='$idesc' m='$mergedDesc'}
set methodsArr($fullName) [list $mergedDesc]
}
}
}
return $fullName
}
return
}
SignatureRepository instproc registerObject {name creator superclasses parameters {namespace {}}} {
my instvar xotclObjectsArr
set sfull [list]
tlog::info "register object name=$name creator=$creator sc=$superclasses p=$parameters"
foreach s $superclasses {
lappend sfull [my getFullObjectNameBase $s $namespace]
}
set fullName [my getFullObjectNameBase $name $namespace]
set xotclObjectsArr($fullName) [list $creator $sfull $parameters]
return $fullName
}
SignatureRepository instproc registerProc {cmdName desc {namespace {}}} {
my instvar commandsArr
set fullName [my getFullName $namespace $cmdName]
if {[catch {set commandsArr($fullName)} idesc]} {
set commandsArr($fullName) $desc
} else {
if {[llength $desc]==1 && [llength $idesc]==1} {
set mergedDesc [my mergeDescTypes [lindex $idesc 0] [lindex $desc 0]]
if {[llength $mergedDesc]>0} {
tlog::info "update by register commands $fullName new='$desc' old='$idesc' m='$mergedDesc'"
set commandsArr($fullName) [list $mergedDesc]
}
}
}
return $fullName
}
SignatureRepository instproc registerVariable {class stype name namespace type {override 0}} {
my instvar variableArr
if {!$override} {
set desc [my getVariableType $class $stype $name $namespace]
set desc0 [lindex $desc 0]
if {$desc ne "" && $desc0 ni {def unknown}} {
if {[lindex $type 0] in {array list} && [lindex $type 1 0] eq "unknown" && $desc0 eq [lindex $type 0]} {
} else {
return
}
}
}
if {$stype in {proc instproc}} {
set class [my getFullObjectName $class $namespace]
}
if {$stype eq "global"} {
set name [my getFullName $namespace $name]
}
set fname [list $class $stype $name]
if {[set type0 [lindex $type 0]] in {class xotcl}} {
set istype [my getVariableType $class $stype $name $namespace]
set istype0 [lindex $istype 0]
if {$istype ne "" && $type0 eq $istype0} {
set type [lindex [my mergeOOTypes [list $istype istype] $type] 0]
}
}
tlog::ltrace {register variable $fname -> $type}
if {$stype eq "instproc" && [my isXotclClass $class]} {
foreach c [my getFullHeritage $class] {
set sfname [list $c $stype $name]
if {![catch {set variableArr($sfname)} desc]} {
set fname $sfname
break
}
}
}
set variableArr($fname) $type
tlog::info "registeredVariable $name t=$type o=$override"
return
}
SignatureRepository instproc resolveImportPattern imp {
my instvar namespaceExport
set realImport [list]
if {[string range $imp 0 1] ne "::"} {
set imp ::$imp
}
set impNamespace [namespace qualifiers $imp]
set part [namespace tail $imp]
if {$impNamespace eq ""} return
if {![catch {set namespaceExport($impNamespace)} exportList]} {
foreach exp $exportList {
if {[string match $part $exp]} {
lappend realImport [my getFullName $impNamespace $exp]
}
}
}
return $realImport
}
SignatureRepository instproc resolveLinkedTypes {} {
my instvar linkTypes methodsArr commandsArr
if {![info exists linkTypes]} {
return
}
set resolvedCount 0
set resolved 1
set workLinkTypes $linkTypes
while {$resolved} {
set survived [list]
set resolved 0
foreach lt $workLinkTypes {
lassign $lt link1 link2
lassign $link1 method1 pos1
lassign $link2 method2 pos2
if {[llength $method1]==1} {
set isProc1 1
if {[catch {set commandsArr($method1)} mdef1]} {
continue
}
} else {
set isProc1 0
if {[catch {set methodsArr($method1)} mdef1]} {
continue
}
}
if {[llength $method2]==1} {
set isProc2 1
if {[catch {set commandsArr($method2)} mdef2]} {
continue
}
} else {
set isProc2 0
if {[catch {set methodsArr($method2)} mdef2]} {
continue
}
}
if {[lindex $mdef1 0 $pos1 0 0] eq "unknown"} {
if {[lindex $mdef2 0 $pos2 0 0] eq "unknown"} {
lappend survived $lt
} else {
set resolved 1
lset mdef1 0 $pos1 0 [lindex $mdef2 0 $pos2 0]
if {$isProc1} {
set commandsArr($method1) $mdef1
} else {
set methodsArr($method1) $mdef1
}
incr resolvedCount
}
} else {
if {[lindex $mdef2 0 $pos1 0 0] eq "unknown"} {
set resolved 1
lset mdef2 0 $pos2 0 [lindex $mdef1 0 $pos1 0]
if {$isProc2} {
set commandsArr($method2) $mdef2
} else {
set methodsArr($method2) $mdef2
}
tlog::ltrace {resolve comand type $method2 def=$mdef2}
incr resolvedCount
}
}
}
set workLinkTypes $survived
}
tlog::info "resolved command types count $resolvedCount"
return $resolvedCount
}
SignatureRepository instproc resolveLinkedTypesReduceSuperclass {} {
my instvar linkTypes methodsArr commandsArr
if {![info exists linkTypes]} {
return
}
set resolvedCount 0
set resolved 1
set workLinkTypes $linkTypes
while {$resolved} {
set survived [list]
set resolved 0
foreach lt $workLinkTypes {
lassign $lt link1 link2
lassign $link1 method1 pos1
lassign $link2 method2 pos2
if {[llength $method1]==1} {
set isProc1 1
if {[catch {set commandsArr($method1)} mdef1]} {
continue
}
} else {
set isProc1 0
if {[catch {set methodsArr($method1)} mdef1]} {
continue
}
}
if {[llength $method2]==1} {
set isProc2 1
if {[catch {set commandsArr($method2)} mdef2]} {
continue
}
} else {
set isProc2 0
if {[catch {set methodsArr($method2)} mdef2]} {
continue
}
}
if {[set type0 [lindex $mdef1 0 $pos1 0 0]] in {xotcl class} && $type0 eq [lindex $mdef2 0 $pos2 0 0] && [lindex $mdef1 0 $pos1 0 1] ne [lindex $mdef2 0 $pos2 0 1]} {
set class1 [lindex $mdef1 0 $pos1 0]
set class2 [lindex $mdef2 0 $pos2 0]
set classM [lindex [my mergeOOTypes [list $class1 name] $class2] 0]
tlog::ldebug {resolve supertype from link $lt = def1='[lindex $mdef1 0 $pos1]' def2='[lindex $mdef1 0 $pos1]' to $classM}
lset mdef2 0 $pos2 0 $classM
if {$isProc2} {
set commandsArr($method2) $mdef2
} else {
set methodsArr($method2) $mdef2
}
lset mdef1 0 $pos1 0 $classM
if {$isProc1} {
set commandsArr($method1) $mdef1
} else {
set methodsArr($method1) $mdef1
}
incr resolvedCount
set resolved 1
} else {
lappend survived $lt
}
}
set workLinkTypes $survived
}
tlog::info "resolved linked types superclass reduction count $resolvedCount"
return $resolvedCount
}
SignatureRepository instproc resolveSignatures {} {
my instvar methodsArr commandsArr
set resolvedCount 0
foreach {k def} [array get methodsArr] {
set dpos 0
set changed 0
foreach tdef [lindex $def 0] {
set type [lindex $tdef 0]
if {[lindex $type 0] eq "unknown" && [llength $type]>1} {
if {[lindex $type 1 0] ne $k || [lindex $type 1 1]!=$dpos} {
lassign [lindex $type 1] method pos
if {[llength $method]==1} {
set isProc1 1
if {[catch {set commandsArr($method)} mdef]} {
continue
}
} else {
set isProc1 0
if {[catch {set methodsArr($method)} mdef]} {
continue
}
}
if {[lindex $mdef 0 $pos 0 0] ne "unknown"} {
lset def 0 $dpos 0 [lindex $mdef 0 $pos 0]
incr resolvedCount
set changed 1
}
}
}
incr dpos
}
if {$changed} {
set methodsArr($k) $def
}
}
foreach {k def} [array get commandsArr] {
set dpos 0
set changed 0
foreach tdef [lindex $def 0] {
set type [lindex $tdef 0]
if {[lindex $type 0] eq "unknown" && [llength $type]>1} {
if {[lindex $type 1 0] ne $k || [lindex $type 1 1]!=$dpos} {
lassign [lindex $type 1] method pos
if {[llength $method]==1} {
set isProc1 1
if {[catch {set commandsArr($method)} mdef]} {
continue
}
} else {
set isProc1 0
if {[catch {set methodsArr($method)} mdef]} {
continue
}
}
if {[lindex $mdef 0 $pos 0 0] ne "unknown"} {
lset def 0 $dpos 0 [lindex $mdef 0 $pos 0]
incr resolvedCount
set changed 1
}
}
}
incr dpos
}
if {$changed} {
set commandsArr($k) $def
}
}
tlog::info "resolved signatures count $resolvedCount"
return $resolvedCount
}
SignatureRepository instproc resolveTypes {} {
my resolveLinkedTypes
my resolveLinkedTypesReduceSuperclass
my resolveVariables
my resolveSignatures
my set linkTypes [list]
}
SignatureRepository instproc resolveVariables {} {
my instvar variableArr methodsArr commandsArr
set resolvedCount 0
foreach k [array names variableArr] {
set type $variableArr($k)
if {[lindex $type 0] eq "unknown" && [llength $type]>0} {
lassign [lindex $type 1] method pos
if {[llength $method]==1} {
set isProc1 1
if {[catch {set commandsArr($method)} mdef]} {
continue
}
} else {
set isProc1 0
if {[catch {set methodsArr($method)} mdef]} {
continue
}
}
if {[lindex $mdef 0 $pos 0 0] ne "unknown"} {
set rtype [lindex $mdef 0 $pos 0]
set variableArr($k) $rtype
incr resolvedCount
tlog::ltrace {resolved variable=$k type=$rtype}
}
}
}
tlog::info "resolved variables count $resolvedCount"
return $resolvedCount
}
SignatureRepository instproc safeRepository file {
my instvar commandsArr variableArr methodsArr xotclObjectsArr namespaceExport namespaceImport
set out [open $file w]
foreach c [lsort [array names commandsArr]] {
puts $out "registerProc [list $c] [list $commandsArr($c)]"
}
foreach c [lsort [array names variableArr]] {
set desc $variableArr($c)
lassign $c class type name
puts $out "registerVariable [list $class $type $name {} $desc]"
}
foreach c [lsort [array names methodsArr]] {
set desc $methodsArr($c)
lassign $c class type name
puts $out "registerMethod [list $class $type $name $desc {}]"
}
foreach obj [lsort [array names xotclObjectsArr]] {
set desc $xotclObjectsArr($obj)
puts $out "registerObject [list $obj] [concat $desc]"
}
foreach ns [lsort [array names namespaceExport]] {
puts $out "addNamespaceExport [list $ns] [list $namespaceExport($ns)]"
}
foreach ns [lsort [array names namespaceImport]] {
set imports $namespaceImport($ns)
if {[llength $imports]>0} {
puts $out "addNamespaceImport [list $ns] [list $namespaceImport($ns)]"
}
}
close $out
}
SignatureRepository instproc setReposDir newReposDir {
my instvar reposDir
set reposDir $newReposDir
}
SignatureRepository instproc updateSignatureTypes {desc types} {
my instvar methodsArr commandsArr
tlog::ltrace {updateSignatureTypes $desc types=$types}
if {[llength $desc]==2} {
set repositoryKey [lindex $desc 0]
if {[llength $repositoryKey]==1} {
if {[info exists commandsArr($repositoryKey)]} {
set mergedTypes [my mergeTypes [lindex $desc 1] $types]
if {$mergedTypes ne ""} {
tlog::linfo {update command $repositoryKey types='$types' desc='$desc' merge='$mergedTypes'}
lset desc 1 $mergedTypes
set commandsArr($repositoryKey) [lrange $desc 1 end]
}
}
} else {
if {[info exists methodsArr($repositoryKey)]} {
set mergedTypes [my mergeTypes [lindex $desc 1] $types]
if {$mergedTypes ne ""} {
tlog::linfo {update method $repositoryKey types='$types' desc='$desc' merge='$mergedTypes'}
lset desc 1 $mergedTypes
set methodsArr($repositoryKey) [lrange $desc 1 end]
}
}
}
}
}
SignatureRepository proc createSignatureRepositoryFile {} {
set introRepo [FileSignatureRepository new]
set coreRepo [CoreSignatureRepository new]
set repository [ChainSignatureRepository new [list $coreRepo $introRepo] $introRepo]
return $repository
}
SignatureRepository proc getSignatureRepository {} {
my instvar repository
if {![info exists repository] || ![Object isobject $repository]} {
set introRepo [IntroSignatureRepository new]
set coreRepo [CoreSignatureRepository new]
$coreRepo loadRepoForPackage XOTcl
set repository [ChainSignatureRepository new [list $coreRepo $introRepo] $introRepo]
}
return $repository
}
Class CoreSignatureRepository -superclass ::SignatureRepository
@ CoreSignatureRepository idemeta component IDETclParser
CoreSignatureRepository instproc canAssignType {requiredType isType} {
return 0
}
CoreSignatureRepository instproc convertCommands {} {
my instvar commandsArr
set ret ""
foreach c [lsort [array names commandsArr]] {
set desc $commandsArr($c)
if {[llength $desc]==2} {
append ret [list $c] " " [list $desc] \n
} else {
set sdesc [my convertDesc $desc]
if {[llength $sdesc]>1} {
append ret [list $c] " \{\n \{"
append ret [join $sdesc "\}\n \{"]
append ret "\}\n\}\n"
} else {
append ret [list $c] " " [list $sdesc] \n
}
}
}
return $ret
}
CoreSignatureRepository instproc convertMethods {} {
my instvar methodsArr
set ret ""
foreach c [lsort [array names methodsArr]] {
set desc $methodsArr($c)
if {[llength $desc]==2} {
append ret [list $c] " " [list $desc] \n
} else {
set sdesc [my convertDesc $desc]
if {[llength $sdesc]>1} {
append ret [list $c] " \{\n \{"
append ret [join $sdesc "\}\n \{"]
append ret "\}\n\}\n"
} else {
append ret [list $c] " " [list $sdesc] \n
}
}
}
return $ret
}
CoreSignatureRepository instproc getCommandDescriptionBase {name {namespace {}}} {
my instvar commandsArr
set fullName [my getFullName $namespace $name]
if {![catch {set commandsArr($fullName)} desc]} {
return [linsert $desc 0 $fullName]
}
return
}
CoreSignatureRepository instproc init {} {
my registerCoreProcs
my registerTkProcs
my registerCoreGlobals
}
CoreSignatureRepository instproc loadRepoForPackage packageName {
my instvar knownPackages
if {$packageName eq "XOTcl"} {
if {![info exists knownPackages] || $packageName ni $knownPackages} {
my registerXotclCoreMethods
}
return
}
if {$packageName eq "Itcl"} {
if {![info exists knownPackages] || $packageName ni $knownPackages} {
my registerItcl
}
return
}
next
}
CoreSignatureRepository instproc registerCoreGlobals {} {
my registerVariable {} global auto_path {} list
my registerVariable {} global env {} array
my registerVariable {} global tcl_version {} string
my registerVariable {} global argc {} int
my registerVariable {} global argv {} list
my registerVariable {} global errorCode {} string
my registerVariable {} global errorInfo {} string
my registerVariable {} global argv0 {} string
my registerVariable {} global auto_index {} array
my registerVariable {} global tcl_rcFileName {} string
my registerVariable {} global tcl_interactive {} boolean
my registerVariable {} global tcl_nonwordchars {} string
my registerVariable {} global tcl_wordchars {} string
my registerVariable {} global tcl_patchLevel {} string
my registerVariable {} global tcl_libPath {} list
my registerVariable {} global tcl_library {} string
my registerVariable {} global tcl_platform {} array
my registerVariable {} global tk_library {} string
my registerVariable {} global tk_version {} string
my registerVariable {} global tk_strictMotif {} boolean
my registerVariable {} global tk_patchLevel {} string
}
CoreSignatureRepository instproc registerCoreProcs {} {
my instvar commandsArr xotclObjectsArr methodsArr
array set commandsArr {
::after {
{unknown {{const ms}}}
{unknown {{const cancel}} afterid}
{unknown {{const cancel}} {+ script}}
{afterid {{const idle}} {+ script}}
{list {{const info}} {? afterid}}
{afterid {int {millisecounds}} {? script script}}
{afterid {int {millisecounds}} {+ unknown script}}
}
::append {{{string {}} {{setref string} {}} {+ string {}}}}
::apply {1 -1}
::array {
{boolean {{const anymore}} {{ref array}} searchid}
{void {{const donesearch}} {{ref array}} searchid}
{boolean {{const exists}} string}
{list {{const get}} {{ref array}} {? string pattern}}
{list {{const names}} {{ref array}} {? enum -glob -regexp -exact} {? string pattern}}
{string {{const nextelement}} {{ref array}} searchid}
{void {{const set}} {{setref array}} list}
{{int {}} {{const size}} {{ref array} {}}}
{searchid {{const startsearch}} {{ref array}}}
{void {{const unset}} {{wref array}} {? string pattern}}
{string {{const statistics}} {{ref array}}}
}
::auto_execok {{{boolean {Determines whether there is an executable file or shell builtin by the name cmd}} {string cmd}}}
::auto_import {{void {string pattern}}}
::auto_load {{void {string cmd}}}
::auto_mkindex {{void {string dir} {+ string pattern}}}
::auto_qualify {{{{list string}} {string command} {string namespace}}}
::auto_reset {{void}}
::binary {
{string {{const format}} string {+ unknown}}
{int {{const scan}} string string {+ {ref string}}}
}
::bgerror {{void string}}
::break {{void}}
::cd {{void {? string dirname}}}
::catch {{int unknown {? unknown} {? {setref dict}}}}
::chan {
{boolean {{const blocked}} channelid}
{void {{const close}} channelid}
{list {{const configure}}}
{string {{const configure}} {option -blocking boolean -buffering string -buffersize int -encoding string -eofchar unknown -translation unknown}}
{void {{const copy}} channelid channelid {? {option -size int -command script}}}
{channelid {{const create}} {unknown mode} {unknown cmdPrefix}}
{boolean {{const eof}} channelid}
{void {{const event}} channelId {unknown event} {? script script}}
{void {{const flush}} channelid}
{string {{const gets}} channelid}
{int {{const gets}} channelid {{ref string}}}
{list {{const names}} {? string pattern}}
{int {{const pending}} channelid {{enum input output}}}
{void {{const postevent}} channelid {unknown eventSpec}}
{void {{const puts}} {? {const -nonewline}} {? channelid} string}
{string {{const read}} channelid {? int}}
{void {{const seek}} channelid {int offset} {? {enum start current end} origin}}
{int {{const tell}} channelid}
{void {{const truncate}} channelid {? int}}
}
::clock {
{string {{const format}} int {? {option -base int -format string -gmt boolean -timezone string}}}
{int {{const add}} int {+ unknown} {? {option -base int -format string -gmt boolean -timezone string}}}
{int {{const clicks}}}
{int {{const seconds}}}
{int {{const microseconds}}}
{int {{const milliseconds}}}
{int {{const scan}} string {? {option -base int -format string -gmt boolean -timezone string}}}
}
::close {{{void {}} {channelid {}}}}
::concat {{list {* unknown}}}
::continue {{void}}
::dde {
{string {{const servername}} {? {option -force {} -handler string}} {? {const --}} {? string topic}}
{string {{const execute}} {? {option -async {}}} {string service} {string topic} {string data}}
{string {{const poke}} {string service} {string topic} {string item} {string data}}
{string {{const request}} {? {option -binar {}}} {string service} {string topic} {string item}}
{{{list string}} {{const services}} {string service} {string topic}}
{unknown {{const eval}} {? {option -async {}}} {string topic} {string cmd} {* unknown arg}}
}
::dict {
{void {{const append}} {{ref dict}} {+ string key} {string value}}
{dict {{const create}} {* string keyvalue}}
{boolean {{const exists}} dict {+ string key}}
{dict {{const filter}} dict {enum key value} {string pattern}}
{dict {{const filter}} dict {const script} list {unknown body}}
{void {{const for}} list dict {unknown body}}
{unknown {{const get}} dict {+ string key}}
{int {{const incr}} {{ref dict}} {+ string key}}
{list {{const info}} dict}
{{{list string}} {{const keys}} {? string pattern}}
{void {{const lappend}} {{ref dict}} {+ string key} {string value}}
{dict {{const merge}} {+ dict}}
{dict {{const remove}} dict {+ string key}}
{dict {{const replace}} dict {+ string keyvalue}}
{void {{const set}} {{ref dict}} {+ string key} {string value}}
{int {{const size}} {{ref dict}}}
{void {{const unset}} {{ref dict}} {+ string key}}
{unknown {{const update}} {{ref dict}} {* unknown}}
{{{list string}} {{const values}} dict {string pattern}}
{unknown {{const with}} dict {+ string key} {unknown body}}
}
::encoding {
{string {{const convertfrom}} {? string encoding} string}
{string {{const convertto}} {? string encoding} string}
{list {{const names}}}
{{string encoding} {{const system}} {? string encoding}}
{list {{const dirs}} {? unknown}}
}
::eof {{{boolean {}} {channelid {}}}}
::error {{void {string message} {? string info} {? string code}}}
::eval {1 -1}
::exec {{unknown {? {option -ignorestderr {} -keepnewline {}}} {* unknown}}}
::exit {{{void {}} {? int {return code}}}}
::expr {{{numeric {}} {+ unknown}}}
::fblocked {{unknown {? {option boolean channelid}} unknown {? unknown}}}
::fconfigure {{unknown {? {option -blocking boolean -buffering string -buffersize int -encoding string -eofchar unknown -translation string -translation unknown}} unknown {* unknown}}}
::fcopy {2 -1}
::file {
{int {{const atime}} {string filename} {? int time}}
{list {{const attributes}} {string filename}}
{string {{const attributes}} {string filename} {string option}}
{void {{const attributes}} {string filename} {+ string option}}
{list {{const channels}} {? string pattern}}
{void {{const copy}} {? {option -force}} {? {const --}} {+ string source} {string targetDir}}
{void {{const delete}} {? {option -force}} {? {const --}} {+ string pathname}}
{string {{const dirname}} {string filename}}
{boolean {{const executable}} {string filename}}
{boolean {{const exists}} {string filename}}
{string {{const extension}} {string filename}}
{boolean {{const isdirectory}} {string filename}}
{boolean {{const isfile}} {string filename}}
{string {{const join}} {+ string}}
{void {{const lstat}} {string filename} {{setref array}}}
{unknown {{const mkdir}} unknown {* unknown}}
{int {{const mtime}} {string filename} {? int time}}
{string {{const nativename}} {string filename}}
{string {{const owned}} {string filename}}
{string {{const pathtype}} {string filename}}
{boolean {{const readable}} {string filename}}
{string {{const readlink}} {string filename}}
{unknown {{const rename}} unknown unknown {* unknown}}
{string {{const rootname}} {string filename}}
{int {{const size}} {string filename}}
{{{list string}} {{const split}} {string filename}}
{void {{const stat}} {string filename} {{setref array}}}
{string {{const tail}} {string filename}}
{string {{const type}} {string filename}}
{list {{const volumes}}}
{boolean {{const writable}} {string filename}}
{unknown {{const link}} unknown {? unknown} {? unknown}}
{string {{const normalize}} {string filename}}
{string {{const separator}} {? string filename}}
{list {{const system}} {string filename}}
}
::fileevent {{void channelid {enum readable writable} {? script script}}}
::flush {{{void {}} {channelid {}}}}
::for {{{void {}} {unknown {}} {texpr {}} {unknown {}} {unknown {}}}}
::foreach {{void {+ unknown}}}
::format {{{string {}} {string {format}} {* string args}}}
::gets {
{{string {read line from channel}} {channelid {}}}
{{int {read line from channel}} {channelid {}} {{setref string} {}}}
}
::glob {{unknown {? {option -directory string -join {} -nocomplain {} -path string -tails {} -types list}} unknown {* unknown}}}
::global {1 -1}
::history {
{unknown {{const add}} unknown {? unknown} {? unknown}}
{unknown {{const change}} unknown {? unknown} {? unknown}}
{unknown {{const clear}}}
{unknown {{const event}} {? unknown}}
{unknown {{const info}} {? unknown}}
{unknown {{const keep}} {? unknown}}
{unknown {{const nextid}}}
{unknown {{const redo}} {? unknown}}
}
::if {{{unknown {}} {texpr {}} {? {const then}} {unknown {}} {* unknown}}}
::incr {{{int {increment variable reference}} {{ref int} {}} {? int {}}}}
::info {
{{{list string}} {{const args}} {string {proc name}}}
{string {{const body}} {string {proc name}}}
{int {{const cmdcount}}}
{{{list sting}} {{const commands}} {? string pattern}}
{boolean {{const complete}} string}
{boolean {{const default}} {string {proc name}} {string arg} {{setref string}}}
{boolean {{const exists}} string}
{{{list string}} {{const globals}} {? string pattern}}
{string {{const hostname}}}
{list {{const level}} int}
{int {{const level}}}
{string {{const library}}}
{{{list string}} {{const loaded}} {? unknown interp}}
{{{list string}} {{const locals}} {? string pattern}}
{string {{const nameofexecutable}}}
{string {{const patchlevel}}}
{{{list string}} {{const procs}} {? string pattern}}
{string {{const script} {? string}}}
{string {{const sharedlibextension}}}
{string {{const tclversion}}}
{{{list string}} {{const vars}} {? string pattern}}
{dict {{const frame}} {? int}}
{{{list string}} {{const functions}} {? string pattern}}
}
::interp {
{unknown {{const alias}} unknown unknown {* unknown}}
{list {{const aliases}} {? {class ::_TclInterp}}}
{{{class ::_TclInterp}} {{const create}} {? {option -safe}} {? {new class ::_TclInterp} slave}}
{void {{const delete}} {+ {class ::_TclInterp}}}
{unknown {{const eval}} {{class ::_TclInterp}} {+ unknown}}
{boolean {{const exists}} {{class ::_TclInterp}}}
{void {{const expose}} {{class ::_TclInterp}} {string hiddenName} {? string exposedCmdName}}
{void {{const hide}} {{class ::_TclInterp}} {string hiddenName} {? string hiddenCmdName}}
{list {{const hidden}} {{class ::_TclInterp}}}
{unknown {{const invokehidden}} {{class ::_TclInterp}} {? {option -global {} -namespace string}} {? {const --}} {string hiddenCmdName} {? unknown arg}}
{boolean {{const issafe}} {? {class ::_TclInterp}}}
{void {{const marktrusted}} {{class ::_TclInterp}}}
{void {{const share}} {{class ::_TclInterp}} channelid slave}
{{{list slave}} {{const slaves}} {? {class ::_TclInterp}}}
{list {{const target}} {{class ::_TclInterp}} {string alias}}
{void {{const transfer}} {{class ::_TclInterp}} channelid slave}
{unknown {{const bgerror}} {{class ::_TclInterp}} {string cmdPrefix}}
{boolean {{const debug}} {{class ::_TclInterp}} {? {option -frame {}}} {? boolean}}
{int {{const limit}} {{class ::_TclInterp}} {* unknown}}
{int {{const recursionlimit}} {{class ::_TclInterp}} {? int}}
}
::join {{{string {}} {list {}} {? string {}}}}
::lappend {{{list {}} {{setref list} {}} {+ unknown}}}
::lassign {{{void {}} {list {}} {+ setref}}}
::lindex {{{unknown {}} {list {}} {+ index {}}}}
::linsert {{{list {}} {list {}} {index {}} {+ unknown}}}
::list {{{list {create list}} {* unknown}}}
::llength {{{int {}} {list {}}}}
::load {1 3}
::lrange {{{list {}} {list {}} {index {}} {index {}}}}
::lrepeat {{{list {create list by repeat elements}} {int {number of repeat}} unknown}}
::lreplace {{list list index index {* unknown elem}}}
::lreverse {{{list {}} {list {}}}}
::lsearch {{{unknown {}} {? {option -exact {} -glob {} -regexp {} -sorted {} -all {} -inline {} -not {} -start int -asc {} -dictionary {} -integer {} -nocae {} -real {} -decreasing {} -increasing {} -bisect {} -index int -subindices {}}} {list {}} {unknown {}}}}
::lset {{{list {Change an element in a list}} {{ref list}} {+ index} {? unknown {new value}}}}
::lsort {{{list {}} {? {option -ascii {} -dictionary {} -integer {} -real {} -command script -increasing {} -decreasing {} -indicies {} -index list -nocase {} -unique {}}} list}}
::memory {
{unknown {{const info}}}
{unknown {{const trace}} unknown {? unknown}}
{unknown {{const validate}} unknown {? unknown}}
{unknown {{const trace_on_at_malloc}} unknown {? unknown}}
{unknown {{const break_on_malloc}} unknown {? unknown}}
{unknown {{const display}} unknown {? unknown}}
{unknown {{const active}} unknown {? unknown}}
{unknown {{const init}} unknown {? unknown}}
{unknown {{const onexit}} unknown {? unknown}}
{unknown {{const objs}} unknown {? unknown}}
{unknown {{const tag}} unknown {? unknown}}
}
::namespace {
{unknown {{const children}} {? unknown} {? unknown}}
{unknown {{const code}} unknown {? unknown}}
{unknown {{const current}}}
{unknown {{const delete}} unknown {* unknown}}
{unknown {{const eval}} unknown unknown {* unknown}}
{unknown {{const exists}} unknown {? unknown}}
{unknown {{const export}} {* unknown}}
{unknown {{const forget}} unknown {* unknown}}
{unknown {{const import}} unknown {* unknown}}
{unknown {{const inscope}} unknown unknown {* unknown}}
{unknown {{const origin}} unknown {? unknown}}
{string {{const parent}} {? string}}
{unknown {{const qualifiers}} unknown {? unknown}}
{string {{const tail}} string}
{unknown {{const which}} unknown unknown {* unknown}}
{unknown {{const ensemble}} unknown {* unknown}}
{unknown {{const path}} {? unknown}}
{unknown {{const upvar}} unknown {* unknown}}
{unknown {{const unknown}} {? unknown}}
}
::open {
{{channelid {}} {string {channelid name}} {? {enum r r+ w w+ a a+ RDONLY WRONLY RDWR APPEND BINARY CREAT
EXCL NOCTTY NONBLOCK TRUNC}}}
}
::package {
{unknown {{const forget}} {* unknown}}
{unknown {{const ifneeded}} unknown unknown {? unknown} {? unknown} {? unknown}}
{unknown {{const names}}}
{unknown {{const present}} unknown {? unknown} {? unknown}}
{unknown {{const provide}} unknown {? unknown} {? unknown}}
{unknown {{const require}} {? {option -exact {}}} unknown {? unknown} {? unknown}}
{unknown {{const unknown}} {? unknown}}
{unknown {{const vcompare}} unknown unknown {? unknown} {? unknown}}
{unknown {{const versions}} unknown {? unknown}}
{unknown {{const vsatisifes}} unknown unknown {? unknown} {? unknown}}
{unknown {{const prefer}} {? unknown}}
}
::parray {{{void {print array to stdout}} {{ref array} array}}}
::pid {{{int {get process id}} {? string {}}}}
::proc {{{void {define tcl procedure}} {string {}} {list {}} {unknown body}}}
::puts {{{void {write to stout or file channel}} {? {option -nonewline {}}} {? channelid channel} {string string}}}
::pwd {{{string {get current directory}}}}
::read {{{string {}} {? {option -nonewline {}}} {channelid {}} {? int {}}}}
::regexp {{unknown {? {option -about {} -expanded {} -indices {} -line {} -linestop {} -lineanchor {} -nocase {} -all {} -inline {} -start int -- {}}} unknown unknown {* unknown}}}
::registry {
{unknown {{const brodcast}} {? {option -timeout int}} unknown {? unknown}}
{unknown {{const delete}} unknown {? unknown} {? unknown}}
{unknown {{const get}} unknown unknown {? unknown} {? unknown}}
{unknown {{const keys}} unknown {? unknown} {? unknown}}
{unknown {{const set}} unknown {? unknown} {? unknown} {? unknown}}
{unknown {{const type}} unknown unknown {? unknown} {? unknown}}
{unknown {{const values}} unknown {? unknown} {? unknown}}
}
::regsub {{string {? {option -all {} -expanded {} -line {} -linestop {} -lineanchor {} -nocase {} -start int -- {}}} {string expression} {string string} {string substring} {? {setref string}}}}
::rename {2 2}
::return {
{void {? {option -errorcode string -errorinfo string -level string -options dict -code string}} {? unknown}}
}
::scan {2 -1}
::seek {{{void {}} {channelid {}} {int {}} {? {enum start current end} {origin}}}}
::set {{{unknown {}} {{wref unknown} {}} {? unknown}}}
::socket {
{channelid {? {option -myaddr string -myport int -async {} -myaddr string -error {} -sockname {} -peername {}}} {string host} {int port}}
{channelid {{const -server}} script {? {option -myaddr string -myport int -async {} -myaddr string -error {} -sockname {} -peername {}}} {int port}}
}
::source {1 3}
::split {{{list {}} {string {}} {? string splitChars}}}
::string {
{int {{const bytelength}} string}
{int {{const compare}} {? {option -nocase {} -length int}} string string}
{boolean {{const equal}} {? {option -nocase {} -length int}} string string}
{int {{const first}} string string {? int}}
{string {{const index}} string index}
{boolean {{const is}} {{enum alnum alpha ascii boolean control digit double false graph integer list lower print punct space true upper wideinteger wordchar xdigit}} {? {option -strict {} -failindex {setref int}}} string}
{int {{const last}} string string {? int}}
{int {{const length}} string}
{{string {}} {{const map}} {? {option -nocase {}}} {list {}} {string {}}}
{boolean {{const match}} {? {option -nocase {}}} {string pattern} string}
{string {{const range}} string index index}
{string {{const repeat}} string int}
{string {{const replace}} string index index {? string}}
{string {{const totitle}} string {? index} {? index}}
{string {{const tolower}} string {? index} {? index}}
{string {{const toupper}} string {? index} {? index}}
{string {{const trim}} string {? string}}
{string {{const trimleft}} string {? string}}
{string {{const trimright}} string {? string}}
{string {{const wordend}} string index}
{string {{const wordstart}} string index}
{string {{const reverse}} string}
}
::subst {{{string {}} {? {option -nobackslashes {} -nocommands {} -novariables {}}} {string {}}}}
::switch {{void {? {option -exact {} -glob {} -regexp {} -nocase {} -matchvar {setref {list string}} -indexvar {setref {list int}}}} {? {const --}} string {* unknown}}}
::tcl_endOfWord {2 2}
::tcl_findLibrary {6 6}
::tcl_startOfNextWord {2 2}
::tcl_startOfPreviousWord {2 2}
::tcl_wordBreakAfter {2 2}
::tcl_wordBreakBefore {2 2}
::tell {{{void {}} {channelid {}}}}
::time {{string body {? int}}}
::trace {
{unknown {{const variable}} unknown unknown unknown}
{unknown {{const vdelete}} unknown unknown unknown}
{unknown {{const vinfo}} unknown}
{void {{const add}} {{enum command execution variable}} {{enum array read write unset enter leave enterstep leavestep rename delete}} unknown}
{void {{const remove}} {{enum command execution variable}} unknown unknown}
{list {{const info}} {{enum command execution variable}} unknown}
}
::unknown {1 -1}
::unload {{unknown {? {option -nocomplain {} -keeplibrary {}}} unknown {* unknown}}}
::unset {{void {? {option -nocomplain}} {? {const --}} {+ unknown}}}
::update {{void {? {const idletasks}}}}
::uplevel {
{unknown {? int level} {body script}}
{unknown {? int level} {+ unknown scriptargs}}
}
::upvar {2 -1}
::variable {{void {* unknown}}}
::vwait {1 1}
::while {{{void {}} {texpr {}} {unknown {}}}}
}
my registerObject ::_TclInterp Class {} {}
array set methodsArr {
{::_TclInterp instproc alias} {{unknown unknown unknown {* unknown}}}
{::_TclInterp instproc aliases} {{list}}
{::_TclInterp instproc bgerror} {{unknown {string cmdPrefix}}}
{::_TclInterp instproc eval} {0 -1}
{::_TclInterp instproc expose} {0 -1}
{::_TclInterp instproc hide} {void {string hiddenName} {? string hiddenCmdName}}
{::_TclInterp instproc hidden} {{list}}
{::_TclInterp instproc invokehidden} {0 -1}
{::_TclInterp instproc issafe} {{boolean}}
{::_TclInterp instproc limit} {{int {* unknown}}}
{::_TclInterp instproc marktrusted} {0 -1}
{::_TclInterp instproc recursionlimit} {{int {? int}}}
}
}
CoreSignatureRepository instproc registerItcl {} {
my instvar commandsArr methodsArr
array set commandsArr {
::itcl::class {{{void docu} {string name} {string body}}}
::itcl::body {{{void docu} {string itcl-class} {list arguments} {string body}}}
::itcl::code {{{script docu} {+ unknown args}}}
::itcl::delete {{{void docu} {{enum object class namespace}} {+ string elem}}}
::itcl::is {
{boolean {{const class}} {string class}}
{boolean {{const object}} {? {option -class string}} {string object}}
}
::itcl::find {
{list {{const classes}} {? string pattern}}
{list {{const objects}} {? string pattern} {? {option -class string -isa string}}}
}
::itcl::ensemble {1 -1}
::itcl::scope {{string string}}
::itcl::configbody {2 2}
::itcl::local {{class string {* unknown args}}}
}
array set methodsArr {
{::itcl::object instproc configure} {0 -1 {} {list}}
{::itcl::object instproc cget} {1 1 {} {unknown}}
{::itcl::object instproc isa} {1 1 {} {boolean}}
{::itcl::object instproc info} {0 0 {} {} {
{class 0 0 {} {xotcl}}
{inherit 0 0 {} {list}}
{heritage 0 0 {} {list}}
{function 0 -1 {} {unknown}}
{variable 0 -1 {} {unknown}}
}}
}
my addNamespaceExport ::itcl {body class code configbody delete delete_helper ensemble find local scope}
}
CoreSignatureRepository instproc registerTTkProcs {} {
my instvar commandsArr xotclObjectsArr methodsArr
array set commandsArr {
::ttk::style {{{unknown docu} {unknown element} {unknown create} {unknown name} {unknown vsapi} {unknown className} {unknown partId} {unknown ?stateMap?} {unknown ?options?}}}
::ttk::button {{{{tk ::ttk::Button}} {{new tk ::ttk::Button} ttk::button} {? {option -takefocus boolean -command script -default unknown -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::checkbutton {{{{tk ::ttk::Checkbutton}} {{new tk ::ttk::Checkbutton} ttk::checkbutton} {? {option -takefocus boolean -variable unknown -onvalue unknown -offvalue unknown -command script -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::combobox {{{{tk ::ttk::Combobox}} {{new tk ::ttk::Combobox} ttk::combobox} {? {option -height unknown -postcommand unknown -values unknown -takefocus boolean -exportselection boolean -font string -invalidcommand unknown -justify {enum left center right} -show unknown -state unknown -textvariable {setgref string} -validate unknown -validatecommand unknown -width unknown -xscrollcommand script -foreground color -background color -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::entry {{{{tk ::ttk::Entry}} {{new tk ::ttk::Entry} ttk::entry} {? {option -takefocus boolean -exportselection boolean -font string -invalidcommand unknown -justify {enum left center right} -show unknown -state unknown -textvariable {setgref string} -validate unknown -validatecommand unknown -width unknown -xscrollcommand script -foreground color -background color -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::frame {{{{tk ::ttk::Frame}} {{new tk ::ttk::Frame} ttk::frame} {? {option -borderwidth pixel -padding unknown -relief {enum raised sunken flat ridge solid groove} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::label {{{{tk ::ttk::Label}} {{new tk ::ttk::Label} ttk::label} {? {option -background color -foreground color -font string -borderwidth pixel -relief {enum raised sunken flat ridge solid groove} -anchor {enum n ne e se s sw w nw center} -justify {enum left center right} -wraplength int -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::labelframe {{{{tk ::ttk::Labelframe}} {{new tk ::ttk::Labelframe} ttk::labelframe} {? {option -labelanchor unknown -text string -underline int -labelwidget unknown -borderwidth pixel -padding unknown -relief {enum raised sunken flat ridge solid groove} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::menubutton {{{{tk ::ttk::Menubutton}} {{new tk ::ttk::Menubutton} ttk::menubutton} {? {option -takefocus boolean -menu unknown -direction unknown -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::notebook {{{{tk ::ttk::Notebook}} {{new tk ::ttk::Notebook} ttk::notebook} {? {option -takefocus boolean -width unknown -height unknown -padding unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::panedwindow {{{{tk ::ttk::Panedwindow}} {{new tk ::ttk::Panedwindow} ttk::panedwindow} {? {option -orient {enum horizontal vertical} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::progressbar {{{{tk ::ttk::Progressbar}} {{new tk ::ttk::Progressbar} ttk::progressbar} {? {option -orient {enum horizontal vertical} -length unknown -mode unknown -maximum unknown -variable unknown -value unknown -phase unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::radiobutton {{{{tk ::ttk::Radiobutton}} {{new tk ::ttk::Radiobutton} ttk::radiobutton} {? {option -takefocus boolean -variable unknown -value unknown -command script -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::scale {{{{tk ::ttk::Scale}} {{new tk ::ttk::Scale} ttk::scale} {? {option -takefocus boolean -command script -variable unknown -orient {enum horizontal vertical} -from unknown -to unknown -value unknown -length unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::scrollbar {{{{tk ::ttk::Scrollbar}} {{new tk ::ttk::Scrollbar} ttk::scrollbar} {? {option -command script -orient {enum horizontal vertical} -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::separator {{{{tk ::ttk::Separator}} {{new tk ::ttk::Separator} ttk::separator} {? {option -orient {enum horizontal vertical} -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::sizegrip {{{{tk ::ttk::Sizegrip}} {{new tk ::ttk::Sizegrip} ttk::sizegrip} {? {option -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
::ttk::treeview {{{{tk ::ttk::Treeview}} {{new tk ::ttk::Treeview} ttk::treeview} {? {option -takefocus boolean -columns unknown -displaycolumns unknown -show unknown -selectmode unknown -height unknown -padding unknown -xscrollcommand script -yscrollcommand script -takefocus boolean -cursor unknown -style unknown -class unknown}}}}
}
array set methodsArr {
{::ttk::Button instproc cget} {{unknown {{enum -takefocus -command -default -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Button instproc configure} {list {void {{option -takefocus boolean -command script -default unknown -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -command -default -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Button instproc identify} {0 -1}
{::ttk::Button instproc instate} {0 -1}
{::ttk::Button instproc invoke} {0 -1}
{::ttk::Button instproc state} {0 -1}
{::ttk::Checkbutton instproc cget} {{unknown {{enum -takefocus -variable -onvalue -offvalue -command -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Checkbutton instproc configure} {list {void {{option -takefocus boolean -variable unknown -onvalue unknown -offvalue unknown -command script -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -variable -onvalue -offvalue -command -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Checkbutton instproc identify} {0 -1}
{::ttk::Checkbutton instproc instate} {0 -1}
{::ttk::Checkbutton instproc invoke} {0 -1}
{::ttk::Checkbutton instproc state} {0 -1}
{::ttk::Combobox instproc bbox} {0 -1}
{::ttk::Combobox instproc cget} {{unknown {{enum -height -postcommand -values -takefocus -exportselection -font -invalidcommand -justify -show -state -textvariable -validate -validatecommand -width -xscrollcommand -foreground -background -takefocus -cursor -style -class}}}}
{::ttk::Combobox instproc configure} {list {void {{option -height unknown -postcommand unknown -values unknown -takefocus boolean -exportselection boolean -font string -invalidcommand unknown -justify {enum left center right} -show unknown -state unknown -textvariable {setgref string} -validate unknown -validatecommand unknown -width unknown -xscrollcommand script -foreground color -background color -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -height -postcommand -values -takefocus -exportselection -font -invalidcommand -justify -show -state -textvariable -validate -validatecommand -width -xscrollcommand -foreground -background -takefocus -cursor -style -class}}}}
{::ttk::Combobox instproc current} {0 -1}
{::ttk::Combobox instproc delete} {0 -1}
{::ttk::Combobox instproc get} {0 -1}
{::ttk::Combobox instproc icursor} {0 -1}
{::ttk::Combobox instproc identify} {0 -1}
{::ttk::Combobox instproc index} {0 -1}
{::ttk::Combobox instproc insert} {0 -1}
{::ttk::Combobox instproc instate} {0 -1}
{::ttk::Combobox instproc selection} {0 -1}
{::ttk::Combobox instproc set} {0 -1}
{::ttk::Combobox instproc state} {0 -1}
{::ttk::Combobox instproc xview} {0 -1}
{::ttk::Entry instproc bbox} {0 -1}
{::ttk::Entry instproc cget} {{unknown {{enum -takefocus -exportselection -font -invalidcommand -justify -show -state -textvariable -validate -validatecommand -width -xscrollcommand -foreground -background -takefocus -cursor -style -class}}}}
{::ttk::Entry instproc configure} {list {void {{option -takefocus boolean -exportselection boolean -font string -invalidcommand unknown -justify {enum left center right} -show unknown -state unknown -textvariable {setgref string} -validate unknown -validatecommand unknown -width unknown -xscrollcommand script -foreground color -background color -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -exportselection -font -invalidcommand -justify -show -state -textvariable -validate -validatecommand -width -xscrollcommand -foreground -background -takefocus -cursor -style -class}}}}
{::ttk::Entry instproc delete} {0 -1}
{::ttk::Entry instproc get} {0 -1}
{::ttk::Entry instproc icursor} {0 -1}
{::ttk::Entry instproc identify} {0 -1}
{::ttk::Entry instproc index} {0 -1}
{::ttk::Entry instproc insert} {0 -1}
{::ttk::Entry instproc instate} {0 -1}
{::ttk::Entry instproc selection} {0 -1}
{::ttk::Entry instproc state} {0 -1}
{::ttk::Entry instproc validate} {0 -1}
{::ttk::Entry instproc xview} {0 -1}
{::ttk::Frame instproc cget} {{unknown {{enum -borderwidth -padding -relief -width -height -takefocus -cursor -style -class}}}}
{::ttk::Frame instproc configure} {list {void {{option -borderwidth pixel -padding unknown -relief {enum raised sunken flat ridge solid groove} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -borderwidth -padding -relief -width -height -takefocus -cursor -style -class}}}}
{::ttk::Frame instproc identify} {0 -1}
{::ttk::Frame instproc instate} {0 -1}
{::ttk::Frame instproc state} {0 -1}
{::ttk::Label instproc cget} {{unknown {{enum -background -foreground -font -borderwidth -relief -anchor -justify -wraplength -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Label instproc configure} {list {void {{option -background color -foreground color -font string -borderwidth pixel -relief {enum raised sunken flat ridge solid groove} -anchor {enum n ne e se s sw w nw center} -justify {enum left center right} -wraplength int -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -background -foreground -font -borderwidth -relief -anchor -justify -wraplength -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Label instproc identify} {0 -1}
{::ttk::Label instproc instate} {0 -1}
{::ttk::Label instproc state} {0 -1}
{::ttk::Labelframe instproc cget} {{unknown {{enum -labelanchor -text -underline -labelwidget -borderwidth -padding -relief -width -height -takefocus -cursor -style -class}}}}
{::ttk::Labelframe instproc configure} {list {void {{option -labelanchor unknown -text string -underline int -labelwidget unknown -borderwidth pixel -padding unknown -relief {enum raised sunken flat ridge solid groove} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -labelanchor -text -underline -labelwidget -borderwidth -padding -relief -width -height -takefocus -cursor -style -class}}}}
{::ttk::Labelframe instproc identify} {0 -1}
{::ttk::Labelframe instproc instate} {0 -1}
{::ttk::Labelframe instproc state} {0 -1}
{::ttk::Menubutton instproc cget} {{unknown {{enum -takefocus -menu -direction -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Menubutton instproc configure} {list {void {{option -takefocus boolean -menu unknown -direction unknown -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -menu -direction -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Menubutton instproc identify} {0 -1}
{::ttk::Menubutton instproc instate} {0 -1}
{::ttk::Menubutton instproc state} {0 -1}
{::ttk::Notebook instproc add} {0 -1}
{::ttk::Notebook instproc cget} {{unknown {{enum -takefocus -width -height -padding -takefocus -cursor -style -class}}}}
{::ttk::Notebook instproc configure} {list {void {{option -takefocus boolean -width unknown -height unknown -padding unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -width -height -padding -takefocus -cursor -style -class}}}}
{::ttk::Notebook instproc forget} {0 -1}
{::ttk::Notebook instproc hide} {0 -1}
{::ttk::Notebook instproc identify} {0 -1}
{::ttk::Notebook instproc index} {0 -1}
{::ttk::Notebook instproc insert} {0 -1}
{::ttk::Notebook instproc instate} {0 -1}
{::ttk::Notebook instproc select} {0 -1}
{::ttk::Notebook instproc state} {0 -1}
{::ttk::Notebook instproc tab} {0 -1}
{::ttk::Notebook instproc tabs} {0 -1}
{::ttk::Panedwindow instproc add} {0 -1}
{::ttk::Panedwindow instproc cget} {{unknown {{enum -orient -width -height -takefocus -cursor -style -class}}}}
{::ttk::Panedwindow instproc configure} {list {void {{option -orient {enum horizontal vertical} -width unknown -height unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -orient -width -height -takefocus -cursor -style -class}}}}
{::ttk::Panedwindow instproc forget} {0 -1}
{::ttk::Panedwindow instproc identify} {0 -1}
{::ttk::Panedwindow instproc insert} {0 -1}
{::ttk::Panedwindow instproc instate} {0 -1}
{::ttk::Panedwindow instproc pane} {0 -1}
{::ttk::Panedwindow instproc panes} {0 -1}
{::ttk::Panedwindow instproc sashpos} {0 -1}
{::ttk::Panedwindow instproc state} {0 -1}
{::ttk::Progressbar instproc cget} {{unknown {{enum -orient -length -mode -maximum -variable -value -phase -takefocus -cursor -style -class}}}}
{::ttk::Progressbar instproc configure} {list {void {{option -orient {enum horizontal vertical} -length unknown -mode unknown -maximum unknown -variable unknown -value unknown -phase unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -orient -length -mode -maximum -variable -value -phase -takefocus -cursor -style -class}}}}
{::ttk::Progressbar instproc identify} {0 -1}
{::ttk::Progressbar instproc instate} {0 -1}
{::ttk::Progressbar instproc start} {0 -1}
{::ttk::Progressbar instproc state} {0 -1}
{::ttk::Progressbar instproc step} {0 -1}
{::ttk::Progressbar instproc stop} {0 -1}
{::ttk::Radiobutton instproc cget} {{unknown {{enum -takefocus -variable -value -command -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Radiobutton instproc configure} {list {void {{option -takefocus boolean -variable unknown -value unknown -command script -text string -textvariable {setgref string} -underline int -width unknown -image unknown -compound {enum none bottom top left right center} -padding unknown -state unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -variable -value -command -text -textvariable -underline -width -image -compound -padding -state -takefocus -cursor -style -class}}}}
{::ttk::Radiobutton instproc identify} {0 -1}
{::ttk::Radiobutton instproc instate} {0 -1}
{::ttk::Radiobutton instproc invoke} {0 -1}
{::ttk::Radiobutton instproc state} {0 -1}
{::ttk::Scale instproc cget} {{unknown {{enum -takefocus -command -variable -orient -from -to -value -length -takefocus -cursor -style -class}}}}
{::ttk::Scale instproc configure} {list {void {{option -takefocus boolean -command script -variable unknown -orient {enum horizontal vertical} -from unknown -to unknown -value unknown -length unknown -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -command -variable -orient -from -to -value -length -takefocus -cursor -style -class}}}}
{::ttk::Scale instproc coords} {0 -1}
{::ttk::Scale instproc get} {0 -1}
{::ttk::Scale instproc identify} {0 -1}
{::ttk::Scale instproc instate} {0 -1}
{::ttk::Scale instproc set} {0 -1}
{::ttk::Scale instproc state} {0 -1}
{::ttk::Scrollbar instproc cget} {{unknown {{enum -command -orient -takefocus -cursor -style -class}}}}
{::ttk::Scrollbar instproc configure} {list {void {{option -command script -orient {enum horizontal vertical} -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -command -orient -takefocus -cursor -style -class}}}}
{::ttk::Scrollbar instproc delta} {0 -1}
{::ttk::Scrollbar instproc fraction} {0 -1}
{::ttk::Scrollbar instproc get} {0 -1}
{::ttk::Scrollbar instproc identify} {0 -1}
{::ttk::Scrollbar instproc instate} {0 -1}
{::ttk::Scrollbar instproc set} {0 -1}
{::ttk::Scrollbar instproc state} {0 -1}
{::ttk::Separator instproc cget} {{unknown {{enum -orient -takefocus -cursor -style -class}}}}
{::ttk::Separator instproc configure} {list {void {{option -orient {enum horizontal vertical} -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -orient -takefocus -cursor -style -class}}}}
{::ttk::Separator instproc identify} {0 -1}
{::ttk::Separator instproc instate} {0 -1}
{::ttk::Separator instproc state} {0 -1}
{::ttk::Sizegrip instproc cget} {{unknown {{enum -takefocus -cursor -style -class}}}}
{::ttk::Sizegrip instproc configure} {list {void {{option -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -cursor -style -class}}}}
{::ttk::Sizegrip instproc identify} {0 -1}
{::ttk::Sizegrip instproc instate} {0 -1}
{::ttk::Sizegrip instproc state} {0 -1}
{::ttk::Treeview instproc bbox} {0 -1}
{::ttk::Treeview instproc cget} {{unknown {{enum -takefocus -columns -displaycolumns -show -selectmode -height -padding -xscrollcommand -yscrollcommand -takefocus -cursor -style -class}}}}
{::ttk::Treeview instproc children} {0 -1}
{::ttk::Treeview instproc column} {0 -1}
{::ttk::Treeview instproc configure} {list {void {{option -takefocus boolean -columns unknown -displaycolumns unknown -show unknown -selectmode unknown -height unknown -padding unknown -xscrollcommand script -yscrollcommand script -takefocus boolean -cursor unknown -style unknown -class unknown}}} {list {{enum -takefocus -columns -displaycolumns -show -selectmode -height -padding -xscrollcommand -yscrollcommand -takefocus -cursor -style -class}}}}
{::ttk::Treeview instproc delete} {0 -1}
{::ttk::Treeview instproc detach} {0 -1}
{::ttk::Treeview instproc drag} {0 -1}
{::ttk::Treeview instproc exists} {0 -1}
{::ttk::Treeview instproc focus} {0 -1}
{::ttk::Treeview instproc heading} {0 -1}
{::ttk::Treeview instproc identify} {0 -1}
{::ttk::Treeview instproc index} {0 -1}
{::ttk::Treeview instproc insert} {0 -1}
{::ttk::Treeview instproc instate} {0 -1}
{::ttk::Treeview instproc item} {0 -1}
{::ttk::Treeview instproc move} {0 -1}
{::ttk::Treeview instproc next} {0 -1}
{::ttk::Treeview instproc parent} {0 -1}
{::ttk::Treeview instproc prev} {0 -1}
{::ttk::Treeview instproc see} {0 -1}
{::ttk::Treeview instproc selection} {0 -1}
{::ttk::Treeview instproc set} {0 -1}
{::ttk::Treeview instproc state} {0 -1}
{::ttk::Treeview instproc tag} {0 -1}
{::ttk::Treeview instproc xview} {0 -1}
{::ttk::Treeview instproc yview} {0 -1}
}
array set xotclObjectsArr {
::ttk::Button {Class ::widget {}}
::ttk::Checkbutton {Class ::widget {}}
::ttk::Combobox {Class ::widget {}}
::ttk::Entry {Class ::widget {}}
::ttk::Frame {Class ::widget {}}
::ttk::Label {Class ::widget {}}
::ttk::Labelframe {Class ::widget {}}
::ttk::Menubutton {Class ::widget {}}
::ttk::Notebook {Class ::widget {}}
::ttk::Panedwindow {Class ::widget {}}
::ttk::Progressbar {Class ::widget {}}
::ttk::Radiobutton {Class ::widget {}}
::ttk::Scale {Class ::widget {}}
::ttk::Scrollbar {Class ::widget {}}
::ttk::Separator {Class ::widget {}}
::ttk::Sizegrip {Class ::widget {}}
::ttk::Treeview {Class ::widget {}}
}
}
CoreSignatureRepository instproc registerTkProcs {} {
my instvar commandsArr xotclObjectsArr methodsArr
array set commandsArr {
::bell {{{void {Ring a display's bell}} {? {option -displayof tk -nice {}}}}}
::bind {{{unknown docu} {unknown tag} {? string ?sequence?} {? script script}}}
::bindtags {{{unknown docu} {tk window} {? list ?tagList?}}}
::clipboard {
{{void docu} {{const clear}} {? {option -displayof tk}}}
{{void docu} {{const append}} {? {option -displayof tk -format string -type string -- {}}} {unknown string}}
{{string docu} {{const get}} {? {option -displayof tk -format string -type string}}}
}
::console {
{{unknown docu} {{const eval}} {unknown script}}
{{void docu} {{const hide}}}
{{void docu} {{const show}}}
{{string docu} {{const title}} {? string ?string?}}
}
::destroy {{{void docu} {+ tk}}}
::event {
{{void docu} {{const add}} {unknown <<virtual>>} {+ string sequence}}
{{void docu} {{const delete}} {unknown <<virtual>>} {* string sequence}}
{{void docu} {{const generate}} {tk window} {unknown event} {* unknown ?...?}}
{{list docu} {{const info}} {? string <<virtual>>}}
}
::focus {
{{tk docu} {? tk window}}
{{tk docu} {{const -displayof}} {tk window}}
{{void docu} {{const -force}} {tk window}}
{{tk docu} {{const -lastfor}} {tk window}}
}
::font {
{{unknown docu} {{const actual}} {string font} {? {option -displayof tk}} {unknown ?option?} {? {enum -family -size -weight -slant -underline -overstrike}} {? {const --}} {? string char}}
{{string docu} {{const create}} {? string fontname} {? {option -family string -size pixel -weight {enum normal bold} -slant {enum roman italic}
-underline boolean -overstrike boolean}}}
{{unknown docu} {{const configure}} {string fontname} {? {enum -family -size -weight -slant -underline -overstrike}}}
{{void docu} {{const configure}} {string fontname} {? {option -family string -size pixel -weight {enum normal bold} -slant {enum roman italic}
-underline boolean -overstrike boolean}}}
{{void docu} {{const delete}} {+ string fontname}}
{{list docu} {{const families}} {? {option -displayof tk}}}
{{int docu} {{const measure}} {string font} {? {option -displayof tk}} {string text}}
{{unknown docu} {{const metrics}} {string font} {? {option -displayof tk}} {{enum -ascent -descent -linespace -fixed}}}
{{list docu} {{const names}}}
}
::grab {
{{void docu} {? {option -global {}}} {tk window}}
{{tk docu} {{const current}} {? tk window}}
{{void docu} {{const release}} {tk window}}
{{void docu} {{const set}} {? {option -global {}}} {tk window}}
{{string docu} {{const status}} {tk window}}
}
::grid {
{{string docu} {{const anchor}} {tk master} {? string anchor}}
{{unknown docu} {{const bbox}} {tk master} {unknown ?column} {unknown row?} {unknown ?column2} {unknown row2?}}
{{void docu} {{const columnconfigure}} {tk master} {int index} {? {option -minsize int -weight double -uniform string -pad pixel}}}
{{unknown docu} {{const columnconfigure}} {tk master} {string index} {enum -minsize -weight -uniform -pad}}
{{unknown docu} {{const configure}} {+ tk slave} {? {option -column int -columnspan int -in tk -ipadx pixel -ipady pixel -padx pixel -pady pixel -row int -rowspan int -sticky {enum n s e w}}}}
{{void docu} {{const forget}} {+ tk slave}}
{{list docu} {{const info}} {tk slave}}
{{list docu} {{const location}} {tk master} {int x} {int y}}
{{boolean docu} {{const propagate}} {tk master} {? boolean}}
{{void docu} {{const rowconfigure}} {tk master} {string index} {? {option -minsize int -weight double -uniform string -pad pixel}}}
{{void docu} {{const remove}} {+ tk slave}}
{{{list int} docu} {{const size}} {tk master}}
{{list docu} {{const slaves}} {tk master} {? {option -row int -column int}}}
{{void docu} {+ tk slave} {* {const -}} {* {const x}} {* {const ^}} {? {option -column int -columnspan int -in tk -ipadx pixel -ipady pixel -padx pixel -pady pixel -row int -rowspan int -sticky string}}}
}
::image {
{string {{const create}} {string type} {? string name} {? {option -background color -data string -file string -foreground color -maskdata string -maskfile string -format string -gamma string -height int -palette string -width int}}}
{void {{const delete}} {+ string name}}
{int {{const height}} {string name}}
{boolean {{const inuse}} {string name}}
{list {{const names}} }
{string {{const type}} {string name}}
{list {{const types}} }
{int {{const width}} {string name}}
}
::lower {{{unknown docu} {tk window} {? tk belowThis}}}
::option {
{void {{const add}} {string pattern} {string value} {? {enum widgetDefault startupFile userDefault interactive} priority}}
{string {{const get}} tk {string name} {string class}}
{void {{const clear}}}
{void {{const readfile}} {string fileName} {? {enum widgetDefault startupFile userDefault interactive} priority}}
}
::pack {
{{void docu} {{const configure}} {+ tk slave} {? {option -after tk -anchor string -before tk -expand boolean -fill {enum none x y both} -in tk -ipadx pixel -ipady pixel -padx pixel -pady pixel -side {enum left right top bottom}}}}
{{void docu} {{const forget}} {+ tk slave}}
{{list docu} {{const info}} {tk slave}}
{{boolean docu} {{const propagate}} {tk master} {? boolean}}
{{{list tk} docu} {{const slaves}} {tk master}}
{void {+ tk slave} {? {option -after tk -anchor string -before tk -expand boolean -fill {enum none x y both} -in tk -ipadx pixel -ipady pixel -padx pixel -pady pixel -side {enum left right top bottom}}}}
}
::pathname {{{unknown docu} {unknown insert} {unknown index} {tk window} {unknown ?options...?}}}
::place {
{{void docu} {+ tk slave} {? {option -anchor string -bordermode string -height pixel -in tk -relheight pixel -relwidth pixel -relx pixel -rely pixel -width pixel -x pixel -y pixel}}}
{{void docu} {{const configure}} {+ tk window} {? {option -anchor string -bordermode string -height pixel -in tk -relheight pixel -relwidth pixel -relx pixel -rely pixel -width pixel -x pixel -y pixel}}}
{{void docu} {{const forget}} {+ tk window}}
{{list docu} {{const info}} {tk window}}
{{list docu} {{const slaves}} {tk window}}
}
::raise {{{unknown docu} {tk window} {? tk aboveThis}}}
::selection {
{{unknown docu} {{const clear}} {? {option -displayof tk -selection string}}}
{{unknown docu} {{const get}} {? {option -displayof tk -selection string -type string}}}
{{unknown docu} {{const handle}} {? {option -selection string -type string -format string}} {tk window} {script command}}
{{unknown docu} {{const own}} {? {option -displayof tk -selection string}}}
{{unknown docu} {{const own}} {? {option -command string -selection string}} {tk window}}
}
::send {{{unknown docu} {? {option -async {} -displayof string}} {string app} {string cmd} {* string args}}}
::tk {
{{string docu} {{const appname}} {? string newName}}
{{list docu} {{const caret}} {tk window} {? {option -x int -y int -height int}}}
{{string docu} {{const scaling}} {? {option -displayof tk}} {? pixel number}}
{{unknown docu} {{const inactive}} {? {option -displayof tk}} {? {const reset}}}
{{unknown docu} {{const useinputmethods}} {? {option -displayof tk}} {?boolean boolean}}
{{string docu} {{const windowingsystem}}}
}
::tk_bindForTraversal {{{unknown docu} {unknown arg} {unknown arg} {unknown ...}}}
::tk_bisque {{{unknown docu}}}
::tk_chooseColor {{color {? {option -initialcolor color -parent tk -title string}}}}
::tk_chooseDirectory {{string {? {option -initialdir string -mustexist boolean -parent tk -title string}}}}
::tk_dialog {{{string docu} {tk window} {unknown title} {string text} {unknown bitmap} {unknown default} {+ string string}}}
::tk_focusFollowsMouse {{{unknown docu}}}
::tk_focusNext {{{tk docu} {tk window}}}
::tk_focusPrev {{{tk docu} {tk window}}}
::tk_getOpenFile {{{string docu} {? {option -defaultextension string -filetypes {list string} -initialdir string -initialfile string -message string -multiple boolean -parent tk -title string -typevariable {ref string}}}}}
::tk_getSaveFile {{{string docu} {? {option -defaultextension string -filetypes {list string} -initialdir string -initialfile string -message string -multiple boolean -parent tk -title string -typevariable {ref string}}}}}
::tk_menuBar {{{unknown docu} {unknown frame} {unknown ?...?}}}
::tk_menuSetFocus {{{unknown docu} {tk pathName}}}
::tk_messageBox {{{string docu} {{option -default string -detail string -icon unknown -message string -parent tk -title string -type {enum abortretryignore ok okcancel retrycancel yesno yesnocancel}}}}}
::tk_optionMenu {{{unknown docu} {tk pathName} {{ref string} varName} {+ string value}}}
::tk_popup {{{unknown docu} {{tk ::Menu} menu} {int x} {int y} {? int entry}}}
::tk_setPalette {{{unknown docu} {unknown name} {unknown value} {? unknown}}}
::tk_textCopy {{{unknown docu} {tk pathName}}}
::tk_textCut {{{unknown docu} {tk pathName}}}
::tk_textPaste {{{unknown docu} {tk pathName}}}
::tkerror {{{unknown docu} {string message}}}
::tkwait {
{{unknown docu} {{const variable}} {gref varname}}
{{unknown docu} {{const visibility}} {tk name}}
{{unknown docu} {{const window}} {tk name}}
}
::winfo {
{{int docu} {{const atom}} {? {option -displayof tk}} {string name}}
{{string docu} {{const atomname}} {? {option -displayof tk}} {string id}}
{{int docu} {{const cells}} {tk window}}
{{{list tk} docu} {{const children}} {tk window}}
{{string docu} {{const class}} {tk window}}
{{boolean docu} {{const colormapfull}} {tk window}}
{{tk docu} {{const containing}} {? {option -displayof tk}} {int rootX} {int rootY}}
{{int docu} {{const depth}} {tk window}}
{{boolean docu} {{const exists}} {{new tk ::widget} window}}
{{double docu} {{const fpixels}} {tk window} {pixel number}}
{{string docu} {{const geometry}} {tk window}}
{{int docu} {{const height}} {tk window}}
{{string docu} {{const id}} {tk window}}
{{list docu} {{const interps}} {? {option -displayof tk}} {string id}}
{{boolean docu} {{const ismapped}} {tk window}}
{{string docu} {{const manager}} {tk window}}
{{string docu} {{const name}} {tk window}}
{{tk docu} {{const parent}} {tk window}}
{{tk docu} {{const pathname}} {? {option -displayof tk}} {unknown id}}
{{int docu} {{const pixels}} {tk window} {pixel number}}
{{int docu} {{const pointerx}} {tk window}}
{{list docu} {{const pointerxy}} {tk window}}
{{int docu} {{const pointery}} {tk window}}
{{int docu} {{const reqheight}} {tk window}}
{{int docu} {{const reqwidth}} {tk window}}
{{{list int} docu} {{const rgb}} {tk window} {string color}}
{{int docu} {{const rootx}} {tk window}}
{{int docu} {{const rooty}} {tk window}}
{{string docu} {{const screen}} {tk window}}
{{int docu} {{const screencells}} {tk window}}
{{int docu} {{const screendepth}} {tk window}}
{{int docu} {{const screenheight}} {tk window}}
{{int docu} {{const screenmmheight}} {tk window}}
{{int docu} {{const screenmmwidth}} {tk window}}
{{string docu} {{const screenvisual}} {tk window}}
{{int docu} {{const screenwidth}} {tk window}}
{{string docu} {{const server}} {tk window}}
{{{tk ::Toplevel} docu} {{const toplevel}} {tk window}}
{{boolean docu} {{const viewable}} {tk window}}
{{string docu} {{const visual}} {tk window}}
{{int docu} {{const visualid}} {tk window}}
{{list docu} {{const visualsavailable}} {tk window} {? {const includeids}}}
{{int docu} {{const vrootheight}} {tk window}}
{{int docu} {{const vrootwidth}} {tk window}}
{{int docu} {{const vrootx}} {tk window}}
{{int docu} {{const vrooty}} {tk window}}
{{int docu} {{const width}} {tk window}}
{{int docu} {{const x}} {tk window}}
{{int docu} {{const y}} {tk window}}
}
::wm {
{{list docu} {{const aspect}}}
{{void docu} {{const aspect}} {tk window} {int minNumer} {int minDenom} {int maxNumer} {int maxDenom}}
{{list docu} {{const attributes}} {tk window}}
{{unknown docu} {{const attributes}} {tk window} {{enum -fullscreen -topmost -alpha -disabled -toolwindow -transparentcolor -alpha -modified -notify -titlepath -transparent -zoomed -type}}}
{{void docu} {{const attributes}} {tk window} {{option -fullscreen unknown -topmost unknown -alpha unknown -disabled unknown -toolwindow unknown -transparentcolor unknown -alpha unknown -modified unknown -notify unknown -titlepath unknown -transparent unknown -zoomed unknown -type unknown}}}
{{string docu} {{const client}} {tk window} {? string name}}
{{list docu} {{const colormapwindows}} {tk window} {? list windowList}}
{{unknown docu} {{const command}} {tk window} {? unknown value}}
{{void docu} {{const deiconify}} {tk window}}
{{unknown docu} {{const focusmodel}} {tk window} {{enum active passive}}}
{{void docu} {{const forget}} {tk window}}
{{string docu} {{const frame}} {tk window}}
{{unknown docu} {{const geometry}} {tk window} {? unknown newGeometry}}
{{unknown docu} {{const grid}} {tk window}}
{{unknown docu} {{const grid}} {tk window} {int baseWidth} {int baseHeight} {int widthInc} {int heightInc?}}
{{unknown docu} {{const group}} {tk window} {? string pathName}}
{{unknown docu} {{const iconbitmap}} {tk window} {? {const -default}} {? unknown bitmap}}
{{unknown docu} {{const iconify}} {tk window}}
{{unknown docu} {{const iconmask}} {tk window} {? unknown bitmap}}
{{unknown docu} {{const iconname}} {tk window} {? string newName}}
{{unknown docu} {{const iconphoto}} {tk window} {unknown ?-default?} {unknown image1} {unknown ?...?}}
{{unknown docu} {{const iconposition}} {tk window} {unknown ?x} {unknown y?}}
{{unknown docu} {{const iconwindow}} {tk window} {? unknown pathName}}
{{void docu} {{const manage}} {tk widget}}
{{list docu} {{const maxsize}} {tk window}}
{{void docu} {{const maxsize}} {tk window} {int width} {int height}}
{{list docu} {{const minsize}} {tk window}}
{{void docu} {{const minsize}} {tk window} {int width} {int height}}
{{boolean docu} {{const overrideredirect}} {tk window} {? boolean boolean}}
{{string docu} {{const positionfrom}} {tk window} {? unknown who}}
{{unknown docu} {{const protocol}} {tk window}}
{{unknown docu} {{const protocol}} {tk window} {string name} {script command}}
{{string docu} {{const resizable}} {tk window}}
{{string docu} {{const resizable}} {tk window} {int width} {int height}}
{{string docu} {{const sizefrom}} {tk window} {? unknown who}}
{{list docu} {{const stackorder}} {tk window} }
{{list docu} {{const stackorder}} {tk window} {{enum isabove isbelow}} {tk window}}
{{string docu} {{const state}} {tk window} {? unknown newstate}}
{{string docu} {{const title}} {tk window} {? string string}}
{{tk docu} {{const transient}} {tk window} {? tk master}}
{{void docu} {{const withdraw}} {tk window}}
}
}
my registerMethod ::widget instproc configure {0 -1}
my registerMethod ::widget instproc cget {1 1}
my registerObject ::widget Class {} {}
array set commandsArr {
::button {{{{tk ::Button}} {{new tk ::Button} button} {? {option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -default unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -justify {enum left center right} -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -state unknown -takefocus boolean -text string -textvariable {gref string} -underline int -width pixel -wraplength int}}}}
::canvas {{{{tk ::Canvas}} {{new tk ::Canvas} canvas} {? {option -background color -bd pixel -bg color -borderwidth pixel -closeenough unknown -confine unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -offset unknown -relief {enum raised sunken flat ridge solid groove} -scrollregion unknown -selectbackground color -selectborderwidth pixel -selectforeground color -state unknown -takefocus boolean -width unknown -xscrollcommand script -xscrollincrement unknown -yscrollcommand script -yscrollincrement unknown}}}}
::checkbutton {{{{tk ::Checkbutton}} {{new tk ::Checkbutton} checkbutton} {? {option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -offrelief unknown -offvalue unknown -onvalue unknown -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -selectimage unknown -state unknown -takefocus boolean -text string -textvariable {gref string} -tristateimage unknown -tristatevalue unknown -underline int -variable unknown -width unknown -wraplength int}}}}
::entry {{{{tk ::Entry}} {{new tk ::Entry} entry} {? {option -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledbackground unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -highlightbackground color -highlightcolor color -highlightthickness pixel -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -invalidcommand unknown -invcmd unknown -justify {enum left center right} -readonlybackground unknown -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -show unknown -state unknown -takefocus boolean -textvariable {setgref string} -validate unknown -validatecommand unknown -vcmd unknown -width unknown -xscrollcommand script}}}}
::frame {{{{tk ::Frame}} {{new tk ::Frame} frame} {? {option -bd pixel -borderwidth pixel -class unknown -relief {enum raised sunken flat ridge solid groove} -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}}}
::label {{{{tk ::Label}} {{new tk ::Label} label} {? {option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -justify {enum left center right} -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -state unknown -takefocus boolean -text string -textvariable {setgref string} -underline int -width unknown -wraplength pixel}}}}
::labelframe {{{{tk ::Labelframe}} {{new tk ::Labelframe} labelframe} {? {option -bd pixel -borderwidth pixel -class unknown -fg color -font string -foreground color -labelanchor unknown -labelwidget unknown -relief {enum raised sunken flat ridge solid groove} -text string -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}}}
::listbox {{{{tk ::Listbox}} {{new tk ::Listbox} listbox} {? {option -activestyle unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -selectmode unknown -setgrid boolean -state unknown -takefocus boolean -width unknown -xscrollcommand script -yscrollcommand script -listvariable unknown}}}}
::menu {{{{tk ::Menu}} {{new tk ::Menu} menu} {? {option -activebackground color -activeborderwidth pixel -activeforeground unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledforeground color -fg color -font string -foreground color -postcommand unknown -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -takefocus boolean -tearoff unknown -tearoffcommand unknown -title unknown -type unknown}}}}
::menubutton {{{{tk ::Menubutton}} {{new tk ::Menubutton} menubutton} {? {option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -cursor unknown -direction unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -menu unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -compound {enum none bottom top left right center} -state unknown -takefocus boolean -text string -textvariable {setgref string} -underline int -width unknown -wraplength int}}}}
::message {{{{tk ::Message}} {{new tk ::Message} message} {? {option -anchor {enum n ne e se s sw w nw center} -aspect unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -fg color -font string -foreground color -highlightbackground color -highlightcolor color -highlightthickness pixel -justify {enum left center right} -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -takefocus boolean -text string -textvariable {setgref string} -width unknown}}}}
::panedwindow {{{{tk ::Panedwindow}} {{new tk ::Panedwindow} panedwindow} {? {option -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -handlepad unknown -handlesize unknown -height unknown -opaqueresize unknown -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -sashcursor unknown -sashpad unknown -sashrelief unknown -sashwidth unknown -showhandle unknown -width unknown}}}}
::radiobutton {{{{tk ::Radiobutton}} {{new tk ::Radiobutton} radiobutton} {? {option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -offrelief unknown -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -selectimage unknown -state unknown -takefocus boolean -text string -textvariable {setgref string} -tristateimage unknown -tristatevalue unknown -underline int -value unknown -variable unknown -width unknown -wraplength int}}}}
::scale {{{{tk ::Scale}} {{new tk ::Scale} scale} {? {option -activebackground color -background color -bigincrement unknown -bd pixel -bg color -borderwidth pixel -command script -cursor unknown -digits unknown -fg color -font string -foreground color -from unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -label unknown -length unknown -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -resolution unknown -showvalue unknown -sliderlength unknown -sliderrelief unknown -state unknown -takefocus boolean -tickinterval unknown -to unknown -troughcolor color -variable unknown -width unknown}}}}
::scrollbar {{{{tk ::Scrollbar}} {{new tk ::Scrollbar} scrollbar} {? {option -activebackground color -activerelief unknown -background color -bd pixel -bg color -borderwidth pixel -command script -cursor unknown -elementborderwidth unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -jump boolean -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -takefocus boolean -troughcolor color -width unknown}}}}
::spinbox {{{{tk ::Spinbox}} {{new tk ::Spinbox} spinbox} {? {option -activebackground color -background color -bd pixel -bg color -borderwidth pixel -buttonbackground unknown -buttoncursor unknown -buttondownrelief unknown -buttonuprelief unknown -command script -cursor unknown -disabledbackground unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -format unknown -from unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -increment unknown -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -invalidcommand unknown -invcmd unknown -justify {enum left center right} -relief {enum raised sunken flat ridge solid groove} -readonlybackground unknown -repeatdelay int -repeatinterval int -selectbackground color -selectborderwidth pixel -selectforeground color -state unknown -takefocus boolean -textvariable {setgref string} -to unknown -validate unknown -validatecommand unknown -values unknown -vcmd unknown -width unknown -wrap unknown -xscrollcommand script}}}}
::text {{{{tk ::Text}} {{new tk ::Text} text} {? {option -autoseparators unknown -background color -bd pixel -bg color -blockcursor unknown -borderwidth pixel -cursor unknown -endline unknown -exportselection boolean -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -inactiveselectbackground unknown -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -maxundo unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -setgrid boolean -spacing1 unknown -spacing2 unknown -spacing3 unknown -startline unknown -state unknown -tabs unknown -tabstyle unknown -takefocus boolean -undo unknown -width unknown -wrap unknown -xscrollcommand script -yscrollcommand script}}}}
::toplevel {{{{tk ::Toplevel}} {{new tk ::Toplevel} toplevel} {? {option -bd pixel -borderwidth pixel -class unknown -menu unknown -relief {enum raised sunken flat ridge solid groove} -screen unknown -use unknown -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}}}
}
array set methodsArr {
{::Button instproc cget} {{unknown {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -default -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -justify -overrelief -padx -pady -relief -repeatdelay -repeatinterval -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Button instproc configure} {list {void {{option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -default unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -justify {enum left center right} -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -state unknown -takefocus boolean -text string -textvariable {setgref string} -underline int -width unknown -wraplength int}}} {list {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -default -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -justify -overrelief -padx -pady -relief -repeatdelay -repeatinterval -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Button instproc flash} void
{::Button instproc invoke} void
{::Canvas instproc addtag} {
{void string {{const above}} {string tagOrId}}
{void string {{const below}} {string tagOrId}}
{void string {{const closest}} int int {? int} {? unknown start}}
{void string {{const enclosed}} int int int int}
{void string {{const overlapping}} int int int int}
{void string {{const withtag}} string}
}
{::Canvas instproc bbox} {{list {+ string tag}}}
{::Canvas instproc bind} {{void string {? string sequence} {? script}}}
{::Canvas instproc canvasx} {{int int {? int}}}
{::Canvas instproc canvasy} {{int int {? int}}}
{::Canvas instproc cget} {{unknown {{enum -background -bd -bg -borderwidth -closeenough -confine -cursor -height -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -offset -relief -scrollregion -selectbackground -selectborderwidth -selectforeground -state -takefocus -width -xscrollcommand -xscrollincrement -yscrollcommand -yscrollincrement}}}}
{::Canvas instproc configure} {list {void {{option -background color -bd pixel -bg color -borderwidth pixel -closeenough unknown -confine unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -offset unknown -relief {enum raised sunken flat ridge solid groove} -scrollregion unknown -selectbackground color -selectborderwidth pixel -selectforeground color -state unknown -takefocus boolean -width unknown -xscrollcommand script -xscrollincrement unknown -yscrollcommand script -yscrollincrement unknown}}} {list {{enum -background -bd -bg -borderwidth -closeenough -confine -cursor -height -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -offset -relief -scrollregion -selectbackground -selectborderwidth -selectforeground -state -takefocus -width -xscrollcommand -xscrollincrement -yscrollcommand -yscrollincrement}}}}
{::Canvas instproc coords} {0 -1}
{::Canvas instproc create} {0 -1}
{::Canvas instproc dchars} {0 -1}
{::Canvas instproc delete} {0 -1}
{::Canvas instproc dtag} {0 -1}
{::Canvas instproc find} {0 -1}
{::Canvas instproc focus} {0 -1}
{::Canvas instproc gettags} {0 -1}
{::Canvas instproc icursor} {0 -1}
{::Canvas instproc index} {0 -1}
{::Canvas instproc insert} {0 -1}
{::Canvas instproc itemcget} {0 -1}
{::Canvas instproc itemconfigure} {0 -1}
{::Canvas instproc lower} void
{::Canvas instproc move} {0 -1}
{::Canvas instproc postscript} {0 -1}
{::Canvas instproc raise} void
{::Canvas instproc scale} {0 -1}
{::Canvas instproc scan} {0 -1}
{::Canvas instproc select} {0 -1}
{::Canvas instproc type} {0 -1}
{::Canvas instproc xview} {0 -1}
{::Canvas instproc yview} {0 -1}
{::Checkbutton instproc cget} {{unknown {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -offrelief -offvalue -onvalue -overrelief -padx -pady -relief -selectcolor -selectimage -state -takefocus -text -textvariable -tristateimage -tristatevalue -underline -variable -width -wraplength}}}}
{::Checkbutton instproc configure} {list {void {{option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -offrelief unknown -offvalue unknown -onvalue unknown -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -selectimage unknown -state unknown -takefocus boolean -text string -textvariable {setgref string} -tristateimage unknown -tristatevalue unknown -underline int -variable unknown -width unknown -wraplength int}}} {list {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -offrelief -offvalue -onvalue -overrelief -padx -pady -relief -selectcolor -selectimage -state -takefocus -text -textvariable -tristateimage -tristatevalue -underline -variable -width -wraplength}}}}
{::Checkbutton instproc deselect} void
{::Checkbutton instproc flash} void
{::Checkbutton instproc invoke} void
{::Checkbutton instproc select} void
{::Checkbutton instproc toggle} void
{::Entry instproc bbox} {0 -1}
{::Entry instproc cget} {{unknown {{enum -background -bd -bg -borderwidth -cursor -disabledbackground -disabledforeground -exportselection -fg -font -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -invalidcommand -invcmd -justify -readonlybackground -relief -selectbackground -selectborderwidth -selectforeground -show -state -takefocus -textvariable -validate -validatecommand -vcmd -width -xscrollcommand}}}}
{::Entry instproc configure} {list {void {{option -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledbackground unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -highlightbackground color -highlightcolor color -highlightthickness pixel -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -invalidcommand unknown -invcmd unknown -justify {enum left center right} -readonlybackground unknown -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -show unknown -state unknown -takefocus boolean -textvariable {setgref string} -validate unknown -validatecommand unknown -vcmd unknown -width unknown -xscrollcommand script}}} {list {{enum -background -bd -bg -borderwidth -cursor -disabledbackground -disabledforeground -exportselection -fg -font -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -invalidcommand -invcmd -justify -readonlybackground -relief -selectbackground -selectborderwidth -selectforeground -show -state -takefocus -textvariable -validate -validatecommand -vcmd -width -xscrollcommand}}}}
{::Entry instproc delete} {{void string {? string}}}
{::Entry instproc get} string
{::Entry instproc icursor} {0 -1}
{::Entry instproc index} {{int string}}
{::Entry instproc insert} {{void string string}}
{::Entry instproc scan} {0 -1}
{::Entry instproc selection} {0 -1}
{::Entry instproc validate} void
{::Entry instproc xview} {0 -1}
{::Frame instproc cget} {{unknown {{enum -bd -borderwidth -class -relief -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
{::Frame instproc configure} {list {void {{option -bd pixel -borderwidth pixel -class unknown -relief {enum raised sunken flat ridge solid groove} -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}} {list {{enum -bd -borderwidth -class -relief -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
{::Label instproc cget} {{unknown {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -justify -padx -pady -relief -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Label instproc configure} {list {void {{option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -justify {enum left center right} -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -state unknown -takefocus boolean -text string -textvariable {setgref string} -underline int -width unknown -wraplength int}}} {list {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -justify -padx -pady -relief -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Labelframe instproc cget} {{unknown {{enum -bd -borderwidth -class -fg -font -foreground -labelanchor -labelwidget -relief -text -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
{::Labelframe instproc configure} {list {void {{option -bd pixel -borderwidth pixel -class unknown -fg color -font string -foreground color -labelanchor unknown -labelwidget unknown -relief {enum raised sunken flat ridge solid groove} -text string -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}} {list {{enum -bd -borderwidth -class -fg -font -foreground -labelanchor -labelwidget -relief -text -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
{::Listbox instproc activate} void
{::Listbox instproc bbox} {0 -1}
{::Listbox instproc cget} {{unknown {{enum -activestyle -background -bd -bg -borderwidth -cursor -disabledforeground -exportselection -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -relief -selectbackground -selectborderwidth -selectforeground -selectmode -setgrid -state -takefocus -width -xscrollcommand -yscrollcommand -listvariable}}}}
{::Listbox instproc configure} {list {void {{option -activestyle unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -selectmode unknown -setgrid boolean -state unknown -takefocus boolean -width unknown -xscrollcommand script -yscrollcommand script -listvariable unknown}}} {list {{enum -activestyle -background -bd -bg -borderwidth -cursor -disabledforeground -exportselection -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -relief -selectbackground -selectborderwidth -selectforeground -selectmode -setgrid -state -takefocus -width -xscrollcommand -yscrollcommand -listvariable}}}}
{::Listbox instproc curselection} {0 -1}
{::Listbox instproc delete} {0 -1}
{::Listbox instproc get} {0 -1}
{::Listbox instproc index} {0 -1}
{::Listbox instproc insert} {0 -1}
{::Listbox instproc itemcget} {0 -1}
{::Listbox instproc itemconfigure} {0 -1}
{::Listbox instproc nearest} {0 -1}
{::Listbox instproc scan} {0 -1}
{::Listbox instproc see} {0 -1}
{::Listbox instproc selection} {0 -1}
{::Listbox instproc size} {0 -1}
{::Listbox instproc xview} {0 -1}
{::Listbox instproc yview} {0 -1}
{::Menu instproc activate} {0 -1}
{::Menu instproc add} {0 -1}
{::Menu instproc cget} {{unknown {{enum -activebackground -activeborderwidth -activeforeground -background -bd -bg -borderwidth -cursor -disabledforeground -fg -font -foreground -postcommand -relief -selectcolor -takefocus -tearoff -tearoffcommand -title -type}}}}
{::Menu instproc clone} {0 -1}
{::Menu instproc configure} {list {void {{option -activebackground color -activeborderwidth pixel -activeforeground unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -disabledforeground color -fg color -font string -foreground color -postcommand unknown -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -takefocus boolean -tearoff unknown -tearoffcommand unknown -title unknown -type unknown}}} {list {{enum -activebackground -activeborderwidth -activeforeground -background -bd -bg -borderwidth -cursor -disabledforeground -fg -font -foreground -postcommand -relief -selectcolor -takefocus -tearoff -tearoffcommand -title -type}}}}
{::Menu instproc delete} {0 -1}
{::Menu instproc entrycget} {0 -1}
{::Menu instproc entryconfigure} {0 -1}
{::Menu instproc index} {0 -1}
{::Menu instproc insert} {0 -1}
{::Menu instproc invoke} {0 -1}
{::Menu instproc post} {0 -1}
{::Menu instproc postcascade} {0 -1}
{::Menu instproc type} {0 -1}
{::Menu instproc unpost} {0 -1}
{::Menu instproc xposition} {0 -1}
{::Menu instproc yposition} {0 -1}
{::Menubutton instproc cget} {{unknown {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -cursor -direction -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -menu -padx -pady -relief -compound -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Menubutton instproc configure} {list {void {{option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -cursor unknown -direction unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -menu unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -compound {enum none bottom top left right center} -state unknown -takefocus boolean -text string -textvariable {setgref string} -underline int -width unknown -wraplength int}}} {list {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -cursor -direction -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -menu -padx -pady -relief -compound -state -takefocus -text -textvariable -underline -width -wraplength}}}}
{::Message instproc cget} {{unknown {{enum -anchor -aspect -background -bd -bg -borderwidth -cursor -fg -font -foreground -highlightbackground -highlightcolor -highlightthickness -justify -padx -pady -relief -takefocus -text -textvariable -width}}}}
{::Message instproc configure} {list {void {{option -anchor {enum n ne e se s sw w nw center} -aspect unknown -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -fg color -font string -foreground color -highlightbackground color -highlightcolor color -highlightthickness pixel -justify {enum left center right} -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -takefocus boolean -text string -textvariable {setgref string} -width unknown}}} {list {{enum -anchor -aspect -background -bd -bg -borderwidth -cursor -fg -font -foreground -highlightbackground -highlightcolor -highlightthickness -justify -padx -pady -relief -takefocus -text -textvariable -width}}}}
{::Panedwindow instproc add} {0 -1}
{::Panedwindow instproc cget} {{unknown {{enum -background -bd -bg -borderwidth -cursor -handlepad -handlesize -height -opaqueresize -orient -relief -sashcursor -sashpad -sashrelief -sashwidth -showhandle -width}}}}
{::Panedwindow instproc configure} {list {void {{option -background color -bd pixel -bg color -borderwidth pixel -cursor unknown -handlepad unknown -handlesize unknown -height unknown -opaqueresize unknown -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -sashcursor unknown -sashpad unknown -sashrelief unknown -sashwidth unknown -showhandle unknown -width unknown}}} {list {{enum -background -bd -bg -borderwidth -cursor -handlepad -handlesize -height -opaqueresize -orient -relief -sashcursor -sashpad -sashrelief -sashwidth -showhandle -width}}}}
{::Panedwindow instproc forget} {0 -1}
{::Panedwindow instproc identify} {0 -1}
{::Panedwindow instproc panecget} {0 -1}
{::Panedwindow instproc paneconfigure} {0 -1}
{::Panedwindow instproc panes} {0 -1}
{::Panedwindow instproc proxy} {0 -1}
{::Panedwindow instproc sash} {0 -1}
{::Radiobutton instproc cget} {{unknown {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -offrelief -overrelief -padx -pady -relief -selectcolor -selectimage -state -takefocus -text -textvariable -tristateimage -tristatevalue -underline -value -variable -width -wraplength}}}}
{::Radiobutton instproc configure} {list {void {{option -activebackground color -activeforeground unknown -anchor {enum n ne e se s sw w nw center} -background color -bd pixel -bg color -bitmap unknown -borderwidth pixel -command script -compound {enum none bottom top left right center} -cursor unknown -disabledforeground color -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -image unknown -indicatoron unknown -justify {enum left center right} -offrelief unknown -overrelief unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectcolor unknown -selectimage unknown -state unknown -takefocus boolean -text string -textvariable {setgref string} -tristateimage unknown -tristatevalue unknown -underline int -value unknown -variable unknown -width unknown -wraplength int}}} {list {{enum -activebackground -activeforeground -anchor -background -bd -bg -bitmap -borderwidth -command -compound -cursor -disabledforeground -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -image -indicatoron -justify -offrelief -overrelief -padx -pady -relief -selectcolor -selectimage -state -takefocus -text -textvariable -tristateimage -tristatevalue -underline -value -variable -width -wraplength}}}}
{::Radiobutton instproc deselect} void
{::Radiobutton instproc flash} void
{::Radiobutton instproc invoke} void
{::Radiobutton instproc select} {0 -1}
{::Scale instproc cget} {{unknown {{enum -activebackground -background -bigincrement -bd -bg -borderwidth -command -cursor -digits -fg -font -foreground -from -highlightbackground -highlightcolor -highlightthickness -label -length -orient -relief -repeatdelay -repeatinterval -resolution -showvalue -sliderlength -sliderrelief -state -takefocus -tickinterval -to -troughcolor -variable -width}}}}
{::Scale instproc configure} {list {void {{option -activebackground color -background color -bigincrement unknown -bd pixel -bg color -borderwidth pixel -command script -cursor unknown -digits unknown -fg color -font string -foreground color -from unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -label unknown -length unknown -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -resolution unknown -showvalue unknown -sliderlength unknown -sliderrelief unknown -state unknown -takefocus boolean -tickinterval unknown -to unknown -troughcolor color -variable unknown -width unknown}}} {list {{enum -activebackground -background -bigincrement -bd -bg -borderwidth -command -cursor -digits -fg -font -foreground -from -highlightbackground -highlightcolor -highlightthickness -label -length -orient -relief -repeatdelay -repeatinterval -resolution -showvalue -sliderlength -sliderrelief -state -takefocus -tickinterval -to -troughcolor -variable -width}}}}
{::Scale instproc coords} {0 -1}
{::Scale instproc get} {0 -1}
{::Scale instproc identify} {0 -1}
{::Scale instproc set} {0 -1}
{::Scrollbar instproc activate} {0 -1}
{::Scrollbar instproc cget} {{unknown {{enum -activebackground -activerelief -background -bd -bg -borderwidth -command -cursor -elementborderwidth -highlightbackground -highlightcolor -highlightthickness -jump -orient -relief -repeatdelay -repeatinterval -takefocus -troughcolor -width}}}}
{::Scrollbar instproc configure} {list {void {{option -activebackground color -activerelief unknown -background color -bd pixel -bg color -borderwidth pixel -command script -cursor unknown -elementborderwidth unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -jump boolean -orient {enum horizontal vertical} -relief {enum raised sunken flat ridge solid groove} -repeatdelay int -repeatinterval int -takefocus boolean -troughcolor color -width unknown}}} {list {{enum -activebackground -activerelief -background -bd -bg -borderwidth -command -cursor -elementborderwidth -highlightbackground -highlightcolor -highlightthickness -jump -orient -relief -repeatdelay -repeatinterval -takefocus -troughcolor -width}}}}
{::Scrollbar instproc delta} {0 -1}
{::Scrollbar instproc fraction} {0 -1}
{::Scrollbar instproc get} {0 -1}
{::Scrollbar instproc identify} {0 -1}
{::Scrollbar instproc set} {0 -1}
{::Spinbox instproc bbox} {0 -1}
{::Spinbox instproc cget} {{unknown {{enum -activebackground -background -bd -bg -borderwidth -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief -command -cursor -disabledbackground -disabledforeground -exportselection -fg -font -foreground -format -from -highlightbackground -highlightcolor -highlightthickness -increment -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -invalidcommand -invcmd -justify -relief -readonlybackground -repeatdelay -repeatinterval -selectbackground -selectborderwidth -selectforeground -state -takefocus -textvariable -to -validate -validatecommand -values -vcmd -width -wrap -xscrollcommand}}}}
{::Spinbox instproc configure} {list {void {{option -activebackground color -background color -bd pixel -bg color -borderwidth pixel -buttonbackground unknown -buttoncursor unknown -buttondownrelief unknown -buttonuprelief unknown -command script -cursor unknown -disabledbackground unknown -disabledforeground color -exportselection boolean -fg color -font string -foreground color -format unknown -from unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -increment unknown -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -invalidcommand unknown -invcmd unknown -justify {enum left center right} -relief {enum raised sunken flat ridge solid groove} -readonlybackground unknown -repeatdelay int -repeatinterval int -selectbackground color -selectborderwidth pixel -selectforeground color -state unknown -takefocus boolean -textvariable {setgref string} -to unknown -validate unknown -validatecommand unknown -values unknown -vcmd unknown -width unknown -wrap unknown -xscrollcommand script}}} {list {{enum -activebackground -background -bd -bg -borderwidth -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief -command -cursor -disabledbackground -disabledforeground -exportselection -fg -font -foreground -format -from -highlightbackground -highlightcolor -highlightthickness -increment -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -invalidcommand -invcmd -justify -relief -readonlybackground -repeatdelay -repeatinterval -selectbackground -selectborderwidth -selectforeground -state -takefocus -textvariable -to -validate -validatecommand -values -vcmd -width -wrap -xscrollcommand}}}}
{::Spinbox instproc delete} {0 -1}
{::Spinbox instproc get} {0 -1}
{::Spinbox instproc icursor} {0 -1}
{::Spinbox instproc identify} {0 -1}
{::Spinbox instproc index} {0 -1}
{::Spinbox instproc insert} {0 -1}
{::Spinbox instproc invoke} {0 -1}
{::Spinbox instproc scan} {0 -1}
{::Spinbox instproc selection} {0 -1}
{::Spinbox instproc set} {0 -1}
{::Spinbox instproc validate} {0 -1}
{::Spinbox instproc xview} {0 -1}
{::Text instproc bbox} {0 -1}
{::Text instproc cget} {{unknown {{enum -autoseparators -background -bd -bg -blockcursor -borderwidth -cursor -endline -exportselection -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -inactiveselectbackground -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -maxundo -padx -pady -relief -selectbackground -selectborderwidth -selectforeground -setgrid -spacing1 -spacing2 -spacing3 -startline -state -tabs -tabstyle -takefocus -undo -width -wrap -xscrollcommand -yscrollcommand}}}}
{::Text instproc compare} {{boolean string {{enum < <= == >= > !=}} string}}
{::Text instproc configure} {list {void {{option -autoseparators unknown -background color -bd pixel -bg color -blockcursor unknown -borderwidth pixel -cursor unknown -endline unknown -exportselection boolean -fg color -font string -foreground color -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -inactiveselectbackground unknown -insertbackground color -insertborderwidth pixel -insertofftime int -insertontime int -insertwidth pixel -maxundo unknown -padx pixel -pady pixel -relief {enum raised sunken flat ridge solid groove} -selectbackground color -selectborderwidth pixel -selectforeground color -setgrid boolean -spacing1 unknown -spacing2 unknown -spacing3 unknown -startline unknown -state unknown -tabs unknown -tabstyle unknown -takefocus boolean -undo unknown -width unknown -wrap unknown -xscrollcommand script -yscrollcommand script}}} {list {{enum -autoseparators -background -bd -bg -blockcursor -borderwidth -cursor -endline -exportselection -fg -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -inactiveselectbackground -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -maxundo -padx -pady -relief -selectbackground -selectborderwidth -selectforeground -setgrid -spacing1 -spacing2 -spacing3 -startline -state -tabs -tabstyle -takefocus -undo -width -wrap -xscrollcommand -yscrollcommand}}}}
{::Text instproc count} {{int {? {option -chars {} -displaychars {} -displayindices {} -displaylines {} -indices {} -lines {} -xpixels {} -ypixels {}}} string string}}
{::Text instproc debug} {0 -1}
{::Text instproc delete} {0 -1}
{::Text instproc dlineinfo} {0 -1}
{::Text instproc dump} {0 -1}
{::Text instproc edit} {0 -1}
{::Text instproc get} {0 -1}
{::Text instproc image} {0 -1}
{::Text instproc index} {0 -1}
{::Text instproc insert} {0 -1}
{::Text instproc mark} {0 -1}
{::Text instproc peer} {0 -1}
{::Text instproc replace} {0 -1}
{::Text instproc scan} {0 -1}
{::Text instproc search} {0 -1}
{::Text instproc see} {0 -1}
{::Text instproc tag} {0 -1}
{::Text instproc window} {0 -1}
{::Text instproc xview} {0 -1}
{::Text instproc yview} {0 -1}
{::Toplevel instproc cget} {{unknown {{enum -bd -borderwidth -class -menu -relief -screen -use -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
{::Toplevel instproc configure} {list {void {{option -bd pixel -borderwidth pixel -class unknown -menu unknown -relief {enum raised sunken flat ridge solid groove} -screen unknown -use unknown -background color -bg color -colormap unknown -container unknown -cursor unknown -height unknown -highlightbackground color -highlightcolor color -highlightthickness pixel -padx pixel -pady pixel -takefocus boolean -visual unknown -width unknown}}} {list {{enum -bd -borderwidth -class -menu -relief -screen -use -background -bg -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -takefocus -visual -width}}}}
}
array set xotclObjectsArr {
::Button {Class ::widget {}}
::Canvas {Class ::widget {}}
::Checkbutton {Class ::widget {}}
::Entry {Class ::widget {}}
::Frame {Class ::widget {}}
::Label {Class ::widget {}}
::Labelframe {Class ::widget {}}
::Listbox {Class ::widget {}}
::Menu {Class ::widget {}}
::Menubutton {Class ::widget {}}
::Message {Class ::widget {}}
::Panedwindow {Class ::widget {}}
::Radiobutton {Class ::widget {}}
::Scale {Class ::widget {}}
::Scrollbar {Class ::widget {}}
::Spinbox {Class ::widget {}}
::Text {Class ::widget {}}
::Toplevel {Class ::widget {}}
}
my registerObject ::. ::Toplevel {} {}
my registerTTkProcs
}
CoreSignatureRepository instproc registerXotclCoreMethods {} {
my instvar methodsArr commandsArr
array set methodsArr {
{::xotcl::Class instproc allinstances} {{{{list xotcl} {}}}}
{::xotcl::Class instproc alloc} {{{xotcl {}} {string {}}}}
{::xotcl::Class instproc create} {{{xotcl {}} {string {}} {* unknown}}}
{::xotcl::Class instproc info} {
{{{list xotcl} {}} {{const classchildren}} {? string {}}}
{{xotcl {}} {{const classparent}}}
{{{list xotcl} {}} {{const heritage}} {? string {}}}
{{{list xotcl} {}} {{const instances}} {? {option -closure {}}} {? string {}}}
{{list {}} {{const instargs}} {string {}}}
{{body {}} {{const instbody}} {string {}}}
{{list {}} {{const instcommands}} {string {}}}
{{string {}} {{const instdefault}} {string {}} {string {}} {wref {}}}
{{{list xotcl} {}} {{const instfilter}}}
{{xotcl {}} {{const instfilterguard}} {string {}}}
{{list {}} {{const instforward}} {? {option -definition string}} {string {}}}
{{unknown {}} {{const instinvar}}}
{{{list xotcl} {}} {{const instmixin}} {string {}}}
{{{list xotcl} {}} {{const instmixinof}} {? {option -closure {}}} {? string}}
{{list {}} {{const instnonposargs}} {string {}}}
{{body {}} {{const instpost}} {string {}}}
{{body {}} {{const instpre}} {string {}}}
{{list {}} {{const instprocs}} {string {}}}
{{{list xotcl} {}} {{const mixinof}} {? {option -closure {}}} {? string pattern}}
{{list {}} {{const parameter}}}
{{{list xotcl} {}} {{const subclass}} {? {option -closure {}}} {? string pattern}}
{{{list xotcl} {}} {{const superclass}} {? {option -closure {}}} {? string pattern}}
{{list {}} {{const args}} {string {}}}
{{string {}} {{const body}} {string {}}}
{{xotcl {}} {{const class}}}
{{{list xotcl} {}} {{const children}} {string {}}}
{{list {}} {{const commands}} {string {}}}
{{string {}} {{const default}} {string {}} {string {}} {wref {}}}
{{list {}} {{const filter}} {? {option -guard {} -order {}}}}
{{xotcl {}} {{const filterguard}} {string {}}}
{{{list xotcl} {}} {{const forwards}} {? {option -definition string}} {string {}}}
{{boolean {}} {{const hasNamespace}}}
{{list {}} {{const info}} {string {}}}
{{string {}} {{const invar}}}
{{{list string} {}} {{const methods}} {? {option -nocmds {} -noprocs {} -nomixins {}}} {string {}}}
{{list {}} {{const mixin}} {? {option -guard {} -order {}}} {string {}}}
{{{list string} {}} {{const nonposargs}} {string {}}}
{{{list string} {}} {{const parametercmd}} {string {}}}
{xotcl {{const parent}}}
{{string {}} {{const post}} {string {}}}
{{string {}} {{const pre}} {string {}}}
{{{list string} {}} {{const procs}} {string {}}}
{{{list xotcl} {}} {{const precedence}} {? {option -intrisic {}}} {string {}}}
{{{list string} {}} {{const vars}} {string {}}}
}
{::xotcl::Class instproc instdestroy} {{{void {}}}}
{::xotcl::Class instproc instfilter} {{{void {}}}}
{::xotcl::Class instproc instfilterguard} {{{void {}}}}
{::xotcl::Class instproc instforward} {{{void {}}}}
{::xotcl::Class instproc instinvar} {{{void {}}}}
{::xotcl::Class instproc instmixin} {{{void {}}}}
{::xotcl::Class instproc instparametercmd} {{{void {}} {string {}}}}
{::xotcl::Class instproc instproc} {{{void {}} string {+ unknown}}}
{::xotcl::Class instproc new} {{{xotcl {}} {* unknown}}}
{::xotcl::Class instproc parameter} {{{void {}} {list {}}}}
{::xotcl::Class instproc parameterclass} {{{void {}} {xotcl {}}}}
{::xotcl::Class instproc recreate} {{{void {}} {xotcl {}} {* unknown}}}
{::xotcl::Class instproc superclass} {{{void {}} {{list xotcl} {}}}}
{::xotcl::Object instproc append} {{{string {}} {{ref string} {}} {string {}}}}
{::xotcl::Object instproc array} {
{boolean {{const anymore}} string searchid}
{void {{const donesearch}} string searchid}
{boolean {{const exists}} string}
{list {{const get}} string {? string pattern}}
{list {{const names}} string {? enum -glob -regexp -exact} {? string pattern}}
{string {{const nextelement}} {{ref array}} searchid}
{void {{const set}} string list}
{{int {}} {{const size}} string}
{searchid {{const startsearch}} string}
{void {{const unset}} string {? string pattern}}
{unknown {{const statistics}} string}
}
{::xotcl::Object instproc autoname} {{{string {}} {string {}}}}
{::xotcl::Object instproc check} {1 1}
{::xotcl::Object instproc class} {{{void {}} {xotcl {}} {* unknown}}}
{::xotcl::Object instproc cleanup} {{{void {}}}}
{::xotcl::Object instproc configure} {{{void {}} {* unknown}}}
{::xotcl::Object instproc contains} {{{void {}} {? {option -withnew {} -object {xotcl} -class {xotcl}}} {body {}}}}
{::xotcl::Object instproc copy} {{{void {}} {string {}}}}
{::xotcl::Object instproc destroy} {{{void {}}}}
{::xotcl::Object instproc eval} {1 -1}
{::xotcl::Object instproc exists} {{boolean string}}
{::xotcl::Object instproc extractConfigureArg} {2 3}
{::xotcl::Object instproc filter} {0 -1}
{::xotcl::Object instproc filterguard} {2 2}
{::xotcl::Object instproc filtersearch} {1 1}
{::xotcl::Object instproc forward} {0 -1}
{::xotcl::Object instproc getExitHandler} {{{void {}}}}
{::xotcl::Object instproc hasclass} {{{boolean {}} {string {}}}}
{::xotcl::Object instproc incr} {{{int {}} {unknown {}} {int {}}}}
{::xotcl::Object instproc info} {
{{list {}} {{const args}} {string {}}}
{{string {}} {{const body}} {string {}}}
{{xotcl {}} {{const class}} {? string {}}}
{{{list xotcl} {}} {{const children}} {? string {}}}
{{list {}} {{const commands}} {? string {}}}
{{string {}} {{const default}} {string {}} {string {}} {wref {}}}
{{list {}} {{const filter}} {? {option -guard {} -order {}}}}
{{xotcl {}} {{const filterguard}} {string {}}}
{{{list xotcl} {}} {{const forwards}} {? {option -definition string}} {string {}}}
{{boolean {}} {{const hasNamespace}}}
{{list {}} {{const info}} {string {}}}
{{string {}} {{const invar}}}
{{{list string} {}} {{const methods}} {? {option -nocmds {} -noprocs {} -nomixins {}}} {? string {}}}
{{list {}} {{const mixin}} {? {option -guard {} -order {}}} {string {}}}
{{{list string} {}} {{const nonposargs}} {string {}}}
{{{list string} {}} {{const parametercmd}} {string {}}}
{xotcl {{const parent}}}
{{string {}} {{const post}} {string {}}}
{{string {}} {{const pre}} {string {}}}
{{{list string} {}} {{const procs}} {? string {}}}
{{{list xotcl} {}} {{const precedence}} {? {option -intrisic {}}} {? string {}}}
{{{list string} {}} {{const vars}} {? string {}}}
}
{::xotcl::Object instproc instvar} {{{void {}} {+ unknown}}}
{::xotcl::Object instproc insvar} {{{void {}} {+ unknown}}}
{::xotcl::Object instproc isclass} {{{boolean {}} {unknown {}}}}
{::xotcl::Object instproc ismetaclass} {{{boolean {}} {unknown {}}}}
{::xotcl::Object instproc ismixin} {{{boolean {}} {string {}}}}
{::xotcl::Object instproc isobject} {{{boolean {}} {unknown {}}}}
{::xotcl::Object instproc istype} {{{boolean {}} {xotcl {}}}}
{::xotcl::Object instproc lappend} {{{list {}} {{setref list} {}} {+ unknown}}}
{::xotcl::Object instproc mixin} {0 -1}
{::xotcl::Object instproc move} {{{void {}} {string {}}}}
{::xotcl::Object instproc noinit} {{{void {}}}}
{::xotcl::Object instproc parametercmd} {{{void {}}}}
{::xotcl::Object instproc proc} {{{void {}} {string {proc name}} {* unknown}}}
{::xotcl::Object instproc procsearch} {{{list {}} {string {}}}}
{::xotcl::Object instproc requireNamespace} {{{void {}}}}
{::xotcl::Object instproc self} {0 -1}
{::xotcl::Object instproc set} {{{unknown {}} {{wref unknown} {}} {? unknown}}}
{::xotcl::Object instproc setExitHandler} {{{void {}} {body {}}}}
{::xotcl::Object instproc subst} {{{string {}} {string {}}}}
{::xotcl::Object instproc trace} {
{unknown {{const variable}} unknown unknown unknown {? unknown} {? unknown} {? unknown}}
{unknown {{const vdelete}} unknown unknown unknown {? unknown} {? unknown} {? unknown}}
{unknown {{const vinfo}} unknown {? unknown}}
{unknown {{const add}} unknown unknown unknown unknown {? unknown} {? unknown} {? unknown} {? unknown} {? unknown}}
{unknown {{const remove}} unknown unknown unknown unknown unknown {? unknown} {? unknown} {? unknown} {? unknown} {? unknown}}
{unknown {{const info}} unknown unknown unknown {? unknown} {? unknown} {? unknown}}
}
{::xotcl::Object instproc unset} {1 -1}
{::xotcl::Object instproc uplevel} {1 -1}
{::xotcl::Object instproc upvar} {2 -1}
{::xotcl::Object instproc volatile} {{{void {}}}}
{::xotcl::Object instproc vwait} {1 1}
}
my registerObject ::xotcl::Class Class ::xotcl::Object {}
my registerObject ::xotcl::Object Class {} {}
my registerObject ::xotcl::Attribute Class ::xotcl::Object {}
array set commandsArr {
::xotcl::my {0 -1}
::xotcl::self {0 -1}
::xotcl::next {0 -1}
::xotcl::myproc {0 -1}
::xotcl::myvar {0 -1}
::xotcl::@ {0 -1}
}
my addNamespaceExport ::xotcl {Object Class self next my @ myproc myvar Attribute}
my addNamespaceImport {} ::xotcl::*
}
Class FileSignatureRepository -superclass ::SignatureRepository
@ FileSignatureRepository idemeta component IDETclParser
Class IntroRepoBuilder
@ IntroRepoBuilder idemeta component IDETclParser
IntroRepoBuilder instproc buildWidget widget {
my instvar optTypes commandsArr methodsArr xotclObjectsArr
lassign [my getWidgetOptionsCommands $widget] options methods
if {[namespace qualifiers $widget] ne ""} {
set widgetClass ::[namespace qualifiers $widget]::[string toupper [namespace tail $widget] 0 0]
} else {
set widgetClass ::[string toupper $widget 0 0]
}
set optionsDesc [list]
foreach opt $options {
if {[catch {set optTypes($opt)} type]} {
set type unknown
}
lappend optionsDesc $opt $type
}
lappend command [list [list [list tk $widgetClass]] [list [list new tk $widgetClass] $widget] [list ? [concat option $optionsDesc]]]
set commandsArr(::$widget) $command
set xotclObjectsArr($widgetClass) [list Class ::widget {}]
set methodsArr([list $widgetClass instproc cget]) [list [list unknown [list [concat enum $options]]]]
lappend confMethod [list list]
lappend confMethod [list void [list [concat option $optionsDesc]]]
lappend confMethod [list list [list [concat enum $options]]]
set methodsArr([list $widgetClass instproc configure]) $confMethod
foreach m $methods {
if {$m ni {cget configure}} {
set methodsArr([list $widgetClass instproc $m]) {0 -1}
}
}
}
IntroRepoBuilder instproc buildWidgetOptions widget {
my instvar coreRepo
set tkwidget .twidget
$widget $tkwidget;
set options [list]
foreach l [$tkwidget configure] {
lappend options [lindex $l 0]
}
destroy $tkwidget
return $options
}
IntroRepoBuilder instproc createTTkRepo {} {
set widgets {ttk::separator ttk::sizegrip ttk::checkbutton ttk::combobox ttk::entry ttk::treeview ttk::frame ttk::labelframe ttk::menubutton ttk::notebook ttk::panedwindow ttk::progressbar ttk::radiobutton ttk::scale ttk::scrollbar ttk::label ttk::button}
foreach w $widgets {
my buildWidget $w
}
}
IntroRepoBuilder instproc createTkRepo {} {
set widgets {button checkbutton radiobutton menubutton label frame labelframe message menu scale scrollbar listbox entry spinbox text canvas frame toplevel panedwindow}
foreach w $widgets {
my buildWidget $w
}
}
IntroRepoBuilder instproc dumpRepo {} {
my instvar commandsArr methodsArr xotclObjectsArr
set ret "array set commandsArr {\n"
foreach c [lsort [array names commandsArr]] {
set sdesc $commandsArr($c)
if {[llength $sdesc]>1} {
append ret [list $c] " \{\n \{"
append ret [join $sdesc "\}\n \{"]
append ret "\}\n\}\n"
} else {
append ret [list $c] " " [list $sdesc] \n
}
}
append ret "\n}\n"
append ret "array set methodsArr {\n"
foreach c [lsort [array names methodsArr]] {
set sdesc $methodsArr($c)
if {[llength $sdesc]>1 && [llength [lindex $sdesc 0]]>1} {
append ret [list $c] " \{\n \{"
append ret [join $sdesc "\}\n \{"]
append ret "\}\n\}\n"
} else {
append ret [list $c] " " [list $sdesc] \n
}
}
append ret "\n}\n"
append ret "array set xotclObjectsArr {\n"
foreach c [lsort [array names xotclObjectsArr]] {
set sdesc $xotclObjectsArr($c)
append ret [list $c] " " [list $sdesc] \n
}
append ret "\n}\n"
return $ret
}
IntroRepoBuilder instproc getMethodsForObject widget {
set commands [list]
if {[catch {$widget nocommand} error]} {
if {[regexp {must be (.+) or (.+)} $error _ m1 m2]} {
set m1 [string map [list , ""] $m1]
foreach m $m1 {
lappend commands $m
}
lappend commands $m2
}
}
return $commands
}
IntroRepoBuilder instproc getWidgetOptionsCommands widget {
my instvar coreRepo
set tkwidget .twidget
$widget $tkwidget;
set options [list]
foreach l [$tkwidget configure] {
lappend options [lindex $l 0]
}
set methods [my getMethodsForObject $tkwidget]
destroy $tkwidget
return [list $options $methods]
}
IntroRepoBuilder instproc init {} {
my instvar optTypes
array set optTypes {
-command script
-text string
-underline int
-activebackground color
-activeborderwidth pixel
-anchor {enum n ne e se s sw w nw center}
-background color
-bg color
-bitmap unknown
-borderwidth pixel
-bd pixel
-cursor unknown
-compound {enum none bottom top left right center}
-disabledforeground color
-exportselection boolean
-font string
-foreground color
-fg color
-highlightbackground color
-highlightcolor color
-highlightthickness pixel
-image unknown
-insertbackground color
-insertborderwidth pixel
-insertofftime int
-insertontime int
-insertwidth pixel
-jump boolean
-justify {enum left center right}
-orient {enum horizontal vertical}
-padx pixel
-pady pixel
-relief {enum raised sunken flat ridge solid groove}
-repeatdelay int
-repeatinterval int
-selectbackground color
-selectborderwidth pixel
-selectforeground color
-setgrid boolean
-takefocus boolean
-text string
-textvariable {setgref string}
-troughcolor color
-wraplength int
-xscrollcommand script
-yscrollcommand script
}
}
IntroRepoBuilder instproc purge {} {
my instvar commandsArr methodsArr xotclObjectsArr
unset commandsArr methodsArr xotclObjectsArr
}
Class IntroSignatureRepository -superclass ::SignatureRepository
@ IntroSignatureRepository idemeta component IDETclParser
IntroSignatureRepository instproc getClassParameters class {
if {[Object isclass $class]} {
$class info parameter
} else {
return
}
}
IntroSignatureRepository instproc getClassSuperclassesFromFullName fullName {
if {[Object isclass $fullName]} {
return [$fullName info superclass]
} else {
return
}
}
IntroSignatureRepository instproc getCommandDescription {name {namespace {}}} {
if {[set desc [my getCommandDescriptionBase $name $namespace]] ne ""} {
return $desc
} elseif {[llength [info procs $name]]>0} {
return [my getProcDescFromIntro $name]
} else {
if {$namespace ne ""} {
set oname [namespace eval $namespace [list namespace which -command $name]]
if {[llength [info procs $oname]]>0} {
return [my getProcDescFromIntro $oname]
}
}
}
if {[llength [info commands $name]]>0} {
return [list $name 0 -1]
}
}
IntroSignatureRepository instproc getFullHeritage {class {namespace {}}} {
set fullCl [my getFullObjectName $class $namespace]
if {[Object isobject $fullCl]} {
return [concat $fullCl [$fullCl info heritage]]
} else {
return [list $fullCl]
}
}
IntroSignatureRepository instproc getFullObjectName {object {namespace {}}} {
if {[Object isobject $object]} {
return [$object]
} else {
return $object
}
}
IntroSignatureRepository instproc getMethodDescFromIntro {object type method} {
if {$type eq "inst"} {
if {[llength [$object info instprocs $method]]==0} {
return
}
} else {
if {[llength [$object info procs $method]]==0} {
return
}
}
set argList [$object info ${type}args $method]
set types [list unknown]
foreach a $argList {
if {$a eq "args"} {
lappend types [list * unknown $a]
} elseif {[$object info ${type}default $method $a var]} {
lappend types [list ? unknown $a]
} else {
lappend types [list unknown $a]
}
}
list {} $types
}
IntroSignatureRepository instproc getProcDescFromIntro procName {
set argList [info args $procName]
set types [list unknown]
foreach a $argList {
if {$a eq "args"} {
lappend types [list * unknown $a]
} elseif {[info default $procName $a var]} {
lappend types [list ? unknown $a]
} else {
lappend types [list unknown $a]
}
}
list $procName $types
}
IntroSignatureRepository instproc getXotclClassForObject {object {namespace {}}} {
$object info class
}
IntroSignatureRepository instproc isXotclClass {name {namespace {}}} {
Object isclass $name
}
IntroSignatureRepository instproc isXotclMetaClass {name {namespace {}}} {
Object ismetaclass $name
}
IntroSignatureRepository instproc isXotclObject {name {namespace {}}} {
Object isobject $name
}
Class PrsElement -parameter {begin end}
@ PrsElement idemeta component IDETclParser
PrsElement instproc basicEvalContents {} {
my set operation eval
set parser [my getParser]
set stream [$parser stream]
set opos [$stream pos]
set olastpos [$stream lastpos]
set offset [my getContentOffset]
$stream pos [expr {[my begin]+$offset}]
$stream lastpos [expr {[my end]-$offset}]
$parser parseScriptTo [self]
$stream pos $opos
$stream lastpos $olastpos
}
PrsElement instproc basicEvalExpr {context notifier} {
my set operation substitute
set parser [my getParser]
set stream [$parser stream]
set opos [$stream pos]
set olastpos [$stream lastpos]
set offset [my getContentOffset]
$stream pos [expr {[my begin]+$offset}]
$stream lastpos [expr {[my end]-$offset}]
$parser parseExprTo [self] $context $notifier
$stream pos $opos
$stream lastpos $olastpos
}
PrsElement instproc basicExtractList {} {
set parser [my getParser]
set stream [$parser stream]
set opos [$stream pos]
set olastpos [$stream lastpos]
set offset [my getContentOffset]
$stream pos [expr {[my begin]+$offset}]
$stream lastpos [expr {[my end]-$offset}]
$parser extractListTo [self]
$stream pos $opos
$stream lastpos $olastpos
}
PrsElement instproc basicParseAsVariableRef {} {
my set operation eval
set parser [my getParser]
set stream [$parser stream]
set opos [$stream pos]
set olastpos [$stream lastpos]
$stream pos [my begin]
$stream lastpos [my end]
$parser parseVariableRef [self]
$stream pos $opos
$stream lastpos $olastpos
my class PrsVariableRef
}
PrsElement instproc basicSubstituteContents {} {
my set operation substitute
set parser [my getParser]
set stream [$parser stream]
set opos [$stream pos]
set olastpos [$stream lastpos]
set offset [my getContentOffset]
$stream pos [expr {[my begin]+$offset}]
$stream lastpos [expr {[my end]-$offset}]
$parser substituteTo [self]
$stream pos $opos
$stream lastpos $olastpos
}
PrsElement instproc canAssignType {context type} {
$context canAssignType $type [my getType]
}
PrsElement instproc checkAsList {context notifier} {
next
}
PrsElement instproc checkAsType {rtype context notifier} {
set mtype [my getTypeWithContext $context $rtype]
if {[$context canAssignType $rtype $mtype]} {
return 1
}
set rtypeName [lindex $rtype 0]
if {$rtypeName in {ref setref wref gref setgref}} {
my parseAsVariableRef
return [my checkRefAsType $rtype $context $notifier]
} else {
if {[lindex $mtype 0] eq "array"} {
$notifier addError "can not use array as $rtypeName" [self]
} else {
$notifier addError "possibly error expect as '[join $rtype]' but is '[join $mtype]'" [self]
}
return 0
}
}
PrsElement instproc checkRefAsType {rtype context notifier} {
return 1
}
PrsElement instproc checkSyntax {context notifier} {
next
}
PrsElement instproc evalContents {} {
}
PrsElement instproc evalExpr {context notifier} {
}
PrsElement instproc extractList {} {
next
}
PrsElement instproc getAsList {} {
if {[my exists list] && [llength [my set list]]>0} {
return [my set list]
} else {
set content [my prsContentString]
if {$content ne ""} {
return [list [self]]
} else {
return [list]
}
}
}
PrsElement instproc getContentOffset {} {
return 0
}
PrsElement instproc getParser {} {
set i [self]
while {[Object isobject $i] && ![$i hasclass TclParser]} {
set i [$i info parent]
}
return $i
}
PrsElement instproc getType {{sugestedType {}}} {
my instvar type
if {[info exists type]} {
return $type
} else {
return [list unknown]
}
}
PrsElement instproc getTypeWithContext {context {sugestedType {}}} {
my getType $sugestedType
}
PrsElement instproc isLiteral literal {
return 0
}
PrsElement instproc parseAsVariableRef {} {
}
PrsElement instproc printString {} {
if {[my exists begin] && [my exists end]} {
return "[my info class] ([my begin],[my end]) [[[my getParser] stream] copyFromTo [my begin] [my end]]"
}
next
}
PrsElement instproc prsContentString {} {
set offset [my getContentOffset]
[[my getParser] stream] copyFromTo [expr {[my begin]+$offset}] [expr {[my end]-$offset}]
}
PrsElement instproc prsString {} {
[[my getParser] stream] copyFromTo [my begin] [my end]
}
PrsElement instproc prsStringToLineEnd {} {
[[my getParser] stream] copyFromToLineEnd [my begin]
}
PrsElement instproc setType type {
my set type $type
}
PrsElement instproc substituteContents {} {
}
PrsElement instproc visit visitor {
next
$visitor visit [self]
}
PrsElement instproc visitPost visitor {
next
$visitor visitPost [self]
}
PrsElement instproc wasSubstituted {} {
my instvar operation
expr {[info exists operation] && $operation eq "substitute"}
}
Class PrsElementList -superclass ::PrsElement -parameter list
@ PrsElementList idemeta component IDETclParser
PrsElementList instproc addElem elem {
my lappend list $elem
}
PrsElementList instproc getElem index {
lindex [my list] $index
}
PrsElementList instproc getListLength {} {
llength [my list]
}
PrsElementList instproc hasList {} {
my exists list
}
PrsElementList instproc visit visitor {
if {[my exists list]} {
foreach elem [my list] {
$elem visit $visitor
}
}
$visitor visit [self]
}
PrsElementList instproc visitPost visitor {
if {[my exists list]} {
foreach elem [my list] {
$elem visitPost $visitor
}
}
$visitor visitPost [self]
}
Class PrsArgumentExpansion -superclass ::PrsElementList
@ PrsArgumentExpansion idemeta component IDETclParser
Class PrsArgumentMatcher -parameter context
@ PrsArgumentMatcher idemeta component IDETclParser
PrsArgumentMatcher instproc applyTypes {arguments types notifier descsAll} {
my instvar context
set realTypes [list]
set allOk 1
foreach elem $arguments typeIndex $types {
lassign $typeIndex type index
set type0 [lindex $type 0]
if {$type0 ne "_"} {
if {$type0 eq "new"} {
if {[$elem hasclass PrsLiteral]} {
set name [$elem prsString]
[$context set repository] registerObject $name [lindex $type 2] {} {}
} elseif {[$elem hasclass PrsVariable]} {
set type [lrange $type 1 end]
if {[$elem isArray]} {
set type [linsert $type 0 array]
}
$context checkVariableType [$elem getVariableName] $type 1
}
} else {
if {[$elem checkAsType $type $context $notifier]} {
lappend realTypes [list [$context getTypeFromElem $elem] $index]
} else {
if {$type0 ni {xotcl class tk}} {
set allOk 0
} else {
lappend realTypes [list [$context getTypeFromElem $elem] $index]
}
}
}
} else {
lappend realTypes [list unknown $index]
}
}
if {$allOk && [llength $realTypes]>0} {
[$context set repository] updateSignatureTypes $descsAll $realTypes
}
}
PrsArgumentMatcher instproc checkType {parameters typeIndex} {
my instvar fullName
lassign $typeIndex type index
if {[llength $type]>1 && [lindex $type 0] eq "option"} {
set shift 0
set parLen [llength $parameters]
set types [list]
for {set shift 0} {$shift<$parLen} {incr shift} {
set found 0
set elem [lindex $parameters $shift]
foreach {optName optType} [lrange $type 1 end] {
if {[$elem isLiteral $optName]} {
set found 1
if {$optType ne ""} {
incr shift
if {$shift<$parLen} {
lappend types _
set elem [lindex $parameters $shift]
lappend types [list $optType $index]
} else {
my parseError $elem "expect option parameter for $type: $fullName"
}
} else {
lappend types _
}
}
}
if {!$found} {
break
}
}
return $types
} else {
my checkTypeBase [lindex $parameters 0] $typeIndex
}
}
PrsArgumentMatcher instproc checkTypeBase {elem typeIndex} {
my instvar context fullName subcommands
lassign $typeIndex type index
set type0 [lindex $type 0]
if {$type0 in {unknown def}} {
return [list $typeIndex]
}
if {[llength $type]>1} {
set otype $type0
if {$otype eq "const"} {
if {[$elem isLiteral [lindex $type 1]] || [my isUniqueSubcommand [$elem prsString] [lindex $type 1]]} {
return _
} else {
my parseError $elem "unmatched const [lindex $type 1] expect one of [join $subcommands ,]: $fullName"
}
} elseif {$otype eq "enum"} {
if {[$elem hasclass PrsLiteral]} {
if {[$elem prsString] in [lrange $type 1 end]} {
return _
} else {
my parseError $elem "unmatched enums: [join [lrange $type 1 end] ,]: $fullName"
}
}
} elseif {$otype in {wref setref ref gref setgref}} {
if {[$elem hasclass PrsLiteral] || [$elem hasclass PrsQuoted]} {
return [list $typeIndex]
}
} elseif {$otype in {xotcl class tk}} {
return [list $typeIndex]
}
}
if {$type0 in {wref setref ref gref setgref}} {
if {[$elem hasclass PrsLiteral] || [$elem hasclass PrsQuoted] || [$elem hasclass PrsVariableRef]} {
return [list $typeIndex]
}
return [list $typeIndex]
}
if {[$elem canAssignType $context $type]} {
return [list $typeIndex]
}
if {$type eq "setref"} {
}
my parseError $elem "unmatched type '$type': $fullName"
}
PrsArgumentMatcher instproc getArgDesc argDesc {
set type unknown
set mult {}
set typeindex 0
if {[lindex $argDesc 0] in {* ? +}} {
set mult [lindex $argDesc 0]
set typeindex 1
}
if {[llength $argDesc]>=$typeindex+1} {
set type [lindex $argDesc $typeindex]
}
list $mult $type
}
PrsArgumentMatcher instproc initSubcommands descs {
my instvar subcommands
set subcommands [list]
if {[llength $descs]<=1} {
return
}
foreach desc $descs {
if {[lindex $desc 1 0 0] eq "const"} {
lappend subcommands [lindex $desc 1 0 1]
}
}
}
PrsArgumentMatcher instproc isUniqueSubcommand {subname targetSubCommand} {
my instvar subcommands
if {[llength $subcommands]==0} {
return 0
}
set sublen [string length $subname]
incr sublen -1
set matchedSubcommand ""
foreach subcommand $subcommands {
if {[string range $subcommand 0 $sublen] eq $subname && $subcommand eq $targetSubCommand} {
if {$matchedSubcommand ne "" && $matchedSubcommand ne $subcommand} {
return 0
} else {
set matchedSubcommand $subcommand
}
}
}
expr {$matchedSubcommand ne ""}
}
PrsArgumentMatcher instproc parseCommand {command notifier startArg descsAll} {
my instvar parseErrors context fullName
set parseErrors [list]
set descs [lrange $descsAll 1 end]
set fullName [lindex $descsAll 0]
if {[ttype::isSimpleDesc $descs]} {
set count [expr {[$command argsCount]+1-$startArg}]
lassign $descs min max
if {$count<$min || ($max!=-1 && $count>$max)} {
$notifier addError "false argument count $count ($min,$max): $fullName" [$command getElem [expr {$startArg-1}]]
return 0
}
return 1
}
set arguments [lrange [$command set list] $startArg end]
foreach a $arguments {
if {[$a hasclass PrsArgumentExpansion]} {
return 1
}
}
my initSubcommands $descs
foreach desc $descs {
if {![catch {my parseCommandTypes $arguments [lrange [my prepareDesc $desc] 1 end]} types options]} {
my applyTypes $arguments $types $notifier $descsAll
[$command getElem [expr {$startArg-1}]] set desc $desc
$command setType [lindex $desc 0 0]
return 1
} else {
}
}
if {![info exists parseErrors]} {
return -options $options $types
}
set maxargs -1
set i 0
set maxargIndex -1
foreach err $parseErrors {
lassign $err parseErrorElem parseErrorMessage
if {$parseErrorElem eq ""} {
set argindex 0
} else {
set argindex [lsearch $arguments $parseErrorElem]
}
if {$argindex>$maxargs} {
set maxargs $argindex
set maxargIndex $i
}
incr i
}
lassign [lindex $parseErrors $maxargIndex] parseErrorElem parseErrorMessage
if {$parseErrorElem eq ""} {
set parseErrorElem [$command getElem [expr {$startArg-1}]]
}
$notifier addError $parseErrorMessage $parseErrorElem
return 0
}
PrsArgumentMatcher instproc parseCommandTypes {parameters argDescs} {
my instvar fullName
set parLen [llength $parameters]
set argDescLen [llength $argDescs]
if {$argDescLen == 0 && $parLen == 0} {
return
}
if {$argDescLen==0} {
my parseError [lindex $parameters 0] "unexpected parameter: $fullName"
}
lassign [lindex $argDescs 0] mult type index
set type [list $type $index]
switch -exact -- $mult {
* {
if {$parLen==0} {
return
}
set alltypes [list]
for {set i 0} {$i<$parLen} {incr i} {
if {![catch {my checkType [lrange $parameters $i end] $type} ptypes]} {
lappend alltypes {*}$ptypes
if {![catch {my parseCommandTypes [lrange $parameters [llength $alltypes] end] [lrange $argDescs 1 end]} ptypes2]} {
return [concat $alltypes $ptypes2]
}
}
}
return [my parseCommandTypes [lrange $parameters [llength $alltypes] end] [lrange $argDescs 1 end]]
}
? {
if {$parLen==0} {
return [my parseCommandTypes $parameters [lrange $argDescs 1 end]]
}
if {![catch {my checkType $parameters $type} ptypes]} {
if {![catch {my parseCommandTypes [lrange $parameters [llength $ptypes] end] [lrange $argDescs 1 end]} ptypes2]} {
return [concat $ptypes $ptypes2]
}
}
return [my parseCommandTypes $parameters [lrange $argDescs 1 end]]
}
+ {
if {$parLen==0} {
my parseError {} "expect argument for type $type: $fullName"
}
set alltypes [list]
for {set i 0} {$i<$parLen} {incr i} {
if {![catch {my checkType [lrange $parameters $i end] $type} ptypes]} {
lappend alltypes {*}$ptypes
if {![catch {my parseCommandTypes [lrange $parameters [llength $alltypes] end] [lrange $argDescs 1 end]} ptypes2]} {
return [concat $alltypes $ptypes2]
}
}
}
my parseError [lindex $parameters 0] "unmatched type '$type': $fullName"
}
default {
if {$parLen==0} {
my parseError {} "expect argument for type $type: $fullName"
}
set ptypes [my checkType $parameters $type]
set typcount [llength $ptypes]
return [concat $ptypes [my parseCommandTypes [lrange $parameters $typcount end] [lrange $argDescs 1 end]]]
}
}
my parseError {} "unmatched: $fullName"
}
PrsArgumentMatcher instproc parseError {elem message} {
my instvar parseErrors
lappend parseErrors [list $elem $message]
error "$message"
}
PrsArgumentMatcher instproc prepareDesc desc {
set udesc [list]
set index 0
foreach a $desc {
lassign [my getArgDesc $a] mult type
lappend udesc [list $mult $type $index]
incr index
}
return $udesc
}
Class PrsCommand -superclass ::PrsElementList
@ PrsCommand idemeta component IDETclParser
PrsCommand instproc argsCount {} {
expr {[llength [my list]]-1}
}
PrsCommand instproc checkSyntax {context notifier} {
$context checkCommand [self] $notifier
}
Class PrsCommandSubst -superclass ::PrsElementList
@ PrsCommandSubst idemeta component IDETclParser
PrsCommandSubst instproc checkAsType {rtype context notifier} {
my instvar lastCommand
if {[info exists lastCommand]} {
return [$lastCommand checkAsType $rtype $context $notifier]
}
return 1
}
PrsCommandSubst instproc checkSyntax {context notifier} {
next
my instvar lastCommand
if {[info exists lastCommand]} {
my setType [$lastCommand getType]
}
}
PrsCommandSubst instproc evalContents {} {
my instvar lastCommand list
my basicEvalContents
if {[info exists list]} {
foreach e [lreverse $list] {
if {[$e hasclass PrsCommand]} {
set lastCommand $e
break
}
}
}
}
PrsCommandSubst instproc getContentOffset {} {
return 1
}
Class PrsComment -superclass ::PrsElement
@ PrsComment idemeta component IDETclParser
PrsComment instproc checkSyntax {context notifier} {
$context checkComment [self] $notifier
}
@ Class PrsContext {
description {The class has very important rolle by parsing xotcl/tcl sources.
In this methods are coded the meaning (syntax) of all build-in tcl functions
as loops and conditional.
The context handle/store such context information
1. where the code ist (xotcl method, tcl proc)
2. know variables}
}
Class PrsContext -parameter {parser errors warnings}
@ PrsContext idemeta categories {interface complex-command oo-complex-command checking-command check-variables private}
@ PrsContext idemeta categoriesMethods {{hasErrors parseAndCheck parseAndVisit parse parseGlobal} {check_lset check_gets check_while check_lassign check_dict check_for check_scan check_proc check_foreach check_global check_switch check_variable check_incr check_expr check_if check_regexp check_unset check_append check_lappend check_set check_try check_upvar check_catch} {xocheck_set check_return xocheck_proc check_itcl_local xocheck_instproc check_itcl_class xocheck_lappend xocheck_instvar xocheck_incr xocheck_array xocheck_append check_package check_namespace check_itcl_body check_xotcl_self xocheck_create} {checkCommand checkDirectObjectCall checkObjectCall checkObjectSelfCall checkObjectClassCall checkTclCommand} {addVariableFromList checkVariableFrom addVariableFrom checkVariable checkVariableType updateComplexType addVariable} {visit addError}}
@ PrsContext idemeta component IDETclParser
PrsContext instproc addError {text elem} {
set line [$elem prsStringToLineEnd]
if {![regexp {#ttc noerror} $line]} {
my lappend errors [list [$elem begin] [$elem end] $text]
}
}
PrsContext instproc addReturnType type {
my instvar returnTypes
if {![info exists returnTypes]} {
set returnTypes [list]
}
if {$type ni $returnTypes} {
lappend returnTypes $type
}
}
PrsContext instproc addVariable {name prsObject notifier {type unknown} {scope local} {overridetype 0}} {
my instvar varArr repository namespace
if {[string first :: $name]>=0} {
set scope [list global]
}
set type0 [lindex $type 0]
tlog::ltrace {addVariable $name $type $scope $overridetype}
if {![info exists varArr($name)]} {
if {[lindex $scope 0] in {instproc proc global}} {
set regType ""
if {$type0 in {def unknown}} {
set regType [$repository getVariableType [lindex $scope 1] [lindex $scope 0] $name $namespace]
if {$regType ne ""} {
set type $regType
}
}
if {$type0 eq ""} {
set type unknown
}
if {$regType eq "" || $overridetype} {
$repository registerVariable [lindex $scope 1] [lindex $scope 0] $name $namespace $type 0
}
}
set varArr($name) [list $type $scope]
} else {
lassign $varArr($name) currType currScope
if {[my updateComplexType $name $currType $type $currScope]} {
return
}
set currType0 [lindex $currType 0]
if {$currType0 in {unknown def string} || ([PrsCheckerOptions allowSetTypeChange] && $overridetype)} {
set varArr($name) [list $type $currScope]
} elseif {$currType0 eq "array" && $type0 ni {array def}} {
if {$notifier ne ""} {
$notifier addError "can not use array as scalar" $prsObject
}
} elseif {$currType0 ne "array" && $type0 eq "array"} {
if {$notifier ne ""} {
$notifier addError "can not use scalar as array" $prsObject
}
}
if {[lindex $currScope 0] in {instproc proc global} && $overridetype} {
if {$type0 eq "unknown"} {
set overridetype 0
}
$repository registerVariable [lindex $currScope 1] [lindex $currScope 0] $name $namespace $type $overridetype
}
}
}
PrsContext instproc addVariableFrom {prsObject notifier {type unknown} {scope {}} {overridetype 0}} {
my instvar varTypes
if {$scope eq ""} {
set scope [my getDefaultScope]
}
$prsObject parseAsVariableRef
if {[$prsObject hasclass PrsVariableRef]} {
set name [$prsObject getVariableName]
if {[$prsObject isArray]} {
set type [list array $type]
}
my addVariable $name $prsObject $notifier $type $scope $overridetype
} elseif {[$prsObject hasclass PrsVariable]} {
if {[my checkVariable [$prsObject getVariableName]] && ![my exists varrefref] && ![PrsCheckerOptions allowVarRef]} {
$notifier addError "usually expect here variable name and not its value (remove \$)" $prsObject
}
}
}
PrsContext instproc addVariableFromList {prsObject notifier} {
$prsObject extractList
foreach variable [$prsObject getAsList] {
my addVariableFrom $variable $notifier
}
}
PrsContext instproc canAssignType {requiredType isType} {
my instvar repository
$repository canAssignType $requiredType $isType
}
PrsContext instproc checkCommand {command notifier} {
my instvar localprocsArr isTclproc repository namespace localObject
set first [lindex [$command list] 0]
if {[$first hasclass PrsLiteral]} {
set name [$first prsString]
if {$name eq ""} {
return 1
}
if {$name eq "my"} {
my checkObjectSelfCall $command $notifier
} elseif {[$repository isXotclObject $name $namespace]} {
set obj [$repository getFullObjectName $name $namespace]
my checkDirectObjectCall $obj $command $notifier
} elseif {![catch {set localObject($name)} type]} {
my checkObjectClassCall [list $type] $command $notifier
} else {
my checkTclCommand $name $command $notifier
}
} elseif {[$first hasclass PrsCommandSubst] && [$first prsString] eq {[self]}} {
my checkObjectSelfCall $command $notifier
} elseif {[$first hasclass PrsVariable] || [$first hasclass PrsCommandSubst]} {
my checkObjectCall $command $notifier
}
return 1
}
PrsContext instproc checkComment {comment notifier} {
foreach {all type value} [regexp -all -inline -linestop {#ttc (vartype|rettype) (.+)} [$comment prsString]] {
if {$type eq "vartype"} {
if {[regexp {(\S+)\s(.+)} $value _ varname vartype]} {
tlog::info "adding ttc variable $varname type=$vartype"
my addVariable $varname $comment $notifier $vartype local 1
}
} elseif {$type eq "rettype"} {
tlog::info "seting rettype to $value"
my set forceRetType $value
} elseif {$type eq "varrefref"} {
my set varrefref 1
}
}
}
PrsContext instproc checkDirectObjectCall {cobject command notifier} {
my instvar repository
[$command getElem 0] set ref [list object $cobject]
if {[$command argsCount]==0} {
$command setType [concat obj $cobject]
return
}
set method [$command getElem 1]
if {![$method hasclass ::PrsLiteral]} return
set mname [$method prsString]
set desc [$repository getMethodDescriptionForObject $cobject $mname]
if {$desc eq ""} {
if {[$repository isXotclMetaClass $cobject] || [$repository isXotclClass $cobject]} {
set desc [$repository getMethodDescriptionForObject $cobject create]
my checkParametersToDesc $command $notifier 1 $desc
my xocheck_create [$command argsCount] proc $cobject $command $notifier 1
} else {
$notifier addError "method '$mname' unknown" $method
}
} else {
$method set ref [list method [lindex $desc 0]]
my checkParametersToDesc $command $notifier 2 $desc
if {[my info methods xocheck_$mname] ne ""} {
my xocheck_$mname [$command argsCount] proc $cobject $command $notifier
}
}
}
PrsContext instproc checkObjectCall {command notifier} {
set first [lindex [$command list] 0]
set type [my getTypeFromElem $first]
set btype [lindex $type 0]
if {$btype in {xotcl tk class}} {
set argsCount [$command argsCount]
if {$argsCount>0} {
set method [$command getElem 1]
if {[$method hasclass PrsLiteral]} {
set methodName [$method prsString]
set classes [lrange $type 1 end]
if {[llength $classes]==0 && $btype eq "xotcl"} {
set classes [list ::xotcl::Object]
} elseif {[llength $classes]==0 && $btype eq "tk"} {
set classes [list ::widget]
}
[$command getElem 0] set ref [list object [lindex $classes 0]]
my checkObjectClassCall $classes $command $notifier
}
}
} elseif {$btype eq "obj"} {
my checkDirectObjectCall [lindex $type 1] $command $notifier
} elseif {$btype ni {unknown tk def}} {
$notifier addError "expect object to call but is $btype" $first
if {[$first hasclass PrsVariable] && ![$first isArray]} {
my addVariable [$first getVariableName] $first $notifier [list class] [my getDefaultScope] 1
}
}
}
PrsContext instproc checkObjectClassCall {classList command notifier} {
my instvar repository
set argsCount [$command argsCount]
if {$argsCount==0} {
$command setType [concat xotcl $classList]
return
}
set method [$command getElem 1]
if {![$method hasclass ::PrsLiteral]} return
set mname [$method prsString]
set desc [$repository getMethodDescriptionForClasses $classList $mname]
if {$desc eq ""} {
set desc [$repository getVariableType [lindex $classList 0] subobject $mname]
if {$desc ne ""} {
if {$argsCount>=2} {
set method [$command getElem 2]
if {![$method hasclass ::PrsLiteral]} return
set mname [$method prsString]
set desc [$repository getMethodDescriptionForClasses [list $desc] $mname]
if {$desc eq ""} {
if {[lindex $classList 0] ni {::xotcl::Object ::widget}} {
$notifier addError "method '$mname' unknown for types: $desc" $method
}
} else {
my checkParametersToDesc $command $notifier 3 $desc
return
}
} else {
$command setType [concat xotcl $desc]
return
}
}
}
if {$desc eq ""} {
if {[lindex $classList 0] ni {::xotcl::Object ::widget} && [llength $classList]>0} {
$notifier addError "method '$mname' unknown for types: [join $classList {, }]" $method
}
} else {
$method set ref [list method [lindex $desc 0]]
my checkParametersToDesc $command $notifier 2 $desc
if {[my info methods xocheck_$mname] ne ""} {
if {$mname in {create new}} {
if {"::xotcl::Object" ne [$repository getFullHeritage [lindex $classList 0]]} {
return
}
}
my xocheck_$mname [$command argsCount] instproc [lindex $classList 0] $command $notifier
}
}
}
PrsContext instproc checkObjectSelfCall {command notifier} {
my instvar object isInstproc isTclproc isTclGlobalScript
if {$isTclproc || $isTclGlobalScript} {
my addError "xotcl::self can be used only in xotcl object context" $command
return
}
if {[$command argsCount]==0} {
$command setType [concat xotcl $object]
return
}
set method [lindex [$command list] 1]
if {[$method info class] ne "::PrsLiteral"} return
set mname [$method prsString]
if {[string index $mname 0] eq "@"} {
return
}
if {$isInstproc} {
my checkObjectClassCall $object $command $notifier
} else {
my checkDirectObjectCall $object $command $notifier
}
}
PrsContext instproc checkParametersToDesc {command notifier startArg desc} {
set argMatcher [my getArgumentMatcher]
$argMatcher parseCommand $command $notifier $startArg $desc
}
PrsContext instproc checkTclCommand {name command notifier} {
my instvar repository namespace
set desc [$repository getCommandDescription $name $namespace]
if {$desc eq ""} {
$notifier addError "unknown proc '$name'" [$command getElem 0]
return 0
}
set fullName [lindex $desc 0]
set count [$command argsCount]
[$command getElem 0] set ref [list proc $fullName]
if {![my checkParametersToDesc $command $notifier 1 $desc]} {
return 0
}
set checkCmdName check_[regsub :: [string trimleft $fullName :] _]
if {[my info methods $checkCmdName] ne ""} {
tlog::info "checking special command $fullName"
my $checkCmdName $count $command $notifier
}
return 1
if {0} {
my check_xotcl_self $count $command $notifier
my check_gets $count $command $notifier
my check_proc $count $command $notifier
my check_while $count $command $notifier
my check_package $count $command $notifier
my check_upvar $count $command $notifier
my check_unset $count $command $notifier
my check_return $count $command $notifier
my check_scan $count $command $notifier
my check_foreach $count $command $notifier
my check_global $count $command $notifier
my check_switch $count $command $notifier
my check_dict $count $command $notifier
my check_namespace $count $command $notifier
my check_itcl_local $count $command $notifier
my check_variable $count $command $notifier
my check_append $count $command $notifier
my check_lset $count $command $notifier
my check_itcl_body $count $command $notifier
my check_for $count $command $notifier
my check_expr $count $command $notifier
my check_catch $count $command $notifier
my check_set $count $command $notifier
my check_incr $count $command $notifier
my check_lassign $count $command $notifier
my check_itcl_class $count $command $notifier
my check_regexp $count $command $notifier
my check_lappend $count $command $notifier
my check_try $count $command $notifier
my check_if $count $command $notifier
}
}
PrsContext instproc checkVariable {variable {type unknown} {scope {}}} {
my instvar varArr repository namespace
if {[info exists varArr($variable)]} {
return 1
} else {
if {[string first :: $variable]>=0 || $scope eq "global"} {
set rtype [$repository getVariableType {} global $variable $namespace]
if {$rtype ne ""} {
set varArr($variable) [list $rtype global]
return 1
}
}
}
return 0
}
PrsContext instproc checkVariableFrom {prsObject notifier {type unknown}} {
$prsObject parseAsVariableRef
if {[$prsObject hasclass PrsVariableRef]} {
set name [$prsObject getVariableName]
if {![my checkVariable $name $type]} {
$notifier addError "unknown variable '$name'" $prsObject
}
$prsObject setType [my getVariableType $name]
}
}
PrsContext instproc checkVariableType {variable rtype {override 0}} {
my instvar varArr repository namespace isTclGlobalScript repository
if {[ttype::isRefType $rtype] && !$override} {
return 1
}
if {[catch {set varArr($variable)} desc]} {
return 1
} else {
if {[lindex $rtype 0] in {unknown def}} {
return 1
}
lassign $desc type scope
set type0 [lindex $type 0]
if {$type0 in {unknown def} || $override} {
lset desc 0 $rtype
set varArr($variable) $desc
if {$isTclGlobalScript && [lindex $scope 0] in {instproc proc global}} {
$repository registerVariable [lindex $scope 1] [lindex $scope 0] $variable $namespace $rtype 1
}
tlog::ltrace {updating variable type $variable type=$rtype from unknown}
return 1
}
if {[my updateComplexType $variable $type $rtype $scope]} {
return 1
}
set ret [my canAssignType $rtype $type]
set needUpdate 0
set rtype0 [lindex $rtype 0]
if {!$ret && $type0 eq "string"} {
set needUpdate 1
} elseif {$ret && $type0 eq "string" && $rtype0 eq [lindex $type 1]} {
set needUpdate 1
} elseif {$ret && $type0 in {index pixel} && $rtype0 in {numeric int}} {
set needUpdate 1
} elseif {$ret && $type0 eq "string" && $rtype0 in {list tk xotcl class} && [lindex $type 1] eq "empty"} {
set needUpdate 1
}
if {$needUpdate} {
TclParser log "updating variable type $variable type=$rtype from $type override=$override" trace
set varArr($variable) [list $rtype $scope]
}
return $ret
}
}
PrsContext instproc check_append {count command notifier} {
my addVariableFrom [$command getElem 1] $notifier [list string]
}
PrsContext instproc check_catch {count command notifier} {
my evalContents [$command getElem 1]
if {$count>=2} {
my addVariableFrom [$command getElem 2] $notifier [my getTypeFromElem [$command getElem 1]] [my getDefaultScope] 1
}
if {$count>=3} {
my addVariableFrom [$command getElem 3] $notifier [list dict] 1
}
}
PrsContext instproc check_dict {count command notifier} {
set elem [$command getElem 1]
if {[$elem hasclass PrsLiteral]} {
set name [$elem prsString]
if {$name eq "for" && $count>=3} {
my addVariableFromList [$command getElem 2] $notifier
my evalContents [$command getElem 4]
} elseif {$name in {set lappend incr append} && $count>=1} {
my addVariableFrom [$command getElem 2] $notifier
}
}
}
PrsContext instproc check_expr {count command notifier} {
set expr [$command getElem 1]
if {[$expr hasclass PrsQuoted]} {
$notifier addError "possible unintended double substitution for expr use {}" $expr
}
my evalExpr $expr $notifier
$command set type [my getTypeFromElem $expr]
}
PrsContext instproc check_for {count command notifier} {
my evalContents [$command getElem 1]
my substituteContents [$command getElem 2]
my evalContents [$command getElem 3]
my evalContents [$command getElem 4]
}
PrsContext instproc check_foreach {count command notifier} {
for {set x 1} {$x<$count} {incr x 2} {
set variablesRefElem [$command getElem $x]
if {[$variablesRefElem hasclass PrsQuoted]} {
$variablesRefElem changeToLiteralListIfPossible
}
my addVariableFromList $variablesRefElem $notifier
set listElem [$command getElem [expr {$x+1}]]
$listElem extractList
$listElem checkAsType list [self] $notifier
}
if {$x<=$count} {
my evalContents [$command getElem $x]
} else {
$notifier addError "expect body as last foreach parameter" [$command getElem 0]
}
}
PrsContext instproc check_gets {count command notifier} {
if {$count==2} {
my addVariableFrom [$command getElem 2] $notifier
}
}
PrsContext instproc check_global {count command notifier} {
for {set x 1} {$x<=$count} {incr x} {
my addVariableFrom [$command getElem $x] $notifier [list def] global
}
}
PrsContext instproc check_if {count command notifier} {
my evalExpr [$command getElem 1] $notifier
set wasElseIf 0
for {set x 2} {$x<=$count} {incr x} {
set elem [$command getElem $x]
if {[$elem info class] eq "::PrsLiteral"} {
set name [$elem prsString]
if {[lsearch -exact {then else elseif} $name]!=-1} {
if {[$notifier hasclass ::PrsSyntaxHightlight]} {
$notifier hightlightElement $elem tclproc
}
if {$name eq "elseif"} {
set wasElseIf 1
} else {
set wasElseIf 0
}
continue
}
}
if {$wasElseIf} {
my evalExpr $elem $notifier
} else {
my evalContents $elem
if {[$elem hasclass PrsNoSubst]} {
$command setType [$elem getEvalType]
}
}
set wasElseIf 0
}
}
PrsContext instproc check_incr {count command notifier} {
my checkVariableFrom [$command getElem 1] $notifier
}
PrsContext instproc check_itcl_body {count command notifier} {
my instvar repository namespace parser
if {$count==3} {
set nameElem [$command getElem 1]
set argumentsElem [$command getElem 2]
set bodyElem [$command getElem 3]
if {[$nameElem hasclass PrsLiteral]} {
set name [$nameElem prsString]
set functionName [namespace tail $name]
if {$functionName eq ""} {
$notifier addError "can not extract function name (expect class::function)" $nameElem
return
}
set className [namespace qualifiers $name]
if {"::itcl::object" ni [$repository getFullHeritage $className $namespace]} {
$notifier addError "is not itcl class $className" $nameElem
return
}
set context [PrsITclContext new -childof [self] -namespace $namespace -repository $repository -parser $parser]
$context set namespace $namespace
$context set name $className
$context parse_body_method $functionName $command $notifier
my importErrors $context [$command set begin]
$context destroy
}
}
}
PrsContext instproc check_itcl_class {count command notifier} {
my instvar repository namespace parser
set context [PrsITclContext new -childof [self] -namespace $namespace -repository $repository -parser $parser]
$context evalClassBody $command [self] $notifier
my importErrors $context [$command set begin]
$context destroy
}
PrsContext instproc check_itcl_local {count command notifier} {
my instvar repository namespace parser localObject
if {$count>=2} {
set classElem [$command getElem 1]
if {[$classElem hasclass PrsLiteral]} {
set class [$classElem prsString]
if {"::itcl::object" ni [$repository getFullHeritage $class $namespace]} {
$notifier "need to be itcl class" $classElem
return
}
set nameElem [$command getElem 2]
set desc [$repository getMethodDescriptionForObject $class create $namespace]
if {$desc ne ""} {
my checkParametersToDesc $command $notifier 2 $desc
if {[$nameElem hasclass PrsLiteral]} {
set localObject([$nameElem prsString]) [$repository getFullObjectName $class $namespace]
} elseif {[$nameElem hasclass PrsVariable]} {
set type [list class [$repository getFullObjectName $class $namespace]]
if {[$nameElem isArray]} {
set type [linsert $type 0 array]
}
my checkVariableType [$nameElem getVariableName] $type 1
}
}
}
}
}
PrsContext instproc check_lappend {count command notifier} {
if {$count>=2} {
set elemType [my getTypeFromElem [$command getElem 2]]
} else {
set elemType [list unknown]
}
set type [list list $elemType]
my addVariableFrom [$command getElem 1] $notifier $type
$command setType $type
}
PrsContext instproc check_lassign {count command notifier} {
for {set i 2} {$i<=$count} {incr i} {
my addVariableFrom [$command getElem $i] $notifier
}
}
PrsContext instproc check_lset {count command notifier} {
my checkVariableFrom [$command getElem 1] $notifier
}
PrsContext instproc check_namespace {count command notifier} {
my instvar repository namespace
if {$count>=2} {
set subcommand [$command getElem 1]
set namespaceElem [$command getElem 2]
if {[$subcommand isLiteral eval] && [$namespaceElem hasclass PrsLiteral] && $count>=3} {
set snamespace [$namespaceElem prsString]
set evalBody [$command getElem 3]
if {[$evalBody hasclass PrsNoSubst]} {
my subParseGlobal $evalBody $notifier [my joinNamespace $snamespace]
}
} elseif {[$subcommand isLiteral export]} {
set exportList [list]
for {set i 2} {$i<=$count} {incr i} {
set elem [$command getElem $i]
if {[$elem hasclass PrsLiteral]} {
lappend exportList [$elem prsString]
}
}
if {[llength $exportList]>0} {
$repository addNamespaceExport $namespace $exportList
}
} elseif {[$subcommand isLiteral import]} {
set importList [list]
for {set i 2} {$i<=$count} {incr i} {
set elem [$command getElem $i]
if {[$elem hasclass PrsLiteral] && ![$elem isLiteral -force]} {
lappend importList [$elem prsString]
}
}
if {[llength $importList]>0} {
$repository addNamespaceImport $namespace $importList
}
}
}
}
PrsContext instproc check_package {count command notifier} {
my instvar namespace repository
if {$count>=2} {
if {[[$command getElem 1] isLiteral require] && [[$command getElem 2] hasclass PrsLiteral]} {
$repository loadRepoForPackage [[$command getElem 2] prsString]
[$command getElem 2] set ref [list package [[$command getElem 2] prsString]]
} elseif {[[$command getElem 1] isLiteral provide] && [[$command getElem 2] hasclass PrsLiteral]} {
[$command getElem 2] set def [list package [[$command getElem 2] prsString]]
}
}
}
PrsContext instproc check_proc {count command notifier} {
my instvar namespace repository
set bodyElem [$command getElem 3]
if {[$bodyElem hasclass PrsNoSubst]} {
my subParse $command $notifier $namespace
} else {
set nameElem [$command getElem 1]
if {[$nameElem hasclass PrsLiteral]} {
$repository registerProc [$nameElem prsString] [list 0 -1] $namespace
}
}
}
PrsContext instproc check_regexp {count command notifier} {
for {set x 1} {$x<$count} {incr x} {
set elem [$command getElem $x]
if {[$elem hasclass PrsLiteral] && [$elem prsString] eq "--"} {
incr x
break
}
if {![$elem hasclass PrsLiteral]} {
break
}
set literal [$elem prsString]
if {$literal in {-about -expanded -indices -line -linestop -lineanchor -nocase -all -inline}} {
continue
}
if {$literal eq "-start"} {
incr x
}
}
incr x 2
for {} {$x<=$count} {incr x} {
my addVariableFrom [$command getElem $x] $notifier
}
}
PrsContext instproc check_return {count command notifier} {
for {set x 1} {$x<=$count} {incr x 2} {
set elem [$command getElem $x]
if {![$elem hasclass PrsLiteral] || [string index [$elem prsString] 0] ne "-"} {
break
}
}
if {$x<=$count} {
set type [my getTypeFromElem [$command getElem $x]]
} else {
set type void
}
$command setType $type
my addReturnType $type
}
PrsContext instproc check_scan {count command notifier} {
for {set x 2} {$x<=$count} {incr x} {
my addVariableFrom [$command getElem $x] $notifier
}
}
PrsContext instproc check_set {count command notifier} {
if {$count==2} {
set type [my getTypeFromElem [$command getElem 2]]
my addVariableFrom [$command getElem 1] $notifier $type [my getDefaultScope] 1
$command setType $type
} else {
my checkVariableFrom [$command getElem 1] $notifier
$command setType [my getTypeFromElem [$command getElem 1]]
}
}
PrsContext instproc check_switch {count command notifier} {
set last [$command getElem end]
if {[$last info class] ne "::PrsNoSubst"} return
$last extractList
if {[$last exists list]} {
if {[llength [$last list]]%2!=0} {
my addError "expect odd elements in the list" $last
}
foreach {pattern script} [$last list] {
if {$script ne ""} {my evalContents $script}
}
}
}
PrsContext instproc check_try {count command notifier} {
my evalContents [$command getElem 1]
set elem [$command getElem 2]
if {[$elem hasclass PrsLiteral]} {
set name [$elem prsString]
if { $name ne "finally" } {
$notifier addError "expect finally keyword" $elem
}
}
my evalContents [$command getElem 3]
}
PrsContext instproc check_unset {count command notifier} {
for {set x 1} {$x<=$count} {incr x} {
set prsObject [$command getElem $x]
if {$x==1 && $count>=2 && [$prsObject istype ::PrsLiteral]} {
set name [$prsObject prsString]
if {$name eq "-nocomplain"} {
return
}
}
my checkVariableFrom $prsObject $notifier
}
}
PrsContext instproc check_upvar {count command notifier} {
my instvar varRefs
set start [expr {1+$count%2}]
for {set x $start} {$x<=$count} {incr x} {
set fromElem [$command getElem $x]
incr x
set toElem [$command getElem $x]
my checkVariableFrom $fromElem $notifier
my addVariableFrom $toElem $notifier [list def]
if {[$fromElem hasclass PrsVariable] && [$toElem hasclass PrsVariableRef]} {
set fromVar [$fromElem getVariableName]
set toVar [$toElem getVariableName]
lappend varRefs $fromVar $toVar
}
}
}
PrsContext instproc check_variable {count command notifier} {
for {set index 1} {$index<=$count} {incr index 2} {
if {$index+1<=$count} {
my addVariableFrom [$command getElem $index] $notifier [my getTypeFromElem [$command getElem [expr {$index+1}]]] global
} else {
my addVariableFrom [$command getElem $index] $notifier [list def] global
}
}
}
PrsContext instproc check_while {count command notifier} {
my substituteContents [$command getElem 1]
my evalContents [$command getElem 2]
}
PrsContext instproc check_xotcl_self {count command notifier} {
my instvar object isInstproc isTclproc isTclGlobalScript
if {$isTclproc || $isTclGlobalScript} {
return
}
if {!$isTclproc} {
if {$count>0} {
if {[[$command getElem 1] isLiteral class]} {
$command setType [concat obj $object]
}
} else {
$command setType [concat xotcl $object]
}
}
}
PrsContext instproc cleanupSubcontext subcontext {
}
PrsContext instproc createSubcontext {notifier elem} {
my instvar repository parseMode
set subContext [PrsSubContext new -childof $elem]
$elem set context $subContext
$subContext set repository $repository
$subContext set parseMode $parseMode
return $subContext
}
PrsContext instproc evalContents elem {
$elem evalContents
$elem visit [self]
}
PrsContext instproc evalExpr {elem notifier} {
$elem evalExpr [self] $notifier
$elem visit [self]
}
PrsContext instproc getArgumentMatcher {} {
my instvar argMatcher
if {![info exists argMatcher]} {
set argMatcher [PrsArgumentMatcher new -childof [self] -context [self]]
}
return $argMatcher
}
PrsContext instproc getDefaultScope {} {
my instvar isTclGlobalScript
if {$isTclGlobalScript} {
return [list global]
}
return [list local]
}
@ PrsContext instproc getFullName {} {
description {Full name is name used in repository for proc or oo methods with namespace}
}
PrsContext instproc getFullName {} {
my instvar object isTclproc isInstproc name namespace repository
if {$isTclproc} {
return [$repository getFullName $namespace $name]
} else {
if {$isInstproc} {
return [list $object instproc $name]
} else {
return [list $object proc $name]
}
}
}
PrsContext instproc getReturnType {} {
my instvar parser returnTypes repository forceRetType
if {[info exists forceRetType]} {
return $forceRetType
}
set unknownType [list unknown [list [my getFullName] 0]]
set body [$parser root]
if {[$body exists lastCommand]} {
set type [my getTypeFromElem [$body set lastCommand]]
lappend returnTypes $type
}
if {[llength $returnTypes]==0} {
return $unknownType
}
set returnTypes [lsort -unique $returnTypes]
for {set i 0} {$i<[llength $returnTypes]} {incr i} {
if {[lindex $returnTypes $i 0] eq "unknown" && [llength [lindex $returnTypes $i]]==1} {
lset returnTypes $i $unknownType
}
}
if {[llength $returnTypes]==1} {
return [lindex $returnTypes 0]
}
set isobject 1
set oreturnTypes [list]
foreach o $returnTypes {
if {[lindex $o 0] ni {xotcl class tk} && [lindex $o 0] ne "void"} {
set isobject 0
break
} elseif {[lindex $o 0] ne "void"} {
lappend oreturnTypes $o
}
}
if {$isobject} {
set classes [$repository getFullHeritage [lindex $oreturnTypes 0 1]]
foreach t [lrange $oreturnTypes 1 end] {
set tclasses [$repository getFullHeritage [lindex $t 1]]
set i 0
foreach c $classes {
if {$c in $tclasses} {
break
}
incr i
}
set classes [lrange $classes $i end]
if {[llength $classes]==0} {
return [lindex $oreturnTypes 0 0]
}
}
return [list [lindex $oreturnTypes 0 0] [lindex $classes 0]]
}
set type [lindex $returnTypes 0]
if {[lindex $type 0] eq "unknown"} {
return $unknownType
}
foreach t [lrange $returnTypes 1 end] {
set t0 [lindex $t 0]
if {$t0 eq "unknown"} {
return $unknownType
}
if {$t0 ne "void" && $type ne $t} {
if {[$repository canAssignType $type $t]} {
} elseif {[$repository canAssignType $t $type]} {
set type $t
} else {
tlog::info "can not compute one return type $t $type -> is unknown"
return $unknownType
}
}
}
return $type
}
PrsContext instproc getTypeFromElem elem {
if {[$elem hasclass PrsVariable] || [$elem hasclass PrsVariableRef]} {
set type [my getVariableType [$elem getVariableName]]
if {[$elem isArray] && [lindex $type 0] eq "array"} {
if {[llength $type]>1} {
return [lindex $type 1]
} else {
return [list unknown]
}
}
return $type
} else {
$elem getTypeWithContext [self]
}
}
PrsContext instproc getVariableDesc variable {
my instvar varArr
if {[catch {set varArr($variable)} desc]} {
return [list unknown local]
} else {
return $desc
}
}
PrsContext instproc getVariableNames {} {
my instvar varArr
if {[array exists varArr]} {
array names varArr
} else {
return
}
}
PrsContext instproc getVariableType variable {
my instvar varArr
if {[catch {set varArr($variable)} desc]} {
return [list unknown]
} else {
return [lindex $desc 0]
}
}
PrsContext instproc hasErrors {} {
expr {[my exists errors] && [llength [my set errors]]>0}
}
PrsContext instproc importErrors {subcontext offset} {
my instvar errors
if {[$subcontext hasErrors]} {
foreach err [$subcontext set errors] {
lassign $err start end message
incr start $offset
incr end $offset
lappend errors [list $start $end $message]
}
}
}
PrsContext instproc init {} {
my instvar repository
set repository [SignatureRepository getSignatureRepository]
my initBase
next
}
PrsContext instproc initBase {} {
my instvar namespace stream parser isTclGlobalScript isTclproc parseMode
set namespace ""
set isTclGlobalScript 0
set stream [ReadStringStream new -childof [self] -string {}]
set parser [TclParser new -childof [self] -stream $stream]
set isTclproc 0
set parseMode collect
}
PrsContext instproc initParser script {
my instvar parser stream errors varArr
set errors [list]
unset -nocomplain varArr
$parser cleanUp
$stream setString $script
}
PrsContext instproc initVariablesFromArguments {} {
my instvar object isTclproc isInstproc name hasNonPosArgs repository namespace rootCommand parser variablesList nonPosVariablesList
if {$isTclproc} {
set shift 2
} else {
set shift 3
}
set count [$rootCommand getListLength]
if {$isTclproc} {
set desc [$repository getCommandDescription $name $namespace]
} else {
if {$isInstproc} {
set desc [$repository getMethodDescriptionForClasses $object $name]
} else {
set desc [$repository getMethodDescriptionForObject $object $name]
}
}
if {[llength $desc]!=2} {
set desc [list]
} else {
set desc [lindex $desc 1]
}
set i 1
set fullName [my getFullName]
set argListElem [$rootCommand getElem $shift]
$argListElem extractList
if {!$isTclproc} {
if {$count>5} {
set hasNonPosArgs 1
set varsToAdd [list]
foreach v [$argListElem getAsList] {
$v extractList
set argValueElem [lindex [$v getAsList] 0]
if {$argValueElem ne ""} {
set va [$argValueElem prsString]
if {[regexp -- {-([^:]+).*} $va _ var]} {
set type [lindex $desc $i 0]
if {$type in {? * +}} {
set type [lindex $desc $i 1]
}
if {$type eq ""} {
set type [list unknown [list $fullName $i]]
}
lappend varsToAdd $var $v $type
incr i
} else {
set hasNonPosArgs 0
break
}
}
}
if {$hasNonPosArgs} {
set nonPosVariablesList $argListElem
incr shift
set argListElem [$rootCommand getElem $shift]
$argListElem extractList
foreach {var v type} $varsToAdd {
my addVariable $var $v {} $type
}
}
}
}
set variablesList $argListElem
foreach v [$argListElem getAsList] {
$v extractList
set argValueElem [lindex [$v getAsList] 0]
if {$argValueElem ne ""} {
set va [$argValueElem prsString]
set type [lindex $desc $i 0]
if {$type in {? * +}} {
set type [lindex $desc $i 1]
}
if {$type eq ""} {
set type [list unknown [list $fullName $i]]
}
if {!$isTclproc && !$hasNonPosArgs} {
if {[regexp -- {-([^:]+).*} $va _ var]} {
my addVariable $var $v {} $type
} else {
my addVariable $va $v {} $type
}
} else {
my addVariableFrom $argValueElem {} $type
}
incr i
}
}
}
PrsContext instproc isObjectContext {} {
my instvar isTclproc isTclGlobalScript
expr {$isTclproc || ([info exists isTclGlobalScript] && !$isTclGlobalScript)}
}
PrsContext instproc joinNamespace childNamespace {
my instvar namespace
if {[string range $childNamespace 0 1] eq "::"} {
return $childNamespace
}
return "${namespace}::[string trimright $childNamespace :]"
}
@ PrsContext instproc parse {} {
description {This Method parse a text and build a parse tree
It return 1 on success}
}
PrsContext instproc parse script {
my instvar errors parser rootCommand
my initParser $script
if {![info complete $script]} {
lappend errors [list 0 0 "Methodbody is not proper tcl list"]
return 0
}
set rootCommand [$parser getCommand $parser]
my parseCommand
}
PrsContext instproc parseAndCheck script {
if {[string first "no syntax check" $script]>=0} return
my parseAndVisit $script
}
PrsContext instproc parseAndCheckCommand command {
my instvar rootCommand parser errors
set script [$command prsString]
set rootCommand $command
set parser [$command getParser]
if {[my parseCommand]} {
[[my parser] root] visit [self]
my registerSignature
}
if {[string first "no syntax check" $script]>=0} {
set errors [list]
}
}
PrsContext instproc parseAndVisit script {
if {[my parse $script]} {
[[my parser] root] visit [self]
my registerSignature
}
}
PrsContext instproc parseBody {} {
my instvar hasNonPosArgs parser rootCommand isTclproc parseMode
set i 2
if {!$isTclproc} {
incr i
if {$hasNonPosArgs} {
incr i
}
incr i
} else {
incr i
}
set root [$rootCommand getElem $i]
if {$root eq ""} {
my addError "method/proc body not found" $rootCommand
return 0
}
$parser root $root
if {$parseMode ne "shallow"} {
$root evalContents
}
return 1
}
PrsContext instproc parseCommand {} {
my instvar errors parser isTclGlobalScript rootCommand object name isInstproc
set isTclGlobalScript 0
if {![my parseShallow]} {
tlog::warn "parseShallow failed [$rootCommand prsString]"
return 0
}
if {[$parser catchParseErrors {set ret [my parseBody]}]} {
return $ret
} else {
if {[$parser exists parseErrors]} {
lappend errors [list 0 1 [$parser set parseErrors]]
}
return 0
}
}
PrsContext instproc parseGlobal script {
my instvar parser stream isTclGlobalScript rootCommand
set isTclGlobalScript 1
my initParser $script
set rootCommand [PrsScript new -childof $parser -begin [$stream pos] -end [$stream lastpos]]
$parser root $rootCommand
if {![$parser catchParseErrors {$rootCommand evalContents}]} {
if {[$parser exists parseErrors]} {
set lerror [lindex [$parser set parseErrors] end]
my lappend errors [list [$rootCommand begin] [lindex $lerror 0] [lindex $lerror end]]
}
} else {
$rootCommand visit [self]
}
}
PrsContext instproc parseGlobalCommand command {
my instvar parser stream isTclGlobalScript rootCommand
set isTclGlobalScript 1
set rootCommand $command
$rootCommand evalContents
$rootCommand visit [self]
}
PrsContext instproc parseShallow {} {
my instvar object isTclproc isInstproc errors name repository namespace rootCommand parser hasNonPosArgs returnTypes forceRetType
set count [$rootCommand getListLength]
set objectElem [$rootCommand getElem 0]
if {![$objectElem hasclass PrsLiteral]} {
my addError "First elem in list need to be literal" $objectElem
return 0
}
set object [$objectElem prsString]
set hasNonPosArgs 0
set returnTypes [list]
unset -nocomplain forceRetTypes
if {$object eq "proc"} {
set isTclproc 1
set isInstproc 0
set shift 1
} else {
set isTclproc 0
if {![$repository isXotclObject $object $namespace]} {
my addError "Await xotcl object but got $object" $objectElem
return 0
}
set object [$repository getFullObjectName $object $namespace]
set methodtypeElem [$rootCommand getElem 1]
if {![$methodtypeElem hasclass PrsLiteral]} {
my addError "Expect proc or instproc" $methodtypeElem
return 0
}
set methodtype [$methodtypeElem prsString]
if {$methodtype eq "instproc"} {
set isInstproc 1
} elseif {$methodtype eq "proc"} {
set isInstproc 0
} else {
my addError "Expect proc or instproc" $methodtypeElem
return 0
}
set shift 2
}
set nameElem [$rootCommand getElem $shift]
if {![$nameElem hasclass PrsLiteral]} {
if {[$nameElem hasclass PrsNoSubst]} {
set name [$nameElem prsContentString]
} else {
my addError "Expect name of proc/method as literal" $nameElem
return 0
}
} else {
set name [$nameElem prsString]
}
set pnamespace [namespace qualifiers $name]
if {$pnamespace ne ""} {
set namespace [my joinNamespace $pnamespace]
set name [namespace tail $name]
}
incr shift
my initVariablesFromArguments
if {$isTclproc} {
tlog::ldebug {parse proc definition $name}
} else {
tlog::ldebug {parse method definition $object>$name (instproc $isInstproc)}
}
return 1
}
PrsContext instproc registerSignature {} {
my instvar variablesList parser repository object isTclproc name isInstproc varArr isTclGlobalScript namespace hasNonPosArgs nonPosVariablesList rootCommand
if {![info exists variablesList]} {
return
}
my resolveVarRefs
lappend types [list [my getReturnType]]
if {$hasNonPosArgs} {
set options [list]
$nonPosVariablesList extractList
foreach v [$nonPosVariablesList getAsList] {
$v extractList
set list [$v getAsList]
set parName [[lindex $list 0] prsString]
if {[regexp -- {(-[^:]+)(.*)} $parName _ var type]} {
if {$type eq "boolean"} {
set parType boolean
} else {
set parType unknown
}
lappend options $parName $parType
}
}
if {[llength $options]>0} {
lappend types [list ? [concat option $options]]
}
}
set canHaveNonPosArgs [expr {!$isTclproc && !$hasNonPosArgs}]
set options [list]
foreach v [$variablesList getAsList] {
$v extractList
set list [$v getAsList]
set parName [[lindex $list 0] prsString]
set mult {}
if {[llength $list]>1} {
set mult ?
}
if {$parName eq "args"} {
set mult *
}
if {$canHaveNonPosArgs} {
if {[regexp -- {(-[^:]+)(.*)} $parName _ var type]} {
if {$type eq "boolean"} {
set parType boolean
} else {
set parType unknown
}
lappend options $parName $parType
continue
} else {
set canHaveNonPosArgs 0
if {[llength $options]>0} {
lappend types [list ? [concat option $options]]
}
set options [list]
}
}
if {$mult ne ""} {
if {$parName ne "args"} {
lappend types [list $mult [my getVariableType $parName] $parName]
} else {
lappend types [list $mult unknown $parName]
}
} else {
lappend types [list [my getVariableType $parName] $parName]
}
}
if {[llength $options]>0} {
lappend types [list ? [concat option $options]]
}
if {$isTclproc} {
set class ""
set mtype proc
} else {
set class $object
if {$isInstproc} {
set mtype instproc
} else {
set mtype proc
}
}
foreach variable [array names varArr] {
lassign $varArr($variable) type scope
if {[lindex $scope 0] in {instproc proc global}} {
$repository registerVariable [lindex $scope 1] [lindex $scope 0] $variable $namespace $type
}
}
if {$isTclproc} {
tlog::info "register signature proc $name $types"
set fullName [$repository registerProc $name [list $types] $namespace]
$rootCommand set def [list proc $fullName]
} else {
set fullName [$repository registerMethod $class $mtype $name [list $types] $namespace]
$rootCommand set def [list method $fullName]
}
}
PrsContext instproc resolveVarRefs {} {
my instvar varRefs
if {[info exists varRefs]} {
foreach {fromVar toVar} $varRefs {
my checkVariableType $fromVar [list setref [my getVariableType $toVar]] 1
}
}
}
PrsContext instproc subParse {command notifier {namespace {}}} {
my instvar parser errors
set subcontext [my createSubcontext $notifier $command]
$subcontext set namespace $namespace
$subcontext parseAndCheckCommand $command
my importErrors $subcontext 0
my cleanupSubcontext $subcontext
}
PrsContext instproc subParseGlobal {elem notifier {namespace {}}} {
my instvar parser errors
set subcontext [my createSubcontext $notifier $elem]
$subcontext set namespace $namespace
$subcontext parseGlobalCommand $elem
my importErrors $subcontext 0
my cleanupSubcontext $subcontext
}
PrsContext instproc substituteContents elem {
$elem substituteContents
$elem visit [self]
}
PrsContext instproc updateComplexType {varName currentType requiredType scope} {
my instvar varArr repository namespace
if {[lindex $currentType 0] in {array list} && [lindex $currentType 0] eq [lindex $requiredType 0]
&& [lindex $currentType 1] ne "unknown" && [llength $requiredType]>1
&& [lindex $currentType 1] ne [lindex $requiredType 1]} {
if {[lindex $currentType 1] ne "" && [lindex $currentType 1] ne [lindex $requiredType 1]} {
set desc [list [list [lindex $currentType 0] unknown] $scope]
} else {
set desc [list $requiredType $scope]
}
set varArr($varName) $desc
if {[lindex $scope 0] in {global proc instproc}} {
$repository registerVariable [lindex $scope 1] [lindex $scope 0] $varName $namespace [lindex $desc 0]
}
tlog::ltrace {updating complex variable type $varName type=$requiredType}
return 1
}
return 0
}
PrsContext instproc visit obj {
set parser [my parser]
if {![$parser catchParseErrors {$obj checkSyntax [self] [self]}]} {
if {[$parser exists parseErrors]} {
set lerror [lindex [$parser set parseErrors] end]
my lappend errors [list [$obj begin] [lindex $lerror 0] [lindex $lerror end]]
}
}
}
PrsContext instproc xocheck_append {count type object command notifier} {
if {$count>=3} {
set ltype [my getTypeFromElem [$command getElem 3]]
} else {
set ltype [list unknown]
}
set ltype [list string]
my addVariableFrom [$command getElem 2] $notifier $ltype [list $type $object]
$command setType $ltype
}
PrsContext instproc xocheck_array {count type object command notifier} {
my instvar repository
if {$count==4 && [[$command getElem 2] isLiteral set]} {
my addVariableFrom [$command getElem 3] $notifier array [list $type $object]
} elseif {$count==3 && [[$command getElem 2] isLiteral get]} {
}
}
PrsContext instproc xocheck_create {count type object command notifier {startParam 2}} {
my instvar repository namespace
if {[$repository isXotclMetaClass $object]} {
set nameElem [$command getElem $startParam]
if {$nameElem ne "" && [$nameElem hasclass PrsLiteral]} {
set name [$nameElem prsString]
tlog::info "define xotcl class $name"
set superclasses ""
set parameters ""
incr startParam
for {set i $startParam} {$i<$count} {incr i} {
set parElem [$command getElem $i]
if {[$parElem hasclass PrsLiteral]} {
set par [$parElem prsString]
if {$par eq "-superclass"} {
incr i
set parValueElem [$command getElem $i]
if {$parValueElem ne "" && ([$parValueElem hasclass PrsLiteral] || [$parValueElem hasclass PrsNoSubst])} {
$parValueElem extractList
foreach par [$parValueElem getAsList] {
set sclass [$par prsString]
set fnsclass [$repository getFullObjectName $sclass $namespace]
if {$fnsclass eq ""} {
my addError "is not a class" $par
} else {
set sclass $fnsclass
}
lappend superclasses $sclass
}
}
} elseif {$par eq "-parameter"} {
incr i
set parValueElem [$command getElem $i]
if {$parValueElem ne "" && ([$parValueElem hasclass PrsLiteral] || [$parValueElem hasclass PrsNoSubst])} {
$parValueElem extractList
foreach par [$parValueElem getAsList] {
$par extractList
lappend parameters [[lindex [$par getAsList] 0] prsString]
}
}
}
}
}
if {[llength $superclasses]==0} {
lappend superclasses ::xotcl::Object
}
set fullName [$repository registerObject $name Class $superclasses $parameters $namespace]
[$command getElem 0] set def [list object $fullName]
}
} elseif {[$repository isXotclClass $object]} {
set nameElem [$command getElem $startParam]
if {$nameElem ne "" && [$nameElem hasclass PrsLiteral]} {
set name [$nameElem prsString]
set fullClass [$repository getFullObjectName $object $namespace]
if {[string first #auto $name]<0 || "::itcl::object" ni [$repository getFullHeritage $fullClass]} {
set fullName [$repository registerObject $name $fullClass {} {} $namespace]
[$command getElem 0] set def [list object $fullName]
}
} elseif {$nameElem ne "" && [regexp {\[self\]::(.+)} [$nameElem prsString] _ name]} {
if {[my exists object]} {
$repository registerVariable [my set object] subobject $name {} [$repository getFullObjectName $object $namespace]
}
}
}
}
PrsContext instproc xocheck_incr {count type object command notifier} {
my addVariableFrom [$command getElem 2] $notifier int [list $type $object]
}
PrsContext instproc xocheck_instproc {count type object command notifier} {
my instvar namespace
my subParse $command $notifier $namespace
}
PrsContext instproc xocheck_instvar {count type object command notifier} {
my instvar repository
for {set x 2} {$x<=$count} {incr x} {
my addVariableFrom [$command getElem $x] $notifier [list def] [list $type $object]
}
}
PrsContext instproc xocheck_lappend {count type object command notifier} {
if {$count>=3} {
set ltype [my getTypeFromElem [$command getElem 3]]
} else {
set ltype unknown
}
set ltype [list list $ltype]
my addVariableFrom [$command getElem 2] $notifier $ltype [list $type $object]
$command setType $ltype
}
PrsContext instproc xocheck_proc {count type object command notifier} {
my instvar namespace
my subParse $command $notifier $namespace
}
PrsContext instproc xocheck_set {count type object command notifier} {
my instvar repository
if {$count==3} {
set vtype [[$command getElem 3] getType]
my addVariableFrom [$command getElem 2] $notifier $vtype [list $type $object]
$command setType $vtype
} elseif {$count==2} {
set typeElem [$command getElem 2]
if {[$typeElem hasclass PrsLiteral]} {
set varName [$typeElem prsString]
set vtype [$repository getVariableType $object $type $varName]
if {$vtype ne ""} {
$command setType $vtype
}
}
}
}
Class PrsExpr -superclass ::PrsElementList
@ PrsExpr idemeta component IDETclParser
PrsExpr instproc checkSyntax {context notifier} {
my instvar perror
if {[info exists perror]} {
foreach e $perror {
$notifier addError [lindex $e 1] [lindex $e 0]
}
}
}
PrsExpr instproc getContentOffset {} {
return 1
}
PrsExpr instproc getTreeAsString {{tree {}}} {
my instvar exprTree
if {$tree eq ""} {
set tree $exprTree
}
if {[llength $tree]==1} {
return [[lindex $tree 0] prsString]
} else {
set ret "op='[[lindex $tree 0] prsString]' ("
set first 1
foreach v [lrange $tree 1 end] {
if {!$first} {
append ret ,
}
append ret [my getTreeAsString $v]
set first 0
}
append ret ")"
return $ret
}
}
PrsExpr instproc getType {{suggestedType {}}} {
my instvar exprTree
if {[info exists exprTree]} {
[lindex $exprTree 0] getType
}
next
}
PrsExpr instproc hasErrors {} {
my instvar perror
expr {[info exists perror] && [llength $perror]>0}
}
Class PrsFileContext -superclass ::PrsContext
@ PrsFileContext idemeta categories command-start
@ PrsFileContext idemeta categoriesMethods {{parseArgs putsProgLicense putsArgHelp startWithArgs}}
@ PrsFileContext idemeta component IDETclParser
PrsFileContext instproc checkVariable {variable {type unknown} {scope {}}} {
my instvar repository varArr namespace
if {[next]} {
return 1
} else {
set scope [my getDefaultScope]
if {$scope eq "global"} {
set rtype [$repository getVariableType {} global $variable $namespace]
if {$rtype ne ""} {
set varArr($variable) [list $rtype global]
return 1
}
}
return 0
}
}
PrsFileContext instproc destroy {} {
my instvar repository
catch {$repository destroy}
next
}
PrsFileContext instproc getVariableType variable {
my instvar isTclGlobalScript repository namespace
if {$isTclGlobalScript} {
set rtype [$repository getVariableType {} global $variable $namespace]
if {$rtype ne ""} {
return $rtype
}
}
next
}
PrsFileContext instproc handleGlobalComment comment {
}
PrsFileContext instproc init {} {
my instvar repository logStream errorCount fileName
set logStream stdout
set fileName ""
set repository [SignatureRepository createSignatureRepositoryFile]
set errorCount 0
my initBase
}
PrsFileContext instproc initPass2 {} {
my instvar errorCount repository
$repository initNewCreateMethods
set errorCount 0
}
PrsFileContext instproc loadPackagesFromFilesExtensions files {
my instvar repository
set extensions [list]
foreach f $files {
lappend extensions [file extension $f]
}
if {".xotcl" in $extensions} {
$repository loadRepoForPackage XOTcl
}
if {".itcl" in $extensions || ".itk" in $extensions } {
$repository loadRepoForPackage Itcl
}
}
PrsFileContext instproc logErrors {} {
my instvar errors stream errorCount
foreach err $errors {
incr errorCount
lassign $err begin end message
set beginLine [my posToLine $begin]
set endLine [my posToLine $end]
my logMessage "$message <<[$stream copyFromTo $begin $end]>>" [lindex $beginLine 0]
}
}
PrsFileContext instproc logMessage {message {line {}}} {
my instvar fileName logStream parseMode
if {$parseMode eq "report"} {
if {$fileName eq ""} {
puts $logStream $message
} elseif {$line ne ""} {
puts $logStream "${fileName}:${line}: $message"
} else {
puts $logStream "${fileName}: $message"
}
}
}
PrsFileContext instproc openFile file {
my instvar fileDesc fileName
set fileName $file
set fileDesc [open $file r]
}
PrsFileContext instproc openTestFile {} {
my parseFile temptest.tcl
}
PrsFileContext instproc openTestFile2 {} {
my parseFile test2.tcl
}
PrsFileContext instproc openTestFileItcl {} {
my parseFile itcltest.tcl
}
PrsFileContext instproc openTestFileNs {} {
my parseFile nstest.tcl
}
PrsFileContext instproc parseArgs arguments {
return 0
}
PrsFileContext instproc parseFile file {
my instvar fileDesc lineStart linesLen isTclproc isTclGlobalScript errorCount lineCount fileName
set errorFileStart $errorCount
if {![file readable $file]} {
my logMessage "can not read $file"
return
}
my openFile $file
my logMessage "parsing file $file"
set isTclproc 0
set isTclGlobalScript 1
set lineCount 1
set completePart ""
set lineStart $lineCount
set linesLen [list]
while {[gets $fileDesc line]>=0} {
lappend linesLen [expr {[string length $line]+1}]
append completePart $line \n
if {[info complete $completePart]} {
my parsePart $completePart
set completePart ""
incr lineCount
set linesLen [list]
set lineStart $lineCount
} else {
incr lineCount
}
}
my parsePart $completePart
my logMessage "errors file: [expr {$errorCount-$errorFileStart}]"
close $fileDesc
set fileName ""
}
PrsFileContext instproc parseFiles files {
my instvar errorCount repository allLinesCount
set startTime [clock milliseconds]
my parseFilesPass $files shallow
my parseFilesPass $files collect
my initPass2
set allLinesCount 0
[$repository getWriteRepository] resolveTypes
my parseFilesPass $files report
set endTime [clock milliseconds]
set tempSec [expr {($endTime-$startTime)/1000}]
if {$allLinesCount==0} {
my logMessage "no lines parsed"
return
}
my logMessage "errors all: $errorCount ([format %.2f [expr {100.0*$errorCount/$allLinesCount}]]% lines)"
my logMessage "lines: $allLinesCount in: [clock format $tempSec -format "%H:%M:%S" -gmt 1] [expr {($endTime-$startTime)%1000}] lines/sec: [format %.2f [expr {(1000*$allLinesCount)/(double($endTime-$startTime))}]]"
my logMessage [[$repository getWriteRepository] getStat]
}
PrsFileContext instproc parseFilesPass {files _scanMode} {
my instvar parseMode allLinesCount lineCount
set parseMode $_scanMode
tlog::warn "pass $parseMode"
foreach f $files {
tlog::warn "parsing $f"
my parseFile $f
incr allLinesCount $lineCount
}
}
PrsFileContext instproc parseObjectDefinition script {
my instvar repository
set defobj [lindex $script 0]
set count [llength $script]
if {$defobj in {::xotcl::Class Class}} {
set cobject [lindex $script 1]
set defstart 2
if {$cobject eq "create"} {
set cobject [lindex $script 2]
set defstart 3
}
if {$cobject eq ""} {
return
}
set superclasses ""
set parameters ""
for {set i $defstart} {$i<$count} {incr i} {
set elem [lindex $script $i]
if {$elem eq "-superclasses"} {
incr i
set superclasses [lindex $script $i]
} elseif {$elem eq "-parameters"} {
incr i
set parameters [lindex $script $i]
}
}
}
}
PrsFileContext instproc parsePart script {
my instvar lineStart repository
set trimmed [string trim $script]
if {$trimmed eq "" || [string index $trimmed 0] eq "#"} {
my handleGlobalComment $script
return
}
my parsePartGlobal $script
}
PrsFileContext instproc parsePartGlobal script {
my parseGlobal $script
my logErrors
}
PrsFileContext instproc posToLine pos {
my instvar lineStart linesLen
set i 0
set lineEnd 0
foreach l $linesLen {
incr lineEnd $l
if {$pos<$lineEnd} {
return [list [expr {$lineStart+$i}] [expr {$l-$pos}]]
}
incr i
}
incr i -1
list [expr {$lineStart+$i}] [expr {$l-$pos}]
}
PrsFileContext instproc putsArgHelp {} {
puts "
ttclcheck options files
-h : write help and exit
-scan directory : scan recursively directory for *.tcl, *.xotcl, *.itk, *.itcl files
-w file : write signatures to file
-r file : read signatures from file and write to it at the end
-log (trace|debug|info|warn|error) : set log level
-encoding encoding : set file encoding
-l directory : use directory as repository the package signatures
-req tclpackage : same like tcl code package require name (use to register Itcl or XOTcl)
-out file : write output to file
-i file : include repository
-log loglevel : (trace,debug,info,warn,error)
-notypes : supress type checking
-oldstringop : allow usage of == operator also for strings
-html : convert all sources to html site
(only if -html present)
-od : output dir for html site
-noerror : do not incluse errors in html site
"
}
PrsFileContext instproc putsProgLicense {} {
puts "ttclcheck version: [TclParser getVersion] Copyright 2013 Artur Trzewik
All Rights Reserved.
GPL licensed software"
}
PrsFileContext instproc scanTclFiles dir {
set files [list]
foreach f [glob -directory $dir -nocomplain -types {f r} *.tcl *.itcl *.tk *.xotcl *.itk] {
if {[file tail $f] eq "pkgIndex.tcl"} continue
lappend files $f
}
foreach d [glob -directory $dir -nocomplain -types {d r} *] {
lappend files {*}[my scanTclFiles $d]
}
return $files
}
PrsFileContext instproc setOutStream outStream {
my instvar logStream
set logStream $outStream
}
PrsFileContext instproc startWithArgs arguments {
my instvar repository
if {[llength $arguments]==0} {
my putsArgHelp
exit 0
}
my putsProgLicense
set files [list]
set out ""
set repositoryFile ""
set writeRepositoryFile ""
for {set i 0} {$i<[llength $arguments]} {incr i} {
set elem [lindex $arguments $i]
if {$elem eq "-out"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -out"
}
set outfile [lindex $arguments $i]
set out [open $outfile w]
my setOutStream $out
} elseif {$elem eq "-i"} {
set coreRepository [$repository getCoreRepository]
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -i"
}
puts "loading core signatures from [lindex $arguments $i]"
$coreRepository loadRepository [lindex $arguments $i]
} elseif {$elem eq "-r"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -r"
}
set repositoryFile [lindex $arguments $i]
if {[file isfile $repositoryFile]} {
puts "loading signatures from [lindex $arguments $i]"
set writeRepository [$repository getWriteRepository]
$writeRepository loadRepository [lindex $arguments $i]
} else {
puts "can not find repository [lindex $arguments $i]"
}
} elseif {$elem eq "-l"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -l"
}
set reposDir [lindex $arguments $i]
if {![file isdirectory $reposDir]} {
error "can not find repo directory from argument -l $reposDir"
}
[$repository getCoreRepository] setReposDir [lindex $arguments $i]
} elseif {$elem eq "-log"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -log"
}
tlog::setLogLevel [lindex $arguments $i]
} elseif {$elem eq "-req"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -log"
}
set coreRepository [$repository getCoreRepository]
$coreRepository loadRepoForPackage [lindex $arguments $i]
} elseif {$elem eq "-w"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -w"
}
set writeRepositoryFile [lindex $arguments $i]
} elseif {$elem eq "-scan"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -scan"
}
set dir [lindex $arguments $i]
if {![file isdirectory $dir]} {
error "expect paramter as directory $dir"
}
lappend files {*}[my scanTclFiles $dir]
} elseif {$elem eq "-devel"} {
TclParser setDevelMode 1
} elseif {$elem eq "-encoding"} {
incr i
if {$i>=[llength $arguments]} {
error "expect argument for option -encoding"
}
encoding system [lindex $arguments $i]
} elseif {$elem eq "-html"} {
my class Tcl2HTML
my initMarkup
} elseif {$elem eq "-notypes"} {
PrsCheckerOptions set checkTypes 0
} elseif {$elem eq "-oldstringop"} {
PrsCheckerOptions set oldStringOp 1
} elseif {$elem in {-h -help}} {
my putsArgHelp
exit 0
} else {
set argParsed [my parseArgs [lrange $arguments $i end]]
if {$argParsed>0} {
incr i [expr {$argParsed-1}]
} else {
lappend files $elem
}
}
}
if {[llength $files]==0} {
error "no files as parameter found"
}
my parseFiles $files
if {$out ne ""} {
close $out
}
if {$repositoryFile ne ""} {
set writeRepository [$repository getWriteRepository]
puts "writing signatures to $repositoryFile"
$writeRepository safeRepository $repositoryFile
}
if {$writeRepositoryFile ne ""} {
set writeRepository [$repository getWriteRepository]
puts "writing signatures to $writeRepositoryFile"
$writeRepository safeRepository $writeRepositoryFile
}
}
PrsFileContext proc startFromShell arguments {
set fileContext [PrsFileContext new]
$fileContext startWithArgs $arguments
}
Class PrsITclContext -superclass ::PrsContext -parameter {name namespace repository}
@ PrsITclContext idemeta component IDETclParser
PrsITclContext instproc checkArgCount {command startArg notifier min max} {
set count [$command argsCount]
if {$count-$startArg+1<$min || ($count-$startArg+1>$max && $max>0)} {
puts "error count=$count start=$startArg $min $max realcount=[expr {$count-$startArg+1}]"
$notifier addError "wrong number of paramter expect $min to $max" [$command getElem [expr {$startArg-1}]]
return 0
}
return 1
}
PrsITclContext instproc checkTclCommand {cmdName command notifier} {
my instvar isTclGlobalScript repository name namespace defaultVisibility
if {!$isTclGlobalScript} {
if {$cmdName eq "chain"} {
return
}
set desc [$repository getMethodDescriptionForClasses [list $name] $cmdName $namespace]
if {$desc eq ""} {
set desc [$repository getMethodDescriptionForObject $name $cmdName $namespace]
}
if {$desc ne ""} {
[$command getElem 0] set ref [list method [lindex $desc 0]]
my checkParametersToDesc $command $notifier 1 $desc
} else {
next
}
} else {
set defCommands {inherit constructor destructor method proc variable common public protected private set}
if {$cmdName ni $defCommands} {
next
} else {
if {$cmdName in {public protected private}} {
if {[$command argsCount]==1} {
set oldVis $defaultVisibility
set defaultVisibility $cmdName
set body [$command getElem 1]
$body evalContents
$body visit [self]
set defaultVisibility $oldVis
} else {
my checkTclCommandInner $cmdName $command $notifier 1 $cmdName
}
} else {
my checkTclCommandInner $cmdName $command $notifier 0 $defaultVisibility
}
}
}
}
PrsITclContext instproc checkTclCommandInner {name command notifier startArg visibilty} {
if {[$command argsCount]<$startArg} {
$notifier addError "expect more parameters" [$command getElem 0]
return
}
set cmdElem [$command getElem $startArg]
set defCommands {inherit constructor destructor method proc variable common set array}
if {![$cmdElem hasclass PrsLiteral]} {
$notifier addError "expect itcl defintion one of ([join $defCommands ,])" $cmdElem
return
}
set cmd [$cmdElem prsString]
if {$cmd ni $defCommands} {
$notifier addError "expect itcl defintion one of ([join $defCommands ,])" $cmdElem
return
}
incr startArg
my def_$cmd $command $startArg $notifier $visibilty
}
PrsITclContext instproc checkVariable {variable {type unknown} {scope {}}} {
my instvar isTclGlobalScript namespace name repository
set ret [next]
if {!$ret && !$isTclGlobalScript} {
set rtype [$repository getVariableType $name instproc $variable $namespace]
if {$rtype eq ""} {
set rtype [$repository getVariableType $name proc $variable $namespace]
}
if {$rtype ne ""} {
set varArr($variable) [list $rtype [list instproc $name]]
return 1
}
}
return $ret
}
PrsITclContext instproc cleanupLocalVars {} {
my instvar varArr
foreach variable [array names varArr] {
lassign $varArr($variable) type scope
if {[lindex $scope 0] eq "local"} {
unset -nocomplain varArr($variable)
}
}
}
PrsITclContext instproc def_common {command startArg notifier visibilty} {
my instvar repository name namespace
my checkArgCount $command $startArg $notifier 1 2
set argsCount [expr {[$command argsCount]-$startArg+1}]
if {$argsCount>=2} {
set type [my getTypeFromElem [$command getElem $startArg]]
} else {
set type [list def]
}
my addVariableFrom [$command getElem $startArg] $notifier $type [list proc $name]
}
PrsITclContext instproc def_constructor {command startArg notifier visibilty} {
my instvar repository isTclGlobalScript object
my checkArgCount $command $startArg $notifier 2 3
set isTclGlobalScript 0
set isTclProc 1
if {[$command argsCount]+$startArg-1==2} {
set argumentElem [$command getElem $startArg]
incr startArg
set bodyElem [$command getElem $startArg]
my parseArguments $argumentElem
my evalContents $bodyElem
my registerMethod init $bodyElem
$command set def [list method [list $object instproc constructor]]
my cleanupLocalVars
}
set isTclGlobalScript 1
}
PrsITclContext instproc def_destructor {command startArg notifier visibilty} {
my instvar repository isTclGlobalScript object
my checkArgCount $command $startArg $notifier 1 1
set isTclGlobalScript 0
set isTclProc 1
set bodyElem [$command getElem $startArg]
my evalContents $bodyElem
$command set def [list method [list $object instproc destructor]]
my cleanupLocalVars
set isTclGlobalScript 1
}
PrsITclContext instproc def_inherit {command startArg notifier visibilty} {
my instvar repository name namespace superclasses
my checkArgCount $command $startArg $notifier 1 -1
set count [$command argsCount]
set superclasses [list]
for {set i $startArg} {$i<=$count} {incr i} {
set classElem [$command getElem $i]
if {[$classElem hasclass PrsLiteral]} {
set className [$classElem prsString]
if {[llength [$repository getFullHeritage $className $namespace]]==0} {
$notifier addError "is not itcl class" $classElem
} else {
[$command getElem $i] set ref [list object [$repository getFullObjectName $className]]
lappend superclasses $className
}
}
}
$repository registerObject $name ::itcl::class $superclasses {} $namespace
}
PrsITclContext instproc def_method {command startArg notifier visibilty} {
my instvar repository name namespace isTclGlobalScript object
my checkArgCount $command $startArg $notifier 1 3
set isTclGlobalScript 0
set isTclProc 1
if {[$command argsCount]-$startArg+1==3} {
set nameElem [$command getElem $startArg]
tlog::info "parse itcl method definition [$nameElem prsString]"
incr startArg
set argumentElem [$command getElem $startArg]
incr startArg
set bodyElem [$command getElem $startArg]
my parseArguments $argumentElem
my evalContents $bodyElem
if {[$nameElem hasclass PrsLiteral]} {
set methodName [$nameElem prsString]
my registerMethod $methodName $bodyElem
$command set def [list method [list $object instproc $methodName]]
}
my cleanupLocalVars
}
set isTclGlobalScript 1
}
PrsITclContext instproc def_proc {command startArg notifier visibilty} {
my instvar repository name namespace isTclGlobalScript object
my checkArgCount $command $startArg $notifier 1 3
set isTclGlobalScript 0
set isTclProc 1
if {[$command argsCount]-$startArg+1==3} {
set nameElem [$command getElem $startArg]
incr startArg
set argumentElem [$command getElem $startArg]
incr startArg
set bodyElem [$command getElem $startArg]
my parseArguments $argumentElem
my evalContents $bodyElem
if {[$nameElem hasclass PrsLiteral]} {
set desc [my registerMethod [$nameElem prsString] $bodyElem proc]
$command set def [list method [list $object proc [$nameElem prsString]]]
if {$visibilty in {public default}} {
$repository registerProc [$nameElem prsString] $desc [my joinNamespace $name]
}
}
my cleanupLocalVars
}
set isTclGlobalScript 1
}
PrsITclContext instproc def_set {command startArg notifier visibilty} {
my instvar repository name namespace
my checkArgCount $command $startArg $notifier 1 2
set varName [$command getElem $startArg]
incr startArg
set valueElem [$command getElem $startArg]
my addVariableFrom $varName $notifier [my getTypeFromElem $valueElem] [list instproc $name]
}
PrsITclContext instproc def_variable {command startArg notifier visibility} {
my instvar repository name namespace parameters
my checkArgCount $command $startArg $notifier 1 3
set argsCount [expr {[$command argsCount]-$startArg+1}]
if {$argsCount>=2} {
set type [my getTypeFromElem [$command getElem $startArg]]
} else {
set type [list def]
}
set varNameElem [$command getElem $startArg]
my addVariableFrom $varNameElem $notifier $type [list instproc $name]
if {$visibility eq "public" && [$varNameElem hasclass PrsVariableRef]} {
lappend parameters [$varNameElem getVariableName]
}
}
PrsITclContext instproc evalClassBody {command context notifier} {
my instvar repository name namespace object varArr parameters superclasses
set nameElem [$command getElem 1]
if {[$nameElem hasclass PrsLiteral]} {
set name [$nameElem prsString]
set body [$command getElem 2]
set object [$repository registerObject $name ::itcl::class itcl::object {} $namespace]
$command set def [list object $object]
set class [$repository getFullObjectName $name $namespace]
my addVariable this {} $notifier [list class $class] [list instproc $name]
$body evalContents
$body visit [self]
$repository registerObject $name ::itcl::class $superclasses $parameters $namespace
set initDesc [$repository getMethodDescriptionForClasses $name init $namespace]
set call [list]
lappend call [list [list class $class] "create instance of itcl $class"]
set options [list option]
set allParameters [list]
foreach c [$repository getFullHeritage $class] {
foreach p [$repository getClassParameters $c] {
set type [$repository getVariableType $class instproc $p]
if {$type eq "" || $type eq "def"} {
set type unknown
}
lappend allParameters $p
lappend options -$p $type
}
}
if {[llength $options]>0} {
lappend call [list ? $options]
}
if {$initDesc ne ""} {
foreach p [lrange [lindex $initDesc 1] 1 end] {
lappend call $p
}
}
set createDesc [list [linsert $call 1 [list string "instance name"]]]
$repository registerMethod $class proc create $createDesc
set enumList [list]
foreach p $allParameters {
lappend enumList -$p
}
$repository registerMethod $class instproc cget [list [list unknown [list [concat enum $enumList]]]]
set configureDesc [list]
lappend configureDesc [list list]
lappend configureDesc [list unknown [list $options]]
lappend configureDesc [list list [concat enum $enumList]]
$repository registerMethod $class instproc configure $configureDesc
}
}
PrsITclContext instproc init {} {
my instvar isTclGlobalScript defaultVisibility parameters superclasses
set defaultVisibility default
set isTclGlobalScript 1
set parameters [list]
set superclasses [list ::itcl::object]
}
PrsITclContext instproc parseArguments argumentsElem {
my instvar repository name namespace variablesList
set variablesList $argumentsElem
$variablesList extractList
foreach v [$variablesList getAsList] {
$v extractList
set list [$v getAsList]
set parName [[lindex $list 0] prsString]
set type unknown
if {[llength $list]>1} {
set type [my getTypeFromElem [lindex $list 1]]
}
my addVariableFrom [lindex $list 0] {} $type
}
}
PrsITclContext instproc parse_body_method {functionName command notifier} {
my instvar repository name namespace isTclGlobalScript
set isTclGlobalScript 0
set startArg 2
set argumentElem [$command getElem $startArg]
incr startArg
set bodyElem [$command getElem $startArg]
my parseArguments $argumentElem
my evalContents $bodyElem
my registerMethod $functionName $bodyElem
my cleanupLocalVars
set isTclGlobalScript 1
}
PrsITclContext instproc registerMethod {methodName body {mtype instproc}} {
my instvar variablesList parser repository object isTclproc name isInstproc varArr isTclGlobalScript namespace
my resolveVarRefs
set types [list unknown]
foreach v [$variablesList getAsList] {
$v extractList
set list [$v getAsList]
if {[llength $list]>0} {
set parName [[lindex $list 0] prsString]
} else {
set parName [$v prsString]
}
set mult {}
if {[llength $list]>1} {
set mult ?
}
if {$parName eq "args"} {
set mult *
}
if {$mult ne ""} {
if {$parName ne "args"} {
lappend types [list $mult [my getVariableType $parName] $parName]
} else {
lappend types [list $mult unknown $parName]
}
} else {
lappend types [list [my getVariableType $parName] $parName]
}
}
if {[$body exists lastCommand]} {
lset types 0 [list [[$body set lastCommand] getType]]
}
set desc [list $types]
$repository registerMethod $name $mtype $methodName $desc $namespace
return $desc
}
Class PrsLiteral -superclass ::PrsElement
@ PrsLiteral idemeta component IDETclParser
PrsLiteral instproc canAssignType {context rtype} {
my instvar type
if {[my canAssignTypeBase $rtype $context]} {
return 1
}
next
}
PrsLiteral instproc canAssignTypeBase {type context} {
set content [my prsString]
set type0 [lindex $type 0]
if {($type0 eq "tk" || ($type0 eq "new" && [lindex $type 1] eq "tk")) && [regexp {^\.($|[_a-z])} $content]} {
return 1
} elseif {$type0 eq "boolean" && [string is boolean $content]} {
return 1
} elseif {$type0 eq "int" && [string is integer $content]} {
return 1
} elseif {$type0 eq "double" && [string is double $content]} {
return 1
} elseif {$type0 eq "index" && ([string is integer $content] || [regexp {end(-\d+)?} $content])} {
return 1
} elseif {$type0 eq "channelid" && $content in {stdin stderr stdout}} {
return 1
} elseif {$type0 eq "list" && ![catch {lindex $content 0}]} {
return 1
} elseif {$type0 eq "pixel" && [regexp {^\d*\.?\d+[cimp]?$} $content]} {
return 1
} elseif {$type0 eq "new"} {
return 1
} elseif {$type0 eq "enum" && $content in [lrange $type 1 end]} {
return 1
} elseif {$type0 eq "color" && [ttype::isColor $content]} {
return 1
} elseif {[lindex $type 0] in {tk xotcl class}} {
set repo [$context set repository]
set classes [$repo getFullHeritage [my prsString] [$context set namespace]]
if {[llength $type]==1} {
switch -exact -- [lindex $type 0] {
tk {
return [expr {"::widget" in $classes}]
}
xotcl {
return [expr {"::xotcl::Object" in $classes || "Class" in $classes}]
}
default {
return 1
}
}
}
if {[lindex $type 1] in $classes} {
set type $type
return 1
}
}
return 0
}
PrsLiteral instproc checkRefAsType {rtype context notifier} {
set rtypeName [lindex $rtype 1]
set refType [lindex $rtype 0]
set varName [my getVariableName]
set hasVariable [$context checkVariable $varName]
set mtype [$context getVariableType $varName]
set mtype0 [lindex $mtype 0]
if {$mtype0 eq "unknown" && $refType eq "ref" && !$hasVariable} {
$notifier addError "expected reference to variable of $rtypeName" [self]
return 0
}
if {$mtype0 eq "unknown" && $refType eq "setref"} {
$context addVariableFrom [self] $notifier $rtypeName
return 1
}
if {$rtypeName eq "unknown"} {
return 1
}
if {[$context checkVariableType $varName $rtypeName]} {
return 1
}
if {$mtype0 eq "array"} {
$notifier addError "can not use array as reference to '$rtypeName'" [self]
} else {
$notifier addError "possibly error expect variable reference of type '$rtypeName' seems to be '$mtype'" [self]
}
return 0
}
PrsLiteral instproc getStringSubType {} {
set content [my prsString]
if {$content eq ""} {
return empty
} elseif {[regexp {^\.($|[_a-z])} $content]} {
return tk
} elseif {[regexp {end(-\d+)?} $content]} {
return index
} elseif {$content in {stdin stderr stdout}} {
return channelid
} elseif {[regexp {^\d*\.?\d+[cimp]?$} $content]} {
return pixel
} elseif {[ttype::isColor $content]} {
return color
}
return
}
PrsLiteral instproc getTypeWithContext {context {suggestedType {}}} {
my instvar type
if {[info exists type]} {
return $type
}
if {$suggestedType ne "" && [my canAssignTypeBase $suggestedType $context]} {
set type $suggestedType
} else {
set content [my prsString]
if {[string is integer $content]} {
set type int
} elseif {[string is double $content]} {
set type double
} elseif {[regexp {end(-\d+)?} $content]} {
set type index
} else {
set type [list string [my getStringSubType]]
}
}
return $type
}
PrsLiteral instproc getVariableName {} {
my prsString
}
PrsLiteral instproc isLiteral literal {
expr {[my prsString] eq $literal}
}
PrsLiteral instproc parseAsVariableRef {} {
my basicParseAsVariableRef
}
Class PrsNoSubst -superclass ::PrsElementList
@ PrsNoSubst idemeta component IDETclParser
PrsNoSubst instproc checkAsType {rtype context notifier} {
my instvar operation
set mtype [my getType]
set rtype0 [lindex $rtype 0]
set mtype0 [lindex $mtype 0]
if {$mtype0 eq "unknown"} {
my setType $rtype
if {$rtype0 eq "body"} {
if {![info exists operation] || $operation ne "eval"} {
$context evalContents [self]
}
} elseif {$rtype0 eq "script"} {
if {![info exists operation] || $operation ne "eval"} {
$context subParseGlobal [self] $notifier {}
}
}
return 1
}
if {[$context canAssignType $rtype $mtype]} {
return 1
}
if {$rtype0 in {ref setref wref}} {
return [my checkRefAsType $rtype $context $notifier]
} else {
if {$mtype0 eq "array"} {
$notifier addError "can not use array as $rtype0" [self]
} else {
$notifier addError "possibly error expect as '[join $rtype]' but is '[join $mtype]'" [self]
}
return 0
}
}
PrsNoSubst instproc evalContents {} {
my basicEvalContents
my instvar list lastCommand
if {[info exists list]} {
foreach e [lreverse $list] {
if {[$e hasclass PrsCommand]} {
set lastCommand $e
break
}
}
}
}
PrsNoSubst instproc evalExpr {context notifier} {
my basicEvalExpr $context $notifier
}
PrsNoSubst instproc extractList {} {
my basicExtractList
}
PrsNoSubst instproc getContentOffset {} {
return 1
}
PrsNoSubst instproc getEvalType {} {
my instvar lastCommand
if {[info exists lastCommand]} {
return [$lastCommand getType]
}
return void
}
PrsNoSubst instproc substituteContents {} {
my basicSubstituteContents
}
Class PrsNoSubstOwnContext -superclass ::PrsNoSubst -parameter context
@ PrsNoSubstOwnContext idemeta component IDETclParser
PrsNoSubstOwnContext instproc visit visitor {
[my context] visit [self]
next [my context]
}
Class PrsQuoted -superclass ::PrsElementList -parameter {{hasQuote 0}}
@ PrsQuoted idemeta component IDETclParser
PrsQuoted instproc canAssignType {context type} {
if {[my canAssignTypeBase $type]} {
return 1
}
next
}
PrsQuoted instproc canAssignTypeBase type {
set type0 [lindex $type 0]
if {$type0 eq "tk" || ($type0 eq "new" && [lindex $type 1] eq "tk")} {
set literal [my getLiteralAfterVariable]
if {[regexp {^\.[_a-z]} $literal]} {
return 1
}
} elseif {$type eq "index"} {
if {[regexp {^end-} [my prsString]]} {
return 1
}
}
return 0
}
PrsQuoted instproc changeToLiteralListIfPossible {} {
if {![my hasList]} {
set content [my prsContentString]
if {[regexp {\s} $content]} {
my class PrsNoSubst
}
}
}
PrsQuoted instproc getContentOffset {} {
my instvar hasQuote
expr {$hasQuote ? 1 : 0}
}
PrsQuoted instproc getLiteralAfterVariable {} {
my instvar list end
if {[my isVariablePlusLiteral]} {
return [[[my getParser] stream] copyFromTo [expr {[[lindex $list 0] set end]+1}] [my end]]
}
return
}
PrsQuoted instproc getStringSubType {} {
set content [my prsContentString]
if {$content eq ""} {
return empty
}
return
}
PrsQuoted instproc getTypeWithContext {context {suggestedType {}}} {
my instvar type
if {[info exists type]} {
return $type
}
if {$suggestedType ne "" && [my canAssignTypeBase $suggestedType]} {
set type $suggestedType
} else {
if {[my isTkWidgetType $context]} {
set type [list tk]
} else {
set type [list string [my getStringSubType]]
}
}
return $type
}
PrsQuoted instproc getVariableName {} {
my prsString
}
PrsQuoted instproc isTkWidgetType context {
my instvar list
set literal [my getLiteralAfterVariable]
if {[regexp {^\.} $literal]} {
set first [lindex $list 0]
if {[$first hasclass PrsVariable]} {
set t [$context getTypeFromElem $first]
set t0 [lindex $t 0]
if {$t0 in {unknown tk}} {
return 1
}
}
}
return 0
}
PrsQuoted instproc isVariablePlusLiteral {} {
my instvar list begin hasQuote
expr {!$hasQuote && [info exists list] && [llength $list]>=1 && [[lindex $list 0] set begin]==$begin}
}
PrsQuoted instproc parseAsVariableRef {} {
set content [my prsContentString]
if {[regexp {^[\w:]+\(.+\)$} $content]} {
my basicParseAsVariableRef
}
}
PrsQuoted instproc substituteContents {} {
my basicSubstituteContents
}
Class PrsScript -superclass ::PrsNoSubst
@ PrsScript idemeta component IDETclParser
PrsScript instproc getContentOffset {} {
return 0
}
Class PrsSubContextMix
@ PrsSubContextMix idemeta component IDETclParser
Class PrsSubContext -superclass {::PrsSubContextMix ::PrsContext} -parameter notifier
@ PrsSubContext idemeta component IDETclParser
PrsSubContext instproc init {} {
my initBase
}
Class PrsVariable -superclass ::PrsElement
@ PrsVariable idemeta component IDETclParser
PrsVariable instproc checkAsType {type context notifier} {
set name [my getVariableName]
if {[my isArray]} {
set type [list array $type]
}
set istype [$context getVariableType $name]
if {![$context checkVariableType $name $type]} {
$notifier addError "expect variable '$name' as '$type' but is '$istype'" [self]
return 0
}
return 1
}
PrsVariable instproc checkSyntax {context notifier} {
set name [my getVariableName]
if {![$context checkVariable $name]} {
$notifier addError "unknown variable $name" [self]
} else {
set isArray [my isArray]
set type [lindex [$context getVariableType $name] 0]
if {$type ni {def unknown}} {
if {$isArray && $type ne "array"} {
$notifier addError "variable is scalar $type but is used as array" [self]
} elseif {!$isArray && $type eq "array"} {
$notifier addError "variable is array but is used as scalar" [self]
}
}
}
}
PrsVariable instproc getVariableName {} {
my set varName
}
PrsVariable instproc isArray {} {
my exists key
}
PrsVariable instproc visit visitor {
next
if {[my exists key]} {
[my set key] visit $visitor
}
}
PrsVariable instproc visitPost visitor {
if {[my exists key]} {
[my set key] visitPost $visitor
}
next
}
Class PrsVariableRef -superclass ::PrsElement
@ PrsVariableRef idemeta component IDETclParser
PrsVariableRef instproc checkRefAsType {rtype context notifier} {
set rtypeName [lindex $rtype 1]
if {$rtypeName eq ""} {
set rtypeName unknown
}
set refType [lindex $rtype 0]
if {$refType in {gref setgref}} {
set scope global
} else {
set scope local
}
set varName [my getVariableName]
set hasVariable [$context checkVariable $varName $rtypeName $scope]
set mtype [$context getVariableType $varName]
set mtype0 [lindex $mtype 0]
if {$mtype0 eq "unknown" && $refType in {ref gref} && !$hasVariable} {
$notifier addError "expected reference to variable of $rtypeName" [self]
return 0
}
if {$mtype0 eq "unknown" && $refType eq "setref"} {
$context addVariableFrom [self] $notifier $rtypeName
return 1
}
if {$mtype0 eq "unknown" && $refType eq "setgref"} {
$context addVariableFrom [self] $notifier $rtypeName $scope
return 1
}
if {$rtypeName eq "unknown"} {
return 1
}
if {$mtype0 eq "array" && [my isArray]} {
set mtype [lrange $mtype 1 end]
if {[$context canAssignType $rtypeName $mtype]} {
return 1
} else {
$context updateComplexType $varName $mtype $rtypeName $scope
return 1
}
}
if {[my isArray]} {
set rtypeName [list array $rtypeName]
}
if {[$context checkVariableType $varName $rtypeName]} {
return 1
}
if {$mtype0 eq "array"} {
$notifier addError "can not use array as reference to '$rtypeName'" [self]
} else {
$notifier addError "possibly error expect variable reference of type '$rtypeName' seems to be '$mtype'" [self]
}
return 0
}
PrsVariableRef instproc getVariableName {} {
my set varName
}
PrsVariableRef instproc isArray {} {
my exists key
}
PrsVariableRef instproc visit visitor {
next
if {[my exists key]} {
[my set key] visit $visitor
}
}
@ Class ReadStringStream {
description {This class wrap a string to use it as a stream.
Additional you can set the last position (end of stream)}
}
Class ReadStringStream -parameter {string pos lastpos}
@ ReadStringStream idemeta component IDETclParser
ReadStringStream instproc addPos add {
my incr pos $add
}
ReadStringStream instproc atEnd {} {
my instvar pos lastpos
expr {$pos>$lastpos}
}
ReadStringStream instproc copyFromTo {from to} {
my instvar string
string range $string $from $to
}
ReadStringStream instproc copyFromToLineEnd from {
my instvar string
if {[regexp -start $from -linestop {.+} $string match]} {
return $match
}
return
}
ReadStringStream instproc getChar {} {
my instvar pos string
string index $string $pos
}
ReadStringStream instproc getFromCurrent len {
my instvar pos string
string range $string $pos [expr {$pos+$len-1}]
}
ReadStringStream instproc getRest {} {
my instvar pos string lastpos
if {[info exists lastpos]} {
set epos $lastpos
} else {
set epos end
}
string range $string $pos $lastpos
}
ReadStringStream instproc init {} {
my pos 0
my lastpos [expr {[my length]-1}]
}
ReadStringStream instproc length {} {
string length [my string]
}
ReadStringStream instproc nextChar {} {
my instvar pos string
set ret [string index $string $pos]
incr pos
return $ret
}
ReadStringStream instproc setString tstring {
my string $tstring
my pos 0
my lastpos [expr {[my length]-1}]
}
Class TclExprParser -parameter parser
@ TclExprParser idemeta component IDETclParser
TclExprParser instproc addError {message {token {}}} {
my instvar isError elem valueStack
set isError 1
if {$token eq ""} {
if {[llength $valueStack]>0} {
set telem [lindex $valueStack end 0 0]
if {![Object isobject $telem]} {
set telem $elem
}
} else {
set telem $elem
}
} else {
set telem $token
}
$elem lappend perror [list $telem $message]
}
TclExprParser instproc applyTypes {opElem values types} {
my instvar context notifier
set opValue [my getOpValue $opElem]
set ok 1
set realTypes [list]
set hasEqEmpty 0
if {$opValue in {eq ne}} {
foreach v $values {
if {[llength $v]>1} {
continue
}
set v0 [lindex $v 0]
if {([$v0 hasclass PrsQuoted] || [$v0 hasclass PrsNoSubst]) && [$v0 prsContentString] eq ""} {
set hasEqEmpty 1
break
}
}
if {$hasEqEmpty} {
$opElem set type boolean
return
}
}
foreach v $values t [lrange $types 1 end] {
if {$t ne "" && [llength $v]>0} {
set v0 [lindex $v 0]
if {[$v0 checkAsType $t $context $notifier]} {
lappend realTypes [$context getTypeFromElem $v0]
} else {
set ok 0
}
}
}
set retType [lindex $types 0]
if {$ok} {
if {$retType eq "%n"} {
set tretType int
foreach r $realTypes {
if {$r eq "numeric"} {
set tretType numeric
} elseif {$r eq "double" && $tretType ne "numeric"} {
set tretType double
} elseif {$r in {unknown def}} {
set tretType numeric
}
}
set retType $tretType
} elseif {$retType eq "?"} {
set retType [lindex $realTypes 1]
}
}
if {$retType eq "%n"} {
set retType numeric
}
$opElem set type $retType
}
TclExprParser instproc closeBrace {} {
my instvar valueStack opStack
if {[llength $opStack]==0} {
my addError "unmatched braces"
return
}
set commaCount 0
while {[my getOpValue [lindex $opStack end]] ne "("} {
if {[my getOpValue [lindex $opStack end]] eq ","} {
incr commaCount
set opStack [lrange $opStack 0 end-1]
} else {
my consumeOp
}
if {[llength $opStack]==0} {
my addError "unmatched braces"
return
}
}
set openBrace [lindex $opStack end]
set opStack [lrange $opStack 0 end-1]
set retType numeric
if {[llength $opStack]>0} {
set top [lindex $opStack end]
set functionName [my getOpValue $top]
set functArgCount [my getFunctionArgCount $functionName]
if {$functArgCount!=-2} {
set functionTypes [my getFunctionTypes $functionName]
if {$functArgCount!=-1 && $functArgCount!=$commaCount+1 && $functArgCount!=0 && $commaCount!=0} {
my addError "funct $top expect $functArgCount arguments but was [expr {$commaCount+1}]"
return
}
if {$functArgCount>0} {
set values [lrange $valueStack end-$commaCount end]
my applyTypes $top $values $functionTypes
set braceToken [concat $top $values]
set valueStack [lreplace $valueStack end-$commaCount end $braceToken]
} else {
$top set type [lindex $functionTypes 0]
lappend valueStack [list $top]
}
set opStack [lrange $opStack 0 end-1]
return
}
}
if {$commaCount>0} {
my addError "found comma wihout function"
return
}
set braceValue [lindex $valueStack end]
$openBrace set type [[lindex $braceValue 0] getType]
set braceToken [list $openBrace $braceValue]
lset valueStack end $braceToken
}
TclExprParser instproc consumeComma {} {
my instvar valueStack opStack
if {[llength $opStack]==0} {
my addError "can not find function by comma"
}
while {[my getOpValue [lindex $opStack end]] ni {( ,}} {
my consumeOp
if {[llength $opStack]==0} {
my addError "can not find function by comma"
}
}
}
TclExprParser instproc consumeOp {} {
my instvar valueStack opStack
set op [lindex $opStack end]
set opValue [my getOpValue $op]
if {$opValue eq ""} {
return
}
if {$opValue eq "("} {
my addError "unmatched braces" $op
return
}
if {$opValue eq "?"} {
my addError "? operator without :" $op
return
}
set arity [my getOpArity $op]
set opStack [lrange $opStack 0 end-1]
if {$opValue eq ":"} {
if {[llength $opStack]==0 || [my getOpValue [lindex $opStack end]] ne "?"} {
my addError ": operator without leading ?"
return
}
set opStack [lrange $opStack 0 end-1]
}
set endShif $arity
incr endShif -1
if {[llength $valueStack]<$arity} {
my addError "expression error not enough values for [my getOpValue $op]"
return
}
set values [lrange $valueStack end-$endShif end]
set valueStack [lrange $valueStack 0 end-$arity]
my applyTypes $op $values [my getOpTypes $op]
lappend valueStack [concat $op $values]
}
TclExprParser instproc emtyStacks {} {
my instvar valueStack opStack isError
while {[llength $opStack]>0 && !$isError} {
my consumeOp
}
}
TclExprParser instproc getFunctionArgCount functName {
my instvar functionsArr
if {[info exists functionsArr($functName)]} {
return [lindex $functionsArr($functName) 0]
}
return -2
}
TclExprParser instproc getFunctionTypes functName {
my instvar functionsArr
if {[info exists functionsArr($functName)]} {
return [lrange $functionsArr($functName) 1 end]
}
return
}
TclExprParser instproc getNextToken {} {
my instvar stream parser elem
$parser skipBlanks
set exprRest [$stream getRest]
if {$exprRest eq ""} {
return {}
}
switch -regexp -matchvar hit -- $exprRest {
{^[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?} {
set tokenType value
}
{^0[xbo][0-9]+} {
set tokenType value
}
{^(round|wide|sqrt|sin|log10|double|hypot|atan|bool|rand|abs|acos|atan2|entier|srand|sinh|log|floor|tanh|tan|isqrt|int|asin|min|ceil|cos|cosh|exp|pow|max|fmod)} {
set tokenType funct
}
{^(==|ne|\*\*|!=|ni|\|\||<<|<=|>=|&&|>>|eq|in|[!%&*+|<\-^>~?/:])} {
set tokenType op
}
{^\(} {
set tokenType (
}
{^,} {
set tokenType ,
}
{^\)} {
set tokenType )
}
{^:} {
set tokenType :
}
{^\$} {
set selem [$parser getVariable $elem]
if {$selem eq ""} {
my addError "unknown part $exprRest"
return
}
$elem addElem $selem
return [list $selem value]
}
{^\[} {
set selem [$parser getBeginingCommandSubstPure $elem]
$elem addElem $selem
return [list $selem value]
}
{^"} {
set selem [$parser getQuoted $elem]
$elem addElem $selem
return [list $selem value]
}
{\{} {
set selem [$parser getNoSubst $elem]
$elem addElem $selem
return [list $selem value]
}
default {
my addError "unknown part $exprRest"
return
}
}
set tokenValue [lindex $hit 0]
set end [$stream pos]
incr end [string length $tokenValue]
incr end -1
set literal [PrsLiteral new -childof $elem -begin [$stream pos] -end $end]
$elem addElem $literal
$stream addPos [string length $tokenValue]
return [list $literal $tokenType]
}
TclExprParser instproc getOpArity op {
my instvar operatorsArr
lindex $operatorsArr([my getOpValue $op]) 1
}
TclExprParser instproc getOpTypes op {
my instvar operatorsArr
lindex $operatorsArr([my getOpValue $op]) 2
}
TclExprParser instproc getOpValue op {
if {[$op exists op]} {
return [$op set op]
}
$op prsString
}
TclExprParser instproc init {} {
my instvar operatorsArr functionsArr
array set functionsArr {
abs {1 %n numeric}
acos {1 double numeric}
asin {1 double numeric}
atan {1 double numeric}
atan2 {2 double numeric numeric}
bool {1 boolean boolean}
ceil {1 double numeric}
cos {1 double numeric}
cosh {1 double numeric}
double {1 double numeric}
entier {1 int numeric}
exp {1 double numeric}
floor {1 double numeric}
fmod {2 double numeric numeric}
hypot {2 double numeric numeric}
int {1 int numeric}
isqrt {1 int numeric}
log {1 double numeric}
log10 {1 double numeric}
max {-1 numeric}
min {-1 numeric}
pow {2 numeric numeric int}
rand {0 double}
round {1 int numeric}
sin {1 double numeric}
sinh {1 double numeric}
sqrt {1 double numeric}
srand {1 double int}
tan {1 double numeric}
tanh {1 double numeric}
wide {1 int numeric}
}
array set operatorsArr {
( {100 1}
-_ {0 1 {%n numeric}} +_ {0 1 {%n numeric}} ~ {0 1 {int int}} ! {0 1 {boolean boolean}}
** {1 1 {%n numeric numeric}}
* {2 2 {%n numeric numeric}}
/ {2 2 {%n numeric numeric}}
% {2 2 {int int int}}
- {3 2 {%n numeric numeric}}
+ {3 2 {%n numeric numeric}}
<< {4 2 {int int int}} >> {4 2 {int int int}}
< {5 2 {boolean numeric numeric}}
> {5 2 {boolean numeric numeric}}
<= {5 2 {boolean numeric numeric}}
>= {5 2 {boolean numeric numeric}}
== {6 2 {boolean numeric numeric}}
!= {6 2 {boolean numeric numeric}}
eq {7 2 {boolean string string}}
ne {7 2 {boolean string string}}
in {8 2 {boolean string list}}
ni {8 2 {boolean string list}}
& {9 2 {int int int}}
^ {9 2 {int int int}}
| {9 2 {int int int}}
&& {10 2 {boolean boolean boolean}}
|| {11 2 {boolean boolean boolean}}
: {12 3 ? boolean unknown unknown}
? {13 3 ? boolean unknown unknown}
, {1000 1 {}}
}
if {[PrsCheckerOptions set oldStringOp]} {
array set operatorsArr {
== {6 2 {boolean unknown unknown}}
!= {6 2 {boolean unknown unknown}}
}
}
}
TclExprParser instproc opPriority op {
my instvar operatorsArr
lindex $operatorsArr([my getOpValue $op]) 0
}
TclExprParser instproc parseExprTo {pelem tcontext tnotifier} {
my instvar elem stream parser isError valueStack opStack context notifier
set elem $pelem
set context $tcontext
set notifier $tnotifier
set stream [$parser stream]
set valueStack [list]
set opStack [list]
set isError 0
set lastType op
$elem class PrsExpr
set count 0
while {!$isError} {
set token [my getNextToken]
incr count
if {$count>100} {
error "end loop"
}
if {$isError} {
return
}
if {[llength $token]==0} {
my emtyStacks
if {[llength $valueStack]!=1} {
my addError "error in expression missing operator"
return
}
$elem set exprTree [lindex $valueStack end]
$elem set type [[lindex $valueStack end 0] getType]
return
}
lassign $token tokValue tokType
if {($lastType eq $tokType && $tokType ni {( )}) || ($tokType eq "op" && $lastType eq "(")} {
if {$tokType eq "op" && [my getOpValue $tokValue] in {+ - ! ~}} {
if {[my getOpValue $tokValue] in {+ -}} {
$tokValue set op [$tokValue prsString]_
}
lappend opStack ${tokValue}
continue
}
my addError "mismatch in expression same type $tokType" $tokValue
return
}
switch -exact $tokType {
op {
my pushOp $tokValue
}
value {
lappend valueStack $tokValue
}
( {
lappend opStack $tokValue
}
) {
if {$lastType eq "("} {
if {[my getFunctionArgCount [lindex $opStack end-1]]==-2} {
my addError "empty braces wihtout function" $tokValue
return
}
}
my closeBrace
}
, {
my consumeComma
lappend opStack $tokValue
}
funct {
lappend opStack $tokValue
}
default {
my addError "unknown token type $tokType" $tokValue
return
}
}
set lastType $tokType
}
}
TclExprParser instproc pushOp opValue {
my instvar opStack isError
set opPrority [my opPriority $opValue]
set i 0
while {[llength $opStack]!=0 && $opPrority>[my opPriority [lindex $opStack end]] && !$isError} {
incr i
my consumeOp
if {$i>1000} {
error "endless loop"
}
}
lappend opStack $opValue
}
@ Class TclParser {
description {This class can parse tcl code from stream parameter
that consists ReadStringStream object or compatible and produce parse tree.
The parsing can be startet this prs-structure category commands.
getList try to parse string as list element.
parseScriptTo parse stream as command contents to and build parse tree.
substituteTo parse stream as quoted string for command and variable substitution.
The parser is used normaly from PrsContext.
Parser has a special handling of parser errors.
You should use the paraser in this way
set ret [$parser catchParseErrors {$parser parseScriptTo $parser}]
if {$ret} {
puts "parsing was ok"
} else {
puts "parsing has errors"
}
}
}
Class TclParser -parameter {stream root}
@ TclParser idemeta categories {stream-delegation prs-errors prs-structure initialize list-elems}
@ TclParser idemeta categoriesMethods {{getChar skipSeparators skipToWordEnd searchCloseBrace skipUpTo skipUpToCharacters skipCharacters getCharWithMasking skipBlanks} {hasParseErrors parseError catchParseErrors} {getComment parseScriptTo getCommandOrComment getCommand extractListTo getList getArrayKey substituteTo} init {getCommandSubst getQuoted getNoSubst getBeginingCommandSubst getCharKeySequence getVariable getCharSequence getBeginingVariable}}
@ TclParser idemeta component IDETclParser
TclParser instproc addElement elem {
my instvar parseElements
lappend parseElements $elem
return $elem
}
TclParser instproc catchParseErrors eval {
if {[TclParser isDevelMode]} {
uplevel $eval
return 1
}
set ret [catch {uplevel $eval} result options]
if {$ret==0} {
return 1
} elseif {$ret==1020} {
return 0
} else {
return -options $options $result
}
}
TclParser instproc cleanUp {} {
my instvar root parseElements
if {[info exists root] && [Object isobject $root]} {
$root destroy
set root {}
}
if {[info exists parseElements]} {
foreach e $parseElements {
if {[Object isobject $e]} {
$e destroy
}
}
set parseElements [list]
}
}
TclParser instproc extractListTo parent {
my instvar stream
my skipCharacters "\t \n"
while {![$stream atEnd]} {
set elemList [my getList $parent]
$parent addElem $elemList
my skipCharacters "\t \n"
}
}
TclParser instproc getArg parent {
my instvar stream
my skipSeparators
set char [$stream getChar]
switch -exact -- $char {
\[ {
return [my getBeginingCommandSubst $parent]
}
\{ {
if {[$parent hasclass PrsCommand] && [regexp {^{\*}\S$} [$stream getFromCurrent 4]]} {
set argumentExpansion [PrsArgumentExpansion new -childof $parent -begin [$stream pos]]
$stream addPos 3
set elem [my getList $argumentExpansion]
$argumentExpansion end [$elem end]
$argumentExpansion addElem $elem
return $argumentExpansion
} else {
return [my getNoSubst $parent]
}
}
\" {
return [my getQuoted $parent]
}
\$ {
set var [my getBeginingVariable $parent]
if {$var eq ""} {
return [my getCharSequence $parent]
} else {
return $var
}
}
default {
return [my getCharSequence $parent]
}
}
}
TclParser instproc getArrayKey parent {
my instvar stream terminalChar
if {[$stream getChar] ne "("} return
$stream addPos 1
set char [$stream getChar]
set oldTerminalChar $terminalChar
set terminalChar )
switch -- $char {
\[ {
set key [my getBeginingCommandSubst $parent]
}
\$ {
set key [my getBeginingVariable $parent 1]
if {$key eq ""} {
set key [my getCharKeySequence $parent]
}
}
default {
set key [my getCharKeySequence $parent]
}
}
set terminalChar $oldTerminalChar
if {[$stream atEnd] || [$stream getChar] ne ")"} {
my parseError "Can not parse array key"
return
}
$parent set key $key
$stream addPos 1
}
TclParser instproc getBeginingCommandSubst parent {
my instvar stream
set begin [$stream pos]
my parseCommandSubst
set end [$stream pos]
$stream addPos 1
set char [$stream getChar]
if {[my isEndList]} {
set commandsubst [PrsCommandSubst new -childof $parent -begin $begin -end $end]
$commandsubst evalContents
return $commandsubst
} else {
set quote [PrsQuoted new -childof $parent -begin $begin]
set commandsubst [PrsCommandSubst new -childof $quote -begin $begin -end $end]
$commandsubst evalContents
$quote addElem $commandsubst
while {![my isEndList]} {
switch -- $char {
\$ {
set var [my getVariable $quote]
if {$var ne ""} {
$quote addElem $var
} else {
$stream addPos 1
}
}
\[ {
$quote addElem [my getCommandSubst $quote]
}
}
my skipUpToCharacters ";\[\$\t \n"
set char [$stream getChar]
}
$quote end [expr {[$stream pos]-1}]
return $quote
}
}
TclParser instproc getBeginingCommandSubstPure parent {
my instvar stream
set begin [$stream pos]
my parseCommandSubst
set end [$stream pos]
$stream addPos 1
set char [$stream getChar]
set commandsubst [PrsCommandSubst new -childof $parent -begin $begin -end $end]
$commandsubst evalContents
return $commandsubst
}
TclParser instproc getBeginingVariable {parent {isArrayKey 0}} {
my instvar stream
set pbegin [$stream pos]
set variable [my getVariable $parent]
if {$variable eq ""} {
return
}
set char [$stream getChar]
if {[my isEndList]} {
return $variable
} else {
$variable destroy
$stream pos $pbegin
if {$isArrayKey} {
return [my getCharKeySequence $parent]
} else {
return [my getCharSequence $parent]
}
}
}
TclParser instproc getChar {} {
[my stream] getChar
}
TclParser instproc getCharKeySequence parent {
my instvar stream
set begin [$stream pos]
my skipUpToCharacters ";\[\$\t \n)"
set char [$stream getChar]
if {[my isEndList]} {
set charseq [PrsLiteral new -childof $parent -begin $begin]
$charseq end [expr {[$stream pos]-1}]
return $charseq
} else {
set quote [PrsQuoted new -childof $parent -begin $begin]
while {![my isEndList]} {
switch -- $char {
\$ {
set var [my getVariable $quote]
if {$var ne ""} {
$quote addElem $var
} else {
$stream addPos 1
}
}
\[ {
$quote addElem [my getCommandSubst $quote]
}
}
my skipUpToCharacters ";\[\$\t \n)"
set char [$stream getChar]
}
$quote end [expr {[$stream pos]-1}]
return $quote
}
}
@ TclParser instproc getCharSequence {} {
description {This procedure parse string that not begin with special tcl
control characters.
It can return an PrsLitaral when it is normal string with no special
characters or PrsQuoted if they consists tcl substitutions elements as
$variable or [command]}
}
TclParser instproc getCharSequence parent {
my instvar stream
set begin [$stream pos]
while 1 {
my skipUpToCharacters ";\[\$\t \n"
set char [$stream getChar]
if {$char eq "\$"} {
if {![my isRealVariableBegin]} {
$stream addPos 1
continue
}
}
break
}
if {[my isEndList]} {
set charseq [PrsLiteral new -childof $parent -begin $begin]
$charseq end [expr {[$stream pos]-1}]
return $charseq
} else {
set quote [PrsQuoted new -childof $parent -begin $begin]
while {![my isEndList]} {
switch -- $char {
\$ {
set var [my getVariable $quote]
if {$var ne ""} {
$quote addElem $var
} else {
$stream addPos 1
}
}
\[ {
$quote addElem [my getCommandSubst $quote]
}
}
my skipUpToCharacters ";\[\$\t \n"
set char [$stream getChar]
}
$quote end [expr {[$stream pos]-1}]
return $quote
}
}
TclParser instproc getCharSequenceListElem parent {
my instvar stream
set begin [$stream pos]
my skipUpToCharacters "\[\$\t \n"
set char [$stream getChar]
if {[my isEndList]} {
set charseq [PrsLiteral new -childof $parent -begin $begin]
$charseq end [expr {[$stream pos]-1}]
return $charseq
} else {
set quote [PrsQuoted new -childof $parent -begin $begin]
while {![my isEndList]} {
switch -- $char {
\$ {
set var [my getVariable $quote]
if {$var ne ""} {
$quote addElem $var
} else {
$stream addPos 1
}
}
\[ {
$quote addElem [my getCommandSubst $quote]
}
}
my skipUpToCharacters "\[\$\t \n"
set char [$stream getChar]
}
$quote end [expr {[$stream pos]-1}]
return $quote
}
}
TclParser instproc getCharWithMasking {} {
my instvar stream
set c [$stream getChar]
if {$c eq "\\" && ![$stream atEnd]} {
set c [$stream getFromCurrent 2]
}
return $c
}
TclParser instproc getCommand parent {
my instvar stream
set command [PrsCommand new -childof $parent -begin [$stream pos]]
while 1 {
$command addElem [my getArg $command]
my skipSeparators
set char [$stream getChar]
if {[$stream atEnd] || $char eq "\n"} {
$command end [expr {[$stream pos]-1}]
return $command
}
if {$char eq ";"} {
$command end [expr {[$stream pos]-1}]
$stream addPos 1
return $command
}
}
}
TclParser instproc getCommandOrComment parent {
if {[my getChar] eq "#"} {
return [my getComment $parent]
} else {
return [my getCommand $parent]
}
}
TclParser instproc getCommandSubst parent {
my instvar stream
set commandsubst [PrsCommandSubst new -childof $parent -begin [$stream pos]]
my parseCommandSubst
$commandsubst end [$stream pos]
$stream addPos 1
$commandsubst evalContents
return $commandsubst
}
TclParser instproc getComment parent {
my instvar stream
set begin [$stream pos]
my skipUpTo \n
PrsComment new -childof $parent -begin $begin -end [expr {[$stream pos]-1}]
}
TclParser instproc getList parent {
my instvar stream
my skipSeparators
set char [my getCharWithMasking]
switch -exact -- $char {
\{ {
return [my getNoSubst $parent]
}
\" {
set quote [PrsQuoted new -childof $parent -begin [$stream pos] -hasQuote 1]
$stream addPos 1
my skipUpTo \"
$quote end [$stream pos]
$stream addPos 1
return $quote
}
default {
set literal [PrsLiteral new -childof $parent -begin [$stream pos]]
my skipUpToCharacters "\t \n"
$literal end [expr {[$stream pos]-1}]
$stream addPos 1
return $literal
}
}
}
TclParser instproc getNoSubst parent {
my instvar stream
set commandsubst [PrsNoSubst new -childof $parent -begin [$stream pos]]
my parseNoSubst
$commandsubst end [$stream pos]
$stream addPos 1
return $commandsubst
}
TclParser instproc getQuoted parent {
my instvar stream
set quote [PrsQuoted new -childof $parent -begin [$stream pos] -hasQuote 1]
$stream addPos 1
my parseQuote
$quote end [$stream pos]
$stream addPos 1
$quote substituteContents
return $quote
}
@ TclParser instproc getVariable {} {
description {This can parse following expresions
$a $a(2) ${a} ${a(3)} $a([set b])
}
}
TclParser instproc getVariable parent {
my instvar stream
if {![my isRealVariableBegin]} {
return
}
set variable [PrsVariable new -childof $parent -begin [$stream pos]]
$stream addPos 1
set firstChar [$stream getChar]
set varNameStartPos [$stream pos]
if {$firstChar eq "\{"} {
my parseNoSubst
incr varNameStartPos
set varNameEndPos [expr {[$stream pos]-1}]
$variable end [expr {$varNameEndPos+1}]
$stream addPos 1
} else {
my skipToWordEnd
set varNameEndPos [expr {[$stream pos]-1}]
$variable end $varNameEndPos
my getArrayKey $variable
}
$variable set varName [$stream copyFromTo $varNameStartPos $varNameEndPos]
return $variable
}
TclParser instproc hasParseErrors {} {
expr {[my exists parseErrors] && [llength [my set parseErrors]]>0}
}
TclParser instproc init args {
my set terminalChar {}
}
TclParser instproc isEndList {} {
set char [[my stream] getChar]
expr {[[my stream] atEnd] || [string is space $char] || $char eq ";" || $char eq [my set terminalChar]}
}
TclParser instproc isRealVariableBegin {} {
my instvar stream
$stream addPos 1
set firstChar [$stream getChar]
$stream addPos -1
regexp {[\w\{:]} $firstChar
}
TclParser instproc parseCommandSubst {} {
my instvar stream
set open 0
set parseQuote 1
while {![$stream atEnd]} {
set c [my getCharWithMasking]
switch -- $c {
\[ {
incr open
}
\] {
incr open -1
if {$open==0} {
return 1
}
}
\{ {
my parseNoSubst
}
\" {
if {$parseQuote} {
my parseQuote
}
}
}
set parseQuote [string is space $c]
$stream addPos [string length $c]
}
my parseError "Parse Error: can not find closing \]"
}
TclParser instproc parseError text {
my instvar stream parseErrors
lappend parseErrors [list [$stream pos] [$stream pos] $text]
if {[[self class] isDevelMode]} {
error $text
} else {
return -code 1020
}
}
TclParser instproc parseExprTo {elem context notifier} {
my instvar exprParser
if {![info exists exprParser]} {
set exprParser [TclExprParser new -childof [self] -parser [self]]
}
$exprParser parseExprTo $elem $context $notifier
return $elem
}
TclParser instproc parseNoSubst {} {
my searchCloseBrace \{ \}
}
TclParser instproc parseQuote {} {
my instvar stream
while {![$stream atEnd]} {
set c [my getCharWithMasking]
switch -- $c {
\" {
return 1
}
\[ {
my parseCommandSubst
}
}
$stream addPos [string length $c]
}
my parseError "Parse Error: can not find closing \""
}
TclParser instproc parseScriptTo parent {
my instvar stream
my skipBlanks
while {![$stream atEnd]} {
$parent addElem [my getCommandOrComment $parent]
my skipBlanks
}
}
TclParser instproc parseVariableRef variable {
my instvar stream
set varNameStartPos [$stream pos]
if {[$stream getChar] eq "\{"} {
my parseNoSubst
incr varNameStartPos
set varNameEndPos [expr {[$stream pos]-1}]
$variable end [expr {$varNameEndPos+1}]
$stream addPos 1
} else {
my skipUpTo (
set varNameEndPos [expr {[$stream pos]-1}]
$variable end $varNameEndPos
my getArrayKey $variable
}
$variable set varName [$stream copyFromTo $varNameStartPos $varNameEndPos]
return $variable
}
TclParser instproc searchCloseBrace {obrace cbrace} {
my instvar stream
set open 0
while {![$stream atEnd]} {
set c [my getCharWithMasking]
if {$c eq $obrace} {
incr open
} elseif {$c eq $cbrace} {
incr open -1
if {$open==0} {
return 1
}
}
$stream addPos [string length $c]
}
my parseError "Parse Error: can not find closing $cbrace"
}
TclParser instproc skipBlanks {} {
my instvar stream
set char [my getCharWithMasking]
while {![$stream atEnd] && ([string is control $char] || [string is space $char] || $char eq "\\\n")} {
$stream addPos [string length $char]
set char [my getCharWithMasking]
}
}
TclParser instproc skipCharacters string {
my instvar stream
set char [my getCharWithMasking]
while {![$stream atEnd] && [string first $char $string]!=-1} {
$stream addPos [string length $char]
set char [$stream getChar]
}
}
TclParser instproc skipSeparators {} {
my instvar stream
set char [$stream getChar]
while {![$stream atEnd] && [string first $char "\t \\"]!=-1} {
if {$char eq "\\"} {
if {[$stream atEnd]} {
return
}
$stream addPos 1
set char [$stream getChar]
if {$char ne "\n"} {
$stream addPos -1
return
}
}
$stream addPos 1
set char [$stream getChar]
}
}
TclParser instproc skipToWordEnd {} {
my instvar stream
set char [$stream getChar]
while {![$stream atEnd] && ([string is wordchar $char] || $char eq ":")} {
if {$char eq ":"} {
if {[$stream atEnd]} {
return
}
$stream addPos 1
set char [$stream getChar]
if {$char ne ":"} {
$stream addPos -1
return
} else {
set char [$stream getChar]
while {![$stream atEnd] && $char eq ":"} {
$stream addPos 1
set char [$stream getChar]
}
continue
}
}
$stream addPos 1
set char [$stream getChar]
}
}
TclParser instproc skipUpTo echar {
my instvar stream
set char [my getCharWithMasking]
while {![$stream atEnd] && $char ne $echar} {
$stream addPos [string length $char]
set char [my getCharWithMasking]
}
}
TclParser instproc skipUpToCharacters string {
my instvar stream
set char [my getCharWithMasking]
while {![$stream atEnd] && [string first $char $string]==-1} {
$stream addPos [string length $char]
set char [my getCharWithMasking]
}
}
TclParser instproc substituteTo parent {
my instvar stream
my skipBlanks
while {![$stream atEnd]} {
set char [my getCharWithMasking]
switch -- $char {
\[ {
$parent addElem [my getCommandSubst $parent]
continue
}
\$ {
set obj [my getVariable $parent]
if {$obj ne ""} {
$parent addElem $obj
} else {
$stream addPos [string length $char]
}
continue
}
}
$stream addPos [string length $char]
}
}
TclParser proc getVersion {} {
return 0.10
}
TclParser proc isDevelMode {} {
if {[my exists develMode]} {
return [my set develMode]
}
return 0
}
TclParser proc setDevelMode {{mode 1}} {
my set develMode $mode
}
Object PrsCheckerOptions
@ PrsCheckerOptions idemeta component IDETclParser
PrsCheckerOptions proc allowSetTypeChange {} {
return 1
}
PrsCheckerOptions proc allowVarRef {} {
my set allowVarRef
}
PrsCheckerOptions proc checkTypes {} {
my set checkTypes
}
PrsCheckerOptions proc getRootDir {} {
my set rootDir
}
PrsCheckerOptions proc initializeAfterLoad {} {
my set checkTypes 1
my set rootDir [pwd]
my set oldStringOp 0
my set allowVarRef 0
}
catch {PrsCheckerOptions initializeAfterLoad}