1# $Id: predefined.xotcl,v 1.16 2007/09/05 19:09:22 neumann Exp $ 2# provide the standard command set for ::xotcl::Object 3foreach cmd [info command ::xotcl::Object::instcmd::*] { 4 ::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd 5} 6# provide some Tcl-commands as methods for Objects 7foreach cmd {array append eval incr lappend trace subst unset} { 8 ::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd 9} 10# provide the standard command set for ::xotcl::Class 11foreach cmd [info command ::xotcl::Class::instcmd::*] { 12 ::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd 13} 14unset cmd 15 16# init must exist on Object. per default it is empty. 17::xotcl::Object instproc init args {} 18 19# documentation stub object -> just ignore 20# all documentations if xoDoc is not loaded 21::xotcl::Object create ::xotcl::@ 22::xotcl::@ proc unknown args {} 23proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]} 24proc ::xotcl::myvar {var} {::xotcl::my requireNamespace; return [::xotcl::self]::$var} 25namespace eval ::xotcl { namespace export @ myproc myvar Attribute} 26######################## 27# Parameter definitions 28######################## 29::xotcl::setrelation ::xotcl::Class::Parameter superclass ::xotcl::Class 30::xotcl::Class::Parameter instproc mkParameter {obj name args} { 31 #puts "[::xotcl::self proc] $obj $name <$args>" 32 if {[$obj exists $name]} { 33 eval [$obj set $name] configure $args 34 } else { 35 $obj set $name [eval ::xotcl::my new -childof $obj $args] 36 } 37} 38::xotcl::Class::Parameter instproc getParameter {obj name args} { 39 #puts "[::xotcl::self proc] $obj $name <$args>" 40 [$obj set $name] 41} 42::xotcl::Class::Parameter proc Class {param args} { 43 #puts "*** [::xotcl::self] parameter: [::xotcl::self proc] '$param' <$args>" 44 ::xotcl::my set access [lindex $param 0] 45 ::xotcl::my set setter mkParameter 46 ::xotcl::my set getter getParameter 47 ::xotcl::my set extra {[::xotcl::self]} 48 ::xotcl::my set defaultParam [lrange $param 1 end] 49} 50::xotcl::Class::Parameter proc default {val} { 51 [::xotcl::my set cl] set __defaults([::xotcl::my set name]) $val 52} 53::xotcl::Class::Parameter proc setter x { 54 ::xotcl::my set setter $x 55} 56::xotcl::Class::Parameter proc getter x { 57 ::xotcl::my set getter $x 58} 59::xotcl::Class::Parameter proc access obj { 60 ::xotcl::my set access $obj 61 ::xotcl::my set extra \[::xotcl::self\] 62 foreach v [$obj info vars] {::xotcl::my set $v [$obj set $v]} 63} 64::xotcl::Class::Parameter proc values {param args} { 65 set cl [::xotcl::my set cl] 66 set ci [$cl info instinvar] 67 set valueTest {} 68 foreach a $args { 69 ::lappend valueTest "\[\$cl set $param\] == [list $a]" 70 } 71 ::lappend ci [join $valueTest " || "] 72 $cl instinvar $ci 73} 74 75################## 76# Slot definitions 77################## 78# bootstrap code; we cannot use -parameter yet 79::xotcl::Class create ::xotcl::MetaSlot 80::xotcl::setrelation ::xotcl::MetaSlot superclass ::xotcl::Class 81::xotcl::MetaSlot instproc new args { 82 set slotobject [self callingobject]::slot 83 if {![my isobject $slotobject]} {Object create $slotobject; namespace eval $slotobject {namespace import ::xotcl::*; puts stderr IMPORT}} 84 #namespace eval [self]::slot $cmds 85 #puts "metaslot $args // [namespace current] // [self callingobject]" 86 eval next -childof $slotobject $args 87} 88::xotcl::MetaSlot create ::xotcl::Slot -array set __defaults { 89 name "[namespace tail [::xotcl::self]]" 90 domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]" 91 defaultmethods {get assign} 92 manager "[::xotcl::self]" 93 multivalued false 94 per-object false 95} 96foreach p {name domain defaultmethods manager default multivalued type 97 per-object initcmd valuecmd valuechangedcmd} { 98 ::xotcl::Slot instparametercmd $p 99} 100unset p 101 102::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar 103::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar 104::xotcl::Slot instproc add {obj prop value {pos 0}} { 105 if {![my multivalued]} { 106 error "Property $prop of [my domain]->$obj ist not multivalued" 107 } 108 if {[$obj exists $prop]} { 109 $obj set $prop [linsert [$obj set $prop] $pos $value] 110 } else { 111 $obj set $prop [list $value] 112 } 113} 114::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} { 115 set old [$obj set $prop] 116 set p [lsearch -glob $old $value] 117 if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else { 118 error "$value is not a $prop of $obj (valid are: $old)" 119 } 120} 121 122::xotcl::Slot instproc unknown {method args} { 123 set methods [list] 124 foreach m [my info methods] { 125 if {[::xotcl::Object info methods $m] ne ""} continue 126 if {[string match __* $m]} continue 127 lappend methods $m 128 } 129 error "Method '$method' unknown for slot [self]; valid are: {[lsort $methods]]}" 130} 131::xotcl::Slot instproc init {} { 132 my instvar name domain manager 133 set forwarder [expr {[my per-object] ? "forward" : "instforward"}] 134 #puts "domain=$domain /[self callingobject]/[my info parent]" 135 if {$domain eq ""} { 136 set domain [self callingobject] 137 } 138 $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc 139} 140# 141# InfoSlot 142# 143::xotcl::MetaSlot create ::xotcl::InfoSlot -array set __defaults { 144 multivalued true 145 elementtype ::xotcl::Class 146} 147::xotcl::InfoSlot instparametercmd elementtype 148::xotcl::setrelation ::xotcl::InfoSlot superclass ::xotcl::Slot 149::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop} 150::xotcl::InfoSlot instproc add {obj prop value {pos 0}} { 151 if {![my multivalued]} { 152 error "Property $prop of [my domain]->$obj ist not multivalued" 153 } 154 $obj $prop [linsert [$obj info $prop] $pos $value] 155} 156::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} { 157 set old [$obj info $prop] 158 if {[string first * $value] > -1 || [string first \[ $value] > -1} { 159 # string contains meta characters 160 if {[my elementtype] ne "" && ![string match ::* $value]} { 161 # prefix string with ::, since all object names have leading :: 162 set value ::$value 163 } 164 return [$obj $prop [lsearch -all -not -glob -inline $old $value]] 165 } elseif {[my elementtype] ne ""} { 166 if {[string first :: $value] == -1} { 167 if {![my isobject $value]} { 168 error "$value does not appear to be an object" 169 } 170 set value [$value self] 171 } 172 if {![$value isclass [my elementtype]]} { 173 error "$value does not appear to be of type [my elementtype]" 174 } 175 } 176 set p [lsearch -exact $old $value] 177 if {$p > -1} { 178 $obj $prop [lreplace $old $p $p] 179 } else { 180 error "$value is not a $prop of $obj (valid are: $old)" 181 } 182} 183# 184# InterceptorSlot 185# 186::xotcl::MetaSlot create ::xotcl::InterceptorSlot 187::xotcl::setrelation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot 188::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::setrelation ;# for backwards compatibility 189::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::setrelation 190 191::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} { 192 if {![my multivalued]} { 193 error "Property $prop of [my domain]->$obj ist not multivalued" 194 } 195 $obj $prop [linsert [$obj info $prop -guards] $pos $value] 196} 197 198###################### 199# system slots 200###################### 201namespace eval ::xotcl::Class::slot {} 202namespace eval ::xotcl::Object::slot {} 203 204::xotcl::InfoSlot create ::xotcl::Class::slot::superclass 205::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::setrelation 206 207::xotcl::InfoSlot create ::xotcl::Object::slot::class 208::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::setrelation 209 210::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin 211::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype "" 212::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin 213::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype "" 214 215# 216# Attribute 217# 218::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot 219foreach p {default value_check initcmd valuecmd valuechangedcmd} { 220 ::xotcl::Attribute instparametercmd $p 221} 222unset p 223::xotcl::Attribute array set __defaults { 224 value_check once 225} 226::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} { 227 #puts "GETVAR [self proc] obj=$obj cmd=$cmd, var=$var, op=$op" 228 $obj trace remove variable $var $op [list [self] [self proc] $obj $cmd] 229 $obj set $var [$obj eval $cmd] 230} 231::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} { 232 #puts "GETVAR [self proc] obj=$obj cmd=$cmd, var=$var, op=$op" 233 $obj set $var [$obj eval $cmd] 234} 235::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} { 236 #puts stderr "**************************" 237 #puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ... 238 #$obj exists $var -> [$obj set $var]" 239 eval $cmd 240} 241::xotcl::Attribute instproc destroy {} { 242 #puts stderr "++++ [my domain] unset __defaults([my name]) [my default]" 243 #[my domain] unset -nocomplain __defaults([my name]) 244 next 245} 246::xotcl::Attribute instproc check_single_value { 247 {-keep_old_value:boolean true} 248 value predicate type obj var 249} { 250 #puts "+++ checking $value with $predicate ==> [expr $predicate]" 251 if {![expr $predicate]} { 252 if {[$obj exists __oldvalue($var)]} { 253 $obj set $var [$obj set __oldvalue($var)] 254 } else { 255 $obj unset -nocomplain $var 256 } 257 error "$value is not of type $type" 258 } 259 if {$keep_old_value} {$obj set __oldvalue($var) $value} 260} 261 262::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} { 263 foreach value $values { 264 my check_single_value -keep_old_value false $value $predicate $type $obj $var 265 } 266 $obj set __oldvalue($var) $value 267} 268::xotcl::Attribute instproc mk_type_checker {} { 269 set __initcmd "" 270 if {[my exists type]} { 271 my instvar type name 272 if {[::xotcl::Object isclass $type]} { 273 set predicate [subst -nocommands {[::xotcl::Object isobject \$value] 274 && [\$value istype $type]}] 275 } elseif {[llength $type]>1} { 276 set predicate "\[$type \$value\]" 277 } else { 278 set predicate "\[string is $type \$value\]" 279 } 280 my append valuechangedcmd [subst { 281 my [expr {[my multivalued] ? "check_multiple_values" : "check_single_value"}] \[\$obj set $name\] \ 282 {$predicate} [list $type] \$obj $name 283 }] 284 append __initcmd [subst -nocommands { 285 if {[my exists $name]} {my set __oldvalue($name) [my set $name]}\n 286 }] 287 } 288 return $__initcmd 289} 290::xotcl::Attribute instproc init {} { 291 my instvar domain name 292 next ;# do first ordinary slot initialization 293 # there might be already default values registered on the class 294 $domain unset -nocomplain __defaults($name) 295 set __initcmd "" 296 if {[my exists default]} { 297 if {[my per-object] && ![$domain exists $name]} { 298 $domain set $name [my default] 299 } elseif {![my per-object]} { 300 $domain set __defaults($name) [my default] 301 } 302 } elseif [my exists initcmd] { 303 append __initcmd "my trace add variable [list $name] read \ 304 \[list [self] __default_from_cmd \[self\] [list [my initcmd]]\]\n" 305 } elseif [my exists valuecmd] { 306 append __initcmd "my trace add variable [list $name] read \ 307 \[list [self] __value_from_cmd \[self\] [list [my valuecmd]]\]" 308 } 309 append __initcmd [my mk_type_checker] 310 if {[my exists valuechangedcmd]} { 311 append __initcmd "my trace add variable [list $name] write \ 312 \[list [self] __value_changed_cmd \[self\] [list [my valuechangedcmd]]\]" 313 } 314 if {$__initcmd ne ""} { 315 if {[my per-object]} { 316 $domain eval $__initcmd 317 } else { 318 $domain set __initcmds($name) $__initcmd 319 } 320 #puts stderr "$domain set __initcmds($name) $__initcmd" 321 } 322} 323# mixin class for decativating all checks 324::xotcl::Class create ::xotcl::Slot::Nocheck \ 325 -instproc check_single_value args {;} -instproc check_multiple_values args {;} \ 326 -instproc mk_type_checker args {return ""} 327::xotcl::Class create ::xotcl::Slot::Optimizer \ 328 -instproc proc args {::xotcl::next; ::xotcl::my optimize} \ 329 -instproc forward args {::xotcl::next; ::xotcl::my optimize} \ 330 -instproc init args {::xotcl::next; ::xotcl::my optimize} \ 331 -instproc optimize {} { 332 if {[::xotcl::my multivalued]} return 333 if {[::xotcl::my defaultmethods] ne {get assign}} return 334 if {[::xotcl::my procsearch assign] ne "::xotcl::Slot instcmd assign"} return 335 if {[::xotcl::my procsearch get] ne "::xotcl::Slot instcmd get"} return 336 set forwarder [expr {[::xotcl::my per-object] ? "parametercmd":"instparametercmd"}] 337 #puts stderr "**** optimizing [::xotcl::my domain] $forwarder [::xotcl::my name]" 338 [::xotcl::my domain] $forwarder [::xotcl::my name] 339 } 340# register the optimizer per default 341::xotcl::Slot instmixin add ::xotcl::Slot::Optimizer 342 343# 344# Create a mixin class to overload method "new", such it does not allocate 345# new objects in ::xotcl::*, but in the specified object (without 346# syntactic overhead). 347# 348::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class \ 349 -array set __defaults {withclass ::xotcl::Object} 350::xotcl::ScopedNew instparametercmd withclass 351::xotcl::ScopedNew instparametercmd inobject 352::xotcl::ScopedNew instproc init {} { 353 ::xotcl::my instproc new {-childof args} { 354 [::xotcl::self class] instvar {inobject object} withclass 355 if {![::xotcl::my isobject $object]} { 356 $withclass create $object 357 } 358 eval ::xotcl::next -childof $object $args 359 } 360} 361# 362# change the namespace to the specified object and create 363# objects there. This is a friendly notation for creating 364# nested object structures. Optionally, creating new objects 365# in the specified scope can be turned off. 366# 367::xotcl::Object instproc contains { 368 {-withnew:boolean true} 369 -object 370 {-class ::xotcl::Object} 371 cmds} { 372 if {![info exists object]} {set object [::xotcl::self]} 373 if {![::xotcl::my isobject $object]} { 374 $class create $object 375 $object requireNamespace 376 #namespace eval $object {namespace import ::xotcl::*} 377 } 378 if {$withnew} { 379 set m [::xotcl::ScopedNew new \ 380 -inobject $object -withclass $class -volatile] 381 ::xotcl::Class instmixin add $m end 382 namespace eval $object $cmds 383 ::xotcl::Class instmixin delete $m 384 } else { 385 namespace eval $object $cmds 386 } 387 } 388::xotcl::Class instforward slots %self contains \ 389 -object {%::xotcl::my subst [::xotcl::self]::slot} 390 391# 392# utilities 393# 394::xotcl::Class instproc parameter arglist { 395 if {![::xotcl::my isobject [self]::slot]} {::xotcl::Object create [self]::slot} 396 foreach arg $arglist { 397 #puts "arg=$arg" 398 set l [llength $arg] 399 set name [lindex $arg 0] 400 if {$l == 1} { 401 ::xotcl::Attribute create [::xotcl::self]::slot::$name 402 403 } elseif {$l == 2} { 404 #puts stderr "parameter $name has default '[lindex $arg 1]'" 405 ::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 1]] 406 } elseif {$l == 3 && [lindex $arg 1] eq "-default"} { 407 ::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default [lindex $arg 2]] 408 } else { 409 set paramstring [string range $arg [expr {[string length $name]+1}] end] 410 #puts stderr "remaining arg = '$paramstring'" 411 if {[string match {[$\[]*} $paramstring]} { 412 #puts stderr "match, $cl set __defaults($name) $paramstring" 413 ::xotcl::Attribute create [::xotcl::self]::slot::$name [list -default $paramstring] 414 continue 415 } 416 417 set po ::xotcl::Class::Parameter 418 puts stderr "deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead" 419 420 set cl [self] 421 $po set name $name 422 $po set cl [self] 423 ::eval $po configure [lrange $arg 1 end] 424 425 if {[$po exists extra] || [$po exists setter] || 426 [$po exists getter] || [$po exists access]} { 427 $po instvar extra setter getter access defaultParam 428 if {![info exists extra]} {set extra ""} 429 if {![info exists defaultParam]} {set defaultParam ""} 430 if {![info exists setter]} {set setter set} 431 if {![info exists getter]} {set getter set} 432 if {![info exists access]} {set access ::xotcl::my} 433 $cl instproc $name args " 434 if {\[llength \$args] == 0} { 435 return \[$access $getter $extra $name\] 436 } else { 437 return \[eval $access $setter $extra $name \$args $defaultParam \] 438 }" 439 foreach instvar {extra defaultParam setter getter access} { 440 $po unset -nocomplain $instvar 441 } 442 } else { 443 ::xotcl::my instparametercmd $name 444 } 445 } 446 } 447 [self]::slot set __parameter $arglist 448} 449# 450# utilities 451# 452::xotcl::Object instproc self {} {::xotcl::self} 453::xotcl::Object instproc defaultmethod {} { 454 #if {"::" ne [::xotcl::my info parent] } { 455 # [::xotcl::my info parent] __next 456 #} 457 return [::xotcl::self] 458} 459 460# support for XOTcl specifics 461::xotcl::Object instproc hasclass cl { 462 if {[::xotcl::my ismixin $cl]} {return 1} 463 ::xotcl::my istype $cl 464} 465::xotcl::Class instproc allinstances {} { 466 # TODO: mark it deprecated 467 return [::xotcl::my info instances -closure] 468} 469 470 471# Exit Handler 472::xotcl::Object proc unsetExitHandler {} { 473 ::xotcl::Object proc __exitHandler {} { 474 # clients should append exit handlers to this proc body 475 ; 476 } 477} 478# pre-defined as empty method 479::xotcl::Object unsetExitHandler 480::xotcl::Object proc setExitHandler {newbody} { 481 ::xotcl::Object proc __exitHandler {} $newbody 482} 483::xotcl::Object proc getExitHandler {} { 484 ::xotcl::Object info body __exitHandler 485} 486 487::xotcl::Object instproc abstract {methtype methname arglist} { 488 if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} { 489 error "invalid method type '$methtype', \ 490 must be either 'proc', 'instproc' or 'method'." 491 } 492 ::xotcl::my $methtype $methname $arglist " 493 if {!\[::xotcl::self isnextcall\]} { 494 error \"Abstract method $methname $arglist called\" 495 } else {::xotcl::next} 496 " 497} 498 499# 500# copy/move implementation 501# 502::xotcl::Class create ::xotcl::Object::CopyHandler -parameter { 503 {targetList ""} 504 {dest ""} 505 objLength 506} 507 508# targets are all namspaces and objs part-of the copied obj 509::xotcl::Object::CopyHandler instproc makeTargetList t { 510 ::xotcl::my lappend targetList $t 511 # if it is an object without namespace, it is a leaf 512 if {[::xotcl::my isobject $t]} { 513 if {[$t info hasNamespace]} { 514 # make target list from all children 515 set children [$t info children] 516 } else { 517 # ok, no namespace -> no more children 518 return 519 } 520 } 521 # now append all namespaces that are in the obj, but that 522 # are not objects 523 foreach c [namespace children $t] { 524 if {![::xotcl::my isobject $c]} { 525 lappend children [namespace children $t] 526 } 527 } 528 529 # a namespace or an obj with namespace may have children 530 # itself 531 foreach c $children { 532 ::xotcl::my makeTargetList $c 533 } 534} 535 536::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} { 537 #puts stderr "copyNSVarsAndCmds $orig $dest" 538 ::xotcl::namespace_copyvars $orig $dest 539 ::xotcl::namespace_copycmds $orig $dest 540} 541 542# construct destination obj name from old qualified ns name 543::xotcl::Object::CopyHandler instproc getDest origin { 544 set tail [string range $origin [::xotcl::my set objLength] end] 545 return ::[string trimleft [::xotcl::my set dest]$tail :] 546} 547 548::xotcl::Object::CopyHandler instproc copyTargets {} { 549 #puts stderr "copy targetList = [::xotcl::my set targetList]" 550 foreach origin [::xotcl::my set targetList] { 551 set dest [::xotcl::my getDest $origin] 552 if {[::xotcl::my isobject $origin]} { 553 # copy class information 554 if {[::xotcl::my isclass $origin]} { 555 set cl [[$origin info class] create $dest -noinit] 556 # class object 557 set obj $cl 558 $cl superclass [$origin info superclass] 559 $cl parameterclass [$origin info parameterclass] 560 $cl instinvar [$origin info instinvar] 561 $cl instfilter [$origin info instfilter -guards] 562 $cl instmixin [$origin info instmixin] 563 my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest 564 #$cl parameter [$origin info parameter] 565 } else { 566 # create obj 567 set obj [[$origin info class] create $dest -noinit] 568 } 569 # copy object -> may be a class obj 570 $obj invar [$origin info invar] 571 $obj check [$origin info check] 572 $obj mixin [$origin info mixin] 573 $obj filter [$origin info filter -guards] 574 # set md [$origin info metadata] 575 # $obj metadata add $md 576 # foreach m $md { $obj metadata $m [$origin metadata $m] } 577 if {[$origin info hasNamespace]} { 578 $obj requireNamespace 579 } 580 } else { 581 namespace eval $dest {} 582 } 583 ::xotcl::my copyNSVarsAndCmds $origin $dest 584 foreach i [$origin info forward] { 585 eval [concat $dest forward $i [$origin info forward -definition $i]] 586 } 587 if {[::xotcl::my isclass $origin]} { 588 foreach i [$origin info instforward] { 589 eval [concat $dest instforward $i [$origin info instforward -definition $i]] 590 } 591 } 592 set traces [list] 593 foreach var [$origin info vars] { 594 set cmds [$origin trace info variable $var] 595 if {$cmds ne ""} { 596 foreach cmd $cmds { 597 foreach {op def} $cmd break 598 #$origin trace remove variable $var $op $def 599 if {[lindex $def 0] eq $origin} { 600 set def [concat $dest [lrange $def 1 end]] 601 } 602 $dest trace add variable $var $op $def 603 } 604 } 605 } 606 } 607 # alter 'domain' and 'manager' in slot objects 608 set origin [lindex [::xotcl::my set targetList] 0] 609 if {[::xotcl::my isclass $origin]} { 610 foreach oldslot [$origin info slots] { 611 set newslot ${cl}::slot::[namespace tail $oldslot] 612 if {[$oldslot domain] eq $origin} {$newslot domain $cl} 613 if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot} 614 } 615 } 616} 617 618::xotcl::Object::CopyHandler instproc copy {obj dest} { 619 #puts stderr "[::xotcl::self] copy <$obj> <$dest>" 620 ::xotcl::my set objLength [string length $obj] 621 ::xotcl::my set dest $dest 622 ::xotcl::my makeTargetList $obj 623 ::xotcl::my copyTargets 624} 625 626#Class create ::xotcl::NoInit 627#::xotcl::NoInit instproc init args {;} 628 629 630::xotcl::Object instproc copy newName { 631 if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} { 632 [[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName 633 } 634} 635 636::xotcl::Object instproc move newName { 637 if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} { 638 if {$newName ne ""} { 639 ::xotcl::my copy $newName 640 } 641 ### let all subclasses get the copied class as superclass 642 if {[::xotcl::my isclass [::xotcl::self]] && $newName ne ""} { 643 foreach subclass [::xotcl::my info subclass] { 644 set scl [$subclass info superclass] 645 if {[set index [lsearch -exact $scl [::xotcl::self]]] != -1} { 646 set scl [lreplace $scl $index $index $newName] 647 $subclass superclass $scl 648 } 649 } 650 } 651 ::xotcl::my destroy 652 } 653} 654 655::xotcl::Object create ::xotcl::config 656::xotcl::config proc load {obj file} { 657 source $file 658 foreach i [array names ::auto_index [list $obj *proc *]] { 659 set type [lindex $i 1] 660 set meth [lindex $i 2] 661 if {[$obj info ${type}s $meth] == {}} { 662 $obj $type $meth auto $::auto_index($i) 663 } 664 } 665} 666 667::xotcl::config proc mkindex {meta dir args} { 668 set sp {[ ]+} 669 set st {^[ ]*} 670 set wd {([^ ;]+)} 671 foreach creator $meta { 672 ::lappend cp $st$creator${sp}create$sp$wd 673 ::lappend ap $st$creator$sp$wd 674 } 675 foreach method {proc instproc} { 676 ::lappend mp $st$wd${sp}($method)$sp$wd 677 } 678 foreach cl [concat ::xotcl::Class [::xotcl::Class info heritage]] { 679 eval ::lappend meths [$cl info instcommands] 680 } 681 set old [pwd] 682 cd $dir 683 ::append idx "# Tcl autoload index file, version 2.0\n" 684 ::append idx "# xotcl additions generated with " 685 ::append idx "\"::xotcl::config::mkindex [list $meta] [list $dir] $args\"\n" 686 set oc 0 687 set mc 0 688 foreach file [eval glob -nocomplain -- $args] { 689 if {[catch {set f [open $file]} msg]} then { 690 catch {close $f} 691 cd $old 692 error $msg 693 } 694 while {[gets $f line] >= 0} { 695 foreach c $cp { 696 if {[regexp $c $line x obj]==1 && 697 [string index $obj 0]!={$}} then { 698 ::incr oc 699 ::append idx "set auto_index($obj) " 700 ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n" 701 } 702 } 703 foreach a $ap { 704 if {[regexp $a $line x obj]==1 && 705 [string index $obj 0]!={$} && 706 [lsearch -exact $meths $obj]==-1} { 707 ::incr oc 708 ::append idx "set auto_index($obj) " 709 ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n" 710 } 711 } 712 foreach m $mp { 713 if {[regexp $m $line x obj ty pr]==1 && 714 [string index $obj 0]!={$} && 715 [string index $pr 0]!={$}} then { 716 ::incr mc 717 ::append idx "set \{auto_index($obj " 718 ::append idx "$ty $pr)\} \"source \$dir/$file\"\n" 719 } 720 } 721 } 722 close $f 723 } 724 set t [open tclIndex a+] 725 puts $t $idx nonewline 726 close $t 727 cd $old 728 return "$oc objects, $mc methods" 729} 730 731# 732# if cutTheArg not 0, it cut from upvar argsList 733# 734::xotcl::Object instproc extractConfigureArg {al name {cutTheArg 0}} { 735 set value "" 736 upvar $al argList 737 set largs [llength $argList] 738 for {set i 0} {$i < $largs} {incr i} { 739 if {[lindex $argList $i] == $name && $i + 1 < $largs} { 740 set startIndex $i 741 set endIndex [expr {$i + 1}] 742 while {$endIndex < $largs && 743 [string first - [lindex $argList $endIndex]] != 0} { 744 lappend value [lindex $argList $endIndex] 745 incr endIndex 746 } 747 } 748 } 749 if {[info exists startIndex] && $cutTheArg != 0} { 750 set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]] 751 } 752 return $value 753} 754 755::xotcl::Object create ::xotcl::rcs 756::xotcl::rcs proc date string { 757 lreplace [lreplace $string 0 0] end end 758} 759::xotcl::rcs proc version string { 760 lindex $string 2 761} 762 763# if HOME is not set, and ~ is resolved, Tcl chokes on that 764if {![info exists ::env(HOME)]} {set ::env(HOME) /root} 765set ::xotcl::confdir ~/.xotcl 766set ::xotcl::logdir $::xotcl::confdir/log 767 768::xotcl::Class proc __unknown name { 769 #unknown $name 770} 771 772# 773# package support 774# 775::xotcl::Class instproc uses list { 776 foreach package $list { 777 ::xotcl::package import -into [self] $package 778 puts stderr "*** using ${package}::* in [self]" 779 } 780} 781::xotcl::Class create ::xotcl::package -superclass ::xotcl::Class -parameter { 782 provide 783 {version 1.0} 784 {autoexport {}} 785 {export {}} 786} 787::xotcl::package proc create {name args} { 788 set nq [namespace qualifiers $name] 789 if {$nq ne "" && ![namespace exists $nq]} {Object create $nq} 790 next 791} 792::xotcl::package proc extend {name args} { 793 my require $name 794 eval $name configure $args 795} 796::xotcl::package instproc contains script { 797 if {[my exists provide]} { 798 package provide [my provide] [my version] 799 } else { 800 package provide [self] [my version] 801 } 802 namespace eval [self] {namespace import ::xotcl::*} 803 namespace eval [self] $script 804 foreach e [my export] { 805 set nq [namespace qualifiers $e] 806 if {$nq ne ""} { 807 namespace eval [self]::$nq [list namespace export [namespace tail $e]] 808 } else { 809 namespace eval [self] [list namespace export $e] 810 } 811 } 812 foreach e [my autoexport] { 813 namespace eval :: [list namespace import [self]::$e] 814 } 815} 816::xotcl::package configure \ 817 -set component . \ 818 -set verbose 0 \ 819 -set packagecmd ::package 820 821::xotcl::package proc unknown args { 822 #puts stderr "unknown: package $args" 823 eval [my set packagecmd] $args 824} 825::xotcl::package proc verbose value { 826 my set verbose $value 827} 828::xotcl::package proc present args { 829 if {$::tcl_version<8.3} { 830 my instvar loaded 831 switch -exact -- [lindex $args 0] { 832 -exact {set pkg [lindex $args 1]} 833 default {set pkg [lindex $args 0]} 834 } 835 if {[info exists loaded($pkg)]} { 836 return $loaded($pkg) 837 } else { 838 error "not found" 839 } 840 } else { 841 eval [my set packagecmd] present $args 842 } 843} 844::xotcl::package proc import {{-into ::} pkg} { 845 my require $pkg 846 namespace eval $into [subst -nocommands { 847 #puts stderr "*** package import ${pkg}::* into [namespace current]" 848 namespace import ${pkg}::* 849 }] 850 # import subclasses if any 851 foreach e [$pkg export] { 852 set nq [namespace qualifiers $e] 853 if {$nq ne ""} { 854 namespace eval $into$nq [list namespace import ${pkg}::$e] 855 } 856 } 857} 858::xotcl::package proc require args { 859 #puts "XOTCL package require $args, current=[namespace current]" 860 ::xotcl::my instvar component verbose uses loaded 861 set prevComponent $component 862 if {[catch {set v [eval package present $args]} msg]} { 863 #puts stderr "we have to load $msg" 864 switch -exact -- [lindex $args 0] { 865 -exact {set pkg [lindex $args 1]} 866 default {set pkg [lindex $args 0]} 867 } 868 set component $pkg 869 lappend uses($prevComponent) $component 870 set v [uplevel \#1 [my set packagecmd] require $args] 871 if {$v ne "" && $verbose} { 872 set path [lindex [::package ifneeded $pkg $v] 1] 873 puts "... $pkg $v loaded from '$path'" 874 set loaded($pkg) $v ;# loaded stuff needed for Tcl 8.0 875 } 876 } 877 set component $prevComponent 878 return $v 879} 880 881::xotcl::Object instproc method {name arguments body} { 882 my proc name $arguments $body 883} 884::xotcl::Class instproc method {-per-object:switch name arguments body} { 885 if {${per-object}} { 886 my proc $name $arguments $body 887 } else { 888 my instproc $name $arguments $body 889 } 890} 891 892# setup a temp directory 893proc ::xotcl::tmpdir {} { 894 foreach e [list TMPDIR TEMP TMP] { 895 if {[info exists ::env($e)] \ 896 && [file isdirectory $::env($e)] \ 897 && [file writable $::env($e)]} { 898 return $::env($e) 899 } 900 } 901 if {$::tcl_platform(platform) eq "windows"} { 902 foreach d [list "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"] { 903 if {[file isdirectory $d] && [file writable $d]} { 904 return $d 905 } 906 } 907 } 908 return /tmp 909} 910