cmdr
Artifact Content
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 [email protected]
or submit via the online form by Sep 9.

Artifact fce696b03c3973a7a5a7b273056c3e5ea1cbf437:


## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Actor - Command execution. Base.
##                Actors know how to do something.

# @@ Meta Begin
# Package cmdr::actor 0
# Meta author   {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary     Internal. Base class for officers and privates.
# Meta description Internal. Base class for officers and privates.
# Meta subject {command line}
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require TclOO
# @@ Meta End

## Two types:
## - Privates know to do one thing, exactly, and nothing more.
##   They can process their command line to extract/validate
##   the inputs they need for their action from the arguments.
#
## - Officers can learn to do many things, by delegating things to the
##   actors actually able to perform it.

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

package require Tcl 8.5
package require debug
package require debug::caller
package require TclOO

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

debug define cmdr/actor
debug level  cmdr/actor
debug prefix cmdr/actor {[debug caller] | }

# # ## ### ##### ######## ############# #####################
## Definition - Single purpose command.

oo::class create ::cmdr::actor {
    # # ## ### ##### ######## #############
    ## Lifecycle

    constructor {} {
	debug.cmdr/actor {}
	set myname        {}
	set mydescription {}
	set mydocumented  yes
	set mysuper       {}
	set mystore       {}

	set myhistory     {} ; # History handler, reporting commands just about
	#                      # to be executed, and other events related to
	#                      # history management.
	return
    }

    # # ## ### ##### ######## #############
    ## Public API: Common actor attributes and behaviour
    ## - Name.
    ## - Description (help information).
    ## - Chain of command.
    ## - Associative data store

    method name {} {
	return $myname
    }

    method dname {} {
	::list {*}[my get *prefix*] $myname
    }

    method fullname {} {
	set result {}
	if {$mysuper ne {}} {
	    lappend result {*}[$mysuper fullname]
	}
	lappend result $myname
	return $result
    }

    method name: {thename} {
	debug.cmdr/actor {}
	set myname $thename
	return
    }

    method description {} {
	my Setup ; # Calls into the derived class
	return $mydescription
    }

    method description: {text} {
	debug.cmdr/actor {}
	set mydescription [string trim $text]
	return
    }

    method documented {} {
	debug.cmdr/actor {}
	my Setup ; # Calls into the derived class
	return $mydocumented
    }

    method undocumented {} {
	debug.cmdr/actor {}
	set mydocumented no
	return
    }

    method super {} {
	return $mysuper
    }

    method super: {thesuper} {
	set mysuper $thesuper
	return
    }

    method root {} {
	if {$mysuper ne {}} {
	    return [$mysuper root]
	}
	return [self]
    }

    method keys {} {
	debug.cmdr/actor {}
	my Setup
	set result [dict keys $mystore]
	if {$mysuper ne {}} {
	    lappend result {*}[$mysuper keys]
	    set result [lsort -unique $result]
	}
	return $result
    }

    method exists {key} {
	debug.cmdr/actor {}
	my Setup
	set ok [dict exists $mystore $key]
	if {!$ok && ($mysuper ne {})} {
	    return [$mysuper exists $key]
	}
	return $ok
    }

    method get {key} {
	debug.cmdr/actor {}
	my Setup ; # Call into derived class.

	# Satisfy from local store first ...
	if {[dict exists $mystore $key]} {
	    return [dict get $mystore $key]
	}
	# ... then ask in the chain of command ...
	if {$mysuper ne {}} {
	    return [$mysuper get $key]
	}
	# ... and fail if we are at the top.
	return -code error -errorcode {CMDR STORE UNKNOWN} \
	    "Expected known key for get, got \"$key\""
    }

    method set {key args} {
	debug.cmdr/actor {}
	set extend 0
	while {[string match -* [lindex $args 0]]} {
	    set args [lassign $args o]
	    switch -exact -- $o {
		-- {
		    # Stop option processing. Next argument must be the data.
		    break
		}
		-extend {
		    set extend 1
		}
		default {
		    return -code error -errorcode {CMDR SET UNKNOWN OPTION} \
			"Unknown option \"$o\", expected -extend, or --"
		}
	    }
	}
	if {[llength $args] != 1} {
	    # The method of getting the command name is so complicated
	    # to account for calls from specifications, where this is
	    # aliased as 'common'.
	    set cmd [lindex [dict get [info frame -1] cmd] 0]
	    return -code error -errorcode {CMDR SET WRONG-ARGS} \
		"wrong # args: should be \"$cmd key ?-extend? data\""
	}
	set data [lindex $args 0]
	if {$extend} {
	    if {[my has $key]} {
		set data [my get $key]$data
	    }
	    # Note how -extend is a no-op if the block to extend does
	    # not exist yet, and falls back to plain 'set'.
	}
	dict set mystore $key $data
	return
    }

    method lappend {key data} {
	debug.cmdr/actor {}
	catch { set value [my get $key] }
	lappend value $data
	dict set mystore $key $value
	return
    }

    method unset {key} {
	debug.cmdr/actor {}
	dict unset mystore $key
	return
    }

    method unset-all {key} {
	debug.cmdr/actor {}
	dict unset mystore $key
	if {$mysuper eq {}} return
	$mysuper unset-all $key
	return
    }

    method history-via {cmd} {
	debug.cmdr/actor {}
	set myhistory $cmd
	return
    }

    method history-setup {} {
	debug.cmdr/actor {}
	if {![llength $myhistory]} {return {}}
	return [{*}$myhistory initialize [self]]
    }

    method history-add {cmd} {
	debug.cmdr/actor {}
	if {![llength $myhistory]} return
	{*}$myhistory add [string trim $cmd]
	return
    }

    # # ## ### ##### ######## #############
    ## Public APIs:
    ## Overridden by sub-classes.

    # - Perform an action.
    # - Return help information about the action.

    method do   {args} {}
    method help {{prefix {}}} {}

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

    variable myname mydescription mydocumented \
	mysuper mystore myhistory

    # # ## ### ##### ######## #############
    ## Helper methods common to command completion in actors.

    method Quote {word} {
	# Check if word contains special characters, and quote it to
	# prevent special interpretation of these characters, if so.
	if {
	    [string match "*\[ \"'()\$\|\{\}\]*" $word] ||
	    [string match "*\]*"                 $word] ||
	    [string match "*\[\[\]*"             $word]
	} {
	    set map [list \" \\\"]
	    return \"[string map $map $word]\"
	} else {
	    return $word
	}
    }

    method completions {parse cmdlist} {
	debug.cmdr/actor {} 10
	# Quick exit if there is nothing to complete.
	if {![llength $cmdlist]} {
	    return $cmdlist
	}

	dict with parse {}
	# -> line, words (ignored: ok, nwords, at, doexit)

	# The -> cmd is a valid completion of the line.  The actual
	# completion is the line itself, plus the command.  Note that
	# we have to chop off the incomplete part of cmd in the line
	# before adding the complete command.
	#
	# Example:
	# line       = "foo b"
	# cmd            = "bar"
	# completion = "foo bar"

	# Determine the chop point, then chop: Just before the first
	# character of the last word. Which is a prefix to all
	# commands in the list.
	set  chop [lindex $words end 1]
	incr chop -1
	set line [string range $line 0 $chop]

	set completions {}
	foreach cmd $cmdlist {
	    set cmd [my Quote $cmd]
	    # Chop and complete.
	    lappend completions $line$cmd
	}
	return $completions
    }

    # Could possibly use 'struct::list filter', plus a lambda.
    method match {parse cmdlist} {
	debug.cmdr/actor {} 10
	# Quick exit if nothing can match.
	if {![llength $cmdlist]} {
	    return $cmdlist
	}

	dict with parse {}
	# -> words, at (ignored: ok, nwords, line, doexit)

	# We need just the text of the current word.
	set current [lindex $words $at end]

	set filtered {}
	foreach cmd $cmdlist {
	    if {![string match ${current}* $cmd]} continue
	    lappend filtered $cmd
	}
	return $filtered
    }

    method parse-line {line} {
	debug.cmdr/actor {} 10
	set ok    1
	set words {}

	try {
	    set words [string token shell -partial -indices $line]
	} trap {STRING TOKEN SHELL BAD} {e o} {
	    set ok 0
	}

	set len [string length $line]

	if {$ok} {
	    # last word, end index
	    set lwe [lindex $words end 2]
	    # last word ends before end of line -> trailing whitespace
	    # add the implied empty word for the completion processing.
	    if {$lwe < ($len-1)} {
		lappend words [list PLAIN $len $len {}]
	    }
	}
	set parse [dict create \
		       doexit 1 \
		       at     0 \
		       line   $line \
		       ok     $ok \
		       words  $words \
		       nwords [llength $words]]

	return $parse
    }

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

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::actor 1.3.1