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 edit
(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 edit
(file: pkgIndex.tcl)
###############################
#
# APackage reference
#
###############################
package ifneeded APackage 0.9 [list source [file join $dir apackage.tcl]]
(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)
