File Coverage

blib/lib/Parse/ANSIColor/Tiny.pm

Criterion	Covered	Total	%
statement	114	115	99.1
branch	45	48	93.7
condition	7	7	100.0
subroutine	19	19	100.0
pod	13	13	100.0
total	198	202	98.0

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of Parse-ANSIColor-Tiny
#
# This software is copyright (c) 2011 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Parse::ANSIColor::Tiny;
# git description: v0.601-1-g8166474

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Determine attributes of ANSI-Colored string
$Parse::ANSIColor::Tiny::VERSION = '0.700';
our @COLORS = qw( black red green yellow blue magenta cyan white );
our %FOREGROUND = (
  (map { (               $COLORS[$_] =>  30 + $_ ) } 0 .. $#COLORS),
  (map { (   'bright_' . $COLORS[$_] =>  90 + $_ ) } 0 .. $#COLORS),
);
our %BACKGROUND = (
  (map { (       'on_' . $COLORS[$_] =>  40 + $_ ) } 0 .. $#COLORS),
  (map { ('on_bright_' . $COLORS[$_] => 100 + $_ ) } 0 .. $#COLORS),
);

# Generating the 256-color codes involves a lot of codes and offsets that are
# not helped by turning them into constants.
## no critic (ValuesAndExpressions::ProhibitMagicNumbers)

our @COLORS256;

# The first 16 256-color codes are duplicates of the 16 ANSI colors,
# included for completeness.
for my $code (0 .. 15) {
  my $name = "ansi$code";
  $FOREGROUND{$name}      = "38;5;$code";
  $BACKGROUND{"on_$name"} = "48;5;$code";
  push @COLORS256, $name;
}

# 256-color RGB colors.  Red, green, and blue can each be values 0 through 5,
# and the resulting 216 colors start with color 16.
for my $r (0 .. 5) {
  for my $g (0 .. 5) {
    for my $b (0 .. 5) {
      my $code = 16 + (6 * 6 * $r) + (6 * $g) + $b;
      my $name = "rgb$r$g$b";
      $FOREGROUND{$name}    = "38;5;$code";
      $BACKGROUND{"on_$name"} = "48;5;$code";
      push @COLORS256, $name;
    }
  }
}

# The last 256-color codes are 24 shades of grey.
for my $n (0 .. 23) {
  my $code = $n + 232;
  my $name = "grey$n";
  $FOREGROUND{$name}      = "38;5;$code";
  $BACKGROUND{"on_$name"} = "48;5;$code";
  push @COLORS256, $name;
}

our %ATTRIBUTES = (
  clear          => 0,
  reset          => 0,
  bold           => 1,
  dark           => 2,
  faint          => 2,
  underline      => 4,
  underscore     => 4,
  blink          => 5,
  reverse        => 7,
  concealed      => 8,
  reverse_off    => 27,
  reset_foreground => 39,
  reset_background => 49,
  %FOREGROUND,
  %BACKGROUND,
);

# copied from Term::ANSIColor
  our %ATTRIBUTES_R;
  # Reverse lookup.  Alphabetically first name for a sequence is preferred.
  for (reverse sort keys %ATTRIBUTES) {
      $ATTRIBUTES_R{$ATTRIBUTES{$_}} = $_;
  }


sub new {
  my $class = shift;
  my $self = {
    remove_escapes => 1,
    @_ == 1 ? %{ $_[0] } : @_,
  };

  $self->{process} = 1
    if $self->{auto_reverse};

  # fix incorrectly specified attributes
  ($self->{background} ||= 'black') =~ s/^(on_)*/on_/;
  ($self->{foreground} ||= 'white') =~ s/^(on_)*//;

  bless $self, $class;
}


sub colors {
  return (@COLORS, @COLORS256);
}
sub foreground_colors {
  return (
    @COLORS,
    (map { "bright_$_" } @COLORS),
    @COLORS256,
  );
}
sub background_colors {
  return (
    (map { "on_$_" } @COLORS),
    (map { "on_bright_$_" } @COLORS),
    (map { "on_$_" } @COLORS256),
  );
}


sub __separate_and_normalize {
  my ($codes) = @_;

  # Treat empty as "clear".
  defined($codes) && length($codes)
    or return 0;

  # Replace empty (clear) with zero to simplify parsing and return values.
  $codes =~ s/^;/0;/;
  $codes =~ s/;$/;0/;
  # Insert a zero between two semicolons (use look-ahead to get /g to find all).
  $codes =~ s/;(?=;)/;0/g;

  # Remove any leading zeros from (sections of) codes.
  $codes =~ s/\b0+(?=\d)//g;

  # Return all matches (of extended sequences or digits).
  return $codes =~ m{ ( [34]8;5;\d+ | \d+) }xg;
}

sub identify {
  my ($self, @codes) = @_;
  local $_;
  return
    grep { defined }
    map  { $ATTRIBUTES_R{ $_ } }
    map  { __separate_and_normalize($_) }
      @codes;
}


sub normalize {
  my $self = shift;
  my @norm;
  foreach my $attr ( @_ ){
    if( $attr eq 'clear' ){
      @norm = ();
    }
    elsif( $attr eq 'reverse_off' ){
      # reverse_off cancels reverse
      @norm = grep { $_ ne 'reverse' } @norm;
    }
    elsif( $attr eq 'reset_foreground' ){
      @norm = grep { !exists $FOREGROUND{$_} } @norm;
    }
    elsif( $attr eq 'reset_background' ){
      @norm = grep { !exists $BACKGROUND{$_} } @norm;
    }
    else {
      # remove previous (duplicate) occurrences of this attribute
      @norm = grep { $_ ne $attr } @norm;
      # new fg color overwrites previous fg
      @norm = grep { !exists $FOREGROUND{$_} } @norm if exists $FOREGROUND{$attr};
      # new bg color overwrites previous bg
      @norm = grep { !exists $BACKGROUND{$_} } @norm if exists $BACKGROUND{$attr};
      push @norm, $attr;
    }
  }
  return @norm;
}


sub parse {
  my ($self, $orig) = @_;

  my $last_pos = 0;
  my $last_attr = [];
  my $processed = [];
  my $parsed = [];

  # Strip escape sequences that we aren't going to use
  $orig = $self->remove_escape_sequences($orig)
    if $self->{remove_escapes};

  while( $orig =~ m/(\e\[([0-9;]*)m)/mg ){
    my $seq = $1;
    my $attrs = $2;

    my $cur_pos = pos($orig);

    my $len = ($cur_pos - length($seq)) - $last_pos;
    push @$parsed, [
      $processed,
      substr($orig, $last_pos, $len)
    ]
      # don't bother with empty strings
      if $len;

    $last_pos = $cur_pos;
    $last_attr = [$self->normalize(@$last_attr, $self->identify($attrs))];
    $processed = $self->{process} ? [$self->process(@$last_attr)] : $last_attr;
  }

    push @$parsed, [
      $processed,
      substr($orig, $last_pos)
    ]
      # if there's any string left
      if $last_pos < length($orig);

  return $parsed;
}


sub process {
  my ($self, @attr) = @_;
  @attr = $self->process_reverse(@attr) if $self->{auto_reverse};
  return @attr;
}


sub process_reverse {
  my $self = shift;
  my ($rev, $fg, $bg, @attr);
  my $i = 0;
  foreach my $attr ( @_ ){
    if( $attr eq 'reverse' ){
      $rev = 1;
      next;
    }
    elsif( $FOREGROUND{ $attr } ){
      $fg = $i;
    }
    elsif( $BACKGROUND{ $attr } ){
      $bg = $i;
    }
    push @attr, $attr;
    $i++;
  }
  # maintain order for consistency with other methods
  if( $rev ){
    # if either color is missing then the default colors should be reversed
    {
      $attr[ $fg = $i++ ] = $self->{foreground} if !defined $fg;
      $attr[ $bg = $i++ ] = $self->{background} if !defined $bg;
    }
    $attr[ $fg ] = 'on_' . $attr[ $fg ]      if defined $fg;
    $attr[ $bg ] = substr( $attr[ $bg ], 3 ) if defined $bg;
  }
  return @attr;
}


sub remove_escape_sequences {
  my ($self, $string) = @_;

  # This is in no way comprehensive or accurate...
  # it just seems like most of the sequences match this.
  # We could certainly expand this if the need arises.
  $string =~ s{
    \e\[
      [0-9;]*
      [a-ln-zA-Z]
  }{}gx;

  return $string;
}


our @EXPORT_OK;
BEGIN {
  my @funcs = qw(identify normalize parse);
  my $suffix = '_ansicolor';
  local $_;
  eval join '', ## no critic (StringyEval)
    map { "sub ${_}$suffix { __PACKAGE__->new->$_(\@_) }" }
    @funcs;
  @EXPORT_OK = map { $_ . $suffix } @funcs;
}

sub import {
  my $class = shift;
  return unless @_;

  my $caller = caller;
  no strict 'refs'; ## no critic (NoStrict)

  foreach my $arg ( @_ ){
    die "'$arg' is not exported by $class"
      unless grep { $arg eq $_ } @EXPORT_OK;
    *{"${caller}::$arg"} = *{"${class}::$arg"}{CODE};
  }
}

# TODO: option for blotting out 'concealed'? s/\S/ /g

1;

# NOTE: this synopsis is tested (eval'ed) in t/synopsis.t

__END__