1#!/usr/bin/perl -w
2# $XTermId: print-vt-chars.pl,v 1.23 2020/12/13 15:05:06 tom Exp $
3# -----------------------------------------------------------------------------
4# this file is part of xterm
5#
6# Copyright 2018,2020 by Thomas E. Dickey
7#
8#                         All Rights Reserved
9#
10# Permission is hereby granted, free of charge, to any person obtaining a
11# copy of this software and associated documentation files (the
12# "Software"), to deal in the Software without restriction, including
13# without limitation the rights to use, copy, modify, merge, publish,
14# distribute, sublicense, and/or sell copies of the Software, and to
15# permit persons to whom the Software is furnished to do so, subject to
16# the following conditions:
17#
18# The above copyright notice and this permission notice shall be included
19# in all copies or substantial portions of the Software.
20#
21# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
22# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24# IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
25# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28#
29# Except as contained in this notice, the name(s) of the above copyright
30# holders shall not be used in advertising or otherwise to promote the
31# sale, use or other dealings in this Software without prior written
32# authorization.
33# -----------------------------------------------------------------------------
34# Print GL and GR, with the same charset (if possible) for testing.
35
36use strict;
37use warnings;
38
39$| = 2;
40
41use Getopt::Std;
42
43our ( $opt_L, $opt_l, $opt_R, $opt_r, $opt_v );
44
45our %charsets;
46our %caseless;
47our $vt_level;
48
49binmode STDOUT;
50
51sub NRC($) {
52    printf "\033[?42%s", $_[0] ? "h" : "l";
53}
54
55sub LS0($) {
56    printf "\017";
57}
58
59sub LS1() {
60    printf "\016";
61}
62
63sub LS1R() {
64    printf "\033~";
65}
66
67sub LS2() {
68    printf "\033n";
69}
70
71sub LS2R() {
72    printf "\033}";
73}
74
75sub LS3() {
76    printf "\033o";
77}
78
79sub LS3R($) {
80    printf "\033|";
81}
82
83sub G0($) {
84    my %charset = %{ $_[0] };
85    printf "\033(%s", $charset{TAG} if ( $charset{HOW} == 0 );
86}
87
88sub G1($) {
89    my %charset = %{ $_[0] };
90    printf "\033)%s", $charset{TAG} if ( $charset{HOW} == 0 );
91    printf "\033-%s", $charset{TAG} if ( $charset{HOW} == 1 );
92}
93
94sub G2($) {
95    my %charset = %{ $_[0] };
96    printf "\033*%s", $charset{TAG} if ( $charset{HOW} == 0 );
97    printf "\033.%s", $charset{TAG} if ( $charset{HOW} == 1 );
98}
99
100sub G3($) {
101    my %charset = %{ $_[0] };
102    printf "\033+%s", $charset{TAG} if ( $charset{HOW} == 0 );
103    printf "\033/%s", $charset{TAG} if ( $charset{HOW} == 1 );
104}
105
106sub init_charset($$$$$$) {
107    my %charset;
108    my $mixed = shift;
109    $charset{WHO}     = $mixed;
110    $charset{HOW}     = shift;
111    $charset{TAG}     = shift;
112    $charset{MIN}     = shift;
113    $charset{MAX}     = shift;
114    $charset{NRC}     = shift;
115    $charsets{$mixed} = \%charset;
116    my $lower = lc $charset{WHO};
117    $caseless{$lower} = $charset{WHO};
118}
119
120sub find_charset($) {
121    my $mixed = shift;
122    my $lower = lc $mixed;
123    my %result;
124    if ( $caseless{$lower} ) {
125        $mixed  = $caseless{$lower};
126        %result = %{ $charsets{$mixed} };
127        undef %result
128          if ( $result{MAX} < $vt_level or $result{MIN} > $vt_level );
129    }
130    printf STDERR "? no match for $mixed with VT-level $vt_level\n"
131      unless %result;
132    return \%result;
133}
134
135sub failed($) {
136    my $msg = shift;
137    printf STDERR "? %s\n", $msg;
138    exit 1;
139}
140
141sub valid_code($) {
142    my $code   = shift;
143    my $result = 0;
144    $result = 1 if ( $code =~ /^[0-3]$/ );
145    return $result;
146}
147
148sub valid_name($) {
149    my $mixed  = shift;
150    my $lower  = lc $mixed;
151    my $result = 0;
152    $result = 1 if ( defined( $caseless{$lower} ) );
153    return $result;
154}
155
156sub setup_charsets($$$$) {
157    my $gl_code = shift;
158    my $gl_name = shift;
159    my $gr_code = shift;
160    my $gr_name = shift;
161    my %gl_data = %{ &find_charset($gl_name) };
162    my %gr_data = %{ &find_charset($gr_name) };
163
164    return 0 unless %gl_data;
165    return 0 unless %gr_data;
166
167    &NRC(1) if ( $gl_data{NRC} or $gr_data{NRC} );
168
169    if ( $gl_code == 0 ) {
170        &G0( \%gl_data );
171        &LS0;
172    }
173    elsif ( $gl_code == 1 ) {
174        &G1( \%gl_data );
175        &LS1;
176    }
177    elsif ( $gl_code == 2 ) {
178        &G2( \%gl_data );
179        &LS2;
180    }
181    elsif ( $gl_code == 3 ) {
182        &G3( \%gl_data );
183        &LS3;
184    }
185
186    if ( $gr_code == 0 ) {
187        &G0( \%gr_data );
188    }
189    elsif ( $gr_code == 1 ) {
190        &G1( \%gr_data );
191        &LS1R;
192    }
193    elsif ( $gr_code == 2 ) {
194        &G2( \%gr_data );
195        &LS2R;
196    }
197    elsif ( $gr_code == 3 ) {
198        &G3( \%gr_data );
199        &LS3R;
200    }
201    return 1;
202}
203
204sub cleanup() {
205    &setup_charsets( 0, "ASCII", 1, "ASCII" );
206    &NRC(0);
207}
208
209sub doit($$$$) {
210    my $gl_code = shift;
211    my $gl_name = shift;
212    my $gr_code = shift;
213    my $gr_name = shift;
214
215    &failed("Illegal left-code $gl_code")     unless &valid_code($gl_code);
216    &failed("Illegal right-code $gr_code")    unless &valid_code($gr_code);
217    &failed("Unknown left-charset $gl_name")  unless &valid_name($gl_name);
218    &failed("Unknown right charset $gr_name") unless &valid_name($gr_name);
219
220    printf "GL (G%d %s):\n", $gl_code, $gl_name;
221    if ( &setup_charsets( $gl_code, $gl_name, $gr_code, $gr_name ) ) {
222
223        for my $c ( 32 .. 127 ) {
224            printf "%c", $c;
225            printf "\n" if ( ( ( $c - 31 ) % 16 ) == 0 );
226        }
227        printf "\n";
228
229        &cleanup;
230    }
231
232    printf "GR (G%d %s):\n", $gr_code, $gr_name;
233    if ( &setup_charsets( $gl_code, $gl_name, $gr_code, $gr_name ) ) {
234
235        for my $c ( 32 .. 127 ) {
236            printf "%c", $c + 128;
237            printf "\n" if ( ( ( $c - 31 ) % 16 ) == 0 );
238        }
239        printf "\n";
240
241        &cleanup;
242    }
243}
244
245sub main::HELP_MESSAGE() {
246    printf STDERR <<EOF
247Usage: $0 [options]
248
249Options:
250
251 -L code    index 0-3 for GL
252 -l name    charset to map to GL
253 -R code    index 0-3 for GR
254 -r name    charset to map to GR
255 -v level   set/override VT-level
256
257Charsets are determined by the VT-level (currently VT${vt_level}xx):
258EOF
259      ;
260    my @known;
261    my $known = -1;
262    my $width = 0;
263    foreach my $key ( sort( keys %charsets ) ) {
264        my %charset = %{ $charsets{$key} };
265        next if ( $charset{MAX} < $vt_level );
266        next if ( $charset{MIN} > $vt_level );
267        $known[ ++$known ] = $key;
268        $width = length($key) if ( length($key) > $width );
269    }
270    $width += 3;
271    my $cols = int( 78 / $width );
272    my $high = int( ( $known + $cols ) / $cols );
273    for my $y ( 0 .. $high - 1 ) {
274        printf STDERR " ";
275        for my $x ( 0 .. $cols - 1 ) {
276            my $z = $x * $high + $y;
277            next if ( $z > $known );
278            printf STDERR "%-*s", $width, $known[$z];
279        }
280        printf STDERR "\n";
281    }
282    exit 1;
283}
284
285&init_charset( "ASCII",              0, 'B',  1, 9, 0 );
286&init_charset( "British",            0, 'A',  1, 9, 0 );
287&init_charset( "DEC_Spec_Graphic",   0, '0',  1, 9, 0 );
288&init_charset( "DEC_Alt_Chars",      0, '1',  1, 1, 0 );
289&init_charset( "DEC_Alt_Graphics",   0, '2',  1, 1, 0 );
290&init_charset( "DEC_Supp",           0, '<',  2, 9, 0 );
291&init_charset( "Dutch",              0, '4',  2, 9, 1 );
292&init_charset( "Finnish",            0, '5',  2, 9, 1 );
293&init_charset( "Finnish2",           0, 'C',  2, 9, 1 );
294&init_charset( "French",             0, 'R',  2, 9, 1 );
295&init_charset( "French2",            0, 'f',  2, 9, 1 );
296&init_charset( "French_Canadian",    0, 'Q',  2, 9, 1 );
297&init_charset( "German",             0, 'K',  2, 9, 1 );
298&init_charset( "Italian",            0, 'Y',  2, 9, 1 );
299&init_charset( "Norwegian_Danish2",  0, 'E',  2, 9, 1 );
300&init_charset( "Norwegian_Danish3",  0, '6',  2, 9, 1 );
301&init_charset( "Spanish",            0, 'Z',  2, 9, 1 );
302&init_charset( "Swedish",            0, '7',  2, 9, 1 );
303&init_charset( "Swedish2",           0, 'H',  2, 9, 1 );
304&init_charset( "Swiss",              0, '=',  2, 9, 1 );
305&init_charset( "British_Latin_1",    0, 'A',  3, 9, 1 );
306&init_charset( "DEC_Supp_Graphic",   0, '%5', 3, 9, 0 );
307&init_charset( "DEC_Technical",      0, '>',  3, 9, 0 );
308&init_charset( "French_Canadian2",   0, '9',  3, 9, 1 );
309&init_charset( "Norwegian_Danish",   0, '`',  3, 9, 1 );
310&init_charset( "Portuguese",         0, '%6', 3, 9, 1 );
311&init_charset( "ISO_Greek_Supp",     1, 'F',  5, 9, 0 );
312&init_charset( "ISO_Hebrew_Supp",    1, 'H',  5, 9, 0 );
313&init_charset( "ISO_Latin_5_Supp",   1, 'M',  5, 9, 0 );
314&init_charset( "ISO_Latin_Cyrillic", 1, 'L',  5, 9, 0 );
315&init_charset( "Greek",              0, '">', 5, 9, 1 );
316&init_charset( "DEC_Greek",          0, '"?', 5, 9, 1 );
317&init_charset( "Cyrillic",           0, '&4', 5, 9, 0 );
318&init_charset( "DEC_Hebrew",         0, '"4', 5, 9, 0 );
319&init_charset( "Hebrew",             0, '%=', 5, 9, 1 );
320&init_charset( "Russian",            0, '&5', 5, 9, 1 );
321&init_charset( "SCS_NRCS",           0, '%3', 5, 9, 0 );
322&init_charset( "Turkish",            0, '%2', 5, 9, 1 );
323&init_charset( "DEC_Turkish",        0, '%0', 5, 9, 0 );
324
325$vt_level = 1;    # don't expect much
326if ( -t 0 and -t 1 ) {
327    my $da2 = `
328	old=\$(stty -g);
329	stty raw -echo min 0  time 5;
330	printf '\033[>c' >/dev/tty;
331	read response;
332	stty \$old;
333	echo "\$response"`;
334    if ( $da2 =~ /^\033\[>\d+;\d+;\d+c$/ ) {
335        my $Pp = $da2;
336        $Pp =~ s/^.*>//;
337        $Pp =~ s/;.*$//;
338        if ( $Pp == 0 ) {
339            $vt_level = 1;
340        }
341        elsif ( $Pp == 1 or $Pp == 2 ) {
342            $vt_level = 2;
343        }
344        elsif ( $Pp == 18 or $Pp == 19 or $Pp == 24 ) {
345            $vt_level = 3;
346        }
347        elsif ( $Pp == 41 ) {
348            $vt_level = 4;
349        }
350        elsif ( $Pp == 61 or $Pp == 64 or $Pp == 65 ) {
351            $vt_level = 5;
352        }
353    }
354}
355
356$Getopt::Std::STANDARD_HELP_VERSION = 1;
357&getopts('L:l:R:r:v:') || main::HELP_MESSAGE;
358$vt_level = $opt_v if ( defined $opt_v );
359&failed("VT-level must be 1-5") if ( $vt_level < 1 or $vt_level > 5 );
360
361if ( $#ARGV >= 0 ) {
362    while ( $#ARGV >= 0 ) {
363        my $name = shift @ARGV;
364        &doit(
365            defined($opt_L) ? $opt_L : 2,        #
366            defined($opt_l) ? $opt_l : $name,    #
367            defined($opt_R) ? $opt_R : 3,        #
368            defined($opt_r) ? $opt_r : $name
369        );
370        last
371          if (
372            defined($opt_L)                      #
373            and defined($opt_l)                  #
374            and defined($opt_R)                  #
375            and defined($opt_r)
376          );
377    }
378}
379else {
380    &doit(
381        defined($opt_L) ? $opt_L : 2,            #
382        defined($opt_l) ? $opt_l : "ASCII",      #
383        defined($opt_R) ? $opt_R : 3,            #
384        defined($opt_r) ? $opt_r : "ASCII"
385    );
386}
387
3881;
389