"Fossies" - the Fresh Open Source Software Archive

Member "xterm-379/vttests/under-latin.pl" (31 Jan 2020, 3554 Bytes) of package /linux/misc/xterm-379.tgz:

    1 #!/usr/bin/env perl
    2 # $XTermId: under-latin.pl,v 1.6 2020/01/31 00:16:52 tom Exp $
    3 # -----------------------------------------------------------------------------
    4 # this file is part of xterm
    5 #
    6 # Copyright 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 a text-test pattern using Latin-1 characters that have these features:
   35 #   a) accents
   36 #   b) descenders
   37 #   c) underlining
   38 
   39 use strict;
   40 use warnings;
   41 
   42 use Getopt::Std;
   43 use Term::ReadKey;
   44 
   45 $| = 1;
   46 
   47 our ( $opt_b, $opt_i, $opt_u );
   48 
   49 our $ROWS = 24;
   50 our $COLS = 4;
   51 
   52 our @sample;
   53 
   54 sub underlined($$) {
   55     my $text = shift;
   56     my $code = shift;
   57     $text = sprintf "\033[4m%s\033[24m", $text if ($code);
   58     return $text;
   59 }
   60 
   61 sub print_row($) {
   62     my $y     = shift;
   63     my $cells = $y * 5;
   64     for my $x ( 0 .. $COLS ) {
   65         printf "%s",
   66           &underlined( $sample[ $cells % 2 ], ( $cells % 4 ) > 1 ? 1 : 0 );
   67         ++$cells;
   68     }
   69 }
   70 
   71 sub main::HELP_MESSAGE() {
   72     printf STDERR <<EOF
   73 Usage: $0 [options]
   74 
   75 Options:
   76 
   77 -b         write a pattern in bold-text
   78 -i         write a pattern in italic-text
   79 -u         write text in UTF-8
   80 EOF
   81       ;
   82     exit;
   83 }
   84 
   85 $Getopt::Std::STANDARD_HELP_VERSION = 1;
   86 &getopts('biu') || &main::HELP_MESSAGE;
   87 
   88 if ( -t 0 ) {
   89     my $size = `stty size`;
   90     chomp $size;
   91     if ( $size =~ /^\d+\s+\d+$/ ) {
   92         my @size = split /\s+/, $size;
   93         $ROWS = $size[0];
   94         $COLS = $size[1] - 4;
   95         $COLS /= 2 if ( $opt_b or $opt_i );
   96         $COLS /= 7;
   97         $COLS = int($COLS) - 1;
   98     }
   99 }
  100 
  101 binmode( STDOUT, ":utf8" ) if ($opt_u);
  102 
  103 $sample[0] = sprintf "%c%c%c%c%c%c%c", 192, 193, 194, 195, 196, 197, 198;
  104 $sample[1] = sprintf "gjpqy%c%c", 199, 255;
  105 
  106 for my $y ( 0 .. ( $ROWS - 1 ) ) {
  107     printf "%3d ", $y + 1;
  108     printf "\033[1m" if ( $opt_b and $opt_i );
  109     &print_row($y);
  110     printf "\033[22m" if ( $opt_b and $opt_i );
  111     if ( $opt_b or $opt_i ) {
  112         printf "\033[%dm", $opt_i ? 3 : 1;
  113         &print_row($y);
  114         printf "\033[%dm", $opt_i ? 23 : 22;
  115     }
  116     printf "\n" unless ( $y + 1 >= $ROWS );
  117 }
  118 
  119 if ( -t 1 ) {
  120     printf "\033[m";
  121     ReadMode 'cbreak';
  122     my $key = ReadKey(30);
  123     ReadMode 'normal';
  124 }
  125 printf "\n";
  126 
  127 1;