Fossil Wrapper

          2. Getting help:
          Issuing `fsl help COMMAND' works for all `fossil' commands as well
          as for the command interceptors defined by `fsl' (see the wiki
          for further information). Currently these are:
             - alias
             - wrapper
             - df
          
          Issuing `fsl -help' provides a short help text for the `fsl' specific
          options.
       }
       return $mantext
    }

    proc init {filename} {
................................................................................
   # options so it is not sufficient to just test for command name in
   # this case (currently the only example I'm aware of is
   # "amend -e").

   # define a regexp pattern identifying the option bearing
   # commands (and their valid abbreviations) that need interaction.
   # append further commands to the pattern via alteration (logical
   # OR)): 
   append needInteraction {^(am(e(nd?)?)?.* (-e|--edit-comment)( |$))}

   if {[regexp $needInteraction $params]} {
      return true
   } else {
      set command [first $params]
      switch -re $command {
................................................................................
      dict set numrevs $rev :$numrev
   }

   # append chronological revision numbers to sha1 hashes. in order
   # to keep this reasonably fast on large repos, we do *not* use
   # thousands of `regsub' calls on the whole timeline but rather
   # perform those only on a per-line basis and join everything
   # afterwards. 

   set timeline {}
   foreach line $lines {
      if {[regexp $rgxrev $line {} {} {} {} {} sha1rev]} {
         set val [dict get $numrevs $sha1rev]
         regsub $rgxrev $line &$val line
      }
................................................................................

   array set colors {
      descendants yellow
      finfo       blue
      search      yellow
      timeline    yellow

   } 
   set timdcol $colors($command)

   # colorize
   regsub -all $rgxdatehead $timeline \\1[coloured blue {\2\3\4}]\\5 timeline
   regsub -all $rgxtimd $timeline \\1[coloured $timdcol \\2] timeline
   regsub -all $rgxarti $timeline \\1[coloured red \\2]\\3\\4[coloured magenta \\5] timeline
   regsub -all $rgxuser $timeline \\1[coloured yellow \\2][coloured green \\5] timeline
   regsub -all $rgxtags $timeline [coloured yellow \\1][coloured cyan \\3]\\4 timeline 
   regsub      $rgxcurr $timeline [display bright &] timeline
   regsub -all $rgxfmbr $timeline [display underscored &] timeline
   regsub      $rgxlast $timeline [display reversed &] timeline

   set timeline [string trimright $timeline "\n"]
   set lines [split $timeline "\n" ]
   set lines [map {x {set x "$x\n"}}  $lines]
................................................................................
         set rev "\[$rev\]"
         # hopefully, all these are still on the same line ...:
         set date [coloured blue $date]
         set user [coloured green $user]
         set branch [coloured cyan $branch]
      }
      if {![catch {set numrev [dict get $revnums $rev]}]} {
         set rev "$rev:$numrev" 
      }
      set words [lreplace $words 0 3 $rev $date $user $branch]
      set line [join $words]
      lappend out $line\n
   }
   return $out
}


proc computeRevnums {params} {
#-----------------------------------------------------------------------
# generate a dictionary of SHA1 keys vs. revision numbers
#-----------------------------------------------------------------------
   set revcnt  0
   set numrev  0
................................................................................
      }
   }
   return $revnums
}

proc adjustWidth params {
   set widopt {}
   regexp -- {(timeline|finfo|search|descendants).*(-W)} $params widopt 
   if {$widopt == ""} then {
      # determine total number of checkins for computation of required
      # additional space. the following works for the current format of
      # `fossil info' output...

      set rgxrepo {\-R\s+.+}
      set repo {}
      regexp $rgxrepo $params repo
      if {[catch {set fslinfo [exec fossil info {*}$repo]}]} {
         return $params
      }
      
      # we need to ensure that the `fslinfo' string is a valid Tcl list. 
      # this is not guaranteed a priori (e.g. `this is my "string"definition'
      # would fail. so we first explicitly split it:
      set fslinfo [split $fslinfo]

      set numrev [lindex $fslinfo end]; #tot. no. of checkins
      set numrev [expr $numrev - 1]; #ordinal no. of last checkin

................................................................................

      set size   [exec stty size]
      set cols   [lindex $size end]
      set need   [expr [string length $numrev] + $more]
      set width  [expr $cols - $need]

      regsub {(timeline|finfo|search|descendants)} $params "\\1 -W $width" params



   } 
   return $params
}

proc processoptions argv {
   # a `package require cmdline' sometimes can take ages for the lookup
   # of the location if not yet cached (problem encountered under OSX
   # at some point). we try to avoid this by assuming `tcllib' is
................................................................................
   # `cmdline.tcl' directly before resorting to `package require'.
   # whether this workaround continues to make sense is not quite
   # sure but it does no harm either ...

   set status [catch {
      set dname [file dirname $::tcl_library]
      set dir [lindex [lsort -dictionary [glob -directory $dname "*tcllib*"]] 0]
      source [file join $dir cmdline cmdline.tcl] 
   }]
   if {$status != 0} { package require cmdline }

   set progid [::cmdline::getArgv0]

   set knownoptions {
      { reset       "Recreate the default `~/.fslrc' config file by overwriting the existing one." }
................................................................................

      `$progid' {options} command {command_options} {file(s)}

      where `command' is either one of the `$progid'-specific alias definitions
      or command interceptors or a native `fossil' command.

      Options recognized by `$progid':
      
   "

   # `getoptions' raises error even when called with `-help'. this is
   # irritating, so we work around it ...
   if { [catch {::cmdline::getoptions argv $knownoptions $usage} optlist] } {
      if { [string length $argv] } {
         puts "[lindex $argv 0]: invalid option, see `fsl -help'. Giving up"
................................................................................

proc interceptor {command_spec body} {
    # cf. `apply' documentation: the anonymous function for `apply'
    # has to be specified in the form {args body namespace} where
    # `args' spefifies the formal arguments of the function. in the
    # present case `args' is identical to `params'. in the current setup
    # the `namespace' argument is apparently redundant and could be
    # ommitted: 

    set fn [list {params} $body [uplevel 1 {namespace current}]]
    
    foreach command [triggers_for $command_spec] {
       # this loop sets up the dictionary `config::commands' whose
       # keys are the known interceptor commands and whose values are
       # the corresponding anonymous function definitions. note that each
       # alternate name in `command_spec' (e.g., a, ali, alias etc.)
       # generates a further entry (with identical value).
       dict set config::commands $command $fn
................................................................................
}

interceptor ig:ignore {
# ------------------------------------------------------------------------
# report the list of files in the checkout currently ignored by `fossil'
# ------------------------------------------------------------------------
   set afilter ::config::fslrc::status
   
   if { [catch {exec fossil extras} pattern] } {
      puts $pattern
      exit 1
   }
   regsub -all {\n} $pattern {|} pattern
   if {$pattern != ""} {
      set pattern "($pattern)";  #the required OR pattern
................................................................................
   # since it is not guaranteed that this command is issued only when
   # being in the local root of the repo:
   if { [catch {exec fossil status} report] } {
      puts $report
      exit 1
   }
   regexp -line {^local-root:[ ]*(.*)$} $report {} localroot
   
   foreach name $uvfiles {
      if { [catch {exec fossil uv export $name $localroot$name} msg] } {
         puts $msg
         exit 1
      } else { puts $localroot$name }
   }
}

interceptor ll {
# ------------------------------------------------------------------------
# Provide `ls -v' output plus some eye candy
# ------------------------------------------------------------------------
   set afilter ::config::fslrc::status
   
   catch {exec fossil ls -v} lsrep 

   set lsrep [split $lsrep \n]
   foreach line $lsrep {
      filter_with $afilter "$line"
      puts ""
   }
}
................................................................................
#  * trim leading and trailing blanks, if any
#  * replace remaining blanks by underscore
#  * append "-fsl"
#  * use resulting name as checkout directory and create it
#  * clone repo into this directory under the invariant name `.fslrepo'
#
# Otherwise (if FILENAME is provided) just pass the call unmodified to
# fossil. 
# ------------------------------------------------------------------------
   set defaultName .fslrepo
   set params [lreplace $params 0 0 clone]
   set hasOpts [regexp {^-} [lindex $params 1]]
   if {!$hasOpts && [llength $params] == 3} {
      # we do not want to parse all possible `clone' options properly,
      # but this case (a call without options but two arguments...)
................................................................................
      # by `clone' and thus the intention to automaticlly
      # "clone+open" the repo using the described naming strategy.
      set uri [lindex $params end]
      set remoteName [lindex [file split $uri] end]
      set checkout [split [string trimleft $remoteName .] .]
      if {[llength $checkout] > 1} {
         set checkout [lreplace $checkout end end]
      } 
      set checkout [string trim [join $checkout]]
      regsub {(.*)-fsl$} $checkout {\1} checkout
      regsub -all { } $checkout {_} checkout
      append checkout -fsl
      if {[file exists $checkout]} {
         puts "$checkout: file exists"
         exit 1
................................................................................
            exit 1
         } else {
            if {[catch {exec fossil open $defaultName} msg]} {
               puts $msg
               exit 1
            }
         }
      } 
   } else { return $params }
}

interceptor w:wrapper {
# ------------------------------------------------------------------------
# This interceptor provides a compilation of the current aliases, filters,
# and interceptors.
................................................................................
      if {$word == {--to}} {
         set tidx [expr $idx + 1]
         continue
      }
   }
   if {$fidx > 0} {set fversion [lindex $params $fidx]}
   if {$tidx > 0} {set tversion [lindex $params $tidx]}
   
   if {[dict exists $num2hash $fversion]} {
      set fversion [dict get $num2hash $fversion]
   }
   if {[dict exists $num2hash $tversion]} {
      set tversion [dict get $num2hash $tversion]
   }

................................................................................
    while 1 {
        if {[interactive? $params]} {
            interact; break
        }
        expect {
            eof { break }
            \n {
            #collect everything and postpone filtering
            lappend lines $expect_out(buffer)
        }
            -notransfer -re {[?:] $} {
                # [*] Under certain conditions, an incomplete output
                # fragment will match this pattern; check whether
                # there's a pending newline character:
                set timeout 0
                #after 1
                expect -notransfer \n {
................................................................................
          $command == "search"      ||
          $command == "descendants"
          ) && [llength $lines] > 1} {
          set revnums [computeRevnums $params]
          set lines [reformTimeline $lines $revnums $command]
       } elseif {$command == "finfo" && [llength $lines] > 1} {
          if {[regexp {finfo \s*-p} $params]} {
             # this is `finfo -p' (a.k.a. `cat').
	     # prevent further filtering and pass through as is
             # resetting filter chain to `cat' filter:
             #
             set chain ::config::fslrc::cat
          } elseif {[regexp {finfo.*-b} $params]} {
             set revnums [computeRevnums $params]
             set lines [reformFinfo-b $lines $revnums]
          } else {
             set revnums [computeRevnums $params]
             set lines [reformTimeline $lines $revnums $command]
          }

          2. Getting help:
          Issuing `fsl help COMMAND' works for all `fossil' commands as well
          as for the command interceptors defined by `fsl' (see the wiki
          for further information). Currently these are:
             - alias
             - wrapper
             - df

          Issuing `fsl -help' provides a short help text for the `fsl' specific
          options.
       }
       return $mantext
    }

    proc init {filename} {
................................................................................
   # options so it is not sufficient to just test for command name in
   # this case (currently the only example I'm aware of is
   # "amend -e").

   # define a regexp pattern identifying the option bearing
   # commands (and their valid abbreviations) that need interaction.
   # append further commands to the pattern via alteration (logical
   # OR)):
   append needInteraction {^(am(e(nd?)?)?.* (-e|--edit-comment)( |$))}

   if {[regexp $needInteraction $params]} {
      return true
   } else {
      set command [first $params]
      switch -re $command {
................................................................................
      dict set numrevs $rev :$numrev
   }

   # append chronological revision numbers to sha1 hashes. in order
   # to keep this reasonably fast on large repos, we do *not* use
   # thousands of `regsub' calls on the whole timeline but rather
   # perform those only on a per-line basis and join everything
   # afterwards.

   set timeline {}
   foreach line $lines {
      if {[regexp $rgxrev $line {} {} {} {} {} sha1rev]} {
         set val [dict get $numrevs $sha1rev]
         regsub $rgxrev $line &$val line
      }
................................................................................

   array set colors {
      descendants yellow
      finfo       blue
      search      yellow
      timeline    yellow

   }
   set timdcol $colors($command)

   # colorize
   regsub -all $rgxdatehead $timeline \\1[coloured blue {\2\3\4}]\\5 timeline
   regsub -all $rgxtimd $timeline \\1[coloured $timdcol \\2] timeline
   regsub -all $rgxarti $timeline \\1[coloured red \\2]\\3\\4[coloured magenta \\5] timeline
   regsub -all $rgxuser $timeline \\1[coloured yellow \\2][coloured green \\5] timeline
   regsub -all $rgxtags $timeline [coloured yellow \\1][coloured cyan \\3]\\4 timeline
   regsub      $rgxcurr $timeline [display bright &] timeline
   regsub -all $rgxfmbr $timeline [display underscored &] timeline
   regsub      $rgxlast $timeline [display reversed &] timeline

   set timeline [string trimright $timeline "\n"]
   set lines [split $timeline "\n" ]
   set lines [map {x {set x "$x\n"}}  $lines]
................................................................................
         set rev "\[$rev\]"
         # hopefully, all these are still on the same line ...:
         set date [coloured blue $date]
         set user [coloured green $user]
         set branch [coloured cyan $branch]
      }
      if {![catch {set numrev [dict get $revnums $rev]}]} {
         set rev "$rev:$numrev"
      }
      set words [lreplace $words 0 3 $rev $date $user $branch]
      set line [join $words]
      lappend out $line\n
   }
   return $out
}


proc computeRevnums {params} {
#-----------------------------------------------------------------------
# generate a dictionary of SHA1 keys vs. revision numbers
#-----------------------------------------------------------------------
   set revcnt  0
   set numrev  0
................................................................................
      }
   }
   return $revnums
}

proc adjustWidth params {
   set widopt {}
   regexp -- {(timeline|finfo|search|descendants).*(-W)} $params widopt
   if {$widopt == ""} then {
      # determine total number of checkins for computation of required
      # additional space. the following works for the current format of
      # `fossil info' output...

      set rgxrepo {\-R\s+.+}
      set repo {}
      regexp $rgxrepo $params repo
      if {[catch {set fslinfo [exec fossil info {*}$repo]}]} {
         return $params
      }

      # we need to ensure that the `fslinfo' string is a valid Tcl list.
      # this is not guaranteed a priori (e.g. `this is my "string"definition'
      # would fail. so we first explicitly split it:
      set fslinfo [split $fslinfo]

      set numrev [lindex $fslinfo end]; #tot. no. of checkins
      set numrev [expr $numrev - 1]; #ordinal no. of last checkin

................................................................................

      set size   [exec stty size]
      set cols   [lindex $size end]
      set need   [expr [string length $numrev] + $more]
      set width  [expr $cols - $need]

      regsub {(timeline|finfo|search|descendants)} $params "\\1 -W $width" params
      # we need do undo the -W insertion in case we are dealing with
      # `finfo -p'
      regsub {(finfo)( -W .*)( -p)(.*)} $params "\\1\\3\\4" params
   }
   return $params
}

proc processoptions argv {
   # a `package require cmdline' sometimes can take ages for the lookup
   # of the location if not yet cached (problem encountered under OSX
   # at some point). we try to avoid this by assuming `tcllib' is
................................................................................
   # `cmdline.tcl' directly before resorting to `package require'.
   # whether this workaround continues to make sense is not quite
   # sure but it does no harm either ...

   set status [catch {
      set dname [file dirname $::tcl_library]
      set dir [lindex [lsort -dictionary [glob -directory $dname "*tcllib*"]] 0]
      source [file join $dir cmdline cmdline.tcl]
   }]
   if {$status != 0} { package require cmdline }

   set progid [::cmdline::getArgv0]

   set knownoptions {
      { reset       "Recreate the default `~/.fslrc' config file by overwriting the existing one." }
................................................................................

      `$progid' {options} command {command_options} {file(s)}

      where `command' is either one of the `$progid'-specific alias definitions
      or command interceptors or a native `fossil' command.

      Options recognized by `$progid':

   "

   # `getoptions' raises error even when called with `-help'. this is
   # irritating, so we work around it ...
   if { [catch {::cmdline::getoptions argv $knownoptions $usage} optlist] } {
      if { [string length $argv] } {
         puts "[lindex $argv 0]: invalid option, see `fsl -help'. Giving up"
................................................................................

proc interceptor {command_spec body} {
    # cf. `apply' documentation: the anonymous function for `apply'
    # has to be specified in the form {args body namespace} where
    # `args' spefifies the formal arguments of the function. in the
    # present case `args' is identical to `params'. in the current setup
    # the `namespace' argument is apparently redundant and could be
    # ommitted:

    set fn [list {params} $body [uplevel 1 {namespace current}]]

    foreach command [triggers_for $command_spec] {
       # this loop sets up the dictionary `config::commands' whose
       # keys are the known interceptor commands and whose values are
       # the corresponding anonymous function definitions. note that each
       # alternate name in `command_spec' (e.g., a, ali, alias etc.)
       # generates a further entry (with identical value).
       dict set config::commands $command $fn
................................................................................
}

interceptor ig:ignore {
# ------------------------------------------------------------------------
# report the list of files in the checkout currently ignored by `fossil'
# ------------------------------------------------------------------------
   set afilter ::config::fslrc::status

   if { [catch {exec fossil extras} pattern] } {
      puts $pattern
      exit 1
   }
   regsub -all {\n} $pattern {|} pattern
   if {$pattern != ""} {
      set pattern "($pattern)";  #the required OR pattern
................................................................................
   # since it is not guaranteed that this command is issued only when
   # being in the local root of the repo:
   if { [catch {exec fossil status} report] } {
      puts $report
      exit 1
   }
   regexp -line {^local-root:[ ]*(.*)$} $report {} localroot

   foreach name $uvfiles {
      if { [catch {exec fossil uv export $name $localroot$name} msg] } {
         puts $msg
         exit 1
      } else { puts $localroot$name }
   }
}

interceptor ll {
# ------------------------------------------------------------------------
# Provide `ls -v' output plus some eye candy
# ------------------------------------------------------------------------
   set afilter ::config::fslrc::status

   catch {exec fossil ls -v} lsrep

   set lsrep [split $lsrep \n]
   foreach line $lsrep {
      filter_with $afilter "$line"
      puts ""
   }
}
................................................................................
#  * trim leading and trailing blanks, if any
#  * replace remaining blanks by underscore
#  * append "-fsl"
#  * use resulting name as checkout directory and create it
#  * clone repo into this directory under the invariant name `.fslrepo'
#
# Otherwise (if FILENAME is provided) just pass the call unmodified to
# fossil.
# ------------------------------------------------------------------------
   set defaultName .fslrepo
   set params [lreplace $params 0 0 clone]
   set hasOpts [regexp {^-} [lindex $params 1]]
   if {!$hasOpts && [llength $params] == 3} {
      # we do not want to parse all possible `clone' options properly,
      # but this case (a call without options but two arguments...)
................................................................................
      # by `clone' and thus the intention to automaticlly
      # "clone+open" the repo using the described naming strategy.
      set uri [lindex $params end]
      set remoteName [lindex [file split $uri] end]
      set checkout [split [string trimleft $remoteName .] .]
      if {[llength $checkout] > 1} {
         set checkout [lreplace $checkout end end]
      }
      set checkout [string trim [join $checkout]]
      regsub {(.*)-fsl$} $checkout {\1} checkout
      regsub -all { } $checkout {_} checkout
      append checkout -fsl
      if {[file exists $checkout]} {
         puts "$checkout: file exists"
         exit 1
................................................................................
            exit 1
         } else {
            if {[catch {exec fossil open $defaultName} msg]} {
               puts $msg
               exit 1
            }
         }
      }
   } else { return $params }
}

interceptor w:wrapper {
# ------------------------------------------------------------------------
# This interceptor provides a compilation of the current aliases, filters,
# and interceptors.
................................................................................
      if {$word == {--to}} {
         set tidx [expr $idx + 1]
         continue
      }
   }
   if {$fidx > 0} {set fversion [lindex $params $fidx]}
   if {$tidx > 0} {set tversion [lindex $params $tidx]}

   if {[dict exists $num2hash $fversion]} {
      set fversion [dict get $num2hash $fversion]
   }
   if {[dict exists $num2hash $tversion]} {
      set tversion [dict get $num2hash $tversion]
   }

................................................................................
    while 1 {
        if {[interactive? $params]} {
            interact; break
        }
        expect {
            eof { break }
            \n {
                #collect everything and postpone filtering
                lappend lines $expect_out(buffer)
            }
            -notransfer -re {[?:] $} {
                # [*] Under certain conditions, an incomplete output
                # fragment will match this pattern; check whether
                # there's a pending newline character:
                set timeout 0
                #after 1
                expect -notransfer \n {
................................................................................
          $command == "search"      ||
          $command == "descendants"
          ) && [llength $lines] > 1} {
          set revnums [computeRevnums $params]
          set lines [reformTimeline $lines $revnums $command]
       } elseif {$command == "finfo" && [llength $lines] > 1} {
          if {[regexp {finfo \s*-p} $params]} {
             # this is `finfo -p' (a.k.a. `cat'). prevent further
             # filtering and pass through as is by (re)setting filter
             # chain to `passthrough' filter:

             set chain ::config::fslrc::passthrough
          } elseif {[regexp {finfo.*-b} $params]} {
             set revnums [computeRevnums $params]
             set lines [reformFinfo-b $lines $revnums]
          } else {
             set revnums [computeRevnums $params]
             set lines [reformTimeline $lines $revnums $command]
          }