use Perl

• Leather appointed version! (Score:1)

  by Aristotle (5147) <pagaltzis@gmx.de> on 2004.12.16 21:28 (#36877) Homepage Journal

  Holy hell did those @- and @+ semantics ever turn my brain to mush. This was far harder than it promised to be.

  #!/usr/bin/perl -w
  use strict;
  
  use Term::ANSIColor;
  use List::Util qw( min );
  use Getopt::Std;
  
  getopts( 'c:' );
  my @color = split /,/, our $opt_c || 'bold red';
  
  @ARGV or die <<'END_USAGE';
  usage: hl [ -c colour ] pattern [ file... ] [ < input ]
         You can use capturing parens in your pattern. In that case,
         you can supply multiple attributes separated by commas,
         which will be used to individually colour the submatches.
  END_USAGE
  
  my $rx = shift;
  $rx = qr/$rx/;
  
  while( <> ) {
      s{ $rx }{ colored_match() }gex;
      print;
  }
  
  sub colored_match {
      my $last = min( $#color, $#- );
      our( @START, @END );
      BEGIN { *START = \@-; *END = \@+; }
  
      if( $last ) {
          my $str = colored( substr( $_, $START[ 0 ], $START[ 1 ] ), $color[ 0 ] );
          for my $i ( 1 .. $last ) {
              $str .= colored( substr( $_, $START[ $i ], $END[ $i     ] - $START[ $i ] ), $color[ $i ] );
              $str .= colored( substr( $_, $END[ $i ], $START[ $i + 1 ] - $END[ $i ] ), $color[ 0 ] )
                  unless $i == $last;
          }
          $str .= colored( substr( $_, $END[ $last ], $END[ 0 ] - $END[ $last ] ), $color[ 0 ] );
          return $str;
      }
      else {
          return colored( substr( $_, $START[ 0 ], $END[ 0 ] - $START[ 0 ] ), $color[ 0 ] );
      }
  }

  Reply to This

  • Re:Leather appointed version! (Score:2)

    by pudge (1)

    You're crazy. :-)
    • Re:Leather appointed version! (Score:1)

      by Aristotle (5147)

      The good kind, I hope [perlmonks.org]? :-)
  • Re:Leather appointed version! (Score:2)

    by wickline (135)

    Very very nice! I'll certainly be using this! There was an obo error in the output, but 'tis easily fixed:

    --- old/hl      Thu Dec 16 23:24:27 2004
    +++ bin/hl      Thu Dec 16 23:34:29 2004
    @@ -29,7 +29,7 @@
         BEGIN { *START = \@-; *END = \@+; }
     
         if( $last ) {
    -        my $str = colored( substr( $_, $START[ 0 ], $START[ 1 ] ), $color[ 0 ] );
    +        my $str = colored( substr( $_, $START[ 0 ], $START[
    • Re:Leather appointed version! (Score:1)

      by Aristotle (5147)

      Thanks, but your fix is wrong. It introduces a bug in my initial tests. Apparently neither of us tested with sufficiently diverse patterns. The real fix is:

      -        my $str = colored( substr( $_, $START[ 0 ], $START[ 1 ] ), $color[ 0 ] );
      +        my $str = colored( substr( $_, $START[ 0 ], $START[ 1 ] - $START[ 0 ] ), $color[ 0 ] );

      Yeah, I know what you're thinking. D'oh.

      At this point I realized that it almost looked like a common rather than a special case and
      • Re:Leather appointed version! (Score:2)

        by wickline (135)

        That change didn't fix the bug I was concerned with at the time, and I started to tweak it to do so and then got involved with a bug that bugged me even more.
        
        The bug I was concerned with initially was that extra colors should be ignored, and if insufficient colors are provided, then the uncolored captures should get the same color as the uncaptured matched text.
        
        The bug that sidetracked me was the handling of nested matches.
        
        I'd be curious to hear if this monstrosity [perl.org] correctly handled your test cases too..