File Coverage

blib/lib/HTML/FromANSI/Tiny.pm

Criterion	Covered	Total	%
statement	73	73	100.0
branch	24	28	85.7
condition	7	9	77.7
subroutine	14	14	100.0
pod	8	8	100.0
total	126	132	95.4

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of HTML-FromANSI-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 HTML::FromANSI::Tiny;
# git description: v0.106-2-g1454a0d

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Easily convert colored command line output to HTML
$HTML::FromANSI::Tiny::VERSION = '0.107';
our @COLORS = map { "#$_" }
qw(
  000  f33  2c2  bb0  55c  d3d  0cc  bbb
  555  f66  6d6  dd6  99f  f6f  6dd  fff
);

# 256 palette.
our @COLORS256 = (
  # First 16 are the same.
  @COLORS,
  # rgbXYZ
  do {
    my @c;
    for my $r ( 0 .. 5 ){
      for my $g ( 0 .. 5 ){
        for my $b ( 0 .. 5 ){
          push @c, '#' . join('', map { sprintf '%02x', $_ * (255/5) } ($r, $g, $b));
        }
      }
    }
    @c; # return
  },
  # "nearly black to nearly white"
  (map { '#' . join('', (sprintf '%02x', ($_ + 1) * 10) x 3) } (0 .. 23)),
);

our @ALLCOLORS = (@COLORS, @COLORS256);


sub new {
  my $class = shift;
  my $self = {
    class_prefix => '',
    selector_prefix => '',
    tag => 'span',
    # It seems particularly unlikely that somebody would want these in their HTML.
    remove_escapes => 1,
    @_ == 1 ? %{ $_[0] } : @_,
  };

  require Parse::ANSIColor::Tiny
    if !$self->{ansi_parser};
  require HTML::Entities
    if !$self->{html_encode};

  bless $self, $class;
}


sub ansi_parser {
  my ($self) = @_;
  return $self->{ansi_parser} ||= do {
    # hash slice
    my (@fields, %copy) = qw(
      auto_reverse
      foreground background
      remove_escapes
    );
    @copy{ @fields } = @$self{ @fields };
    Parse::ANSIColor::Tiny->new(%copy);
  };
}


sub attr_to_class {
  $_[1];
}


sub css {
  my ($self) = @_;
  my $prefix = $self->{selector_prefix} . '.' . $self->{class_prefix};

  my $styles = $self->_css_class_attr;

  my @css = (
    map {
      sprintf "%s%s { %s }",
        ${prefix},
        $self->attr_to_class($_),
        $self->_css_attr_string($styles->{$_})
    }
      sort keys %$styles
  );

  return wantarray ? @css : join('', @css);
}

sub _css_class_attr {
  my ($self) = @_;
  return $self->{_all_styles} ||= do {

    my $parser = $self->ansi_parser;
    my $styles = {
      bold      => { 'font-weight'      => 'bold'      },
      dark      => { 'opacity'          => '0.7'       },
      underline => { 'text-decoration'  => 'underline' },
      concealed => { 'visibility'       => 'hidden'    },
    };
    {
      my $i = 0;
      foreach my $fg ( $parser->foreground_colors ){
        $styles->{$fg} = { color => $ALLCOLORS[$i++] };
      }
      $i = 0;
      foreach my $bg ( $parser->background_colors ){
        $styles->{$bg} = { 'background-color' => $ALLCOLORS[$i++] };
      }
    }

    # return
    +{
      %$styles,
      %{ $self->{styles} || {} },
    };
  };
}

sub _css_attr_string {
  my ($self, $attr) = @_;
  return join ' ', map { "$_: $attr->{$_};" } keys %$attr;
}


sub html {
  my ($self, $text) = @_;
  $text = $self->ansi_parser->parse($text)
    unless ref($text) eq 'ARRAY';

  my $tag    = $self->{tag};
  my $prefix = $self->{class_prefix};
  # Preload if needed; Don't load if not.
  my $styles = $self->{inline_style} ? $self->_css_class_attr : {};

  local $_;
  my @html = map {
    my ($attr, $text) = @$_;
    my $h = $self->html_encode($text);

    $self->{no_plain_tags} && !@$attr
      ? $h
      : do {
        sprintf q[<%s %s="%s">%s], $tag,
          ($self->{inline_style}
            ? (style => join ' ', map { $self->_css_attr_string($styles->{$_}) } @$attr)
            : (class => join ' ', map { $prefix . $self->attr_to_class($_) } @$attr)
          ), $h, $tag;
      }

  } @$text;

  return wantarray ? @html : join('', @html);
}


sub html_encode {
  my ($self, $text) = @_;
  return $self->{html_encode}->($text)
    if $self->{html_encode};
  return HTML::Entities::encode_entities($text);
}


sub style_tag {
  my ($self) = @_;
  my @style = ('', $self->css, '');
  return wantarray ? @style : join('', @style);
}


our @EXPORT_OK = qw( html_from_ansi );
sub html_from_ansi { __PACKAGE__->new->html(@_) }

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

1;

__END__