File Coverage

blib/lib/String/Tagged/Terminal/Win32Console.pm
Criterion Covered Total %
statement 48 58 82.7
branch 13 30 43.3
condition 3 18 16.6
subroutine 8 8 100.0
pod 0 1 0.0
total 72 115 62.6


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2017-2018 -- leonerd@leonerd.org.uk
5              
6             package String::Tagged::Terminal::Win32Console 0.05;
7              
8 1     1   14 use v5.14;
  1         3  
9 1     1   5 use warnings;
  1         2  
  1         32  
10              
11 1     1   5 use Win32::Console;
  1         2  
  1         49  
12 1     1   6 use List::Util qw( max );
  1         2  
  1         137  
13              
14             =head1 NAME
15              
16             C - Windows-specific code for L
17              
18             =head1 SYNOPSIS
19              
20             # No user serviceable parts inside
21             use String::Tagged::Terminal;
22              
23             =head1 DESCRIPTION
24              
25             This module provides support for L to print to the
26             console on C. It is not intended to be used directly.
27              
28             =cut
29              
30             use constant {
31 1         599 ATTR_BLUE => 0x0001,
32             ATTR_GREEN => 0x0002,
33             ATTR_RED => 0x0004,
34             ATTR_INTENSITY => 0x0008,
35             ATTR_REVERSE_VIDEO => 0x4000, # Windows 10 onwards
36             ATTR_UNDERSCORE => 0x8000, # Windows 10 onwards
37 1     1   7 };
  1         2  
38              
39             # We can only ever allocate a single console on Windows
40             our $WIN32_CONSOLE;
41              
42             my %color_to_attr; # a cache
43              
44             sub print_to_console
45             {
46 3     3 0 7 my $self = shift;
47 3         9 my ( $fh, %opts ) = @_;
48              
49             # Convert filenos to native Win32 file handles, this should also try
50             # Win32API::File::FdGetOsFHandle( $fh );
51             my $fileno = {
52             1 => Win32::Console::STD_OUTPUT_HANDLE(),
53             2 => Win32::Console::STD_ERROR_HANDLE(),
54 3   33     27 }->{ $fh->fileno } || $fh->fileno;
55              
56             my %output_options = (
57 3 50       52 ( $opts{no_color} ? ( except => [qw( fgindex bgindex )] ) : () ),
58             only => [qw( fgindex bgindex bold under reverse )], # only process what we can handle
59             );
60              
61 3 50       8 if( $fileno < 0 ) {
62             # This looks like a Perl-internal FH, let's not output any formatting
63 0         0 $fh->print( $self->build_terminal( %opts ) );
64             }
65             else {
66 3   33     12 my $console = $opts{console} || do { $WIN32_CONSOLE ||= Win32::Console->new( $fileno ); };
67 3         19 my $saved = $console->Attr();
68 3         16 my $attr = $saved;
69              
70             $self->iter_substr_nooverlap( sub {
71 9     9   493 my ( $s, %tags ) = @_;
72              
73             # Simple boolean attributes first
74 9         33 foreach (
75             # bold is handled at the end
76             [ under => ATTR_UNDERSCORE ], # Rendering is flakey under Windows 10
77             # Windows console doesn't support italic, strike, blink
78             [ reverse => ATTR_REVERSE_VIDEO ],
79             ) {
80 18         29 my ( $tag, $on ) = @$_;
81 18         25 $attr &= ~$on;
82              
83 18 100       37 $attr |= $on if $tags{$tag};
84             }
85              
86             # Colour index attributes
87 9         23 foreach (
88             [ fgindex => 0, ],
89             [ bgindex => 4, ],
90             ) {
91 18         23 my ( $tag, $shift ) = @$_;
92 18         28 my $mask = 0x000F << $shift;
93 18         21 $attr &= ~$mask;
94              
95 18 100       28 if( defined $tags{$tag} ) {
96 1         2 my $idx = $tags{$tag};
97 1   33     6 $attr |= ( $color_to_attr{$idx} //= _color_to_attr( $idx ) ) << $shift;
98             }
99             else {
100             # Restore to previous
101 17         30 $attr |= $saved & $mask;
102             }
103             }
104              
105 9 100       20 $attr |= ATTR_INTENSITY if $tags{bold};
106              
107 9         24 $console->Attr($attr);
108 9         55 $console->Write($s);
109 3         29 }, %output_options );
110              
111 3         50 $console->Attr( $saved );
112             }
113             }
114              
115             sub _color_to_attr
116             {
117 1     1   3 my ( $idx ) = @_;
118              
119 1         2 my $attr = 0;
120              
121 1 50       4 if( $idx >= 16 ) {
122             # Attempt to convert xterm256 range into RGB+I
123 0         0 require Convert::Color;
124 0         0 my $color = Convert::Color->new( "xterm:$idx" )->as_rgb;
125              
126 0         0 my ( $red, $green, $blue ) = $color->rgb;
127 0         0 my $max = max( $red, $green, $blue );
128              
129 0 0       0 $attr |= ATTR_RED if $red > 0.5;
130 0 0       0 $attr |= ATTR_GREEN if $green > 0.5;
131 0 0       0 $attr |= ATTR_BLUE if $blue > 0.5;
132 0 0       0 $attr |= ATTR_INTENSITY if $max > 0.75;
133 0 0 0     0 $attr = ATTR_INTENSITY if $attr == 0 and
      0        
      0        
134             $red == $green and $red == $blue and $max > 0.25; # dark grey
135             }
136             else {
137             # The bits are swapped between ANSI and Win32 console
138 1 50       13 $attr |= ATTR_RED if $idx & 1;
139 1 50       5 $attr |= ATTR_GREEN if $idx & 2;
140 1 50       3 $attr |= ATTR_BLUE if $idx & 4;
141 1 50       3 $attr |= ATTR_INTENSITY if $idx & 8;
142             }
143 1         5 return $attr;
144             }
145              
146             =head1 COMPATIBILITY NOTES
147              
148             On Windows before Windows 10, only C, C and C are supported.
149              
150             Starting with Windows 10, also C and C are supported.
151              
152             On Windows, only a single output console is supported.
153              
154             =head1 AUTHOR
155              
156             Paul Evans ,
157             Max Maischein
158              
159             =cut
160              
161             0x55AA;