"Fossies" - the Fresh Open Source Software Archive

Member "xterm-379/vttests/query-fonts.pl" (19 May 2019, 4532 Bytes) of package /linux/misc/xterm-379.tgz:

    1 #!/usr/bin/env perl
    2 # $XTermId: query-fonts.pl,v 1.8 2019/05/19 08:57:31 tom Exp $
    3 # -----------------------------------------------------------------------------
    4 # this file is part of xterm
    5 #
    6 # Copyright 2010-2018,2019 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 # Test the font-query features of xterm.
   35 
   36 # TODO:
   37 # test relative vs absolute font numbering
   38 # test all font-slots
   39 # test selection
   40 # test bold / wide / widebold
   41 # test actual fontname vs nominal
   42 # extend "CSI > Ps; Ps T" to query fontname in hex
   43 
   44 use strict;
   45 use warnings;
   46 
   47 use Getopt::Std;
   48 use IO::Handle;
   49 
   50 our ( $opt_a, $opt_r, $opt_s );
   51 
   52 $Getopt::Std::STANDARD_HELP_VERSION = 1;
   53 &getopts('ars') || die(
   54     "Usage: $0 [options]\n
   55 Options:\n
   56   -a      test using absolute numbers
   57   -r      test using relative numbers
   58   -s      use ^G rather than ST
   59 "
   60 );
   61 
   62 our $ST = $opt_s ? "\007" : "\x1b\\";
   63 
   64 sub get_reply($) {
   65     open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
   66     autoflush TTY 1;
   67     my $old = `stty -g`;
   68     system "stty raw -echo min 0 time 5";
   69 
   70     print TTY @_;
   71     my $reply = <TTY>;
   72     close TTY;
   73     system "stty $old";
   74     if ( defined $reply ) {
   75         die("^C received\n") if ( "$reply" eq "\003" );
   76     }
   77     return $reply;
   78 }
   79 
   80 sub query_font($) {
   81     my $param = $_[0];
   82     my $reply;
   83     my $n;
   84     my $st    = $opt_s ? qr/\007/ : qr/\x1b\\/;
   85     my $osc   = qr/\x1b]50/;
   86     my $match = qr/${osc}.*${st}/;
   87 
   88     $reply = get_reply( "\x1b]50;?" . $param . $ST );
   89 
   90     printf "query{%s}%*s", $param, 3 - length($param), " ";
   91 
   92     if ( defined $reply ) {
   93         printf "%2d ", length($reply);
   94         if ( $reply =~ /${match}/ ) {
   95 
   96             $reply =~ s/^${osc}//;
   97             $reply =~ s/^;//;
   98             $reply =~ s/${st}$//;
   99         }
  100         else {
  101             printf "? ";
  102         }
  103 
  104         my $result = "";
  105         for ( $n = 0 ; $n < length($reply) ; ) {
  106             my $c = substr( $reply, $n, 1 );
  107             if ( $c =~ /[[:print:]]/ ) {
  108                 $result .= $c;
  109             }
  110             else {
  111                 my $k = ord substr( $reply, $n, 1 );
  112                 if ( ord $k == 0x1b ) {
  113                     $result .= "\\E";
  114                 }
  115                 elsif ( $k == 0x7f ) {
  116                     $result .= "^?";
  117                 }
  118                 elsif ( $k == 32 ) {
  119                     $result .= "\\s";
  120                 }
  121                 elsif ( $k < 32 ) {
  122                     $result .= sprintf( "^%c", $k + 64 );
  123                 }
  124                 elsif ( $k > 128 ) {
  125                     $result .= sprintf( "\\%03o", $k );
  126                 }
  127                 else {
  128                     $result .= chr($k);
  129                 }
  130             }
  131             $n += 1;
  132         }
  133 
  134         printf "{%s}", $result;
  135     }
  136     printf "\n";
  137 }
  138 
  139 if ($opt_r) {
  140     my $n;
  141     query_font("-");
  142     foreach $n ( 0 .. 5 ) {
  143         query_font( sprintf "-%d", $n );
  144     }
  145     query_font("+");
  146     foreach $n ( 0 .. 5 ) {
  147         query_font( sprintf "+%d", $n );
  148     }
  149 }
  150 if ($opt_a) {
  151     my $n;
  152     foreach $n ( 0 .. 5 ) {
  153         query_font( sprintf "%d", $n );
  154     }
  155 }
  156 if ( not $opt_a and not $opt_r ) {
  157     query_font("");
  158 }