Fossil Wrapper

Check-in [8df6e8d8f7]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merged `grep'.
Timelines: family | ancestors | descendants | both | dresden
Files: files | file ages | folders
SHA1: 8df6e8d8f7d041a476694fda8727b082bc1450e4
User & Date: j 2019-07-21 12:27:01
Context
2019-07-21
15:42
minor tidy up: avoid redundant sub-pattern captures in `regsub'. check-in: 5a2358d8c3 user: j tags: dresden
12:27
merged `grep'. check-in: 8df6e8d8f7 user: j tags: dresden
12:26
minor. Leaf check-in: 36a8a1862c user: j tags: grep
2019-07-05
16:50
one bug and one regression less. check-in: 6933053d49 user: j tags: dresden
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to fsl.

4
5
6
7
8
9
10

11
12
13
14
15
16
17
...
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
...
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
...
365
366
367
368
369
370
371
372
373
374










375
376
377
378
379
380
381
...
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
...
548
549
550
551
552
553
554























































555
556
557
558
559
560
561
...
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
...
924
925
926
927
928
929
930



931
932
933
934
935
936
937
938
939
940
941
942
943

944
945
946
947
948

949
950
951
952
953
954
955
....
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
....
1258
1259
1260
1261
1262
1263
1264





























1265
1266
1267
1268
1269
1270
1271
....
1354
1355
1356
1357
1358
1359
1360














1361
1362
1363

1364
1365
1366
1367
1368
1369
1370
....
1428
1429
1430
1431
1432
1433
1434



1435
1436
1437
1438
1439
1440
1441
# 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


    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     {diff -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       red    0;31        green   0;32
        yellow  0;33       blue   1;34        purple  0;35
        magenta 1;35       cyan   0;36        grey    0;37










    }
    ansi $colour $colours $text
}

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

proc filter?      {name} { dict exists $config::filters  $name }
................................................................................
   set rgxtimd {}
   set rgxdatehead {}
   set rgxrev {}
   append rgxtimd {(^|\n)} "\($rgxtime|$rgxdate\)"
   append rgxdatehead {(^|\n)(=== )} $rgxdate {( ===)(\n)}
   set rgxarti {(\[)([a-f\d]{4})([a-f\d]{6}\])(:)([0-9-]+)}
   append rgxrev $rgxtimd { } $rgxsha1
   set rgxuser {( \()(user:( |(\n\s+)))([\w.-]+)}
   set rgxtags {( (tags|branch):)([^)]+)(\))}
   set rgxcurr {\*CURRENT\*}
   set rgxfmbr {\*(FORK|MERGE|BRANCH)\*}

   set p1      {(--- (line|entry) limit \([0-9]+\) reached ---)}
   set p2      {(\+\+\+ (end of timeline|no more data) \([0-9]+\) \+\+\+)}
   set rgxlast (\n)($p1|$p2)
................................................................................
         incr revcnt
         regexp $rgxrev $line rev
         dict set revnums $rev [expr {$numrev - $revcnt}]
      }
   }
   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
................................................................................
   "

   # `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"
         error {}
      } else {
         # this should be `fsl -help'
         puts $optlist
         exit
      }
   }

................................................................................
      { W.arg ""              "<num> Width of lines (default is to
                      auto-detect). Must be >20 or 0 (= no limit,
                      resulting in a single line per entry)." }

      { width.arg ""          "<num> Width of lines (default is to
                      auto-detect). Must be >20 or 0 (= no limit,
                      resulting in a single line per entry)." }



   }
   set usage {
      Use `fossil help up' to get real help for the `up' command.
      The options accepted by `up' follow.
   }
   # `getoptions' raises error even when called with `-help'. this is
   # irritating, so we work around it ...
   set args0 [lreplace $params 0 0]
   set cmd [first $params]
   set args $args0
   if { [catch {::cmdline::getoptions args $knownoptions $usage} optlist] } {
      if { [string length $args] } {
         puts "[lindex $args 0]: invalid option, see `fossil help up'. Giving up"

      } else {
         # in case `fsl up -help' is issued ...
         puts $optlist
      }
      exit

   }
   regsub $args $args0 {} opts

   set version [lindex $args 0]
   if { $version != "" } then {
      set hash2num [computeRevnums {}]
      dict for {key val} $hash2num {
................................................................................
          # 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 "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 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) ...
................................................................................
    # Prepare filters:
    set chain [chain_for $candidate]
    set chain [expr {[empty? $chain] ? [chain_for $command] : $chain}]
    set chain [string trimright $chain]

    # Expect settings:
    set prior_log [log_user];   # to be reverted before returning














    if {![empty? $chain]} {
        log_user 0;             # disable logging to stdout
    }

    if {![interactive? $params]} {
        set stty_init -onlcr;   # do not map LF to CRLF on output
    }

    #ensure that `lines' always exists:
    set lines {}
    # Call to `fossil' binary:
................................................................................
          } 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]
          }



       }

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

       foreach line $lines {
          if {$::config::dbglvl > 98} {
             catch {puts "IN: >$line<"}







>







 







|







 







|







 







|
|
|
>
>
>
>
>
>
>
>
>
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







>
>
>













>



<
|
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|

>







 







>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
...
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
...
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
...
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016

1017
1018
1019
1020
1021
1022
1023
1024
1025
....
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
....
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
....
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
....
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
# 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 }
................................................................................
   set rgxtimd {}
   set rgxdatehead {}
   set rgxrev {}
   append rgxtimd {(^|\n)} "\($rgxtime|$rgxdate\)"
   append rgxdatehead {(^|\n)(=== )} $rgxdate {( ===)(\n)}
   set rgxarti {(\[)([a-f\d]{4})([a-f\d]{6}\])(:)([0-9-]+)}
   append rgxrev $rgxtimd { } $rgxsha1
   set rgxuser {( \()(user:( |(\n\s+)))([^\s]+)}
   set rgxtags {( (tags|branch):)([^)]+)(\))}
   set rgxcurr {\*CURRENT\*}
   set rgxfmbr {\*(FORK|MERGE|BRANCH)\*}

   set p1      {(--- (line|entry) limit \([0-9]+\) reached ---)}
   set p2      {(\+\+\+ (end of timeline|no more data) \([0-9]+\) \+\+\+)}
   set rgxlast (\n)($p1|$p2)
................................................................................
         incr revcnt
         regexp $rgxrev $line rev
         dict set revnums $rev [expr {$numrev - $revcnt}]
      }
   }
   return $revnums
}

proc fixGrep {lines params grepflags} {
   set fname [last $params]
   set finfo [lrange [split [exec fossil finfo -W 0 $fname] \n] 1 end]
   set rgxdate {^\d{4}-\d\d-\d\d}
   set rgxhash {\[([a-f\d]{10})\]}
   foreach line $finfo {
      regexp "$rgxdate $rgxhash" $line _ cihash
      regexp ", artifact: $rgxhash, branch: .*\\)" $line _ fhash
      # an artifact 'fhash' can be part of multiple checkins. so we
      # have to collect all of them via `dict lappend'
      dict lappend cihashes $fhash \[$cihash\]
   }
   set revnums [computeRevnums {}]
   set f1 [last $grepflags]
   set f2 [first $grepflags]
   if {$f1 + $f2 > 0} {
      set buf $lines
      set lines {}
      if {$f1} { lappend lines [first $buf] } 
      if {$f2} { lappend lines [last $buf] } 
   }
   set greppat [lindex $params end-1]
   set checkincols {blue green}
   set idx 0
   set lastrev 0
   foreach line $lines {
      # need to separate file hash and line number to match `greppat'
      # against the real line content (so that anchoring of the
      # pattern works and spurious coloring of hash or line number
      # is prevented).
      set field  [split $line :]
      set fhash  [string trimright [first $field]]
      set lino   [lindex $field 1]
      set line   [join [lrange $field 2 end]]
      set cihash [dict get $cihashes $fhash]
      set revnum {}
      foreach hash $cihash {
         append revnum [dict get $revnums $hash] " "
      }
      set revnum [join $revnum ,]
      regsub -all "($greppat)" $line [coloured redbold \\1] line
      # for now, we just preprend the chronological revision numbers
      # and add a bit of colour
      if {[lindex $revnum end] != $lastrev} { set idx [expr {1 - $idx}] }
      set col [lindex $checkincols $idx]
      set buf [coloured magenta $revnum]:[coloured $col $fhash]
      if {[llength $field] > 1} {
         append buf :[coloured cyan $lino]:$line
      } else { append buf \n }
      lappend out $buf
      set lastrev [lindex $revnum end]
   }
   return $out
}

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
................................................................................
   "

   # `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"
         exit 1
      } else {
         # this should be `fsl -help'
         puts $optlist
         exit
      }
   }

................................................................................
      { W.arg ""              "<num> Width of lines (default is to
                      auto-detect). Must be >20 or 0 (= no limit,
                      resulting in a single line per entry)." }

      { width.arg ""          "<num> Width of lines (default is to
                      auto-detect). Must be >20 or 0 (= no limit,
                      resulting in a single line per entry)." }
      {setmtime               "Set timestamps of all files to match their SCM-side
                      times (the timestamp of the last checkin which modified
                      them)."}
   }
   set usage {
      Use `fossil help up' to get real help for the `up' command.
      The options accepted by `up' follow.
   }
   # `getoptions' raises error even when called with `-help'. this is
   # irritating, so we work around it ...
   set args0 [lreplace $params 0 0]
   set cmd [first $params]
   set args $args0
   if { [catch {::cmdline::getoptions args $knownoptions $usage} optlist] } {
      if { [string length $args] } {
         puts "[lindex $args 0]: invalid option, see `fossil help up'. Giving up"
         exit 1
      } else {
         # in case `fsl up -help' is issued ...
         puts $optlist

         exit
      }
   }
   regsub $args $args0 {} opts

   set version [lindex $args 0]
   if { $version != "" } then {
      set hash2num [computeRevnums {}]
      dict for {key val} $hash2num {
................................................................................
          # 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.
# ------------------------------------------------------------------------
   # THINK: one might consider to convert this to a complete
   # interceptor, moving all processing from the expect/filter block
   # here. The benefit would be the added capability to make 'grep'
   # work on multiple input files (or the whole '[fsl] ls' output).

   # 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) ...
................................................................................
    # Prepare filters:
    set chain [chain_for $candidate]
    set chain [expr {[empty? $chain] ? [chain_for $command] : $chain}]
    set chain [string trimright $chain]

    # Expect settings:
    set prior_log [log_user];   # to be reverted before returning

    # FIXME: reconcider the overall logic of how to handle log_user
    # on/off. it is slowly becoming a mess. previously 'log_user 0'
    # had to be called only if filter chain is non-empty (indicating
    # that the usual fossil output is going to be processed prior to
    # display). redefining this filter chain further down to
    # `passthrough' then is not a problem (as is done for 'timeline'
    # etc. where the output modifcation is not done by any filter but
    # in a proc prior to final filtering) but it _is_ a problem for
    # commands that lead to an empty filter chain (which usually
    # indicates that one wants just to see the raw fossil output)
    # while something is still done to their output as is the case for
    # `grep' now. maybe we can put everything in a grep filter
    # instead so that this explicit test for 'grep' becomes obsolete:
    if {![empty? $chain] || $command == "grep"} { 
        log_user 0; # disable logging to stdout
    }

    if {![interactive? $params]} {
        set stty_init -onlcr;   # do not map LF to CRLF on output
    }

    #ensure that `lines' always exists:
    set lines {}
    # Call to `fossil' binary:
................................................................................
          } 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]
          }
       } 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} {
             catch {puts "IN: >$line<"}