## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Validate - Common utility commands.
# @@ Meta Begin
# Package cmdr::validate::common 0
# Meta author {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary Utilities for validation types.
# Meta description Utilities for validation types.
# Meta subject {command line} {parameter validation}
# Meta subject {validation type} {type checking}
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# @@ Meta End
# # ## ### ##### ######## ############# #####################
## Requisites
package require Tcl 8.5
package require debug
package require debug::caller
# # ## ### ##### ######## ############# #####################
## Definition
namespace eval ::cmdr {
namespace export validate
namespace ensemble create
}
namespace eval ::cmdr::validate {
namespace export common
namespace ensemble create
}
namespace eval ::cmdr::validate::common {
namespace export \
complete-enum complete-glob ok-directory \
fail fail-unknown-thing fail-known-thing \
lead-in
namespace ensemble create
}
# # ## ### ##### ######## ############# #####################
debug define cmdr/validate/common
debug level cmdr/validate/common
debug prefix cmdr/validate/common {[debug caller] | }
# # ## ### ##### ######## ############# #####################
## Different forms of validation failure messages
proc ::cmdr::validate::common::fail {p code type x {context {}}} {
# Generic failure: "Expected foo, got x".
debug.cmdr/validate/common {}
append msg "Expected $type for [$p type] \"[$p the-name]\"$context,"
append msg " got \"$x\""
return -code error -errorcode [list CMDR VALIDATE {*}$code] $msg
}
proc ::cmdr::validate::common::fail-unknown-thing {p code type x {context {}}} {
# Specific failure for a named thing: Expected existence, found it missing.
debug.cmdr/validate/common {}
append msg "Found a problem with [$p type] \"[$p the-name]\":"
append msg " [lead-in $type] \"$x\" does not exist$context."
append msg " Please use a different value."
return -code error -errorcode [list CMDR VALIDATE {*}$code] $msg
}
proc ::cmdr::validate::common::fail-known-thing {p code type x {context {}}} {
# Specific failure for a named thing: Expected non-existence, found a definition.
debug.cmdr/validate/common {}
append msg "Found a problem with [$p type] \"[$p the-name]\":"
append msg " [lead-in $type] named \"$x\" already exists$context."
append msg " Please use a different name."
return -code error -errorcode [list CMDR VALIDATE {*}$code] $msg
}
# # ## ### ##### ######## ############# #####################
## Support commands for construction of messages.
proc ::cmdr::validate::common::lead-in {type} {
if {[string match {A *} $type] ||
[string match {An *} $type]} {
set lead {}
} elseif {[string match {[aeiouAEIOU]*} $type]} {
set lead {An }
} else {
set lead {A }
}
return $lead$type
}
# # ## ### ##### ######## ############# #####################
proc ::cmdr::validate::common::complete-enum {choices nocase buffer} {
# As a helper function for command completion printing anything
# here would mix with the output of linenoise. Do that only on
# explicit request (level 10).
debug.cmdr/validate/common {} 10
if {$buffer eq {}} {
return $choices
}
if {$nocase} {
set buffer [string tolower $buffer]
}
set candidates {}
foreach c $choices {
if {![string match ${buffer}* $c]} continue
lappend candidates $c
}
debug.cmdr/validate/common {= [join $candidates "\n= "]} 10
return $candidates
}
proc ::cmdr::validate::common::complete-glob {filter buffer} {
debug.cmdr/validate/common {} 10
# Treat everything in the buffer as literal prefix.
# Disable all glob special characters.
regsub -all {(.)} $buffer {\\\1} buffer
set candidates {}
foreach path [glob -nocomplain ${buffer}*] {
if {![{*}$filter $path]} continue
lappend candidates $path
}
debug.cmdr/validate/common {= [join $candidates "\n= "]} 10
return $candidates
}
proc ::cmdr::validate::common::ok-directory {path} {
if {![file exists $path]} {
# The directory is allowed to not exist if its parent
# directory exists and is writable.
# Note: Prevent us from walking up the chain if the directory
# has no parent.
# Note 2: Switch to absolute notation if path is the relative
# name of the CWD (i.e. ".").
if {$path eq "."} {
set path [pwd]
}
set up [file dirname $path]
if {$up eq $path} {
# Reached root (/, x:, x:/), found it missing, stop & fail.
return 0
}
return [ok-directory $up]
}
if {![file isdirectory $path]} {return 0}
if {![file writable $path]} {return 0}
return 1
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::validate::common 1.2
return
