[Xotcl] Re: [Xotcl] abstract method difference 0.83->0.84

[Uwe Zdun]

Ok. First: we didn't realize there is a change from 0.83->0.84 ... we thought 
the error message would occur in 0.83 as well.

Second: I agree, the behavior with "next" is undesirable ... I remember, 
we've found this problem before. I wonder why we haven't changed the behavior 
yet. Anyway, I think a good solution is to change the behvaior of "abstract" 
accordingly. In 0.84 (and 0.83?) it was:


Object instproc abstract {methtype methname arglist} {
  if {$methtype  != "proc" && $methtype != "instproc"} {
    error "invalid method type '$methtype', \
	must be either 'proc' or 'instproc'."
  } 
  [self] $methtype $methname $arglist \
    [list error "Abstract method $methname $arglist called"]
}


I would propose to change it to:


Object instproc abstract {methtype methname arglist} {
  if {$methtype  != "proc" && $methtype != "instproc"} {
    error "invalid method type '$methtype', \
	must be either 'proc' or 'instproc'."
  }
  [self] $methtype $methname $arglist "
    if {\[self callingproc\] != \[self proc\] && 
	\[self callingobject\] != \[self\]} {
      error \"Abstract method $methname $arglist called\"
    }
  "
}


That is, when the calling method name equals the current method and the 
calling object is self, then the call is done with next. In this cases we 
omit the error message. An example:


Class Foo
Foo abstract instproc blah {}
Class Bar -superclass Foo
Bar instproc blah {} {
  puts "Bar--blah"
  next
}

puts [Foo info instbody blah]

# here no error occurs:
Bar b
b blah

# here we still get an error:
Foo a
a blah


I'll attach my predefined.xotcl for your convenience (that is, you have to 
recompile XOTcl with it in order to use the change ...)

--Uwe


On Wednesday 09 May 2001 02:13, you wrote:
> Just wanted to note a change I noticed from 0.83->0.84 which doesn't seem
> to be in the changes file? It's to do with abstract methods and code like
> the following:
>
> Class Foo
> Foo abstract instproc blah {}
>
> Class Bar -superclass Foo
> Bar instproc instproc blah {
>   puts "blah"
>   next
> }
>
> With 0.83 this worked but it gives an error about an abstract method
> being called in 0.84. The reason the "next" is there in the first place is
> basically because if someone decides to add a class to the chain after Bar
> then the "next" commands will already be in place. Are there other
> arguments for/against the 0.84 model?
>
>          -     ---------- = = ---------//--+
>
>          |    /     Kristoffer Lawson      |  www.fishpool.fi|.com
>
>          +-> |    setok at fishpool.com       |  - - --+------
>
>              |-- Fishpool Creations Ltd - /         |
>
>              +-------- = - - - = ---------      /~setok/
>
>
> _______________________________________________
> Xotcl mailing list  -  Xotcl at wi.wu-wien.ac.at
> http://wi.wu-wien.ac.at/mailman/listinfo/xotcl

-- 
Uwe Zdun
Specification of Software Systems, University of Essen
Phone: +49 201 81 00 332, Fax: +49 201 81 00 398
zdun at xotcl.org, uwe.zdun at uni-essen.de
-------------- next part --------------
# $Id$

# init must exist on Object. per default it is empty.
Object instproc init args {}

# documentation stub object -> just ignore 
# all documentations if xoDoc is not loaded
Object ::@
::@ proc unknown args {}

#Object instproc recreate args {
#  [self] cleanup
#  ::set cl [[self] info class]
#  ::set pcl [$cl info parameterclass]
#  $pcl searchDefaults [self]
#  if {![eval [self] initmethods $args]} {
#    eval [self] init $args
#  }
#  return [self]
#}

Class instproc parameters args {
  ::xotcl::deprecated parameters parameter
  ::eval [self] parameter $args
}
# provide some Tcl-commands as methods for every Object
Object instproc array {opt array args} {
  ::eval ::array $opt [self]::$array $args
}
Object instproc vwait {varName} {
  ::vwait [self]::$varName
}
Object instproc append {varName args} {
  ::eval ::append [self]::$varName $args
}
Object instproc lappend {varName args} {
  ::eval ::lappend [self]::$varName $args
}
Object instproc cset {vn arg} {
  if {![[self] exists $vn]} {
    [self] set $vn $arg
  }
}
# newChild creates a new child under the current object
Class instproc newChild args {
  ::set name [[self] autoname -instance [namespace tail [self]]]
  ::eval [self] create [self callingobject]::$name $args
}
# new creates a new global object
Class instproc new args {
  ::eval [self] create [[self] autoname -instance [self]] $args
}
# support for XOTcl specifica
Object instproc filterappend f {
  [self] filter [concat [[self] info filter] $f]
}
Object instproc mixinappend m {
  ::set mix [[self] info mixin]
  [self] mixin [::lappend mix $m]
}

Object proc getExitHandler {} {
  if {[[self] exists __exitHandler]} {
    return [[self] set __exitHandler]
  } else {
    return ""
  }
}
Object proc setExitHandler body {
  return [[self] set __exitHandler $body]
}
Object proc unsetExitHandler {} {
  [self] unset __exitHandler
}
Class::Parameter instproc values {param args} {
  set ci [[self] info instinvar]
  set valueTest {}
  foreach a $args {
    ::lappend valueTest "\[\[self\] set $param\] == [list $a]"
  }
  ::lappend ci [join $valueTest " || "]
  [self] instinvar $ci
}

Object instproc abstract {methtype methname arglist} {
  if {$methtype  != "proc" && $methtype != "instproc"} {
    error "invalid method type '$methtype', \
	must be either 'proc' or 'instproc'."
  }
  [self] $methtype $methname $arglist "
    if {\[self callingproc\] != \[self proc\] && 
	\[self callingobject\] != \[self\]} {
      error \"Abstract method $methname $arglist called\"
    }
  "
}

#
# copy/move implementation 
#
Class Object::CopyHandler -parameter {
  {nsList ""}
  {dest ""}
  objLength
}

Object::CopyHandler instproc makeNamespaceList {ns} {
  ::lappend [self]::nsList $ns
  foreach c [namespace children $ns] {
    [self] makeNamespaceList $c
  }
}

Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} {
  ::xotcl::namespace_copyvars $orig $dest
  ::xotcl::namespace_copycmds $orig $dest
}

# construct destination obj name from old qualified ns name
Object::CopyHandler instproc getNsDest {ns} {
  set tail [string range $ns [[self] set objLength] end]
  return ::[string trimleft [[self] set dest]$tail :]
}

Object::CopyHandler instproc copyNamespaces {} {
  foreach ns [[self] set nsList] {
    set nsDest [[self] getNsDest $ns]
    if {[[self] isobject $ns]} {
      # copy class information
      if {[[self] isclass $ns]} {
	set cl [[$ns info class] create $nsDest]
	# class object
	set obj $cl
	$cl superclass [$ns info superclass]
	$cl parameterclass [$ns info parameterclass]
	$cl parameter [$ns info parameter]
	$cl instinvar [$ns info instinvar]
	$cl filter [$ns info filter]
	[self] copyNSVarsAndCmds ::XOTclClasses::$ns ::XOTclClasses::$nsDest
      } else {
	# create obj
	set obj [[$ns info class] $nsDest]
      }
      # copy object -> may be a class obj
      $obj invar [$ns info invar]
      $obj check [$ns info check]
      $obj mixin [$ns info mixin]
      # set md [$ns info metadata]
      # $obj metadata add $md
      # foreach m $md { $obj metadata $m [$ns metadata $m] }
    } else {
      Namespace [[self] getNsDest $nsDest]
    }
    [self] copyNSVarsAndCmds $ns $nsDest
  }
}

Object::CopyHandler instproc copy {obj dest} {
  #puts stderr "[self] copy <$obj> <$dest>"
  [self] set objLength [string length $obj]
  [self] set dest $dest
  [self] makeNamespaceList $obj
  [self] copyNamespaces
}

Class xotcl::NoInit 
xotcl::NoInit instproc init args {;}


Object instproc copy newName {
  ::set ch [[self class]::CopyHandler create [[self class] autoname xotclCopyHandler]]
  $ch copy [self] $newName
  $ch destroy
}

Object instproc move newName {
  if {$newName != ""} {
    [self] copy $newName
  }
  [self] destroy
}

xotcl proc load {obj file} {
  source $file
  foreach i [array names ::auto_index [list $obj *proc *]] {
    set type [lindex $i 1]
    set meth [lindex $i 2]
    if {[$obj info ${type}s $meth] == {}} {
      $obj $type $meth auto $::auto_index($i)
    }
  }
}


xotcl proc mkindex {meta dir args} {
  ::xotcl::deprecated ::xotcl::mkindex package
  set sp {[         ]+}
  set st {^[        ]*}
  set wd {([^       ]+)}
  foreach creator $meta {
    ::lappend cp $st$creator${sp}create$sp$wd
    ::lappend ap $st$creator$sp$wd
  }
  foreach method {proc instproc} {
    ::lappend mp $st$wd${sp}($method)$sp$wd
  }
  foreach cl [concat Class [Class info heritage]] {
    eval ::lappend meths [$cl info instcommands]
  }
  set old [pwd]
  cd $dir
  ::append idx "# Tcl autoload index file, "
  ::append idx "version 2.0\n"
  ::append idx "# xotcl additions generated with "
  ::append idx "\"::xotcl::mkindex [list $meta] "
  ::append idx "[list $dir] $args\"\n"
  set oc 0
  set mc 0
  foreach file [eval glob -nocomplain -- $args] {
    if {[catch {set f [open $file]} msg]} then {
      catch {close $f}
      cd $old
      error $msg
    }
    while {[gets $f line] >= 0} {
      foreach c $cp {
	if {[regexp $c $line x obj]==1 &&
	    [string index $obj 0]!={$}} then {
	  ::incr oc
	  ::append idx "set auto_index($obj) "
	  ::append idx "\"::xotcl::load $obj "
	  ::append idx "\$dir/$file\"\n"
	}
      }
      foreach a $ap {
	if {[regexp $a $line x obj]==1 &&
	    [string index $obj 0]!={$} &&
	    [lsearch -exact $meths $obj]==-1} {
	  ::incr oc
	  ::append idx "set auto_index($obj) "
	  ::append idx "\"::xotcl::load $obj "
	  ::append idx "\$dir/$file\"\n"
	}
      }
      foreach m $mp {
	if {[regexp $m $line x obj ty pr]==1 &&
	    [string index $obj 0]!={$} &&
	    [string index $pr 0]!={$}} then {
	  ::incr mc
	  ::append idx "set \{auto_index($obj "
	  ::append idx "$ty $pr)\} \"source "
	  ::append idx "\$dir/$file\"\n"
	}
      }
    }
    close $f
  }
  set t [open tclIndex a+]
  puts $t $idx nonewline
  close $t
  cd $old
  return "$oc objects, $mc methods"
}


xotcl proc check_library_path {} {
  global auto_path env
  #puts stderr "initial auto_path <$auto_path>"
  if {[info exists env(XOTCL)] && [file isdirectory $env(XOTCL)]} {
    set ::xotcl::lib $env(XOTCL)
  } else {
    set xl xotcl-$::xotcl::version
    foreach dir $auto_path {
      if {[string match *xotcl* $dir] && [file isdirectory $dir]} {
	set ::xotcl::lib $dir
        return 1
      }
    }
    # check for directories in the current directory, check whether
    # we are in the source directory
    if {[regexp {^(.*/xotcl[^/]*)/?.*$} [pwd] _ p] && 
	[file isdirectory $p/src] && 
	[file isdirectory $p/lib]} {
      set ::xotcl::lib $p/lib
      set success 1
    }

    if {![info exists success]} {
      # check on the auto path for child or neighbor = xotcl
      foreach d $auto_path {
	foreach x [list [file join $d $xl] [file join $d .. $xl]] {
	  #puts stderr "check $x"
	  if {[file isdirectory $x]} { 
	    set ::xotcl::lib $x
	    set success 1
	    break
	  }
	}
	if {[info exists success]} {break}
      }
    }

    if {![info exists success] && ![file isdirectory $::xotcl::lib]} {
      puts stderr "Cannot locate the XOTcl library on your system!"
      return 0
    }
  }
  #puts stderr "[info exists success] <$::xotcl::lib>"
  set auto_path [linsert $auto_path [expr {[llength $auto_path]-2}] $::xotcl::lib]
  #puts stderr "final auto_path <$auto_path>"
}

Object ::xotcl::rcs
::xotcl::rcs proc date string {
  lreplace [lreplace $string 0 0] end end
} 
::xotcl::rcs proc version string {
  lindex $string 2
} 

set ::xotcl::confdir ~/.xotcl
set ::xotcl::logdir $::xotcl::confdir/log