File Coverage

blib/lib/String/Tagged/IRC.pm

Criterion	Covered	Total	%
statement	91	97	93.8
branch	61	80	76.2
condition	22	34	64.7
subroutine	10	10	100.0
pod	2	2	100.0
total	186	223	83.4

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2014 -- [e-mail]

package String::Tagged::IRC;

use strict;
use warnings;
use base qw( String::Tagged );

our $VERSION = '0.01';

use Convert::Color::mIRC;
use Convert::Color::RGB8;

=head1 NAME

C - parse and format IRC messages using C

=head1 TAGS

=head2 b, u, i, rv

Boolean values indicating bold, underline, italics, or reverse-video.

=head2 fg, bg

L objects encoding the color. These will likely be instances
of L, unless a full RGB triplet colour code has been
provided; in which case it will be an instance of L.

=cut

# IRC [well, technically mIRC but other clients have adopted it] uses Ctrl
# characters to toggle formatting
#  ^B = bold
#  ^U = underline
#  ^_ = underline
#  ^R = reverse or italic - we'll use italic
#  ^V = reverse
#  ^] = italics
#  ^O = reset
#  ^C = colour; followed by a code
#     ^C      = reset colours
#     ^Cff    = foreground
#     ^Cff,bb = background
#
# irssi uses the following
#  ^D$$ = foreground/background, in chr('0'+$colour),
#  ^Db  = underline
#  ^Dc  = bold
#  ^Dd  = reverse or italic - we'll use italic
#  ^Dg  = reset colours
#
# As a side effect we'll also strip all the other Ctrl chars

# We'll also look for "poor-man's" highlighting
#   *bold*
#   _underline_
#   /italic/

=head1 METHODS

=cut

=head2 $st = String::Tagged::IRC->parse_irc( $raw, %opts )

Parses a text string containing IRC formatting codes and returns a new
C instance.

Takes the following named options:

=over 8

=item parse_plain_formatting => BOOL

If true, also parse "poor-man's" plain-text formatting of B<*bold*>,
I<*italic*> and _underline_. In this case, formatting tags are added but the
original text formatting is preserved.

=back

=cut

sub _parse_colour_mirc
{
   shift;
   my ( $colcode ) = @_;

   # RRGGBB hex triplet
   $colcode =~ m/^#([0-9a-f]{6})/i and
      return Convert::Color::RGB8->new( $1 );

   # RGB hex triplet
   $colcode =~ m/^#([0-9a-f])([0-9a-f])([0-9a-f])/i and
      return Convert::Color::RGB8->new( "$1$1$2$2$3$3" );

   # mIRC index
   $colcode =~ m/^(\d\d?)/ and $1 < 16 and
      return Convert::Color::mIRC->new( $1 );

   return undef;
}

my @termcolours =
   map { chomp; Convert::Color::RGB8->new( $_ ) } ;
close DATA;

sub _parse_colour_ansiterm
{
   shift;
   my ( $idx ) = @_;

   $idx >= 0 and $idx < @termcolours and
      return $termcolours[$idx];

   return undef;
}

sub parse_irc
{
   my $class = shift;
   my ( $text, %opts ) = @_;

   my $self = $class->new( "" );

   my %format;

   while( length $text ) {
      if( $text =~ s/^([\x00-\x1f])// ) {
         my $ctrl = chr(ord($1)+0x40);

         if( $ctrl eq "B" ) {
            $format{b} ? delete $format{b} : ( $format{b} = 1 );
         }
         elsif( $ctrl eq "U" or $ctrl eq "_" ) {
            $format{u} ? delete $format{u} : ( $format{u} = 1 );
         }
         elsif( $ctrl eq "R" or $ctrl eq "]" ) {
            $format{i} ? delete $format{i} : ( $format{i} = 1 );
         }
         elsif( $ctrl eq "V" ) {
            $format{rv} ? delete $format{rv} : ( $format{rv} = 1 );
         }
         elsif( $ctrl eq "O" ) {
            undef %format;
         }
         elsif( $ctrl eq "C" ) {
            my $colourre = qr/#[0-9a-f]{6}|#[0-9a-f]{3}|\d\d?/i;

            if( $text =~ s/^($colourre),($colourre)// ) {
               $format{fg} = $self->_parse_colour_mirc( $1 );
               $format{bg} = $self->_parse_colour_mirc( $2 );
            }
            elsif( $text =~ s/^($colourre)// ) {
               $format{fg} = $self->_parse_colour_mirc( $1 );
            }
            else {
               delete $format{fg};
               delete $format{bg};
            }
         }
         elsif( $ctrl eq "D" ) {
            if( $text =~ s/^b// ) { # underline
               $format{u} ? delete $format{u} : ( $format{u} = 1 );
            }
            elsif( $text =~ s/^c// ) { # bold
               $format{b} ? delete $format{b} : ( $format{b} = 1 );
            }
            elsif( $text =~ s/^d// ) { # revserse/italic
               $format{i} ? delete $format{i} : ( $format{i} = 1 );
            }
            elsif( $text =~ s/^g// ) {
               undef %format
            }
            else {
               $text =~ s/^(.)(.)//;
               my ( $fg, $bg ) = map { ord( $_ ) - ord('0') } ( $1, $2 );
               if( $fg > 0 ) {
                  $format{fg} = $self->_parse_colour_ansiterm( $fg );
               }
               if( $bg > 0 ) {
                  $format{bg} = $self->_parse_colour_ansiterm( $bg );
               }
            }
         }
      }
      else {
         $text =~ s/^([^\x00-\x1f]+)//;
         my $piece = $1;

         # Now scan this piece for the text-based ones
         while( length $piece and $opts{parse_plain_formatting} ) {
            # Look behind/ahead asserts to ensure we don't capture e.g.
            # /usr/bin/perl by mistake
            $piece =~ s/^(.*?)(?
               last;

            my ( $pre, $inner, $type ) = ( $1, $2, $3 );

            $self->append_tagged( $pre, %format ) if length $pre;

            my %innerformat = %format;

            $type =~ tr{*_/}{bui};
            $innerformat{$type} = 1;

            $self->append_tagged( $inner, %innerformat );
         }

         $self->append_tagged( $piece, %format ) if length $piece;
      }
   }

   return $self;
}

=head2 $raw = $st->build_irc

Returns a plain text string containing IRC formatting codes built from the
given instance. When outputting a colour index, this method always outputs it
as a two-digit number, to avoid parsing ambiguity if the coloured text starts
with a digit.

Currently this will only output F-style formatting, not F-style.

Takes the following options:

=over 8

=item default_fg => INT

Default foreground colour to emit for extents that have only the C tag
set. This is required because F formatting codes cannot set just the
background colour without setting the foreground as well.

=back

=cut

sub build_irc
{
   my $self = shift;
   my %opts = @_;

   my $default_fg = $opts{default_fg} // 0;

   my $ret = "";
   my %formats;

   $self->iter_extents_nooverlap( sub {
      my ( $extent, %tags ) = @_;

      $ret .= "\cB" if !$formats{b}  != !$tags{b};   $formats{b}  = $tags{b};
      $ret .= "\c_" if !$formats{u}  != !$tags{u};   $formats{u}  = $tags{u};
      $ret .= "\c]" if !$formats{i}  != !$tags{i};   $formats{i}  = $tags{i};
      $ret .= "\cV" if !$formats{rv} != !$tags{rv};  $formats{rv} = $tags{rv};

      my $fg = $tags{fg} ? $tags{fg}->as_mirc->index : undef;
      my $bg = $tags{bg} ? $tags{bg}->as_mirc->index : undef;

      if( ( $fg//'' ) ne ( $formats{fg}//'' ) or ( $bg//'' ) ne ( $formats{bg}//'' ) ) {
         if( defined $bg ) {
            # Can't set just bg alone, so if fg isn't defined, use the default
            $fg //= $default_fg;

            $ret .= sprintf "\cC%02d,%02d", $fg, $bg;
         }
         elsif( defined $fg ) {
            $ret .= sprintf "\cC%02d", $fg;
         }
         else {
            $ret .= "\cC";
         }
      }

      $formats{fg} = $fg;
      $formats{bg} = $bg;

      # TODO: colours

      $ret .= $extent->plain_substr;
   });

   # Be polite and reset colours at least
   $ret .= "\cC" if defined $formats{fg} or defined $formats{bg};

   return $ret;
}

=head1 TODO

=over 4

=item *

Define a nicer way to do the ANSI terminal colour space of F-style
formatting codes.

=back

=head1 AUTHOR

Paul Evans

=cut

0x55AA;

# Palette used for irssi->RGB8 conversion

__DATA__