tclmyoo only uses the tcl-standart-api-commands to implement myoo.

A CLASS is a cls array in the CLASS-NS :

The CLASS-NS always starts with ::
The CLASS-CONSTRUCTOR always return the CLASS-NS.
The CLASS-ATTRIBUTE is a variable in the CLASS-NS.
The METHOD (instance or class) is a proc in the CLASS-NS.
- The CONSTRUCTOR is an exported proc called like CLASS-NAME with a INSTANCE-NS as first argument.
- The DESTRUCTOR is an exported proc called like ~CLASS-NAME with a INSTANCE-NS as first argument.
- The PUBLIC-METHOD is a proc with namespace export attribute.
- The CLASS-METHOD is a proc without INSTANCE-NS as first argument.
- The INSTANCE-METHOD is a proc wit INSTANCE-NS as first argument.
The SUPER-CLASS is the CLASS-NS of another class whose public methods are imported into the SUB-CLASS-NS.
- The SUPER-CLASS-CONSTRUCTOR is called by the SUB-CLASS-CONSTRUCTOR as normal proc.

An INSTANCE is a my array in the INSTANCE-NS :

The INSTANCE-NS always starts with ::
The INSTANCE-CONSTRUCTOR always return the INSTANCE-NS
The INSTANCE-ATTRIBUTE is an element in the my array.
The INSTANCE-METHOD always has the INSTANCE-NS as first argument.
The INSTANCE-REF is created using namespace upvar INSTANCE-NS my otherVar

 
#+
#:   @file         NHI1/theLib/myoo/tclmyoox.atl
#:   @brief        tag: nhi1-release-250425
#:   @copyright    (C) NHI - #1 - Project - Group
#:                 This software has NO permission to copy,
#:                 please contact AUTHOR for additional information
#:

# LOG :
#
# 09 apr 2025 : api update change the order of arguments to support the CLASS-FIRST argument.
# 14 feb 2025 : api update adds 'Create[123]N' to cover different sets of fixed arguments:
#               > 'Create1N' and 'NewN' are identical.
# 25 jan 2025 : add EMBEDDED-INSTANCE procs "::myooX::CreateI" and "::myooX::DestroyI"
# -> example  : theLib/docs/main/Instance-Embedded.atl

package provide tclmyoox 1.0

# tags
proc tclmyoox "" ""

namespace eval ::myooX {
  namespace export {*I}
  variable clsNs2Ref
}

# tclmyoor.tcl
# tclmyoos.tcl

# =================================================================================
# class

proc ::myooX::ClassN {clsNs {Xcode ""}} {
  variable clsNs2Ref
  set clsNs2Ref($clsNs)  "${clsNs}::cls"

  # access "base"
  namespace eval $clsNs {
    namespace path ::myooX
  }

  # set the "cls"
  namespace upvar $clsNs cls cls

  set cls(__NS__)             $clsNs
  set cls(__NAME__)           [namespace tail $clsNs]
  set cls(__SUPER__)          ""
  set cls(__NS_ALL_SORTED__)  ""
  set cls(__INDEX__)          0
  set cls(__CTOR__)           ""
  set cls(__DTOR__)           ""

  if {$Xcode ne ""} {
    namespace eval $clsNs $Xcode
  }

  # reset internal dependencies
  RecompileN $clsNs
}

# “ResetN” is a special cammand that is used in testing to “clean up” a class and then get a new reproducible result.
proc ::myooX::ResetN {clsNs} {
  namespace upvar $clsNs cls cls
  # 1. delete all "anonymous children"
  foreach ns [namespace children $clsNs] {
    if {[info exists ${ns}::my]} {
      DestroyN $ns
    }
  }
  # 2. initialize the class
  set cls(__INDEX__)  0
  set cls(__CTOR__)   ""
  set cls(__DTOR__)   ""
  # 3. reset internal dependencies
  RecompileN $clsNs
}

proc ::myooX::SuperI {args} {
  variable clsNs2Ref
  upvar cls cls

  foreach superNs $args {
    if {![info exists clsNs2Ref($superNs)]} {
      throw {MYOOX SUPER NOT-EXISTS} "myoox-error: the super-class='$superNs' does NOT exists"
    }
    if {$superNs in $cls(__SUPER__)} {
      throw {MYOOX SUPER DUPLICATE} "myoox-error: the super-class='$superNs' was already added"
    }
    lappend cls(__SUPER__) $superNs

    namespace eval $cls(__NS__) [list namespace import ${superNs}::*]
  }
}

proc ::myooX::SuperN {clsNs superNs} {
  namespace upvar $clsNs cls cls
  namespace inscope $clsNs SuperI $superNs
}

proc ::myooX::RecompileN {clsNs} {
  namespace upvar $clsNs cls cls

  # 1. resolve CTOR
  set ctorL     [list]
  set myCtor    "${clsNs}::$cls(__NAME__)" 
  set myCtorB   0
  foreach CTOR [info commands $myCtor] {
    set ctorL     $CTOR
    set myCtorB   1
  }
  # 2. resolve DTOR
  set dtorL     [list]
  set myDtor    "${clsNs}::~$cls(__NAME__)"
  set myDtorB   0
  foreach DTOR [info commands $myDtor] {
    set dtorL     $DTOR
    set myDtorB   1
  }
  # 3. resolve __SUPER__
  set cls(__NS_ALL_SORTED__) $clsNs
  foreach superNs $cls(__SUPER__) {
    namespace upvar $superNs cls sup
    lappend cls(__NS_ALL_SORTED__)  {*}$sup(__NS_ALL_SORTED__)
    if {$sup(__CTOR__) ne ""} { lappend ctorL $sup(__CTOR__) }
    if {$sup(__DTOR__) ne ""} { lappend dtorL $sup(__DTOR__) }
  }

  # find CTOR
  if {[llength $ctorL]} {
    if {!$myCtorB && [llength $ctorL] > 1} {
      throw {MYOOX RECOMPILE AMBIGUOUS CTOR} \
        "myoox-error-$cls(__NAME__)-ctor: toplevel CTOR={$myCtor} is required if more than one super-class-ctor={$ctorL} is available"
    }
    set cls(__CTOR__) [lindex $ctorL 0]
    namespace eval $clsNs [list namespace export [namespace tail $cls(__CTOR__)]]    
  } else {
    set cls(__CTOR__) ""
  }

  # find DTOR
  if {[llength $dtorL]} {
    if {!$myDtorB && [llength $dtorL] > 1} {
      throw {MYOOX RECOMPILE AMBIGUOUS DTOR} \
        "myoox-error-$cls(__NAME__)-dtor: toplevel DTOR={$myDtor} is required if more than one super-class-dtor={$dtorL} is available"
    }
    set cls(__DTOR__) [lindex $dtorL 0]
    namespace eval $clsNs [list namespace export [namespace tail $cls(__DTOR__)]]    
  } else {
    set cls(__DTOR__) ""
  }

  set cls(__NS_ALL_SORTED__)  [lsort -unique $cls(__NS_ALL_SORTED__)]
  set clsNs
}

# =================================================================================
# instance CTOR

proc ::myooX::_ErrorRaise {cmd errCode argsL} {
  foreach line [lassign $argsL msg] {
    append msg "\n  | $line"
  }
  tailcall return -code error -errorcode [concat MYOOX $errCode] "\[$cmd\] $msg"
}

proc ::myooX::_ErrorCatch {cmd errCode opts msg} {
  lappend msgL $msg
  if {[dict exists $opts -errorinfo]} {
    lappend msgL {*}[split [dict get $opts -errorinfo] \n]
  }
  tailcall _ErrorRaise $cmd $errCode $msgL
}

proc ::myooX::_ErrorCatchCtorFailedN {cmd myNs opt} {
  namespace delete $myNs
  tailcall _ErrorCatch $cmd {CTOR FAILED} $opt "call CTOR failed for instance '$myNs'."
}

proc ::myooX::_ErrorRaiseCtorInvalidArgumentN {cmd myNs argsL} {
  namespace delete $myNs
  tailcall _ErrorRaise $cmd {CTOR MISSING OVERFLOW} [list \
    "call CTOR failed for instance '$myNs'." \
    "no constructor defined to use the argument(s) '$argsL'."
  ]
}

proc ::myooX::_ErrorCatchDtorFailedN {cmd myNs opt} {
  namespace delete $myNs
  tailcall _ErrorCatch $cmd {DTOR FAILED} $opt "call DTOR failed for instance '$myNs'."
}

# Create a myoo instance
# 1. if already exists return existing instance-hdl
proc ::myooX::MakeN { clsNs {Xname ""} {Xns ""} } {
  namespace upvar $clsNs cls cls
  if {$Xname eq ""} {
    set Xname "$cls(__NAME__)-[incr cls(__INDEX__)]"
    if {$Xns eq ""} {
      set myNs "${clsNs}::$Xname"
    } else {
      set myNs "${Xns}::$Xname"
    }
    set myName $Xname
  } elseif {[string match ::* $Xname]} {
    set myNs "$Xname"
    set myName [namespace tail $myNs]
  } elseif {$Xns eq ""} {
    set myNs "${clsNs}::$Xname"
    set myName $Xname
  } else {
    set myNs "${Xns}::$Xname"
    set myName $Xname
  }
  if {![namespace exists $myNs]} {
    namespace eval $myNs {}
    # set the "my"
    namespace upvar $myNs my my
    set my(__NS__)        $myNs
    set my(__NAME__)      $myName
    set my(__CLASS__)     $clsNs
  }
  set myNs
}

# initialize an myoo instance
proc ::myooX::CtorN { clsNs myNs argsL } {
  namespace upvar $clsNs cls cls
  if {$cls(__CTOR__) ne ""} {
    try {
      $cls(__CTOR__) $myNs {*}$argsL
    } on error {- opt} {
      _ErrorCatchCtorFailedN "CtorN" $myNs $opt
    }
  } elseif {[llength $argsL]} {
    _ErrorRaiseCtorInvalidArgumentN "CtorN" $myNs $argsL
  }
  set myNs
}

proc ::myooX::Create3N {clsNs Xname Xns args} {
  CtorN $clsNs [MakeN $clsNs $Xname $Xns] $args
}

proc ::myooX::Create2N {clsNs Xname args} {
  CtorN $clsNs [MakeN $clsNs $Xname] $args
}

proc ::myooX::Create1N {clsNs args} {
  CtorN $clsNs [MakeN $clsNs] $args
}

proc ::myooX::NewN {clsNs args} {
  CtorN $clsNs [MakeN $clsNs] $args
}

# embedded instance
proc ::myooX::CreateI {myNs clsNs embName args} {
  namespace upvar $myNs my my
  set my($embName) [Create3N $clsNs $embName $myNs {*}$args]
}

proc ::myooX::DestroyI {myNs embName} {
  namespace upvar $myNs my my
  DestroyN $my($embName)
}

# =================================================================================
# instance DTOR

proc ::myooX::DestroyN { myNs } {
  namespace upvar $myNs my my
  namespace upvar $my(__CLASS__) cls cls
  if {$cls(__DTOR__) ne ""} {
    try {
      $cls(__DTOR__) $myNs
    } on error {- opt} {
      _ErrorCatchDtorFailedN "DestroyN" $myNs $opt
    }
  }
  namespace delete $myNs
}

proc ::myooX::ClassIsN { myNs clsNs } {
  namespace upvar $myNs my my
  namespace upvar $my(__CLASS__) cls cls
  expr { [ lsearch -sorted -exact $cls(__NS_ALL_SORTED__) $clsNs ] != -1 }
}