perl.pl

#!/usr/bin/env perl

#!/usr/bin/env perl
# 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.600-2-gba6391f

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Determine attributes of ANSI-Colored string
$Parse::ANSIColor::Tiny::VERSION = '0.601';
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),
);
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,
);

# 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";
  $ATTRIBUTES{$name}      = "38;5;$code";
  $ATTRIBUTES{"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";
      $ATTRIBUTES{$name}    = "38;5;$code";
      $ATTRIBUTES{"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";
  $ATTRIBUTES{$name}      = "38;5;$code";
  $ATTRIBUTES{"on_$name"} = "48;5;$code";
  push @COLORS256, $name;
}

# 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;


package IRC::FromANSI::Tiny;
# ABSTRACT: Convert ANSI color codes to IRC
our $AUTHORITY = 'cpan:ARODLAND'; # AUTHORITY
our $VERSION = '0.02'; # VERSION

use strict;
use warnings;


my %irccolors = (
  black   => 1,
  red     => 5,
  green   => 3,
  yellow  => 7,
  blue    => 2,
  magenta => 6,
  cyan    => 10,
  white   => 14,
  bright_black   => 15,
  bright_red     => 4,
  bright_green   => 9,
  bright_yellow  => 8,
  bright_blue    => 12,
  bright_magenta => 13,
  bright_cyan    => 11,
  bright_white   => 0,
);

sub convert {
  my ($text) = @_;
  my $ret = "";

  my $ansi = Parse::ANSIColor::Tiny->new;
  my $data = $ansi->parse($text);
  my (%foregrounds, %backgrounds);
  $foregrounds{$_} = 1 for $ansi->foreground_colors;
  $backgrounds{$_} = 1 for $ansi->background_colors;
  my ($foreground, $background, $underline, $bold) = (undef, undef, 0, 0);

  for my $chunk (@$data) {
    my ($attrs, $text) = @$chunk;
    my ($fg) = grep $foregrounds{$_}, @$attrs;
    my ($bg) = grep $backgrounds{$_}, @$attrs;
    my $bb = (grep $_ eq 'bold', @$attrs) ? 1 : 0;
    my $u = (grep $_ eq 'underline', @$attrs) ? 1 : 0;

    my $set_color;
    if ($fg) {
      $foreground = ($b ? 'bright_' : '') . $fg;
      # use Acme::Dump::And::Dumper;
      # warn DnD [ $foreground ];
      if ($foreground =~ /^rgb/) {
        $foreground = 'green'; ### FIX FOR RGB
      }
      $set_color = "\cC$irccolors{$foreground}";
      $bb = 0;
    }
    if ($bg) {
      $background = $bg;
      $set_color = "\cC" . $irccolors{$foreground || "black"} . ",$irccolors{$background}";
    }
    if (!$fg && !$bg && ($foreground || $background)) {
      undef $foreground;
      undef $background;
      if ($text =~ /^\d/) {
        # Use "reset all" to clear color to avoid a following number
        # being interpreted as a color code
        $set_color = "\cO";
        undef $underline;
        undef $bold;
      } else {
        $set_color = "\cC";
      }
    }
    $ret .= $set_color if length $set_color;
    if ($bb ^ $bold) {
      $bold = $bb;
      $ret .= "\cB";
    }
    if ($u ^ $underline) {
      $underline = $u;
      $ret .= "\c_";
    }
    if ($ret =~ /\D\d$/ && $text =~ /^\d/) {
      # Avoid a 1-digit color code (e.g. ^C1 or ^C12,3 running into a following
      # digit that's supposed to be part of the literal text, by making it two-digit.
      substr($ret, -1, 0, '0');
    }
    $ret .= $text;
  }
  return $ret;
}

1;



use feature 'say';
say IRC::FromANSI::Tiny::convert(do { local $/; <STDIN> });