1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
set randchan [tcl::chan::random [tcl::randomseed]]
proc rand_hex {} {
global randchan
return [binary encode hex [read randchan 8]]
}
proc lindex* {list args} {
lmap index $args {lindex $list {*}$index}
}
proc sproc {name args} {
if {[llength $args] == 1} {
set config [lindex $args 0]
} else {
set config $args
}
if {[llength $config] % 3 != 0 || $config == {}} {
return -code error "wrong # args: should be \"sproc name { subcommand args body ?subcommand args body ...? }\""
}
set config [lsort -stride 3 $config]
set subcommands [lmap {subcommand _ _} $config {expr {$subcommand}}]
set prefix_args {}
set prefix_body {}
if {[set subcmd_idx [lsearch $subcommands _prefix]] != -1} {
set prefix_idx [expr {$subcmd_idx * 3}]
lassign [lindex* $config $prefix_idx+1 $prefix_idx+2] prefix_args prefix_body
set config [lreplace $config $prefix_idx $prefix_idx+2]
set subcommands [lreplace $subcommands $subcmd_idx $subcmd_idx]
}
set qualifiers [namespace qualifiers $name]
if {[string range $name 0 1] == "::"} {
if {$qualifiers == {}} {
set namespace ::
} else {
set namespace $qualifiers
}
} else {
set parent [uplevel {namespace current}]
if {$qualifiers == {}} {
set namespace ${parent}
} else {
set namespace ${parent}::${qualifiers}
}
}
set name [namespace tail $name]
interp alias {} ${namespace}::${name} {} ::__sproc_impl $name $namespace $prefix_args $prefix_body $subcommands $config
}
proc __sproc_impl {name namespace prefix_args prefix_body subcommands config args} {
if {[llength $args] < [llength prefix_args] + 1} {
return -code error "wrong # args: should be \"$name [concat subcommand $prefix_args] ?arg ...?\""
}
set args [lassign $args subcommand]
# TODO: don't search the list twice, if possible
set subcommand [::tcl::prefix match -message subcommand $subcommands $subcommand]
set cmd_index [expr {[lsearch -sorted $subcommands $subcommand] * 3}]
lassign [lindex* $config $cmd_index+1 $cmd_index+2] sc_args sc_body
set sc_args [concat $prefix_args $sc_args]
set sc_body [string cat $prefix_body \n $sc_body]
if {[lindex $sc_args end] == "args"} {
if {[llength $args] >= [llength $sc_args] - 1} {
uplevel [list apply [list $sc_args $sc_body $namespace] {*}$args]
} else {
return -code error "wrong # args: should be \"$name $subcommand [concat [lrange $sc_args 0 end-1] {?arg ...?}]\""
}
} else {
if {[llength $args] == [llength $sc_args]} {
uplevel [list apply [list $sc_args $sc_body $namespace] {*}$args]
} else {
return -code error "wrong # args: should be \"$name [concat [list $subcommand] $sc_args]\""
}
}
}