Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | cmdr::color - Fixed issues, expanded functionality, better checking. Plus testsuite. |
---|---|
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
ddd5e520dd23fb7b97ac4f7e2f4f5578 |
User & Date: | aku 2014-05-23 07:13:21.002 |
References
2014-05-23
| ||
22:17 | • Ticket [8502a858bd] Add facility for colorization status still Closed with 3 other changes artifact: 2239702142 user: aku | |
22:17 | • Closed ticket [8502a858bd]. artifact: 26dcf622de user: aku | |
Context
2014-05-23
| ||
20:42 | cmdr::ask - Reactivated color support. No tests yet. check-in: 0c33d13e6e user: andreask tags: trunk | |
07:13 | cmdr::color - Fixed issues, expanded functionality, better checking. Plus testsuite. check-in: ddd5e520dd user: aku tags: trunk | |
06:19 | cmdr::tty - Fixed package provision typo, plus testsuite for same. check-in: e8bf343c87 user: aku tags: trunk | |
Changes
Changes to color.tcl.
︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 | package require Tcl 8.5 package require debug package require debug::caller package require cmdr::tty # # ## ### ##### ######## ############# ##################### namespace eval ::cmdr::color { | > > > > > | > < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | < | | | | | > > > > | > | | | | | | > > | > > > > | | | | | | | > | | | | | | | | | > | 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 | package require Tcl 8.5 package require debug package require debug::caller package require cmdr::tty # # ## ### ##### ######## ############# ##################### namespace eval ::cmdr { namespace export color namespace ensemble create } namespace eval ::cmdr::color { namespace export \ activate active names get get-def define exists unset namespace ensemble create \ -unknown [namespace current]::Unknown # Note, the option ensures that all unknown methods are treated as # (list of) color codes to apply to some text, effectively # creating the virtual command # # ::cmdr::color <codelist> <text> ## namespace import ::cmdr::tty } # # ## ### ##### ######## ############# ##################### debug define cmdr/color debug level cmdr/color debug prefix cmdr/color {[debug caller] | } # # ## ### ##### ######## ############# ##################### ## TODO multi-def aka bulk-def aka load ## TODO officer and private for std commands (show, define). proc ::cmdr::color::activate {{flag 1}} { debug.cmdr/color {} variable active $flag return } proc ::cmdr::color::active {} { debug.cmdr/color {} variable active return $active } proc ::cmdr::color::names {} { debug.cmdr/color {} variable def return [dict keys $def] } proc ::cmdr::color::unset {name} { debug.cmdr/color {} variable def if {![dict exists $def $name]} { return -code error \ -errorcode [list CMDR COLOR BAD $name] \ "Expected a color name, got \"$name\"" } variable char dict unset def $name dict unset char $name return } proc ::cmdr::color::get {name} { debug.cmdr/color {} variable def if {![dict exists $def $name]} { return -code error \ -errorcode [list CMDR COLOR BAD $name] \ "Expected a color name, got \"$name\"" } variable char return [dict get $char $name] } proc ::cmdr::color::get-def {name} { debug.cmdr/color {} variable def if {![dict exists $def $name]} { return -code error \ -errorcode [list CMDR COLOR BAD $name] \ "Expected a color name, got \"$name\"" } return [dict get $def $name] } proc ::cmdr::color::exists {name} { debug.cmdr/color {} variable def return [dict exists $def $name] } proc ::cmdr::color::define {name spec} { debug.cmdr/color {} variable def variable char # The spec may be # (1) A reference to other color name. # (2) An RGB spec. # (3) A raw control sequence. # Syntax: # (1) ref := =<name> # (2) rgb := %<r>,<g>,<b> # (3) raw := anything else if {[regexp {^=(.*)$} $spec -> ref]} { if {$ref eq $name} { return -code error \ -errorcode [list CMDR COLOR CIRCLE $name] \ "Rejected self-referential definition of \"$name\"" } elseif {![dict exists $def $ref]} { return -code error \ -errorcode [list CMDR COLOR BAD $ref] \ "Expected a color name, got \"$ref\"" } else { set raw [dict get $char $ref] debug.cmdr/color {reference, resolved => [Quote $raw]} dict set def $name $spec dict set char $name $raw return } } if {[regexp {^%(.*)$} $spec -> rgb]} { if {![regexp {^(\d+),(\d+),(\d+)$} $rgb -> r g b]} { return -code error \ -errorcode [list CMDR COLOR BAD-RGB SYNTAX $rgb] \ "Expected an RGB tuple, got \"$rgb\"" } { # R, G, B all in range 0..5 Clamp R $r Clamp G $g Clamp B $b # 256-color mapping # code = 16 + 36R + 6G + B --> [16..236] set point [expr {16 + 36*$r + 6*$g + $b}] set code [Code $point] debug.cmdr/color {RGB encoded => [Quote $code]} dict set def $name $spec dict set char $name $code return # Legacy mapping # R,G,B mapping 0,1 --> 0, 2,3 --> 1, 4,5 --> 2 # bold mapping: 0,1,2 --> 0,1,1 (set if any of R, G, B) # code = 8bold + R + 2G + 4B # = 8, for R==G==B != 0, special case. } } # Raw control sequence, simply save dict set def $name $spec dict set char $name $spec return } |
︙ | ︙ | |||
130 131 132 133 134 135 136 | if {!$active} { debug.cmdr/color {not active} return $text } variable char foreach c $codes { | | | | | | < | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | < < | | | < < < < < | < | < | < | | | < | < < < | | 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 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | if {!$active} { debug.cmdr/color {not active} return $text } variable char foreach c $codes { if {![dict exists $char $c]} { return -code error \ -errorcode [list CMDR COLOR UNKNOWN $c] \ "Expected a color name, got \"$c\"" } append r [dict get $char $c] } append r $text append r [dict get $char reset] debug.cmdr/color {/done} return $r } proc ::cmdr::color::Quote {text} { # quote all non-printable characters (< space, > ~) variable smap return [string map $smap $text] } proc ::cmdr::color::Code {args} { return \033\[[join $args \;]m } proc ::cmdr::color::Clamp {label x} { if {($x >= 0) && ($x <= 5)} { return $x } return -code error \ -errorcode [list CMDR COLOR BAD-RGB RANGE $x] \ "RGB channel $label out of range, got $x" } # # ## ### ##### ######## ############# ##################### namespace eval ::cmdr::color { # Boolean flag controlling use of color sequences. # Default based on tty-ness of stdout. Active if yes. variable active [tty stdout] # Database (dictionary) of standard colors and associated codes. # Based on the standard ANSI colors (16-color terminal). The two # dictionaries hold the user-level specification and the # full-resolved character sequence. variable def {} variable char {} # Colors. Foreground/Text. define black [Code 30] ; # Black define red [Code 31] ; # Red define green [Code 32] ; # Green define yellow [Code 33] ; # Yellow define blue [Code 34] ; # Blue define magenta [Code 35] ; # Magenta define cyan [Code 36] ; # Cyan define white [Code 37] ; # White define default [Code 39] ; # Default (Black) # Colors. Background. define bg-black [Code 40] ; # Black define bg-red [Code 41] ; # Red define bg-green [Code 42] ; # Green define bg-yellow [Code 43] ; # Yellow define bg-blue [Code 44] ; # Blue define bg-magenta [Code 45] ; # Magenta define bg-cyan [Code 46] ; # Cyan define bg-white [Code 47] ; # White define bg-default [Code 49] ; # Default (Transparent) # Non-color attributes. Activation. define bold [Code 1] ; # Bold define dim [Code 2] ; # Dim define italic [Code 3] ; # Italics define underline [Code 4] ; # Underscore define blink [Code 5] ; # Blink define revers [Code 7] ; # Reverse define hidden [Code 8] ; # Hidden define strike [Code 9] ; # StrikeThrough # Non-color attributes. Deactivation. define no-bold [Code 22] ; # Bold define no-dim [Code __] ; # Dim define no-italic [Code 23] ; # Italics define no-underline [Code 24] ; # Underscore define no-blink [Code 25] ; # Blink define no-revers [Code 27] ; # Reverse define no-hidden [Code 28] ; # Hidden define no-strike [Code 29] ; # StrikeThrough # Remainder define reset [Code 0] ; # Reset # And now the standard symbolic names define advisory =yellow define bad =red define confirm =red define error =magenta define good =green define name =blue define neutral =blue define no =red define note =blue define number =green define prompt =blue define unknown =cyan define warning =yellow define yes =green variable smap {} } apply {{} { variable smap for {set i 0} {$i < 32} {incr i} { set c [format %c $i] set o \\[format %03o $i] lappend smap $c $o } lappend smap \127 \\127 } ::cmdr::color} # # ## ### ##### ######## ############# ##################### ## Ready package provide cmdr::color 0 |
Added tests/color.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | # -*- tcl -*- tcl.tk//DSL tcltest//EN//2.0 # # ## ### ##### ######## ############# ##################### ## Testing the cmdr::color package. kt check Tcl 8.5 kt check tcltest 2 kt require support Tclx kt require support debug kt require support debug::caller kt local support cmdr::tty kt local testing cmdr::color set thecolors {advisory bad bg-black bg-blue bg-cyan bg-default bg-green bg-magenta bg-red bg-white bg-yellow black blink blue bold confirm cyan default dim error good green hidden italic magenta name neutral no no-blink no-bold no-dim no-hidden no-italic no-revers no-strike no-underline note number prompt red reset revers strike underline unknown warning white yellow yes} set thechars { advisory {\033[33m} bad {\033[31m} bg-black {\033[40m} bg-blue {\033[44m} bg-cyan {\033[46m} bg-default {\033[49m} bg-green {\033[42m} bg-magenta {\033[45m} bg-red {\033[41m} bg-white {\033[47m} bg-yellow {\033[43m} black {\033[30m} blink {\033[5m} blue {\033[34m} bold {\033[1m} confirm {\033[31m} cyan {\033[36m} default {\033[39m} dim {\033[2m} error {\033[35m} good {\033[32m} green {\033[32m} hidden {\033[8m} italic {\033[3m} magenta {\033[35m} name {\033[34m} neutral {\033[34m} no {\033[31m} no-blink {\033[25m} no-bold {\033[22m} no-dim {\033[__m} no-hidden {\033[28m} no-italic {\033[23m} no-revers {\033[27m} no-strike {\033[29m} no-underline {\033[24m} note {\033[34m} number {\033[32m} prompt {\033[34m} red {\033[31m} reset {\033[0m} revers {\033[7m} strike {\033[9m} underline {\033[4m} unknown {\033[36m} warning {\033[33m} white {\033[37m} yellow {\033[33m} yes {\033[32m} } set thedefs { advisory =yellow bad =red bg-black {\033[40m} bg-blue {\033[44m} bg-cyan {\033[46m} bg-default {\033[49m} bg-green {\033[42m} bg-magenta {\033[45m} bg-red {\033[41m} bg-white {\033[47m} bg-yellow {\033[43m} black {\033[30m} blink {\033[5m} blue {\033[34m} bold {\033[1m} confirm =red cyan {\033[36m} default {\033[39m} dim {\033[2m} error =magenta good =green green {\033[32m} hidden {\033[8m} italic {\033[3m} magenta {\033[35m} name =blue neutral =blue no =red no-blink {\033[25m} no-bold {\033[22m} no-dim {\033[__m} no-hidden {\033[28m} no-italic {\033[23m} no-revers {\033[27m} no-strike {\033[29m} no-underline {\033[24m} note =blue number =green prompt =blue red {\033[31m} reset {\033[0m} revers {\033[7m} strike {\033[9m} underline {\033[4m} unknown =cyan warning =yellow white {\033[37m} yellow {\033[33m} yes =green } # # ## ### ##### ######## ############# ##################### ## Basic wrong#args checks. test cmdr-color-1.0 {color, wrong num args, not enough} -body { cmdr color } -returnCodes error \ -result {wrong # args: should be "cmdr color subcommand ?argument ...?"} test cmdr-color-1.1 {color, bogus sub-command, not enough args} -body { cmdr color foo } -returnCodes error \ -result {wrong # args: should be "::cmdr::color::Unknown cmd codes text"} test cmdr-color-1.2 {color, bogus sub-command, bogus color name} -setup { set save [cmdr color active] cmdr color activate 1 } -body { cmdr color foo text } -cleanup { cmdr color activate $save unset save } -returnCodes error -result {Expected a color name, got "foo"} test cmdr-color-2.0 {color, formatting, single code} -setup { set save [cmdr color active] cmdr color activate 1 } -body { cmdr color red text } -cleanup { cmdr color activate $save unset save } -result "\033\[31mtext\033\[0m" test cmdr-color-2.1 {color, formatting, multi-code} -setup { set save [cmdr color active] cmdr color activate 1 } -body { cmdr color {bold red} text } -cleanup { cmdr color activate $save unset save } -result "\033\[1m\033\[31mtext\033\[0m" # # ## ### ##### ######## ############# ##################### ## Go through the API commands. ## active, activate, names, get, get-def, define, exists # # ## ### ##### ######## ############# ##################### ## active test cmdr-color-active-1.0 {color active, wrong num args, too many} -body { cmdr color active X } -returnCodes error \ -result {wrong # args: should be "cmdr color active"} test cmdr-color-active-1.1 {color active, default} -body { cmdr color active } -result [cmdr tty stdout] # # ## ### ##### ######## ############# ##################### ## activate test cmdr-color-activate-1.0 {color activate, wrong num args, too many} -body { cmdr color activate 0 X } -returnCodes error \ -result {wrong # args: should be "cmdr color activate ?flag?"} test cmdr-color-activate-1.1 {color activate, activate explicit} -body { cmdr color activate 1 cmdr color active } -result 1 test cmdr-color-activate-1.2 {color activate, deactivate} -body { cmdr color activate 0 cmdr color active } -result 0 test cmdr-color-activate-1.3 {color activate, activate, implicit} -body { cmdr color activate cmdr color active } -result 1 # # ## ### ##### ######## ############# ##################### ## names test cmdr-color-names-1.0 {color names, wrong num args, too many} -body { cmdr color names X } -returnCodes error \ -result {wrong # args: should be "cmdr color names"} test cmdr-color-names-1.0 {color names, wrong num args, too many} -body { lsort -dict [cmdr color names] } -result $thecolors # # ## ### ##### ######## ############# ##################### ## unset test cmdr-color-unset-1.0 {color unset, wrong num args, not enough} -body { cmdr color unset } -returnCodes error \ -result {wrong # args: should be "cmdr color unset name"} test cmdr-color-unset-1.1 {color unset, wrong num args, too many} -body { cmdr color unset N X } -returnCodes error \ -result {wrong # args: should be "cmdr color unset name"} test cmdr-color-unset-1.2 {color unset, bogus color} -body { cmdr color unset foo } -returnCodes error \ -result {Expected a color name, got "foo"} test cmdr-color-unset-1.2 {color unset, known color} -setup { cmdr color define foo =red } -body { cmdr color unset foo } -result {} # # ## ### ##### ######## ############# ##################### ## get test cmdr-color-get-1.0 {color get, wrong num args, not enough} -body { cmdr color get } -returnCodes error \ -result {wrong # args: should be "cmdr color get name"} test cmdr-color-get-1.1 {color get, wrong num args, too many} -body { cmdr color get N X } -returnCodes error \ -result {wrong # args: should be "cmdr color get name"} test cmdr-color-get-1.2 {color get, bogus color} -body { cmdr color get foo } -returnCodes error \ -result {Expected a color name, got "foo"} set n 0 foreach color $thecolors { incr n test cmdr-color-get-2.$n "color get, $color" -body { cmdr color get $color } -result [subst -nocommands -novariables \ [dict get $thechars $color]] } # # ## ### ##### ######## ############# ##################### ## get-def test cmdr-color-get-def-1.0 {color get-def, wrong num args, not enough} -body { cmdr color get-def } -returnCodes error \ -result {wrong # args: should be "cmdr color get-def name"} test cmdr-color-get-def-1.1 {color get-def, wrong num args, too many} -body { cmdr color get-def N X } -returnCodes error \ -result {wrong # args: should be "cmdr color get-def name"} test cmdr-color-get-def-1.2 {color get-def, bogus color} -body { cmdr color get-def foo } -returnCodes error \ -result {Expected a color name, got "foo"} set n 0 foreach color $thecolors { incr n test cmdr-color-get-def-2.$n "color get-def, $color" -body { cmdr color get-def $color } -result [subst -nocommands -novariables \ [dict get $thedefs $color]] } # # ## ### ##### ######## ############# ##################### ## exists test cmdr-color-exists-1.0 {color exists, wrong num args, not enough} -body { cmdr color exists } -returnCodes error \ -result {wrong # args: should be "cmdr color exists name"} test cmdr-color-exists-1.1 {color exists, wrong num args, too many} -body { cmdr color exists N X } -returnCodes error \ -result {wrong # args: should be "cmdr color exists name"} test cmdr-color-exists-2.0 {color exists, unknown} -body { cmdr color exists foo } -result 0 set n 0 foreach color $thecolors { incr n test cmdr-color-exists-2.$n "color exists, $color" -body { cmdr color exists $color } -result 1 } # # ## ### ##### ######## ############# ##################### ## define test cmdr-color-define-1.0 {color define, wrong num args, not enough} -body { cmdr color define } -returnCodes error \ -result {wrong # args: should be "cmdr color define name spec"} test cmdr-color-define-1.1 {color define, wrong num args, not enough} -body { cmdr color define N } -returnCodes error \ -result {wrong # args: should be "cmdr color define name spec"} test cmdr-color-define-1.2 {color define, wrong num args, too many} -body { cmdr color define N S X } -returnCodes error \ -result {wrong # args: should be "cmdr color define name spec"} test cmdr-color-define-2.0 {color define, bad reference} -body { cmdr color define aname =bogus } -returnCodes error \ -result {Expected a color name, got "bogus"} test cmdr-color-define-2.1 {color define, bad reference, cyclic} -body { cmdr color define aname =aname } -returnCodes error \ -result {Rejected self-referential definition of "aname"} test cmdr-color-define-2.2 {color define, reference} -body { lappend r [cmdr color exists aname] lappend r [cmdr color define aname =red] lappend r [cmdr color exists aname] lappend r [cmdr color get aname] lappend r [cmdr color get-def aname] } -cleanup { cmdr color unset aname unset r } -result [list 0 {} 1 \033\[31m =red] test cmdr-color-define-3.0 {color define, bad rgb, syntax} -body { cmdr color define aname %foo } -returnCodes error \ -result {Expected an RGB tuple, got "foo"} test cmdr-color-define-3.1 {color define, bad rgb, range R} -body { cmdr color define aname %7,3,3 } -returnCodes error \ -result {RGB channel R out of range, got 7} test cmdr-color-define-3.2 {color define, bad rgb, range G} -body { cmdr color define aname %3,7,3 } -returnCodes error \ -result {RGB channel G out of range, got 7} test cmdr-color-define-3.3 {color define, bad rgb, range B} -body { cmdr color define aname %3,3,7 } -returnCodes error \ -result {RGB channel B out of range, got 7} test cmdr-color-define-3.4 {color define, rgb} -body { lappend r [cmdr color exists aname] lappend r [cmdr color define aname %2,4,3] lappend r [cmdr color exists aname] lappend r [cmdr color get aname] lappend r [cmdr color get-def aname] } -cleanup { cmdr color unset aname unset r } -result [list 0 {} 1 \033\[115m %2,4,3] test cmdr-color-define-4.0 {color define, raw control} -body { lappend r [cmdr color exists aname] lappend r [cmdr color define aname blimfizzle] lappend r [cmdr color exists aname] lappend r [cmdr color get aname] lappend r [cmdr color get-def aname] } -cleanup { cmdr color unset aname unset r } -result [list 0 {} 1 blimfizzle blimfizzle] # # ## ### ##### ######## ############# ##################### cleanupTests return |