File Coverage

blib/lib/String/Tagged/Terminal.pm

Criterion	Covered	Total	%
statement	127	139	91.3
branch	99	120	82.5
condition	61	88	69.3
subroutine	16	18	88.8
pod	6	6	100.0
total	309	371	83.2

#  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, 2017-2024 -- [e-mail]

package String::Tagged::Terminal 0.08;

use v5.14;
use warnings;

use base qw( String::Tagged );

use Carp;

use constant HAVE_MSWIN32 => $^O eq "MSWin32";
HAVE_MSWIN32 and require String::Tagged::Terminal::Win32Console;

require IO::Handle;

=head1 NAME

C - format terminal output using C

=head1 SYNOPSIS

   use String::Tagged::Terminal;

   my $st = String::Tagged::Terminal->new
      ->append( "Hello my name is " )
      ->append_tagged( $name, bold => 1, fgindex => 4 );

   $st->say_to_terminal;

=head1 DESCRIPTION

This subclass of L provides a method, C,
for outputting the formatting tags embedded in the string as terminal escape
sequences, to render the the output in the appropriate style.

=head1 TAGS

The following tag names are recognised:

=head2 bold, under, italic, strike, blink, reverse

These tags take a boolean value. If the value is true then the corresponding
terminal rendering attribute is enabled.

=head2 altfont

This tag takes an integer value. If defined it uses the "alternate font
selection" sequence.

=head2 fgindex, bgindex

These tags take an integer value in the range 0 to 255. These select the
foreground or background colour by using VGA, high-brightness extended 16
colour, or xterm 256 palette mode attributes, depending on the value.

The ECMA-48-corrected string encoding form of C is used to set
the 256 palette values.

Values will be rounded down to the nearest integer by calling C. This
convenience allows things like the C function for generating random
colours:

   $st->append_tagged( "text", fgindex => 1 + rand 6 );

=head2 sizepos

I

(experimental)

This tag takes a value indicating an adjustment to the vertical positioning,
and possibly also size, in order to create subscript or superscript effects.

Recognised values are C for subscript, and C for superscript.
These are implemented using the F-style C codes.

=head2 link

I

(experimental)

This tag takes a HASH reference, whose C key is emitted using the
C hyperlink sequence.

=cut

=head1 CONSTRUCTORS

=cut

=head2 new_from_formatting

   $st = String::Tagged::Terminal->new_from_formatting( $fmt )

Returns a new instance by converting L standard
tags.

Foreground and background colours are converted to their nearest index in the
xterm 256 colour palette. The C Formatting attribute is rendered by
selecting the first alternate font using C.

=cut

sub new_from_formatting
{
   my $class = shift;
   my ( $orig ) = @_;

   require Convert::Color::XTerm;

   return $class->clone( $orig,
      only_tags => [qw(
         bold under italic strike blink reverse sizepos link
         monospace
         fg bg
      )],
      convert_tags => {
         monospace => sub { $_[1] ? ( altfont => 1 ) : () },

         fg => sub { fgindex => $_[1]->as_xterm->index },
         bg => sub { bgindex => $_[1]->as_xterm->index },
      },
   );
}

=head2 parse_terminal

   $st = String::Tagged::Terminal->parse_terminal( $str );

I

Returns a new instance by parsing a string containing SGR terminal escape
sequences mixed with plain string content.

The parser will only accept 7- or 8-bit encodings of the SGR escape sequence
(C<\e[ ... m> or C<\x9b ... m>). If any other escape sequences are present,
an exception is thrown.

Conversely, unrecognised formatting codes in SGR sequences are simply ignored
without warning.

=cut

my $CSI_args = qr/[0-9;:]*/;

sub parse_terminal
{
   my $class = shift;
   my ( $s ) = @_;

   my $self = $class->new;

   pos($s) = 0;

   my %tags;

   while( pos($s) < length($s) ) {
      if( $s =~ m/\G([^\e]+)/gc ) {
         $self->append_tagged( $1, %tags );
      }
      elsif( $s =~ m/\G\e\[($CSI_args)m/gc || $s =~ m/\G\x9b($CSI_args)m/gc ) {
         my $args = $1;
         length $args or $args = "0";
         foreach my $arg ( split m/;/, $args ) {
            my ( $a0, @arest ) = map { int $_ } split m/:/, $arg;

            # Reset
            if( $a0 == 0 ) { %tags = () }

            # Simple boolean attributes
            elsif( $a0 ==  1 ) { $tags{bold} = 1; }
            elsif( $a0 == 22 ) { delete $tags{bold}; }
            elsif( $a0 ==  4 ) { $tags{under} = 1; }
            elsif( $a0 == 24 ) { delete $tags{under}; }
            elsif( $a0 ==  3 ) { $tags{italic} = 1; }
            elsif( $a0 == 23 ) { delete $tags{italic}; }
            elsif( $a0 ==  9 ) { $tags{strike} = 1; }
            elsif( $a0 == 29 ) { delete $tags{strike}; }
            elsif( $a0 ==  5 ) { $tags{blink} = 1; }
            elsif( $a0 == 25 ) { delete $tags{blink}; }
            elsif( $a0 ==  7 ) { $tags{reverse} = 1; }
            elsif( $a0 == 27 ) { delete $tags{reverse}; }

            # Numerical attributes
            elsif( $a0 >= 10 && $a0 <= 19 ) {
               $a0 > 10 ? $tags{altfont} = $a0 - 10 : delete $tags{altfont};
            }

            # Colours
            elsif( $a0 >= 30 && $a0 <= 39 or $a0 >= 90 && $a0 <= 97 or
                   $a0 >= 40 && $a0 <= 49 or $a0 >= 100 && $a0 <= 107 ) {
               my $hi = $a0 >= 90 ? 8 : 0; $a0 -= 60 if $hi;
               my $attr = $a0 < 40 ? "fgindex" : "bgindex";
               $a0 %= 10;

               if   ( $a0 == 9 ) { delete $tags{$attr} }
               elsif( $a0 == 8 ) {
                  if( @arest >= 2 and $arest[0] == 5 ) {
                     $tags{$attr} = $arest[1];
                  }
                  # Else unrecognised
               }
               else              { $tags{$attr} = $a0 + $hi }
            }

            # Sub/superscript
            elsif( $a0 == 73 ) { $tags{sizepos} = "super"; }
            elsif( $a0 == 74 ) { $tags{sizepos} = "sub"; }
            elsif( $a0 == 75 ) { delete $tags{sizepos}; }

            # Else unrecognised
         }
      }
      elsif( $s =~ m/\G\e]8;/gc || $s =~ m/\G\x{9d}8;/gc ) {
         # OSC 8 hyperlink
         $s =~ m/\G.*?;/gc; # skip args

         $s =~ m/\G(.*?)\e\\/gc or $s =~ m/\G(.*?)\x07/gc or $s =~ m/\G(.*?)\x9c/gc or
            croak "Found an OSC 8 introduction that does not end with ST";

         length $1 ? $tags{link} = { uri => $1 }
                   : delete $tags{link};
      }
      else {
         croak "Found an escape sequence that is not SGR";
      }
   }

   return $self;
}

=head1 METHODS

The following methods are provided in addition to those provided by
L.

=cut

=head2 build_terminal

   $str = $st->build_terminal( %opts );

Returns a string containing terminal escape sequences mixed with string
content to render the string to a terminal.

As this string will contain literal terminal control escape sequences, care
should be taken when passing it around, printing it for debugging purposes, or
similar.

Takes the following additional named options:

=over 4

=item no_color

If true, the C and C attributes will be ignored. This has
the result of performing some formatting using the other attributes, but not
setting colours.

=back

=cut

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

   my $ret = "";
   my %pen;
   my $osc8_uri;
   $self->iter_substr_nooverlap( sub {
      my ( $s, %tags ) = @_;

      my @sgr;

      # Simple boolean attributes first
      foreach (
         [ bold      =>  1, 22 ],
         [ under     =>  4, 24 ],
         [ italic    =>  3, 23 ],
         [ strike    =>  9, 29 ],
         [ blink     =>  5, 25 ],
         [ reverse   =>  7, 27 ],
      ) {
         my ( $tag, $on, $off ) = @$_;

         push( @sgr, $on  ), $pen{$tag} = 1    if  $tags{$tag} and !$pen{$tag};
         push( @sgr, $off ), delete $pen{$tag} if !$tags{$tag} and  $pen{$tag};
      }

      # Numerical attributes
      foreach (
         [ altfont => 10, 9 ],
      ) {
         my ( $tag, $base, $max ) = @$_;

         if( defined $pen{$tag} and !defined $tags{$tag} ) {
            push @sgr, $base;
            delete $pen{$tag};
         }
         elsif( defined $pen{$tag} and defined $tags{$tag} and $pen{$tag} == $tags{$tag} ) {
            # Leave it
         }
         elsif( defined $tags{$tag} ) {
            my $val = $tags{$tag};
            $val = $max if $val > $max;
            push @sgr, $base + $val;
            $pen{$tag} = $val;
         }
      }

      # Colour index attributes
      foreach (
         [ fgindex => 30 ],
         [ bgindex => 40 ],
      ) {
         my ( $tag, $base ) = @$_;
         my $val = $tags{$tag};
         $val = int $val if defined $val;

         if( defined $pen{$tag} and !defined $val ) {
            # Turn it off
            push @sgr, $base + 9;
            delete $pen{$tag};
         }
         elsif( defined $pen{$tag} and defined $val and $pen{$tag} == $val ) {
            # Leave it
         }
         elsif( defined $val ) {
            if( $val < 8 ) {
               # VGA 8
               push @sgr, $base + $val;
            }
            elsif( $val < 16 ) {
               # Hi 16
               push @sgr, $base + 60 + ( $val - 8 );
            }
            else {
               # Xterm256 palette 5 = 256 colours
               push @sgr, sprintf "%d:%d:%d", $base + 8, 5, $val;
            }
            $pen{$tag} = $val;
         }
      }

      {
         if( defined $pen{sizepos} and !defined $tags{sizepos} ) {
            push @sgr, 75; # reset
            delete $pen{sizepos};
         }
         elsif( defined $pen{sizepos} and defined $tags{sizepos} and $pen{sizepos} eq $tags{sizepos} ) {
            # Leave it
         }
         elsif( defined( my $val = $tags{sizepos} ) ) {
            if( $val eq "sub" ) {
               push @sgr, 74;
            }
            elsif( $val eq "super" ) {
               push @sgr, 73;
            }
            $pen{sizepos} = $val;
         }
      }

      {
         my $link = $tags{link};
         my $uri  = $link ? $link->{uri} : undef;

         if( defined $osc8_uri and !defined $uri ) {
            $ret .= "\e]8;;\e\\";
            undef $osc8_uri;
         }
         elsif( defined $osc8_uri and defined $uri and $osc8_uri eq $uri ) {
            # leave it
         }
         elsif( defined $uri ) {
            $ret .= "\e]8;;" . ( $uri =~ s/[^[:print:]]//gr ) . "\e\\";
            $osc8_uri = $uri;
         }
      }

      if( @sgr and %pen ) {
         $ret .= "\e[" . join( ";", @sgr ) . "m";
      }
      elsif( @sgr ) {
         $ret .= "\e[m";
      }

      $ret .= $s;
   },
      ( $opts{no_color} ? ( except => [qw( fgindex bgindex )] ) : () ) );

   $ret .= "\e[m" if %pen;
   $ret .= "\e]8;;\e\\" if defined $osc8_uri;

   return $ret;
}

=head2 as_formatting

   $fmt = $st->as_formatting;

Returns a new C instance tagged with
L standard tags.

=cut

sub as_formatting
{
   my $self = shift;

   require Convert::Color::XTerm;

   return String::Tagged->clone( $self,
      only_tags => [qw(
         bold under italic strike blink reverse sizepos link
         altfont
         fgindex bgindex
      )],
      convert_tags => {
         altfont => sub { $_[1] == 1 ? ( monospace => 1 ) : () },

         fgindex => sub { fg => Convert::Color::XTerm->new( $_[1] ) },
         bgindex => sub { bg => Convert::Color::XTerm->new( $_[1] ) },
      },
   );
}

=head2 print_to_terminal

   $str->print_to_terminal( $fh );

I

Prints the string to the terminal by building a terminal escape string then
printing it to the given IO handle (or C if not supplied).

This method will pass the value of the C environment variable to the
underlying L method call, meaning if that has a true value
then colouring tags will be ignored, yielding a monochrome output. This
follows the suggestion of L.

=cut

sub print_to_terminal
{
   my $self = shift;
   my ( $fh, %options ) = @_;

   $fh //= \*STDOUT;

   $options{win32}++ if HAVE_MSWIN32 and not exists $options{win32};

   if( $options{win32} ) {
      $self->String::Tagged::Terminal::Win32Console::print_to_console( $fh, %options );
   }
   else {
      $fh->print( $self->build_terminal( no_color => $ENV{NO_COLOR} ) );
   }
}

=head2 say_to_terminal

   $str->say_to_terminal( $fh );

I

Prints the string to the terminal as per L, followed by a
linefeed.

=cut

sub say_to_terminal
{
   my $self = shift;
   my ( $fh, %options ) = @_;

   $fh //= \*STDOUT;

   $self->print_to_terminal( $fh, %options );
   $fh->say;
}

=head1 COMPATIBILITY NOTES

On Windows, the following notes apply:

=over 4

=item *

On all versions of Windows, the attributes C, C and C
are supported. The C attribute is implemented by using high-intensity
colours, so will be indistinguishable from using high-intensity colour indexes
without bold. The full 256-color palette is not supported by Windows, so it is
down-converted to the 16 colours that are.

=item *

Starting with Windows 10, also C and C are supported.

=item *

The attributes C, C, C, C are not supported on
any Windows version.

=item *

On Windows, only a single output console is supported.

=back

=cut

=head1 AUTHOR

Paul Evans

=cut

0x55AA;