Posted to tcl by aspect at Thu Feb 02 22:07:12 GMT 2017view pretty

    # main as an ensemble is sweet

    variable START
    set START [clock seconds]

# ----- private commands:
    set fossil_dir $env(HOME)/.fossils  ;# keep all our fossils in one place
    set fossil_bin fossil               ;# rely on $PATH

    proc Find {name} {
        variable fossil_dir
        file join $fossil_dir $name
    }

    proc Fossil {args} {                ;# use this for the shell command
        variable fossil_bin
        # FIXME: quote args a la lexec?
        Exec $fossil_bin {*}$args
    }

    # some silly helpers:
    # FIXME: need a better [exec]-like pattern for this stuff
    proc F:current-branch {} {
        variable fossil_bin
        exec $fossil_bin branch | awk {/^*/ {print $2}}
    }
    proc F:parent {hash} {
        variable fossil_bin
        exec $fossil_bin info $hash | awk {/^parent:/ {print $2}}
    }

# ----- utilities:
    # Make errors and logging easier
    proc Error {args} {
        tailcall return -code error $args
    }
    proc Log {args} {
        puts stderr "[TS] $args"
    }
    proc TS {} {
        variable START
        set elapsed [expr {[clock seconds] - $START}]
        set secs [expr {$elapsed / 1000}]
        set ms   [expr {$elapsed % 1000}]
        format %s:%.03d [
            clock format $secs -format %M:%S
        ] $ms
    }

    # Namespace unknowns are weird.
    proc Unknown {_ cmd args} {
        list [namespace which Fossil] $cmd
    }

    # A more shell-script like [exec].  Passes stdout/err through,
    # and returns the exit code.
    proc Exec {args} {
        # FIXME: handle redirections.  Use >$ 2>$ for variables
        set rc [catch {
            exec {*}$args >@ stdout 2>@ stderr
        } e o]
        if {$rc == 0} {
            return $rc
        } else {
            return [lindex [dict get $o -errorcode] 2]
        }
    }

    # create directory/ies, unless they already exist
    # BEWARE:  race-prone.  Tcl's [file mkdir] is already race-prone
    # so this can't be fixed in Tcl.  Just be careful.
    proc Mkdir {args} {
        foreach dir $args {
            if {[file exists $dir]} {
                if {[file isdirectory]} {
                    Error "Directory already exists" $dir
                } else {
                    Error "File exists" $dir
                }
            }
        }
        file mkdir {*}$args
    }

# ----- aliases and wrappers for fossil commands

    proc clone {url} {
        foreach name [lreverse [split $url /]] {    ;# FIXME: support same repo name from multiple sources .. aliases?
            if {$name ne ""} break
        }
        if {$name eq "" || [string match *: $name]} {
            Error "Unable to derive name for $url:  got [list $name]!"
        }

        set fsl [Find $name]
        if {[file exists $fsl]} {
            Error "File already exists! $fsl"
        }
        Mkdir $name
        Log "Cloning" $url $fsl
        Fossil clone $url $fsl
        cd $name
        Log "Opening in" [pwd]
        Fossil open $fsl
    }

    proc open {name} {
        Mkdir $name
        cd $name
        Log "Opening in" [pwd]
        Fossil open [Find $name]
    }

    proc commit {args} {
        # strip git-ism:
        if {[lindex $args 0] eq "-am" && [llength $args] eq 2} {
            lset args 0 "-m"
        }
        # move -m to the front
        set i [lsearch -exact $args -m]
        if {$i > 0} {
            set a0 [lrange $args $i $i+1]
            set args [lreplace $args $i $i+1]
            set args [linsert $args 0 {*}$a0]
        }
        Fossil commit {*}$args
    }

    # pull might as well checkout current branch's leaf:
    proc pull {args} {
        if {$args eq ""} {
            Fossil pull
            Fossil checkout [F:currrent-branch]
        }
    }

    # support a really useful git-ism
    proc show {hash} {
        set parent [F:parent $hash]
        Fossil diff --from $parent --to $hash
    }

    namespace export {[a-z]*}
    namespace ensemble create -unknown [namespace which Unknown]
}

exit [main {*}$argv]