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