[ulis], 2003-11-03. If you need to write a Tcl package.

   * This is a robust and versatil package proto that you can adapt to fit your needs.
   * Care was taken to hide the internal procs when an error occurs.
   * Extending this package is as easy as filling a table with procs name and descriptions syntax.
   * You can define subcommands as easily you defined commands.

----
**The package**
(file: apackage.tcl)
======
  # This is a robust and versatile package proto that you can adapt to fit your needs.
  # Care was taken to hide the internal procs when an error occurs.
  # Extending this package is as easy as filling a table with procs name and descriptions syntax.
  # You can define subcommands as easily you defined commands.
  
  # check if already loaded
  if {[info exists ::apackage::version]} { return }
  
  # define namespace & package
  namespace eval ::apackage \
  {
    # entry point export
    namespace export apackage
    
    # apackage variables
    variable {}
  ###############################
  #
  #   Package apackage
  variable version 0.9
  #
  #   a apackage proto
  #
  #   (C) 2003, ulis
  #   NOL licence (No obligation licence)
  ###############################
    
    # apackages management
    package provide APackage $version
    package require Tcl 8.4
    
    # ----------------
    # main entry point
    # ----------------
    interp alias {} ::apackage::apackage {} ::apackage::w:dispatch main 

    # ----------------
    # internal generalized dispatch proc
    # ----------------
    # parm1: description name (see description below)
    # parm2: current operation
    # parm3: optional current operation args list
    # ----------------
    # return: operation result 
    # ----------------
    proc w:dispatch {desc operation args} \
    {
      variable {}
      # catch error
      if {[incr (:level)] == 1} { set (:errInfo) "" }
      set rc [catch \
      {
        # retrieve command
        foreach {pattern item} $(:$desc:cmd) \
        { 
          if {[string match $pattern $operation]} \
          { 
            set oper [lindex $item 0]
            set lvl [lindex $item 1]
            set msg [lindex $item 2]
            set conds [lrange $item 3 end]
            break
          } 
        }
        if {![info exists oper]} \
        { 
          error "bad operation \"$operation\": should be $(:$desc:msg)" 
        }
        # check args
        set map [eval $(:$desc:map)]
        foreach cond $conds \
        {
          set cond [string map $map $cond]
          if $cond \
          { w:error "wrong # args: should be [string map $map $msg]" } 
        }
        # eval command
        if {[llength $args] == 0} { uplevel $lvl [namespace code $oper] } \
        else { uplevel $lvl [namespace code $oper] $args }
      } msg]
      # return result
      set code [expr {$rc ? "error" : "ok"}]
      if {$(:errInfo) == ""} { set (:errInfo) $::errorInfo }
      return -code $code -errorinfo $(:errInfo) $msg
    }

    # ----------------
    # internal error management
    # ----------------
    set (:level) 0
    set (:errInfo) ""
    proc w:error {{msg ""}} \
    {
      variable {}
      if {$msg != ""} { set (:errInfo) $msg }
      set (:level) 0
      uplevel 1 [list error $msg]
    }

  # -------------
  # -------------
  #
  #  main level description
  #
  # -------------
  # -------------

    # message for an unknown operation (list of known operations)
    set (:main:msg) {operation1, operation2, operation3 or sub1}
    # computed values for syntax conditions (change only if needed)
    set (:main:map) {list %len% [llength $args] %action% [lindex $args 0]}
    # operations description
    # One entry by operation:
    #   <operation name> \
    #   {
    #     <proc name>
    #     <uplevel level> (0 for aliases)
    #     {"<help message on syntax error>"}
    #     {<error condition>}
    #   }
    set (:main:cmd) \
    { 
      operation1 \
      {
        w:operation1
        1
        {"apackage operation1 arg1 $args"}
        {%len% < 1}
      }
      operation2 \
      {
        w:operation2
        1
        {"apackage operation2 ?$key $value?..."}
        {%len% % 2 != 0}
      }
      operation3 \
      {
        w:operation3
        {"apackage operation3 ?$arg?..."}
        {0}
      }
      sub1       \
      {
        w:sub1
        0
        {"apackage sub1 action1|action2 ?$arg?..."}
        {"%action%" != "action1" && "%action%" != "action2"}
      }
      version    \
      {
        w:version
        0
        {"apackage version"}
        {%len% != 0}
      }
    }

    interp alias {} ::apackage::w:sub1 {} ::apackage::w:dispatch sub1 
    interp alias {} ::apackage::w:version {} set ::apackage::version 

  # -------------
  # -------------
  #
  #  sub1 level description
  #
  # -------------
  # -------------

    set (:sub1:msg) {action1 or action2}
    set (:sub1:map) {list %len% [llength $args]}
    set (:sub1:cmd) \
    { 
      action1 \
      {
        w:sub1:action1
        1
        {"sub1 action1 arg1 $args"}
        {%len% < 1}
      }
      action2 \
      {
        w:sub1:action2
        1
        {"sub1 action2 ?$key $value?..."}
        {%len% % 2 != 0}
      }
    }
    
  # -------------
  # -------------
  #
  #  main procs
  #
  # -------------
  # -------------

    # -------------
    # w:operation1
    #
    # operation1 description
    # -------------
    # parm1: arg1
    # parm2: optional args list
    # -------------
    # return: nothing
    # -------------
    proc w:operation1 {arg1 args} \
    {
      if {![string is integer -strict $arg1]} \
      { w:error "expected integer, got \"$arg1\"" }
      if {$arg1 == 0} { eval w:sub1 action2 $args }
    }
  
    # -------------
    # w:operation2
    #
    # operation2 description
    # -------------
    # parm1: optional key/value pairs list
    # -------------
    # return: nothing
    # -------------
    proc w:operation2 {args} \
    {
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          one     -
          two     -
          thr*    -
          fou*    -
          fiv*    -
          six     { # ok }
          default \
          { w:error "unknown key \"$key\"" }
        }
      }
    }
  
  # -------------
  # -------------
  #
  #  sub1 procs
  #
  # -------------
  # -------------
    
    # -------------
    # w:sub1:action1
    #
    # action1 description
    # -------------
    # parm1: arg1
    # parm2: optional args list
    # -------------
    # return: nothing
    # -------------
    proc w:sub1:action1 {arg1 args} \
    {
      if {![string is integer -strict $arg1]} \
      { w:error "expected integer, got \"$arg1\"" }
    }
  
    # -------------
    # w:sub1:action2
    #
    # action2 description
    # -------------
    # parm1: optional key/value pairs list
    # -------------
    # return: nothing
    # -------------
    proc w:sub1:action2 {args} \
    {
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -one     -
          -two     -
          -thr*    -
          -fou*    -
          -fiv*    -
          -six     { # ok }
          default  \
          { w:error "unknown key \"$key\"" }
        }
      }
    }
  
    
  # end of ::apackage namespace
  }
======

----
**The corresponding reference**
(file: pkgIndex.tcl)
======
  ###############################
  #
  #   APackage reference
  #
  ###############################

  package ifneeded APackage 0.9 [list source [file join $dir apackage.tcl]]
======

----
**A demo**
(file: demo.tcl)
======
  ###############################
  #
  #   APackage demo
  #
  ###############################

  # -----------
  # packages & entry points
  # -----------

  # refering the package in the current directory
  lappend auto_path [pwd]

  package require APackage 0.9
  namespace import ::apackage::apackage

  # -----------
  # demo
  # -----------

  proc demo {} \
  {
    result { apackage version }
    result { apackage operation1 }
    result { apackage operation1 "" }
    result { apackage operation1 2 }
    result { apackage operation1 0 one }
    result { apackage operation1 0 one 1 }
    result { apackage operation1 0 -one 1 }
    result { apackage sub1 action1 arg }
    result { apackage sub1 action2 -one 1 }
    puts "\na full error trace:"
    apackage operation1 0 one 1
  }

  proc result {script} \
  {
    set rc [catch { uplevel 1 $script } res]
    if {$rc} { puts "{$script} -->$res" } \
    elseif {$res != ""} { puts "{$script} : $res" } \
    else { puts "{$script}" }
  }

  demo
======
----
***The result***

  { apackage version } : 0.9
  { apackage operation1 } -->wrong # args: should be "apackage operation1 arg1 $args"
  { apackage operation1 "" } -->expected integer, got ""
  { apackage operation1 2 }
  { apackage operation1 0 one } -->wrong # args: should be "sub1 action2 ?$key $value?..."
  { apackage operation1 0 one 1 } -->unknown key "one"
  { apackage operation1 0 -one 1 }
  { apackage sub1 action1 arg } -->expected integer, got "arg"
  { apackage sub1 action2 -one 1 }

  a full error trace:
  unknown key "one"
      invoked from within
  "apackage operation1 0 one 1"
      (procedure "demo" line 12)
      invoked from within
  "demo"
      (file "D:\mb\Src\Package\demo.tcl" line 44)

<<categories>> Example | Design | Package