Fossil Wrapper

#!/usr/bin/env expect
# -*-tcl-*-
#
# Copyright (c) 2012, Marc Simpson <marc@0branch.com> (ISC, see LICENSE)

# --( Aliases and Filters )---------------------------------------------

namespace eval config {
    variable dbglvl 0;               # debug level
    variable reset 0;                # 1/0: do/don't recreate config file
    variable grepflags              ;# needed to pass around info needed by `fixGrep' 

    set aliases {}
    set filters {};             # registered filters
    set commands {};            # registered interceptors

    proc manpage {} {
       set mantext {

    alias  .      changes
    alias  ..     {changes --differ}
    alias  ,      ui
    alias  ahelp  {test-all-help}
    alias  alog   {timeline -t ci -n 0}
    alias  b      branch
    alias  d      diff
    alias  dd     {df -tk}
    alias  de     descendants
    alias  desc   descendants
    alias  di     diff
    alias  elog   {timeline -t ci -n 0 -v}
    alias  f      {finfo}
    alias  fb     {finfo -b}
    alias  fi     {finfo}

            changes: {
               if {[regexp {^changes:[ ]+None. Already up-to-date} $line]} then {
                  regsub {(^changes:[ ]+)(.*)} $line [coloured green &]
               } else {
                  regsub {(^changes:[ ]+)(.*)} $line [coloured red &]
               }
            }
            default { set line }
        }
    }

    filter colorizeOutput {finfo leaves status} {
        # this used to be `fancy_timeline'. but is now used much less
        # since most of the work is relocated to `reformTimeline'
        # the regex/regsubs below could be tidied up, accordingly...

        underscored 4        reversed    7
    }
    ansi $mode $modes $text
}

proc coloured {colour text} {
    set colours {
        black       0;30
        blue        0;34
        bluebold    1;34
        cyan        0;36
        green       0;32
        grey        0;37
        magenta     0;35
        magentabold 1;35
        purple      0;35
        red         0;31
        redbold     1;31
        yellow      0;33

    }
    ansi $colour $colours $text
}

proc alias?       {name} { dict exists $config::aliases  $name }

proc filter?      {name} { dict exists $config::filters  $name }

proc cihashLookup {lines} {
   set cihashes {}
   foreach line $lines {
      # FIXME: there must be a nicer way to handle `grep -l' as well,
      # no?
      set fhash [string trimright [first [split $line :]]]

      if { [catch {dict get $cihashes $fhash}] }  {
         # no entry, yet, for this file artifact, so we do the lookup.
         # this is the rate limiting step by a large maring here.
         # hopefully `fossil grep' will report the checkin hash itself
         # at some time in the future.
         set report [split [exec fossil whatis $fhash] \n]
         set rgxpat {^[^[]+(\[[0-9a-f]+\])}
         regexp $rgxpat [lindex $report 4] _ cihash
         dict set cihashes $fhash $cihash
      }
   }
   return $cihashes
}

proc fixGrep {lines params grepflags} {
   set f1 [first $grepflags]
   set f2 [last $grepflags]
   if {$f1 + $f2 > 0} {
      set buf $lines
      set lines {}
      if {$f1} { lappend lines [last $buf] } 
      if {$f2} { lappend lines [first $buf] } 
   }

   set cihashes [cihashLookup $lines]
   set revnums [computeRevnums {}]
   set greppat [lindex $params end-1]
   foreach line $lines {
      set fhash [string trimright [first [split $line :]]]
      set cihash [dict get $cihashes $fhash]
      set revnum [dict get $revnums $cihash]
      # for now, we just preprend the chronological revision numbers and
      # add a bit of colour
      regsub -all "(.*?)($greppat)(.*)" $line \\1[coloured redbold \\2]\\3 line
      lappend out [coloured magenta $revnum]:$line
   }
   return $out
}

proc adjustWidth params {
   set widopt {}

          # non-unique (hit > 1) matches (e.g. `fossil a') should not
          # trigger this block at all.
          # NO LONGER QUITE RIGHT (st:stat ...), NEEDS RECONSIDERATION.
          #
          if {$command != $thematch} {
             set insert "an abbreviation of `$thematch' and "
          } else { set insert "" }
          puts "Fossil's `$command' command is ${insert}intercepted by `fsl'."
          puts "The interceptor does the following:"
          # extract leading comment block from the interceptor source
          set src [lindex [dict get $config::commands $command] 1]
          set lines [split $src \n]
          foreach line $lines {
             if {![regexp {^#} $line]} { continue }  ;#skip the first line...
             if {[regexp {^#[ ]?(.*)} $line {} line]} {

        lappend report [format "%10s -> %s" $alias [dict get $config::aliases $alias ]]
      }

    puts "Alias definitions:"
    puts "------------------"
    puts [join $report \n]
}

interceptor gr:grep {
# ------------------------------------------------------------------------
# Extend `grep' by options
#   -F
#   -L
# to report only _f_irst (oldest) and _l_ast (newest) checkin matching
# the pattern. This is frequently what one is interested in.
# ------------------------------------------------------------------------
   # we set up a 2-element list `grepflags' with 0/1 entries
   # indicating whether F and L are set. this list is put into the
   # `config' namespace to make it accessible elsewhere.

   set grepopts [lrange $params 1 end-2]
   set grepflags [regexp -- -F $grepopts]
   lappend grepflags [regexp -- -L $grepopts] 
   set config::grepflags $grepflags

   # strip the non-standard options since `fossil grep' does not
   # understand them
   regsub -all { -(F|L)} $params {} params
   return $params
}


interceptor df|gd:gdf {
# ------------------------------------------------------------------------
# drop-in replacement for `fsl (g)di' using hg/svn-style chronological
# revision numbers. call as
#
# fsl (g)df ... -r n(:m) ...

             set revnums [computeRevnums $params]
             set lines [reformFinfo-b $lines $revnums]
          } else {
             set revnums [computeRevnums $params]
             set lines [reformTimeline $lines $revnums $command]
          }
       } elseif {$command == "grep" && [llength $lines] > 1} {
             set lines [fixGrep $lines $params $config::grepflags]
             set chain ::config::fslrc::passthrough
       }

       if {$::config::dbglvl > 1} {puts "*** filter chain: [join $chain ", "]"}

       foreach line $lines {
          if {$::config::dbglvl > 98} {