cmdr: Artifact Content

Artifact 9df4464e65211e91790871528da76f5573103869:

File color.tcl — part of check-in [9d0fa722e9] at 2014-08-27 23:41:25 on branch trunk — Bump versions of cmdr::color and cmdr::ask to 1. Fixed a prompt issue in cmdr::ask::string*. Extended debug narrative regarding prompt handling. (user: andreask size: 9439)
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Convenience commands for colored text in terminals.

# @@ Meta Begin
# Package cmdr::color 0
# Meta author   {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary     Text colorization for terminal output
# Meta description Commands to manage colored text in terminal
# Meta description output
# Meta subject {command line} terminal color {text colors}
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require cmdr::tty
# @@ Meta End

# # ## ### ##### ######## ############# #####################
## Requisites

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 \
	-prefixes 0

    # Note, the -unknown 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>
    #
    # The -prefix 0 option ensures that we canuse the 'name'
    # color-code, without it will go to 'names' and then fail with
    # wrong#args due to the different expected syntax.
    ##

    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) esc := [Ee]<code>(,...)?
    # (4) 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 {^[eE](.*)$} $spec -> codes]} {
	if {![regexp {^(\d+)(,\d+)*$} $codes]} {
	    return -code error \
		-errorcode [list CMDR COLOR BAD-ESCAPE SYNTAX $spec] \
		"Expected a comma-separated list of codes, got \"$spec\""
	}
	set codes [Code {*}[split $codes ,]]
	debug.cmdr/color {ESC encoded => [Quote $codes]}
	dict set def  $name $spec
	dict set char $name $codes
	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
}

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

proc ::cmdr::color::Unknown {cmd codes {text {}}} {
    list [namespace current]::Apply $codes
}

proc ::cmdr::color::Apply {codes {text {}}} {
    debug.cmdr/color {}

    variable active
    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]
    }
    if {$text ne {}} {
	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        e30  ; # Black  
    define  red          e31  ; # Red    
    define  green        e32  ; # Green  
    define  yellow       e33  ; # Yellow 
    define  blue         e34  ; # Blue   
    define  magenta      e35  ; # Magenta
    define  cyan         e36  ; # Cyan   
    define  white        e37  ; # White  
    define  default      e39  ; # Default (Black)

    # Colors. Background.
    define  bg-black     e40  ; # Black  
    define  bg-red       e41  ; # Red    
    define  bg-green     e42  ; # Green  
    define  bg-yellow    e43  ; # Yellow 
    define  bg-blue      e44  ; # Blue   
    define  bg-magenta   e45  ; # Magenta
    define  bg-cyan      e46  ; # Cyan   
    define  bg-white     e47  ; # White  
    define  bg-default   e49  ; # Default (Transparent)

    # Non-color attributes. Activation.
    define  bold         e1   ; # Bold  
    define  dim          e2   ; # Dim
    define  italic       e3   ; # Italics      
    define  underline    e4   ; # Underscore   
    define  blink        e5   ; # Blink
    define  revers       e7   ; # Reverse      
    define  hidden       e8   ; # Hidden
    define  strike       e9   ; # StrikeThrough

    # Non-color attributes. Deactivation.
    define  no-bold      e21  ; # Bold  
    define  no-dim       e22  ; # Dim
    define  no-italic    e23  ; # Italics      
    define  no-underline e24  ; # Underscore   
    define  no-blink     e25  ; # Blink
    define  no-revers    e27  ; # Reverse      
    define  no-hidden    e28  ; # Hidden
    define  no-strike    e29  ; # StrikeThrough

    # Remainder
    define  reset        e0   ; # 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 1