File Coverage

blib/lib/String/Tagged/Terminal.pm

Criterion	Covered	Total	%
statement	72	81	88.8
branch	35	48	72.9
condition	24	40	60.0
subroutine	14	16	87.5
pod	5	5	100.0
total	150	190	78.9

#  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-2023 -- [e-mail]

package String::Tagged::Terminal 0.06;

use v5.14;
use warnings;

use base qw( String::Tagged );

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

(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.

=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
         monospace
         fg bg
      )],
      convert_tags => {
         monospace => sub { $_[1] ? ( altfont => 1 ) : () },

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

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

      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;

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

=head1 TODO

=over 4

=item *

Consider a C<< ->parse_terminal >> constructor method, which would attempt to
parse SGR sequences from a given source string.

=back

=cut

=head1 AUTHOR

Paul Evans

=cut

0x55AA;