fredderic's gems

Here's a couple handy little gems I like to have available. The one-letter ones are not always the most efficient way of doing the task, but when the line's getting a little convoluted, these things can make it a little more readable. At least, I think so...

interp alias {} nocase {} string equal -nocase

interp alias {} L {} list

proc K {args} {lindex $args 0}

proc U {varName} {
        uplevel 1 [subst -noc {lindex [list [set $varName] [unset $varName]] 0}]
}

proc S {varName {value {}} } {
        uplevel 1 \
        [subst -noc {lindex [list [set $varName] [set $varName [list $value]]] 0}]
}

proc G {varName {default ""} } {
        upvar 1 $varName var
        if { [info exists var] } {return $var}
        return $default
}

proc error-args {mesg} {
        return -level 2 -code error "wrong # args: should be \"$mesg\""
}

proc list2 {args} {
        set outl [list]
        foreach item $args {lappend outl $item $item}
        return $outl
}

And what I consider to be an irritatingly trivial omission from the expr command:

proc ::tcl::mathfunc::sgn {v} {expr {$v > 0 ? 1 : $v < 0 ? -1 : 0}}

Also there's my version of the lshift command.

AMG: Here's rmax's clever version of sgn:

proc ::tcl::mathfunc::sgn {v} {expr {($v > 0) - ($v < 0)}}

Here's a proc I use for adding new commands to an existing ensemble. It's probably not the best version, but it's handy, and it works where I've needed it.

proc proc-ensemble {args} {
        if { ( [llength $args] < 4 || [llength $args] % 3 != 1 ) &&
                        [llength $args] != 2 } {
                error-args "proc-ensemble command ?name args body?..."
        }
        set args [lassign $args command]
        if { [set exists [namespace ensemble exists $command]] } {
                set spc [namespace ensemble configure $command -namespace]
                set map [namespace ensemble configure $command -map]
                # convert "-subcommands" into "-map"
                set cmds [namespace ensemble configure $command -subcommands]
                if { [llength $cmds] } {
                        foreach cmd [namespace ensemble configure $command -subcommands] {
                                dict set map $cmd ${spc}::$cmd
                        }
                        namespace ensemble configure $command -subcommands {}
                }
        } else {
                set spc $command
                set map {}
        }
        # validate list-of-procs form
        if { [llength $args] == 1 } {
                set args [lindex $args 0]
                if { [llength $args] % 3 != 0 } {
                        error-args "proc-ensemble command ?name args body?..."
                }
        }
        # build the new ensemble commands
        foreach {name args body} $args {
                set lname [string tolower [namespace tail $name]]
                if { $body ne "" } {
                        namespace eval $spc [list proc $name $args $body]
                        dict set map $lname ${spc}::$name
                } elseif { [dict exists $map $lname] } {
                        dict unset map $lname
                }
        }
        # update the ensemble command map
        if { $exists } {
                namespace ensemble configure $command -map $map
        } else {
                namespace ensemble create -command $command -map $map
        }
}

And now, a proc that does a similar job to regsub, except that the text to be substituted is the value produced by evaluating the supplied script.

proc regcmd {args} {
        if { [llength $args] < 3 } {
                error-args "regcmd ?switches? exp string script"
        }

        set parts [list]; set opts [list]; set start 0; set all 0
        for {set n 0} {$n < [llength $args]-3} {incr n} {
                set arg [lindex $args $n]
                switch -exact -- $arg {
                   -expanded - -line - -linestop - -lineanchor - -nocase
                        {if {$arg ni $opts} {lappend opts $arg}}
                   -indices - -inline {if {$arg ni $parts} {lappend parts $arg}}
                   -start {set start [lindex $args [incr n]]}
                -all {set all 1}
                default {return -level 1 -code error "bad switch \"$arg\": must be -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, or -start"}
                }
        }
        if { ! [llength $parts] } {set parts "-inline"}
        lassign [lrange $args end-2 end] exp strn script
        lappend opts -start $start $exp
        
        set out ""
        while { [llength [set ranges [regexp -inline -indices {*}$opts $strn]]] } {
                set list [list]
                foreach range $ranges {
                        set item [list]
                        foreach part $parts {
                                switch -exact -- $part {
                                "-inline" {lappend item [string range $strn {*}$range]}
                                "-indices" {lappend item {*}$range}
                                }
                        }
                        lappend list $item
                }
                lassign [lindex $ranges 0] start stop
                append out [string range $strn 0 $start-1][uplevel 1 $script {*}$list]
                set strn [string range $strn $stop+1 end]
                if { ! $all } break
        }

        return $out$strn
}

Category Command