static char cmd[] = "# $Id: predefined.xotcl,v 1.16 2007/09/05 19:09:22 neumann Exp $\n" "foreach cmd [info command ::xotcl::Object::instcmd::*] {\n" "::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd}\n" "foreach cmd {array append eval incr lappend trace subst unset} {\n" "::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" "foreach cmd [info command ::xotcl::Class::instcmd::*] {\n" "::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" "unset cmd\n" "::xotcl::Object instproc init args {}\n" "::xotcl::Object create ::xotcl::@\n" "::xotcl::@ proc unknown args {}\n" "proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]}\n" "proc ::xotcl::myvar {var} {::xotcl::my requireNamespace; return [::xotcl::self]::$var}\n" "namespace eval ::xotcl { namespace export @ myproc myvar Attribute}\n" "::xotcl::setrelation ::xotcl::Class::Parameter superclass ::xotcl::Class\n" "::xotcl::Class::Parameter instproc mkParameter {obj name args} {\n" "if {[$obj exists $name]} {\n" "eval [$obj set $name] configure $args} else {\n" "$obj set $name [eval ::xotcl::my new -childof $obj $args]}}\n" "::xotcl::Class::Parameter instproc getParameter {obj name args} {\n" "[$obj set $name]}\n" "::xotcl::Class::Parameter proc Class {param args} {\n" "::xotcl::my set access [lindex $param 0]\n" "::xotcl::my set setter mkParameter\n" "::xotcl::my set getter getParameter\n" "::xotcl::my set extra {[::xotcl::self]}\n" "::xotcl::my set defaultParam [lrange $param 1 end]}\n" "::xotcl::Class::Parameter proc default {val} {\n" "[::xotcl::my set cl] set __defaults([::xotcl::my set name]) $val}\n" "::xotcl::Class::Parameter proc setter x {\n" "::xotcl::my set setter $x}\n" "::xotcl::Class::Parameter proc getter x {\n" "::xotcl::my set getter $x}\n" "::xotcl::Class::Parameter proc access obj {\n" "::xotcl::my set access $obj\n" "::xotcl::my set extra \\[::xotcl::self\\]\n" "foreach v [$obj info vars] {::xotcl::my set $v [$obj set $v]}}\n" "::xotcl::Class::Parameter proc values {param args} {\n" "set cl [::xotcl::my set cl]\n" "set ci [$cl info instinvar]\n" "set valueTest {}\n" "foreach a $args {\n" "::lappend valueTest \"\\[\\$cl set $param\\] == [list $a]\"}\n" "::lappend ci [join $valueTest \" || \"]\n" "$cl instinvar $ci}\n" "::xotcl::Class create ::xotcl::MetaSlot\n" "::xotcl::setrelation ::xotcl::MetaSlot superclass ::xotcl::Class\n" "::xotcl::MetaSlot instproc new args {\n" "set slotobject [self callingobject]::slot\n" "if {![my isobject $slotobject]} {Object create $slotobject}\n" "eval next -childof $slotobject $args}\n" "::xotcl::MetaSlot create ::xotcl::Slot -array set __defaults {\n" "name \"[namespace tail [::xotcl::self]]\"\n" "domain \"[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]\"\n" "defaultmethods {get assign}\n" "manager \"[::xotcl::self]\"\n" "multivalued false\n" "per-object false}\n" "foreach p {name domain defaultmethods manager default multivalued type\n" "per-object initcmd valuecmd valuechangedcmd} {\n" "::xotcl::Slot instparametercmd $p}\n" "unset p\n" "::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar\n" "::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar\n" "::xotcl::Slot instproc add {obj prop value {pos 0}} {\n" "if {![my multivalued]} {\n" "error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" "if {[$obj exists $prop]} {\n" "$obj set $prop [linsert [$obj set $prop] $pos $value]} else {\n" "$obj set $prop [list $value]}}\n" "::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} {\n" "set old [$obj set $prop]\n" "set p [lsearch -glob $old $value]\n" "if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else {\n" "error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" "::xotcl::Slot instproc unknown {method args} {\n" "set methods [list]\n" "foreach m [my info methods] {\n" "if {[::xotcl::Object info methods $m] ne \"\"} continue\n" "if {[string match __* $m]} continue\n" "lappend methods $m}\n" "error \"Method '$method' unknown for slot [self]; valid are: {[lsort $methods]]}\"}\n" "::xotcl::Slot instproc init {} {\n" "my instvar name domain manager\n" "set forwarder [expr {[my per-object] ? \"forward\" : \"instforward\"}]\n" "if {$domain eq \"\"} {\n" "set domain [self callingobject]}\n" "$domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot -array set __defaults {\n" "multivalued true\n" "elementtype ::xotcl::Class}\n" "::xotcl::InfoSlot instparametercmd elementtype\n" "::xotcl::setrelation ::xotcl::InfoSlot superclass ::xotcl::Slot\n" "::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop}\n" "::xotcl::InfoSlot instproc add {obj prop value {pos 0}} {\n" "if {![my multivalued]} {\n" "error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" "$obj $prop [linsert [$obj info $prop] $pos $value]}\n" "::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} {\n" "set old [$obj info $prop]\n" "if {[string first * $value] > -1 || [string first \\[ $value] > -1} {\n" "if {[my elementtype] ne \"\" && ![string match ::* $value]} {\n" "set value ::$value}\n" "return [$obj $prop [lsearch -all -not -glob -inline $old $value]]} elseif {[my elementtype] ne \"\"} {\n" "if {[string first :: $value] == -1} {\n" "if {![my isobject $value]} {\n" "error \"$value does not appear to be an object\"}\n" "set value [$value self]}\n" "if {![$value isclass [my elementtype]]} {\n" "error \"$value does not appear to be of type [my elementtype]\"}}\n" "set p [lsearch -exact $old $value]\n" "if {$p > -1} {\n" "$obj $prop [lreplace $old $p $p]} else {\n" "error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" "::xotcl::MetaSlot create ::xotcl::InterceptorSlot\n" "::xotcl::setrelation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot\n" "::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::setrelation ;# for backwards compatibility\n" "::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::setrelation\n" "::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} {\n" "if {![my multivalued]} {\n" "error \"Property $prop of [my domain]->$obj ist not multivalued\"}\n" "$obj $prop [linsert [$obj info $prop -guards] $pos $value]}\n" "namespace eval ::xotcl::Class::slot {}\n" "namespace eval ::xotcl::Object::slot {}\n" "::xotcl::InfoSlot create ::xotcl::Class::slot::superclass\n" "::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::setrelation\n" "::xotcl::InfoSlot create ::xotcl::Object::slot::class\n" "::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::setrelation\n" "::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin\n" "::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype \"\"\n" "::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin\n" "::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype \"\"\n" "::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot\n" "foreach p {default value_check initcmd valuecmd valuechangedcmd} {\n" "::xotcl::Attribute instparametercmd $p}\n" "unset p\n" "::xotcl::Attribute array set __defaults {\n" "value_check once}\n" "::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} {\n" "$obj trace remove variable $var $op [list [self] [self proc] $obj $cmd]\n" "$obj set $var [$obj eval $cmd]}\n" "::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} {\n" "$obj set $var [$obj eval $cmd]}\n" "::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} {\n" "eval $cmd}\n" "::xotcl::Attribute instproc destroy {} {\n" "next}\n" "::xotcl::Attribute instproc check_single_value {\n" "{-keep_old_value:boolean true}\n" "value predicate type obj var} {\n" "if {![expr $predicate]} {\n" "if {[$obj exists __oldvalue($var)]} {\n" "$obj set $var [$obj set __oldvalue($var)]} else {\n" "$obj unset -nocomplain $var}\n" "error \"$value is not of type $type\"}\n" "if {$keep_old_value} {$obj set __oldvalue($var) $value}}\n" "::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} {\n" "foreach value $values {\n" "my check_single_value -keep_old_value false $value $predicate $type $obj $var}\n" "$obj set __oldvalue($var) $value}\n" "::xotcl::Attribute instproc mk_type_checker {} {\n" "set __initcmd \"\"\n" "if {[my exists type]} {\n" "my instvar type name\n" "if {[::xotcl::Object isclass $type]} {\n" "set predicate [subst -nocommands {[::xotcl::Object isobject \\$value]\n" "&& [\\$value istype $type]}]} elseif {[llength $type]>1} {\n" "set predicate \"\\[$type \\$value\\]\"} else {\n" "set predicate \"\\[string is $type \\$value\\]\"}\n" "my append valuechangedcmd [subst {\n" "my [expr {[my multivalued] ? \"check_multiple_values\" : \"check_single_value\"}] \\[\\$obj set $name\\] \\\n" "{$predicate} [list $type] \\$obj $name}]\n" "append __initcmd [subst -nocommands {\n" "if {[my exists $name]} {my set __oldvalue($name) [my set $name]}\\n}]}\n" "return $__initcmd}\n" "::xotcl::Attribute instproc init {} {\n" "my instvar domain name\n" "next ;# do first ordinary slot initialization\n" "$domain unset -nocomplain __defaults($name)\n" "set __initcmd \"\"\n" "if {[my exists default]} {\n" "$domain set __defaults($name) [my default]} elseif [my exists initcmd] {\n" "append __initcmd \"my trace add variable [list $name] read \\\n" "\\[list [self] __default_from_cmd \\[self\\] [list [my initcmd]]\\]\\n\"} elseif [my exists valuecmd] {\n" "append __initcmd \"my trace add variable [list $name] read \\\n" "\\[list [self] __value_from_cmd \\[self\\] [list [my valuecmd]]\\]\"}\n" "append __initcmd [my mk_type_checker]\n" "if {[my exists valuechangedcmd]} {\n" "append __initcmd \"my trace add variable [list $name] write \\\n" "\\[list [self] __value_changed_cmd \\[self\\] [list [my valuechangedcmd]]\\]\"}\n" "if {$__initcmd ne \"\"} {\n" "$domain set __initcmds($name) $__initcmd}}\n" "::xotcl::Class create ::xotcl::Slot::Nocheck \\\n" "-instproc check_single_value args {;} -instproc check_multiple_values args {;} \\\n" "-instproc mk_type_checker args {return \"\"}\n" "::xotcl::Class create ::xotcl::Slot::Optimizer \\\n" "-instproc proc args {::xotcl::next; ::xotcl::my optimize} \\\n" "-instproc forward args {::xotcl::next; ::xotcl::my optimize} \\\n" "-instproc init args {::xotcl::next; ::xotcl::my optimize} \\\n" "-instproc optimize {} {\n" "if {[::xotcl::my multivalued]} return\n" "if {[::xotcl::my defaultmethods] ne {get assign}} return\n" "if {[::xotcl::my procsearch assign] ne \"::xotcl::Slot instcmd assign\"} return\n" "if {[::xotcl::my procsearch get] ne \"::xotcl::Slot instcmd get\"} return\n" "set forwarder [expr {[::xotcl::my per-object] ? \"parametercmd\":\"instparametercmd\"}]\n" "[::xotcl::my domain] $forwarder [::xotcl::my name]}\n" "::xotcl::Slot instmixin add ::xotcl::Slot::Optimizer\n" "::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class \\\n" "-array set __defaults {withclass ::xotcl::Object}\n" "::xotcl::ScopedNew instparametercmd withclass\n" "::xotcl::ScopedNew instparametercmd inobject\n" "::xotcl::ScopedNew instproc init {} {\n" "::xotcl::my instproc new {-childof args} {\n" "[::xotcl::self class] instvar {inobject object} withclass\n" "if {![::xotcl::my isobject $object]} {\n" "$withclass create $object}\n" "eval ::xotcl::next -childof $object $args}}\n" "::xotcl::Object instproc contains {\n" "{-withnew:boolean true}\n" "-object\n" "{-class ::xotcl::Object}\n" "cmds} {\n" "if {![info exists object]} {set object [::xotcl::self]}\n" "if {![::xotcl::my isobject $object]} {$class create $object}\n" "$object requireNamespace\n" "if {$withnew} {\n" "set m [::xotcl::ScopedNew new \\\n" "-inobject $object -withclass $class -volatile]\n" "::xotcl::Class instmixin add $m end\n" "namespace eval $object $cmds\n" "::xotcl::Class instmixin delete $m} else {\n" "namespace eval $object $cmds}}\n" "::xotcl::Class instforward slots %self contains \\\n" "-object {%::xotcl::my subst [::xotcl::self]::slot}\n" "::xotcl::Class instproc parameter arglist {\n" "if {![::xotcl::my isobject [self]::slot]} {::xotcl::Object create [self]::slot}\n" "foreach arg $arglist {\n" "set l [llength $arg]\n" "set name [lindex $arg 0]\n" "if {$l == 1} {\n" "::xotcl::Attribute create [::xotcl::self]::slot::$name} elseif {$l == 2} {\n" "::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 1]]} elseif {$l == 3 && [lindex $arg 1] eq \"-default\"} {\n" "::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 2]]} else {\n" "set paramstring [string range $arg [expr {[string length $name]+1}] end]\n" "if {[string match {[$\\[]*} $paramstring]} {\n" "::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default $paramstring]\n" "continue}\n" "set po ::xotcl::Class::Parameter\n" "puts stderr \"deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead\"\n" "set cl [self]\n" "$po set name $name\n" "$po set cl [self]\n" "::eval $po configure [lrange $arg 1 end]\n" "if {[$po exists extra] || [$po exists setter] ||\n" "[$po exists getter] || [$po exists access]} {\n" "$po instvar extra setter getter access defaultParam\n" "if {![info exists extra]} {set extra \"\"}\n" "if {![info exists defaultParam]} {set defaultParam \"\"}\n" "if {![info exists setter]} {set setter set}\n" "if {![info exists getter]} {set getter set}\n" "if {![info exists access]} {set access ::xotcl::my}\n" "$cl instproc $name args \"\n" "if {\\[llength \\$args] == 0} {\n" "return \\[$access $getter $extra $name\\]} else {\n" "return \\[eval $access $setter $extra $name \\$args $defaultParam \\]}\"\n" "foreach instvar {extra defaultParam setter getter access} {\n" "$po unset -nocomplain $instvar}} else {\n" "::xotcl::my instparametercmd $name}}}\n" "[self]::slot set __parameter $arglist}\n" "::xotcl::Object instproc self {} {::xotcl::self}\n" "::xotcl::Object instproc defaultmethod {} {\n" "return [::xotcl::self]}\n" "::xotcl::Object instproc hasclass cl {\n" "if {[::xotcl::my ismixin $cl]} {return 1}\n" "::xotcl::my istype $cl}\n" "::xotcl::Class instproc allinstances {} {\n" "return [::xotcl::my info instances -closure]}\n" "::xotcl::Object proc unsetExitHandler {} {\n" "::xotcl::Object proc __exitHandler {} {\n" ";}}\n" "::xotcl::Object unsetExitHandler\n" "::xotcl::Object proc setExitHandler {newbody} {\n" "::xotcl::Object proc __exitHandler {} $newbody}\n" "::xotcl::Object proc getExitHandler {} {\n" "::xotcl::Object info body __exitHandler}\n" "::xotcl::Object instproc abstract {methtype methname arglist} {\n" "if {$methtype ne \"proc\" && $methtype ne \"instproc\" && $methtype ne \"method\"} {\n" "error \"invalid method type '$methtype', \\\n" "must be either 'proc', 'instproc' or 'method'.\"}\n" "::xotcl::my $methtype $methname $arglist \"\n" "if {!\\[::xotcl::self isnextcall\\]} {\n" "error \\\"Abstract method $methname $arglist called\\\"} else {::xotcl::next}\n" "\"}\n" "::xotcl::Class create ::xotcl::Object::CopyHandler -parameter {\n" "{targetList \"\"}\n" "{dest \"\"}\n" "objLength}\n" "::xotcl::Object::CopyHandler instproc makeTargetList t {\n" "::xotcl::my lappend targetList $t\n" "if {[::xotcl::my isobject $t]} {\n" "if {[$t info hasNamespace]} {\n" "set children [$t info children]} else {\n" "return}}\n" "foreach c [namespace children $t] {\n" "if {![::xotcl::my isobject $c]} {\n" "lappend children [namespace children $t]}}\n" "foreach c $children {\n" "::xotcl::my makeTargetList $c}}\n" "::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} {\n" "::xotcl::namespace_copyvars $orig $dest\n" "::xotcl::namespace_copycmds $orig $dest}\n" "::xotcl::Object::CopyHandler instproc getDest origin {\n" "set tail [string range $origin [::xotcl::my set objLength] end]\n" "return ::[string trimleft [::xotcl::my set dest]$tail :]}\n" "::xotcl::Object::CopyHandler instproc copyTargets {} {\n" "foreach origin [::xotcl::my set targetList] {\n" "set dest [::xotcl::my getDest $origin]\n" "if {[::xotcl::my isobject $origin]} {\n" "if {[::xotcl::my isclass $origin]} {\n" "set cl [[$origin info class] create $dest -noinit]\n" "set obj $cl\n" "$cl superclass [$origin info superclass]\n" "$cl parameterclass [$origin info parameterclass]\n" "$cl instinvar [$origin info instinvar]\n" "$cl instfilter [$origin info instfilter -guards]\n" "$cl instmixin [$origin info instmixin]\n" "my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest} else {\n" "set obj [[$origin info class] create $dest -noinit]}\n" "$obj invar [$origin info invar]\n" "$obj check [$origin info check]\n" "$obj mixin [$origin info mixin]\n" "$obj filter [$origin info filter -guards]\n" "if {[$origin info hasNamespace]} {\n" "$obj requireNamespace}} else {\n" "namespace eval $dest {}}\n" "::xotcl::my copyNSVarsAndCmds $origin $dest\n" "foreach i [$origin info forward] {\n" "eval [concat $dest forward $i [$origin info forward -definition $i]]}\n" "if {[::xotcl::my isclass $origin]} {\n" "foreach i [$origin info instforward] {\n" "eval [concat $dest instforward $i [$origin info instforward -definition $i]]}}\n" "set traces [list]\n" "foreach var [$origin info vars] {\n" "set cmds [$origin trace info variable $var]\n" "if {$cmds ne \"\"} {\n" "foreach cmd $cmds {\n" "foreach {op def} $cmd break\n" "if {[lindex $def 0] eq $origin} {\n" "set def [concat $dest [lrange $def 1 end]]}\n" "$dest trace add variable $var $op $def}}}}\n" "set origin [lindex [::xotcl::my set targetList] 0]\n" "if {[::xotcl::my isclass $origin]} {\n" "foreach oldslot [$origin info slots] {\n" "set newslot ${cl}::slot::[namespace tail $oldslot]\n" "if {[$oldslot domain] eq $origin} {$newslot domain $cl}\n" "if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot}}}}\n" "::xotcl::Object::CopyHandler instproc copy {obj dest} {\n" "::xotcl::my set objLength [string length $obj]\n" "::xotcl::my set dest $dest\n" "::xotcl::my makeTargetList $obj\n" "::xotcl::my copyTargets}\n" "::xotcl::Object instproc copy newName {\n" "if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} {\n" "[[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName}}\n" "::xotcl::Object instproc move newName {\n" "if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} {\n" "if {$newName ne \"\"} {\n" "::xotcl::my copy $newName}\n" "if {[::xotcl::my isclass [::xotcl::self]] && $newName ne \"\"} {\n" "foreach subclass [::xotcl::my info subclass] {\n" "set scl [$subclass info superclass]\n" "if {[set index [lsearch -exact $scl [::xotcl::self]]] != -1} {\n" "set scl [lreplace $scl $index $index $newName]\n" "$subclass superclass $scl}} }\n" "::xotcl::my destroy}}\n" "::xotcl::Object create ::xotcl::config\n" "::xotcl::config proc load {obj file} {\n" "source $file\n" "foreach i [array names ::auto_index [list $obj *proc *]] {\n" "set type [lindex $i 1]\n" "set meth [lindex $i 2]\n" "if {[$obj info ${type}s $meth] == {}} {\n" "$obj $type $meth auto $::auto_index($i)}}}\n" "::xotcl::config proc mkindex {meta dir args} {\n" "set sp {[ ]+}\n" "set st {^[ ]*}\n" "set wd {([^ ;]+)}\n" "foreach creator $meta {\n" "::lappend cp $st$creator${sp}create$sp$wd\n" "::lappend ap $st$creator$sp$wd}\n" "foreach method {proc instproc} {\n" "::lappend mp $st$wd${sp}($method)$sp$wd}\n" "foreach cl [concat ::xotcl::Class [::xotcl::Class info heritage]] {\n" "eval ::lappend meths [$cl info instcommands]}\n" "set old [pwd]\n" "cd $dir\n" "::append idx \"# Tcl autoload index file, version 2.0\\n\"\n" "::append idx \"# xotcl additions generated with \"\n" "::append idx \"\\\"::xotcl::config::mkindex [list $meta] [list $dir] $args\\\"\\n\"\n" "set oc 0\n" "set mc 0\n" "foreach file [eval glob -nocomplain -- $args] {\n" "if {[catch {set f [open $file]} msg]} then {\n" "catch {close $f}\n" "cd $old\n" "error $msg}\n" "while {[gets $f line] >= 0} {\n" "foreach c $cp {\n" "if {[regexp $c $line x obj]==1 &&\n" "[string index $obj 0]!={$}} then {\n" "::incr oc\n" "::append idx \"set auto_index($obj) \"\n" "::append idx \"\\\"::xotcl::config::load $obj \\$dir/$file\\\"\\n\"}}\n" "foreach a $ap {\n" "if {[regexp $a $line x obj]==1 &&\n" "[string index $obj 0]!={$} &&\n" "[lsearch -exact $meths $obj]==-1} {\n" "::incr oc\n" "::append idx \"set auto_index($obj) \"\n" "::append idx \"\\\"::xotcl::config::load $obj \\$dir/$file\\\"\\n\"}}\n" "foreach m $mp {\n" "if {[regexp $m $line x obj ty pr]==1 &&\n" "[string index $obj 0]!={$} &&\n" "[string index $pr 0]!={$}} then {\n" "::incr mc\n" "::append idx \"set \\{auto_index($obj \"\n" "::append idx \"$ty $pr)\\} \\\"source \\$dir/$file\\\"\\n\"}}}\n" "close $f}\n" "set t [open tclIndex a+]\n" "puts $t $idx nonewline\n" "close $t\n" "cd $old\n" "return \"$oc objects, $mc methods\"}\n" "::xotcl::Object instproc extractConfigureArg {al name {cutTheArg 0}} {\n" "set value \"\"\n" "upvar $al argList\n" "set largs [llength $argList]\n" "for {set i 0} {$i < $largs} {incr i} {\n" "if {[lindex $argList $i] == $name && $i + 1 < $largs} {\n" "set startIndex $i\n" "set endIndex [expr {$i + 1}]\n" "while {$endIndex < $largs &&\n" "[string first - [lindex $argList $endIndex]] != 0} {\n" "lappend value [lindex $argList $endIndex]\n" "incr endIndex}}}\n" "if {[info exists startIndex] && $cutTheArg != 0} {\n" "set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]]}\n" "return $value}\n" "::xotcl::Object create ::xotcl::rcs\n" "::xotcl::rcs proc date string {\n" "lreplace [lreplace $string 0 0] end end}\n" "::xotcl::rcs proc version string {\n" "lindex $string 2}\n" "if {![info exists ::env(HOME)]} {set ::env(HOME) /root}\n" "set ::xotcl::confdir ~/.xotcl\n" "set ::xotcl::logdir $::xotcl::confdir/log\n" "::xotcl::Class proc __unknown name {}\n" "::xotcl::Class instproc uses list {\n" "foreach package $list {\n" "::xotcl::package import -into [self] $package\n" "puts stderr \"*** using ${package}::* in [self]\"}}\n" "::xotcl::Class create ::xotcl::package -superclass ::xotcl::Class -parameter {\n" "provide\n" "{version 1.0}\n" "{autoexport {}}\n" "{export {}}}\n" "::xotcl::package proc create {name args} {\n" "set nq [namespace qualifiers $name]\n" "if {$nq ne \"\" && ![namespace exists $nq]} {Object create $nq}\n" "next}\n" "::xotcl::package proc extend {name args} {\n" "my require $name\n" "eval $name configure $args}\n" "::xotcl::package instproc contains script {\n" "if {[my exists provide]} {\n" "package provide [my provide] [my version]} else {\n" "package provide [self] [my version]}\n" "namespace eval [self] {namespace import ::xotcl::*}\n" "namespace eval [self] $script\n" "foreach e [my export] {\n" "set nq [namespace qualifiers $e]\n" "if {$nq ne \"\"} {\n" "namespace eval [self]::$nq [list namespace export [namespace tail $e]]} else {\n" "namespace eval [self] [list namespace export $e]}}\n" "foreach e [my autoexport] {\n" "namespace eval :: [list namespace import [self]::$e]}}\n" "::xotcl::package configure \\\n" "-set component . \\\n" "-set verbose 0 \\\n" "-set packagecmd ::package\n" "::xotcl::package proc unknown args {\n" "eval [my set packagecmd] $args}\n" "::xotcl::package proc verbose value {\n" "my set verbose $value}\n" "::xotcl::package proc present args {\n" "if {$::tcl_version<8.3} {\n" "my instvar loaded\n" "switch -exact -- [lindex $args 0] {\n" "-exact {set pkg [lindex $args 1]}\n" "default {set pkg [lindex $args 0]}}\n" "if {[info exists loaded($pkg)]} {\n" "return $loaded($pkg)} else {\n" "error \"not found\"}} else {\n" "eval [my set packagecmd] present $args}}\n" "::xotcl::package proc import {{-into ::} pkg} {\n" "my require $pkg\n" "namespace eval $into [subst -nocommands {\n" "namespace import ${pkg}::*}]\n" "foreach e [$pkg export] {\n" "set nq [namespace qualifiers $e]\n" "if {$nq ne \"\"} {\n" "namespace eval $into$nq [list namespace import ${pkg}::$e]}}}\n" "::xotcl::package proc require args {\n" "::xotcl::my instvar component verbose uses loaded\n" "set prevComponent $component\n" "if {[catch {set v [eval package present $args]} msg]} {\n" "switch -exact -- [lindex $args 0] {\n" "-exact {set pkg [lindex $args 1]}\n" "default {set pkg [lindex $args 0]}}\n" "set component $pkg\n" "lappend uses($prevComponent) $component\n" "set v [uplevel \\#1 [my set packagecmd] require $args]\n" "if {$v ne \"\" && $verbose} {\n" "set path [lindex [::package ifneeded $pkg $v] 1]\n" "puts \"... $pkg $v loaded from '$path'\"\n" "set loaded($pkg) $v ;# loaded stuff needed for Tcl 8.0}}\n" "set component $prevComponent\n" "return $v}\n" "::xotcl::Object instproc method {name arguments body} {\n" "my proc name $arguments $body }\n" "::xotcl::Class instproc method {-per-object:switch name arguments body} {\n" "if {${per-object}} {\n" "my proc $name $arguments $body} else {\n" "my instproc $name $arguments $body}}\n" "proc ::xotcl::tmpdir {} {\n" "foreach e [list TMPDIR TEMP TMP] {\n" "if {[info exists ::env($e)] \\\n" "&& [file isdirectory $::env($e)] \\\n" "&& [file writable $::env($e)]} {\n" "return $::env($e)}}\n" "if {$::tcl_platform(platform) eq \"windows\"} {\n" "foreach d [list \"C:\\\\TEMP\" \"C:\\\\TMP\" \"\\\\TEMP\" \"\\\\TMP\"] {\n" "if {[file isdirectory $d] && [file writable $d]} {\n" "return $d}}}\n" "return /tmp}\n" "";