1static char cmd[] = 2"# $Id: predefined.xotcl,v 1.16 2007/09/05 19:09:22 neumann Exp $\n" 3"foreach cmd [info command ::xotcl::Object::instcmd::*] {\n" 4"::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd}\n" 5"foreach cmd {array append eval incr lappend trace subst unset} {\n" 6"::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" 7"foreach cmd [info command ::xotcl::Class::instcmd::*] {\n" 8"::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" 9"unset cmd\n" 10"::xotcl::Object instproc init args {}\n" 11"::xotcl::Object create ::xotcl::@\n" 12"::xotcl::@ proc unknown args {}\n" 13"proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]}\n" 14"proc ::xotcl::myvar {var} {::xotcl::my requireNamespace; return [::xotcl::self]::$var}\n" 15"namespace eval ::xotcl { namespace export @ myproc myvar Attribute}\n" 16"::xotcl::setrelation ::xotcl::Class::Parameter superclass ::xotcl::Class\n" 17"::xotcl::Class::Parameter instproc mkParameter {obj name args} {\n" 18"if {[$obj exists $name]} {\n" 19"eval [$obj set $name] configure $args} else {\n" 20"$obj set $name [eval ::xotcl::my new -childof $obj $args]}}\n" 21"::xotcl::Class::Parameter instproc getParameter {obj name args} {\n" 22"[$obj set $name]}\n" 23"::xotcl::Class::Parameter proc Class {param args} {\n" 24"::xotcl::my set access [lindex $param 0]\n" 25"::xotcl::my set setter mkParameter\n" 26"::xotcl::my set getter getParameter\n" 27"::xotcl::my set extra {[::xotcl::self]}\n" 28"::xotcl::my set defaultParam [lrange $param 1 end]}\n" 29"::xotcl::Class::Parameter proc default {val} {\n" 30"[::xotcl::my set cl] set __defaults([::xotcl::my set name]) $val}\n" 31"::xotcl::Class::Parameter proc setter x {\n" 32"::xotcl::my set setter $x}\n" 33"::xotcl::Class::Parameter proc getter x {\n" 34"::xotcl::my set getter $x}\n" 35"::xotcl::Class::Parameter proc access obj {\n" 36"::xotcl::my set access $obj\n" 37"::xotcl::my set extra \\[::xotcl::self\\]\n" 38"foreach v [$obj info vars] {::xotcl::my set $v [$obj set $v]}}\n" 39"::xotcl::Class::Parameter proc values {param args} {\n" 40"set cl [::xotcl::my set cl]\n" 41"set ci [$cl info instinvar]\n" 42"set valueTest {}\n" 43"foreach a $args {\n" 44"::lappend valueTest \"\\[\\$cl set $param\\] == [list $a]\"}\n" 45"::lappend ci [join $valueTest \" || \"]\n" 46"$cl instinvar $ci}\n" 47"::xotcl::Class create ::xotcl::MetaSlot\n" 48"::xotcl::setrelation ::xotcl::MetaSlot superclass ::xotcl::Class\n" 49"::xotcl::MetaSlot instproc new args {\n" 50"set slotobject [self callingobject]::slot\n" 51"if {![my isobject $slotobject]} {Object create $slotobject; namespace eval $slotobject {namespace import ::xotcl::*; puts stderr IMPORT}}\n" 52"eval next -childof $slotobject $args}\n" 53"::xotcl::MetaSlot create ::xotcl::Slot -array set __defaults {\n" 54"name \"[namespace tail [::xotcl::self]]\"\n" 55"domain \"[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]\"\n" 56"defaultmethods {get assign}\n" 57"manager \"[::xotcl::self]\"\n" 58"multivalued false\n" 59"per-object false}\n" 60"foreach p {name domain defaultmethods manager default multivalued type\n" 61"per-object initcmd valuecmd valuechangedcmd} {\n" 62"::xotcl::Slot instparametercmd $p}\n" 63"unset p\n" 64"::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar\n" 65"::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar\n" 66"::xotcl::Slot instproc add {obj prop value {pos 0}} {\n" 67"if {![my multivalued]} {\n" 68"error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" 69"if {[$obj exists $prop]} {\n" 70"$obj set $prop [linsert [$obj set $prop] $pos $value]} else {\n" 71"$obj set $prop [list $value]}}\n" 72"::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} {\n" 73"set old [$obj set $prop]\n" 74"set p [lsearch -glob $old $value]\n" 75"if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else {\n" 76"error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" 77"::xotcl::Slot instproc unknown {method args} {\n" 78"set methods [list]\n" 79"foreach m [my info methods] {\n" 80"if {[::xotcl::Object info methods $m] ne \"\"} continue\n" 81"if {[string match __* $m]} continue\n" 82"lappend methods $m}\n" 83"error \"Method '$method' unknown for slot [self]; valid are: {[lsort $methods]]}\"}\n" 84"::xotcl::Slot instproc init {} {\n" 85"my instvar name domain manager\n" 86"set forwarder [expr {[my per-object] ? \"forward\" : \"instforward\"}]\n" 87"if {$domain eq \"\"} {\n" 88"set domain [self callingobject]}\n" 89"$domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc}\n" 90"::xotcl::MetaSlot create ::xotcl::InfoSlot -array set __defaults {\n" 91"multivalued true\n" 92"elementtype ::xotcl::Class}\n" 93"::xotcl::InfoSlot instparametercmd elementtype\n" 94"::xotcl::setrelation ::xotcl::InfoSlot superclass ::xotcl::Slot\n" 95"::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop}\n" 96"::xotcl::InfoSlot instproc add {obj prop value {pos 0}} {\n" 97"if {![my multivalued]} {\n" 98"error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" 99"$obj $prop [linsert [$obj info $prop] $pos $value]}\n" 100"::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} {\n" 101"set old [$obj info $prop]\n" 102"if {[string first * $value] > -1 || [string first \\[ $value] > -1} {\n" 103"if {[my elementtype] ne \"\" && ![string match ::* $value]} {\n" 104"set value ::$value}\n" 105"return [$obj $prop [lsearch -all -not -glob -inline $old $value]]} elseif {[my elementtype] ne \"\"} {\n" 106"if {[string first :: $value] == -1} {\n" 107"if {![my isobject $value]} {\n" 108"error \"$value does not appear to be an object\"}\n" 109"set value [$value self]}\n" 110"if {![$value isclass [my elementtype]]} {\n" 111"error \"$value does not appear to be of type [my elementtype]\"}}\n" 112"set p [lsearch -exact $old $value]\n" 113"if {$p > -1} {\n" 114"$obj $prop [lreplace $old $p $p]} else {\n" 115"error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" 116"::xotcl::MetaSlot create ::xotcl::InterceptorSlot\n" 117"::xotcl::setrelation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot\n" 118"::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::setrelation ;# for backwards compatibility\n" 119"::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::setrelation\n" 120"::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} {\n" 121"if {![my multivalued]} {\n" 122"error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" 123"$obj $prop [linsert [$obj info $prop -guards] $pos $value]}\n" 124"namespace eval ::xotcl::Class::slot {}\n" 125"namespace eval ::xotcl::Object::slot {}\n" 126"::xotcl::InfoSlot create ::xotcl::Class::slot::superclass\n" 127"::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::setrelation\n" 128"::xotcl::InfoSlot create ::xotcl::Object::slot::class\n" 129"::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::setrelation\n" 130"::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin\n" 131"::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype \"\"\n" 132"::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin\n" 133"::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype \"\"\n" 134"::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot\n" 135"foreach p {default value_check initcmd valuecmd valuechangedcmd} {\n" 136"::xotcl::Attribute instparametercmd $p}\n" 137"unset p\n" 138"::xotcl::Attribute array set __defaults {\n" 139"value_check once}\n" 140"::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} {\n" 141"$obj trace remove variable $var $op [list [self] [self proc] $obj $cmd]\n" 142"$obj set $var [$obj eval $cmd]}\n" 143"::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} {\n" 144"$obj set $var [$obj eval $cmd]}\n" 145"::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} {\n" 146"eval $cmd}\n" 147"::xotcl::Attribute instproc destroy {} {\n" 148"next}\n" 149"::xotcl::Attribute instproc check_single_value {\n" 150"{-keep_old_value:boolean true}\n" 151"value predicate type obj var} {\n" 152"if {![expr $predicate]} {\n" 153"if {[$obj exists __oldvalue($var)]} {\n" 154"$obj set $var [$obj set __oldvalue($var)]} else {\n" 155"$obj unset -nocomplain $var}\n" 156"error \"$value is not of type $type\"}\n" 157"if {$keep_old_value} {$obj set __oldvalue($var) $value}}\n" 158"::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} {\n" 159"foreach value $values {\n" 160"my check_single_value -keep_old_value false $value $predicate $type $obj $var}\n" 161"$obj set __oldvalue($var) $value}\n" 162"::xotcl::Attribute instproc mk_type_checker {} {\n" 163"set __initcmd \"\"\n" 164"if {[my exists type]} {\n" 165"my instvar type name\n" 166"if {[::xotcl::Object isclass $type]} {\n" 167"set predicate [subst -nocommands {[::xotcl::Object isobject \\$value]\n" 168"&& [\\$value istype $type]}]} elseif {[llength $type]>1} {\n" 169"set predicate \"\\[$type \\$value\\]\"} else {\n" 170"set predicate \"\\[string is $type \\$value\\]\"}\n" 171"my append valuechangedcmd [subst {\n" 172"my [expr {[my multivalued] ? \"check_multiple_values\" : \"check_single_value\"}] \\[\\$obj set $name\\] \\\n" 173"{$predicate} [list $type] \\$obj $name}]\n" 174"append __initcmd [subst -nocommands {\n" 175"if {[my exists $name]} {my set __oldvalue($name) [my set $name]}\\n}]}\n" 176"return $__initcmd}\n" 177"::xotcl::Attribute instproc init {} {\n" 178"my instvar domain name\n" 179"next ;# do first ordinary slot initialization\n" 180"$domain unset -nocomplain __defaults($name)\n" 181"set __initcmd \"\"\n" 182"if {[my exists default]} {\n" 183"if {[my per-object] && ![$domain exists $name]} {\n" 184"$domain set $name [my default]} elseif {![my per-object]} {\n" 185"$domain set __defaults($name) [my default]}} elseif [my exists initcmd] {\n" 186"append __initcmd \"my trace add variable [list $name] read \\\n" 187"\\[list [self] __default_from_cmd \\[self\\] [list [my initcmd]]\\]\\n\"} elseif [my exists valuecmd] {\n" 188"append __initcmd \"my trace add variable [list $name] read \\\n" 189"\\[list [self] __value_from_cmd \\[self\\] [list [my valuecmd]]\\]\"}\n" 190"append __initcmd [my mk_type_checker]\n" 191"if {[my exists valuechangedcmd]} {\n" 192"append __initcmd \"my trace add variable [list $name] write \\\n" 193"\\[list [self] __value_changed_cmd \\[self\\] [list [my valuechangedcmd]]\\]\"}\n" 194"if {$__initcmd ne \"\"} {\n" 195"if {[my per-object]} {\n" 196"$domain eval $__initcmd} else {\n" 197"$domain set __initcmds($name) $__initcmd}}}\n" 198"::xotcl::Class create ::xotcl::Slot::Nocheck \\\n" 199"-instproc check_single_value args {;} -instproc check_multiple_values args {;} \\\n" 200"-instproc mk_type_checker args {return \"\"}\n" 201"::xotcl::Class create ::xotcl::Slot::Optimizer \\\n" 202"-instproc proc args {::xotcl::next; ::xotcl::my optimize} \\\n" 203"-instproc forward args {::xotcl::next; ::xotcl::my optimize} \\\n" 204"-instproc init args {::xotcl::next; ::xotcl::my optimize} \\\n" 205"-instproc optimize {} {\n" 206"if {[::xotcl::my multivalued]} return\n" 207"if {[::xotcl::my defaultmethods] ne {get assign}} return\n" 208"if {[::xotcl::my procsearch assign] ne \"::xotcl::Slot instcmd assign\"} return\n" 209"if {[::xotcl::my procsearch get] ne \"::xotcl::Slot instcmd get\"} return\n" 210"set forwarder [expr {[::xotcl::my per-object] ? \"parametercmd\":\"instparametercmd\"}]\n" 211"[::xotcl::my domain] $forwarder [::xotcl::my name]}\n" 212"::xotcl::Slot instmixin add ::xotcl::Slot::Optimizer\n" 213"::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class \\\n" 214"-array set __defaults {withclass ::xotcl::Object}\n" 215"::xotcl::ScopedNew instparametercmd withclass\n" 216"::xotcl::ScopedNew instparametercmd inobject\n" 217"::xotcl::ScopedNew instproc init {} {\n" 218"::xotcl::my instproc new {-childof args} {\n" 219"[::xotcl::self class] instvar {inobject object} withclass\n" 220"if {![::xotcl::my isobject $object]} {\n" 221"$withclass create $object}\n" 222"eval ::xotcl::next -childof $object $args}}\n" 223"::xotcl::Object instproc contains {\n" 224"{-withnew:boolean true}\n" 225"-object\n" 226"{-class ::xotcl::Object}\n" 227"cmds} {\n" 228"if {![info exists object]} {set object [::xotcl::self]}\n" 229"if {![::xotcl::my isobject $object]} {\n" 230"$class create $object\n" 231"$object requireNamespace}\n" 232"if {$withnew} {\n" 233"set m [::xotcl::ScopedNew new \\\n" 234"-inobject $object -withclass $class -volatile]\n" 235"::xotcl::Class instmixin add $m end\n" 236"namespace eval $object $cmds\n" 237"::xotcl::Class instmixin delete $m} else {\n" 238"namespace eval $object $cmds}}\n" 239"::xotcl::Class instforward slots %self contains \\\n" 240"-object {%::xotcl::my subst [::xotcl::self]::slot}\n" 241"::xotcl::Class instproc parameter arglist {\n" 242"if {![::xotcl::my isobject [self]::slot]} {::xotcl::Object create [self]::slot}\n" 243"foreach arg $arglist {\n" 244"set l [llength $arg]\n" 245"set name [lindex $arg 0]\n" 246"if {$l == 1} {\n" 247"::xotcl::Attribute create [::xotcl::self]::slot::$name} elseif {$l == 2} {\n" 248"::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 1]]} elseif {$l == 3 && [lindex $arg 1] eq \"-default\"} {\n" 249"::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 2]]} else {\n" 250"set paramstring [string range $arg [expr {[string length $name]+1}] end]\n" 251"if {[string match {[$\\[]*} $paramstring]} {\n" 252"::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default $paramstring]\n" 253"continue}\n" 254"set po ::xotcl::Class::Parameter\n" 255"puts stderr \"deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead\"\n" 256"set cl [self]\n" 257"$po set name $name\n" 258"$po set cl [self]\n" 259"::eval $po configure [lrange $arg 1 end]\n" 260"if {[$po exists extra] || [$po exists setter] ||\n" 261"[$po exists getter] || [$po exists access]} {\n" 262"$po instvar extra setter getter access defaultParam\n" 263"if {![info exists extra]} {set extra \"\"}\n" 264"if {![info exists defaultParam]} {set defaultParam \"\"}\n" 265"if {![info exists setter]} {set setter set}\n" 266"if {![info exists getter]} {set getter set}\n" 267"if {![info exists access]} {set access ::xotcl::my}\n" 268"$cl instproc $name args \"\n" 269"if {\\[llength \\$args] == 0} {\n" 270"return \\[$access $getter $extra $name\\]} else {\n" 271"return \\[eval $access $setter $extra $name \\$args $defaultParam \\]}\"\n" 272"foreach instvar {extra defaultParam setter getter access} {\n" 273"$po unset -nocomplain $instvar}} else {\n" 274"::xotcl::my instparametercmd $name}}}\n" 275"[self]::slot set __parameter $arglist}\n" 276"::xotcl::Object instproc self {} {::xotcl::self}\n" 277"::xotcl::Object instproc defaultmethod {} {\n" 278"return [::xotcl::self]}\n" 279"::xotcl::Object instproc hasclass cl {\n" 280"if {[::xotcl::my ismixin $cl]} {return 1}\n" 281"::xotcl::my istype $cl}\n" 282"::xotcl::Class instproc allinstances {} {\n" 283"return [::xotcl::my info instances -closure]}\n" 284"::xotcl::Object proc unsetExitHandler {} {\n" 285"::xotcl::Object proc __exitHandler {} {\n" 286";}}\n" 287"::xotcl::Object unsetExitHandler\n" 288"::xotcl::Object proc setExitHandler {newbody} {\n" 289"::xotcl::Object proc __exitHandler {} $newbody}\n" 290"::xotcl::Object proc getExitHandler {} {\n" 291"::xotcl::Object info body __exitHandler}\n" 292"::xotcl::Object instproc abstract {methtype methname arglist} {\n" 293"if {$methtype ne \"proc\" && $methtype ne \"instproc\" && $methtype ne \"method\"} {\n" 294"error \"invalid method type '$methtype', \\\n" 295"must be either 'proc', 'instproc' or 'method'.\"}\n" 296"::xotcl::my $methtype $methname $arglist \"\n" 297"if {!\\[::xotcl::self isnextcall\\]} {\n" 298"error \\\"Abstract method $methname $arglist called\\\"} else {::xotcl::next}\n" 299"\"}\n" 300"::xotcl::Class create ::xotcl::Object::CopyHandler -parameter {\n" 301"{targetList \"\"}\n" 302"{dest \"\"}\n" 303"objLength}\n" 304"::xotcl::Object::CopyHandler instproc makeTargetList t {\n" 305"::xotcl::my lappend targetList $t\n" 306"if {[::xotcl::my isobject $t]} {\n" 307"if {[$t info hasNamespace]} {\n" 308"set children [$t info children]} else {\n" 309"return}}\n" 310"foreach c [namespace children $t] {\n" 311"if {![::xotcl::my isobject $c]} {\n" 312"lappend children [namespace children $t]}}\n" 313"foreach c $children {\n" 314"::xotcl::my makeTargetList $c}}\n" 315"::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} {\n" 316"::xotcl::namespace_copyvars $orig $dest\n" 317"::xotcl::namespace_copycmds $orig $dest}\n" 318"::xotcl::Object::CopyHandler instproc getDest origin {\n" 319"set tail [string range $origin [::xotcl::my set objLength] end]\n" 320"return ::[string trimleft [::xotcl::my set dest]$tail :]}\n" 321"::xotcl::Object::CopyHandler instproc copyTargets {} {\n" 322"foreach origin [::xotcl::my set targetList] {\n" 323"set dest [::xotcl::my getDest $origin]\n" 324"if {[::xotcl::my isobject $origin]} {\n" 325"if {[::xotcl::my isclass $origin]} {\n" 326"set cl [[$origin info class] create $dest -noinit]\n" 327"set obj $cl\n" 328"$cl superclass [$origin info superclass]\n" 329"$cl parameterclass [$origin info parameterclass]\n" 330"$cl instinvar [$origin info instinvar]\n" 331"$cl instfilter [$origin info instfilter -guards]\n" 332"$cl instmixin [$origin info instmixin]\n" 333"my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest} else {\n" 334"set obj [[$origin info class] create $dest -noinit]}\n" 335"$obj invar [$origin info invar]\n" 336"$obj check [$origin info check]\n" 337"$obj mixin [$origin info mixin]\n" 338"$obj filter [$origin info filter -guards]\n" 339"if {[$origin info hasNamespace]} {\n" 340"$obj requireNamespace}} else {\n" 341"namespace eval $dest {}}\n" 342"::xotcl::my copyNSVarsAndCmds $origin $dest\n" 343"foreach i [$origin info forward] {\n" 344"eval [concat $dest forward $i [$origin info forward -definition $i]]}\n" 345"if {[::xotcl::my isclass $origin]} {\n" 346"foreach i [$origin info instforward] {\n" 347"eval [concat $dest instforward $i [$origin info instforward -definition $i]]}}\n" 348"set traces [list]\n" 349"foreach var [$origin info vars] {\n" 350"set cmds [$origin trace info variable $var]\n" 351"if {$cmds ne \"\"} {\n" 352"foreach cmd $cmds {\n" 353"foreach {op def} $cmd break\n" 354"if {[lindex $def 0] eq $origin} {\n" 355"set def [concat $dest [lrange $def 1 end]]}\n" 356"$dest trace add variable $var $op $def}}}}\n" 357"set origin [lindex [::xotcl::my set targetList] 0]\n" 358"if {[::xotcl::my isclass $origin]} {\n" 359"foreach oldslot [$origin info slots] {\n" 360"set newslot ${cl}::slot::[namespace tail $oldslot]\n" 361"if {[$oldslot domain] eq $origin} {$newslot domain $cl}\n" 362"if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot}}}}\n" 363"::xotcl::Object::CopyHandler instproc copy {obj dest} {\n" 364"::xotcl::my set objLength [string length $obj]\n" 365"::xotcl::my set dest $dest\n" 366"::xotcl::my makeTargetList $obj\n" 367"::xotcl::my copyTargets}\n" 368"::xotcl::Object instproc copy newName {\n" 369"if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} {\n" 370"[[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName}}\n" 371"::xotcl::Object instproc move newName {\n" 372"if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} {\n" 373"if {$newName ne \"\"} {\n" 374"::xotcl::my copy $newName}\n" 375"if {[::xotcl::my isclass [::xotcl::self]] && $newName ne \"\"} {\n" 376"foreach subclass [::xotcl::my info subclass] {\n" 377"set scl [$subclass info superclass]\n" 378"if {[set index [lsearch -exact $scl [::xotcl::self]]] != -1} {\n" 379"set scl [lreplace $scl $index $index $newName]\n" 380"$subclass superclass $scl}} }\n" 381"::xotcl::my destroy}}\n" 382"::xotcl::Object create ::xotcl::config\n" 383"::xotcl::config proc load {obj file} {\n" 384"source $file\n" 385"foreach i [array names ::auto_index [list $obj *proc *]] {\n" 386"set type [lindex $i 1]\n" 387"set meth [lindex $i 2]\n" 388"if {[$obj info ${type}s $meth] == {}} {\n" 389"$obj $type $meth auto $::auto_index($i)}}}\n" 390"::xotcl::config proc mkindex {meta dir args} {\n" 391"set sp {[ ]+}\n" 392"set st {^[ ]*}\n" 393"set wd {([^ ;]+)}\n" 394"foreach creator $meta {\n" 395"::lappend cp $st$creator${sp}create$sp$wd\n" 396"::lappend ap $st$creator$sp$wd}\n" 397"foreach method {proc instproc} {\n" 398"::lappend mp $st$wd${sp}($method)$sp$wd}\n" 399"foreach cl [concat ::xotcl::Class [::xotcl::Class info heritage]] {\n" 400"eval ::lappend meths [$cl info instcommands]}\n" 401"set old [pwd]\n" 402"cd $dir\n" 403"::append idx \"# Tcl autoload index file, version 2.0\\n\"\n" 404"::append idx \"# xotcl additions generated with \"\n" 405"::append idx \"\\\"::xotcl::config::mkindex [list $meta] [list $dir] $args\\\"\\n\"\n" 406"set oc 0\n" 407"set mc 0\n" 408"foreach file [eval glob -nocomplain -- $args] {\n" 409"if {[catch {set f [open $file]} msg]} then {\n" 410"catch {close $f}\n" 411"cd $old\n" 412"error $msg}\n" 413"while {[gets $f line] >= 0} {\n" 414"foreach c $cp {\n" 415"if {[regexp $c $line x obj]==1 &&\n" 416"[string index $obj 0]!={$}} then {\n" 417"::incr oc\n" 418"::append idx \"set auto_index($obj) \"\n" 419"::append idx \"\\\"::xotcl::config::load $obj \\$dir/$file\\\"\\n\"}}\n" 420"foreach a $ap {\n" 421"if {[regexp $a $line x obj]==1 &&\n" 422"[string index $obj 0]!={$} &&\n" 423"[lsearch -exact $meths $obj]==-1} {\n" 424"::incr oc\n" 425"::append idx \"set auto_index($obj) \"\n" 426"::append idx \"\\\"::xotcl::config::load $obj \\$dir/$file\\\"\\n\"}}\n" 427"foreach m $mp {\n" 428"if {[regexp $m $line x obj ty pr]==1 &&\n" 429"[string index $obj 0]!={$} &&\n" 430"[string index $pr 0]!={$}} then {\n" 431"::incr mc\n" 432"::append idx \"set \\{auto_index($obj \"\n" 433"::append idx \"$ty $pr)\\} \\\"source \\$dir/$file\\\"\\n\"}}}\n" 434"close $f}\n" 435"set t [open tclIndex a+]\n" 436"puts $t $idx nonewline\n" 437"close $t\n" 438"cd $old\n" 439"return \"$oc objects, $mc methods\"}\n" 440"::xotcl::Object instproc extractConfigureArg {al name {cutTheArg 0}} {\n" 441"set value \"\"\n" 442"upvar $al argList\n" 443"set largs [llength $argList]\n" 444"for {set i 0} {$i < $largs} {incr i} {\n" 445"if {[lindex $argList $i] == $name && $i + 1 < $largs} {\n" 446"set startIndex $i\n" 447"set endIndex [expr {$i + 1}]\n" 448"while {$endIndex < $largs &&\n" 449"[string first - [lindex $argList $endIndex]] != 0} {\n" 450"lappend value [lindex $argList $endIndex]\n" 451"incr endIndex}}}\n" 452"if {[info exists startIndex] && $cutTheArg != 0} {\n" 453"set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]]}\n" 454"return $value}\n" 455"::xotcl::Object create ::xotcl::rcs\n" 456"::xotcl::rcs proc date string {\n" 457"lreplace [lreplace $string 0 0] end end}\n" 458"::xotcl::rcs proc version string {\n" 459"lindex $string 2}\n" 460"if {![info exists ::env(HOME)]} {set ::env(HOME) /root}\n" 461"set ::xotcl::confdir ~/.xotcl\n" 462"set ::xotcl::logdir $::xotcl::confdir/log\n" 463"::xotcl::Class proc __unknown name {}\n" 464"::xotcl::Class instproc uses list {\n" 465"foreach package $list {\n" 466"::xotcl::package import -into [self] $package\n" 467"puts stderr \"*** using ${package}::* in [self]\"}}\n" 468"::xotcl::Class create ::xotcl::package -superclass ::xotcl::Class -parameter {\n" 469"provide\n" 470"{version 1.0}\n" 471"{autoexport {}}\n" 472"{export {}}}\n" 473"::xotcl::package proc create {name args} {\n" 474"set nq [namespace qualifiers $name]\n" 475"if {$nq ne \"\" && ![namespace exists $nq]} {Object create $nq}\n" 476"next}\n" 477"::xotcl::package proc extend {name args} {\n" 478"my require $name\n" 479"eval $name configure $args}\n" 480"::xotcl::package instproc contains script {\n" 481"if {[my exists provide]} {\n" 482"package provide [my provide] [my version]} else {\n" 483"package provide [self] [my version]}\n" 484"namespace eval [self] {namespace import ::xotcl::*}\n" 485"namespace eval [self] $script\n" 486"foreach e [my export] {\n" 487"set nq [namespace qualifiers $e]\n" 488"if {$nq ne \"\"} {\n" 489"namespace eval [self]::$nq [list namespace export [namespace tail $e]]} else {\n" 490"namespace eval [self] [list namespace export $e]}}\n" 491"foreach e [my autoexport] {\n" 492"namespace eval :: [list namespace import [self]::$e]}}\n" 493"::xotcl::package configure \\\n" 494"-set component . \\\n" 495"-set verbose 0 \\\n" 496"-set packagecmd ::package\n" 497"::xotcl::package proc unknown args {\n" 498"eval [my set packagecmd] $args}\n" 499"::xotcl::package proc verbose value {\n" 500"my set verbose $value}\n" 501"::xotcl::package proc present args {\n" 502"if {$::tcl_version<8.3} {\n" 503"my instvar loaded\n" 504"switch -exact -- [lindex $args 0] {\n" 505"-exact {set pkg [lindex $args 1]}\n" 506"default {set pkg [lindex $args 0]}}\n" 507"if {[info exists loaded($pkg)]} {\n" 508"return $loaded($pkg)} else {\n" 509"error \"not found\"}} else {\n" 510"eval [my set packagecmd] present $args}}\n" 511"::xotcl::package proc import {{-into ::} pkg} {\n" 512"my require $pkg\n" 513"namespace eval $into [subst -nocommands {\n" 514"namespace import ${pkg}::*}]\n" 515"foreach e [$pkg export] {\n" 516"set nq [namespace qualifiers $e]\n" 517"if {$nq ne \"\"} {\n" 518"namespace eval $into$nq [list namespace import ${pkg}::$e]}}}\n" 519"::xotcl::package proc require args {\n" 520"::xotcl::my instvar component verbose uses loaded\n" 521"set prevComponent $component\n" 522"if {[catch {set v [eval package present $args]} msg]} {\n" 523"switch -exact -- [lindex $args 0] {\n" 524"-exact {set pkg [lindex $args 1]}\n" 525"default {set pkg [lindex $args 0]}}\n" 526"set component $pkg\n" 527"lappend uses($prevComponent) $component\n" 528"set v [uplevel \\#1 [my set packagecmd] require $args]\n" 529"if {$v ne \"\" && $verbose} {\n" 530"set path [lindex [::package ifneeded $pkg $v] 1]\n" 531"puts \"... $pkg $v loaded from '$path'\"\n" 532"set loaded($pkg) $v ;# loaded stuff needed for Tcl 8.0}}\n" 533"set component $prevComponent\n" 534"return $v}\n" 535"::xotcl::Object instproc method {name arguments body} {\n" 536"my proc name $arguments $body }\n" 537"::xotcl::Class instproc method {-per-object:switch name arguments body} {\n" 538"if {${per-object}} {\n" 539"my proc $name $arguments $body} else {\n" 540"my instproc $name $arguments $body}}\n" 541"proc ::xotcl::tmpdir {} {\n" 542"foreach e [list TMPDIR TEMP TMP] {\n" 543"if {[info exists ::env($e)] \\\n" 544"&& [file isdirectory $::env($e)] \\\n" 545"&& [file writable $::env($e)]} {\n" 546"return $::env($e)}}\n" 547"if {$::tcl_platform(platform) eq \"windows\"} {\n" 548"foreach d [list \"C:\\\\TEMP\" \"C:\\\\TMP\" \"\\\\TEMP\" \"\\\\TMP\"] {\n" 549"if {[file isdirectory $d] && [file writable $d]} {\n" 550"return $d}}}\n" 551"return /tmp}\n" 552""; 553 554