cmdr
Check-in [54065b631c]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Extended cmdr with "table" utility package.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:54065b631c9116bed1ec2297e207e96bc1bf3a7b
User & Date: andreask 2015-07-09 19:12:56
Context
2015-07-14
03:38
Tweaked the in-source docs for "less" a bit. check-in: 83ac211042 user: aku tags: trunk
2015-07-09
19:12
Extended cmdr with "table" utility package. check-in: 54065b631c user: andreask tags: trunk
04:04
pager - Extended the module to run "less" with options allowing display of ANSI colors, and suppressing binary warning (due to such colors). check-in: 782638c0ff user: aku tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added table.tcl.





























































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
# -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## Easy table generation

# @@ Meta Begin
# Package cmdr::table 0
# Meta author      ?
# Meta category    ?
# Meta description ?
# Meta location    http:/core.tcl.tk/akupries/cmdr
# Meta platform    tcl
# Meta require     ?
# Meta subject     ?
# Meta summary     ?
# @@ Meta End

# # ## ### ##### ######## ############# #####################
## Requirements

package require Tcl 8.5
package require TclOO
package require cmdr::color
package require debug
package require debug::caller
package require report
package require struct::matrix

# # ## ### ##### ######## ############# ######################
## Debug narrative setup

debug level  cmdr/table
debug prefix cmdr/table {[debug caller] | }

# # ## ### ##### ######## ############# ######################
## Styles used in the table reports.

# Borders and header row.
::report::defstyle cmdr/table/borders {} {
    data	set [split "[string repeat "| "   [columns]]|"]
    top		set [split "[string repeat "+ - " [columns]]+"]
    bottom	set [top get]
    topdata	set [data get]
    topcapsep	set [top get]
    top		enable
    bottom	enable
    topcapsep	enable
    tcaption	1
    for {set i 0 ; set n [columns]} {$i < $n} {incr i} {
	pad $i both { }
    }
    return
}

# Borders, no header row.
::report::defstyle cmdr/table/borders/nohdr {} {
    data	set [split "[string repeat "| "   [columns]]|"]
    top		set [split "[string repeat "+ - " [columns]]+"]
    bottom	set [top get]
    top		enable
    bottom	enable
    for {set i 0 ; set n [columns]} {$i < $n} {incr i} {
	pad $i both { }
    }
    return
}

# No borders, with header row.
::report::defstyle cmdr/table/plain {} {
    tcaption	1
    for {set i 1 ; set n [columns]} {$i < $n} {incr i} {
	pad $i left { }
    }
    return
}

# No borders, no header row
::report::defstyle cmdr/table/plain/nohdr {} {
    for {set i 1 ; set n [columns]} {$i < $n} {incr i} {
	pad $i left { }
    }
    return
}

::report::defstyle cmdr/table/html {} {
    data	set [split "<tr><td> [string repeat "</td><td> " [expr {[columns]-1}]]</td></tr>"]
    #top		set <table>
    #bottom	set </table>
    #top		enable
    #bottom	enable
    return
}

# # ## ### ##### ######## ############# ######################

namespace eval ::cmdr {
    namespace export table
    namespace ensemble create
}
namespace eval ::cmdr::table {
    variable plain   no   ;# Global style setting (plain yes/no)
    variable showcmd puts ;# Global print setting (command prefix)

    namespace export general dict plain show
    namespace ensemble create
}

# # ## ### ##### ######## ############# #####################
## API

proc ::cmdr::table::plain {v} {
    debug.cmdr/table {}
    variable plain $v
    return
}

proc ::cmdr::table::show {args} {
    debug.cmdr/table {}
    variable showcmd $args
    return
}

proc ::cmdr::table::general {v headings script} {
    debug.cmdr/table {}

    variable plain
    upvar 1 $v t
    set t [uplevel 1 [list ::cmdr::table::Impl::general new {*}$headings]]
    if {$plain} { $t plain }
    uplevel 1 $script
    return $t
}

proc ::cmdr::table::dict {v script} {
    debug.cmdr/table {}

    upvar 1 $v t
    variable plain
    set t [uplevel 1 [list ::cmdr::table::Impl::dict new]]
    if {$plain} { $t plain }
    uplevel 1 $script
    return $t
}

# # ## ### ##### ######## ############# #####################
## Internal classes

oo::class create ::cmdr::table::Impl::general {
    # # ## ### ##### ######## #############

    constructor {args} {
	debug.cmdr/table {}
	namespace import ::cmdr::color
	# args = headings.

	struct::matrix [self namespace]::M
	M add columns [llength $args]

	set headings {}
	foreach w $args { lappend headings [color heading $w] }

	M add row $headings
	set myplain 0
	set myheader 1
	set mystyle {}
	return
    }

    destructor {}

    # # ## ### ##### ######## #############
    ## API

    method add {args} {
	M add row $args
	return
    }
    # Alternate names for creation of new rows.
    forward +  my add ; export +
    forward += my add ; export +=
    forward << my add ; export <<
    forward <= my add ; export <=

    method show {{cmd {}}} {
	if {[llength [info level 0]] == 2} {
	    variable ::cmdr::table::showcmd
	    set cmd $::cmdr::table::showcmd
	}
	uplevel #0 [list {*}$cmd [my String]]
	my destroy
	return
    }

    method show* {{cmd {}}} {
	if {[llength [info level 0]] == 2} {
	    variable ::cmdr::table::showcmd
	    set cmd $::cmdr::table::showcmd
	}
	uplevel #0 [list {*}$cmd [my String]]
	return
    }

    method plain {} {
	debug.cmdr/table {}
	set myplain 1
	return
    }

    method style {style} {
	debug.cmdr/table {}
	set mystyle $style
	return
    }

    method noheader {} {
	debug.cmdr/table {}
	if {!$myheader} return
	set myheader 0
	M delete row 0
	return
    }

    method String {} {
	debug.cmdr/table {}
	# Choose style (user-specified, plain y/n, header y/n)

	if {$mystyle ne {}} {
	    set thestyle $mystyle
	} elseif {$myplain} {
	    if {$myheader} {
		set thestyle cmdr/table/plain
	    } else {
		set thestyle cmdr/table/plain/nohdr
	    }
	} else {
	    if {$myheader} {
		set thestyle cmdr/table/borders
	    } else {
		set thestyle cmdr/table/borders/nohdr
	    }
	}

	set r [report::report [self namespace]::R [M columns] style $thestyle]
	set str [M format 2string $r]
	$r destroy

	return [string trimright $str]
    }

    # # ## ### ##### ######## #############
    ## Internal commands.

    # # ## ### ##### ######## #############
    ## State

    variable myplain myheader mystyle

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################

oo::class create ::cmdr::table::Impl::dict {
    # # ## ### ##### ######## #############
    superclass ::cmdr::table::Impl::general

    constructor {} {
	debug.cmdr/table {}
	next Key Value
	my noheader ;# suppress header row.
	# Keys are the headers (side ways table).
	return
    }

    destructor {}

    # # ## ### ##### ######## #############
    ## API

    # Specialized "add", applies colorization to keys.
    method add {key {value {}}} {
	# Note, we separate leading spaces and indentation from the
	# actual key.  The prefix will not be colored.  Note also that
	# key colorization done by the user will override the color
	# applied here.

	regexp {(^[- ]*)(.*)$} $key -> prefix thekey
	M add row [list $prefix[color heading $thekey] $value]
	return
    }

    # # ## ### ##### ######## #############
    ## Internal commands.

    # # ## ### ##### ######## #############
    ## State - None of its own.

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::table 0