#!/usr/bin/perl -w
# $Id: show-linux-consolefonts,v 1.19 2016/11/26 17:17:58 tom Exp $
# -----------------------------------------------------------------------------
# Copyright 2016 by Thomas E. Dickey
#
#                         All Rights Reserved
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the name(s) of the above copyright
# holders shall not be used in advertising or otherwise to promote the
# sale, use or other dealings in this Software without prior written
# authorization.
# -----------------------------------------------------------------------------
# successively load and display console fonts using either showconsolefonts or
# a grid for the different ISO-8859-x locale settings.  Like the ncurses
# test-programs, provide for reading a key for single-stepping or proceeding
# with a time-delay.  It does not use the perl Curses module, since that would
# interfere with sending raw bytes to the screen.
# -----------------------------------------------------------------------------
# TODO factor in mapscrn (perhaps just "mapscrn trivial")
# TODO https://ask.fedoraproject.org/en/question/33145/how-to-set-console-larger-console-font/
# TODO default font in Fedora is in /etc/vconsole.conf, e.g., FONT="eurlatgr"
# TODO see claims in fedora /usr/lib/kbd/consolefonts/README.eurlatgr
# TODO Debian /etc/default/console-setup takes into account CHARMAP
# TODO use linux-chrset script as alternative to built-in or showconsolefont
# TODO save/restore utf8 mode
# TODO add -u option, u-toggle to cycle through ISO-8859-x rather than sizes.

use strict;
use Getopt::Std;
use Term::ReadKey;
use Encode 'encode_utf8';

$| = 1;

our %all_files;
our $font_dir = "/usr/share/consolefonts";

our ( $opt_L, $opt_l, $opt_n, $opt_s, $opt_t, $opt_u );

our $single_step = 0;
our $delay_time  = 3.0;
our $utf8_mode   = 0;

sub failed($) {
    ReadMode 0;    # Reset tty mode before exiting
    printf "? %s\n", $_[0];
    exit 1;
}

sub unctrl($) {
    my $ord = shift;
    my $result;
    if ( $ord < 32 ) {
        $result = sprintf "^%s", chr( $ord + 64 );
    }
    elsif ( $ord == 127 ) {
        $result = "^?";
    }
    elsif ( $ord >= 128 and $ord < 160 ) {
        $result = sprintf "~%s", chr( $ord - 64 );
    }
    else {
        $result = sprintf "%s", chr($ord);
    }
    return $result;
}

sub set_utf8mode($) {
    my $mode = shift;
    printf "<utf8 %s>\n", $mode ? "on" : "off" if ($opt_n);
    printf $mode ? "\e%%G" : "\e%%@" unless ($opt_n);
}

sub clear() {
    printf "<clear>\n" if ($opt_n);
    printf "\e[H\e[2J" unless ($opt_n);
}

sub whereami($) {
    my $mode = shift;
    if ( -t STDIN and -t STDOUT ) {
        printf STDERR "\e[6n";
        my $buffer = "";
        while ( ( my $key = ReadKey(0) ) ne "R" ) {
            $buffer .= $key;
        }
        $buffer =~ s/^.*\[//;
        my @coords = split /;/, $buffer;
        return ( $coords[0], $coords[1] );
    }
    else {
        return ( 0, $mode );
    }
}

sub restore_font() {
    my $fontname;
    if ( open my $fp, "/etc/default/console-setup" ) {
        my @lines = <$fp>;
        close $fp;
        my $codeset;
        my $fontface;
        my $fontsize;
        for my $n ( 0 .. $#lines ) {
            chomp $lines[$n];
            next if ( $lines[$n] =~ /#/ );
            next if ( $lines[$n] !~ /^\w+=/ );
            $lines[$n] =~ s/="/=/;
            $lines[$n] =~ s/".*//;
            my @fields = split /=/, $lines[$n];
            next unless ( $#fields == 1 );
            $codeset  = $fields[1] if ( $fields[0] eq "CODESET" );
            $fontface = $fields[1] if ( $fields[0] eq "FONTFACE" );
            $fontsize = $fields[1] if ( $fields[0] eq "FONTSIZE" );
        }
        if ( $codeset and $fontface and $fontsize ) {
            $fontsize =~ s/^8x//;
            $fontname = sprintf "%s-%s%s", $codeset, $fontface, $fontsize;
        }
    }
    &change_font( $fontname, 0 ) if ($fontname);
}

sub change_font($$) {
    my $fontname = shift;
    my $reset    = shift;
    my $result   = 0;
    ReadMode 1;
    if ($opt_n) {
        printf "setfont $fontname\n", $fontname;
        $result = 1;
    }
    else {
        system("setfont $fontname 2>/dev/null");
        if ( $? != 0 ) {
            printf "\e(B";
            printf STDERR "cannot load $fontname\n";
        }
        else {
            printf $reset ? "\e(B" : "\e(K";
            $result = 1;
        }
    }
    ReadMode 3;
    return $result;
}

sub show_iso8859($) {
    my $fontname = shift;
    &clear;
    printf "font %s\n", $fontname;
    for my $c ( 0 .. 255 ) {
        printf "\n  " if ( ( $c % 16 ) == 0 );
        printf "  "   if ( ( $c % 8 ) == 0 );
        if ( $c >= 128 and $c < 160 ) {
            if ($utf8_mode) {
                printf " %2s ", &unctrl($c);
            }
            else {
                printf " ";
                my ( $oldy, $oldx ) = &whereami(0);
                printf "%2s", chr($c);
                $oldx += 2;
                my ( $newy, $newx ) = &whereami(1);
                printf "\e[7m \e[m" while ( $oldx-- > $newx );
                printf " ";
            }
        }
        else {
            printf " %2s ", &unctrl($c);
        }
    }
    printf "\n";
}

sub show_consolefont($) {
    my $fontname = shift;
    &clear;
    printf "%s - ", $fontname;
    ReadMode 1;
    if ($opt_n) {
        printf "...\n";
    }
    else {
        system("showconsolefont -v");
        &failed("showconsolefont") if ( $? != 0 );
    }
    ReadMode 3;
}

sub show_something($) {
    my $fontname = shift;
    if ( &change_font( $fontname, 1 ) ) {
        &show_iso8859($fontname) if ($opt_l);
        &show_consolefont($fontname) unless ($opt_l);
    }
    select( undef, undef, undef, 0.10 ) unless ($opt_n);
}

sub decode_key($) {
    my $key  = shift;
    my $quit = 0;
    if ( $key eq 'q' ) {
        $quit = 1;
    }
    elsif ( ( $single_step > 0 ) and ( $key eq ' ' ) ) {
        $single_step = 0;
    }
    elsif ( ( $single_step == 0 ) and ( $key eq 's' ) ) {
        $single_step = 1;
    }
    return $quit;
}

sub check_quit() {
    my $result = 0;
    if ( -t STDIN ) {
        my $key;
        if ($single_step) {
            $result = &decode_key( ReadKey(0) );
        }
        else {
            if ( defined( $key = ReadKey(-1) ) ) {
                $result = &decode_key($key);
            }
            else {
                select( undef, undef, undef, $delay_time ) unless ($opt_n);
            }
        }
    }
    return $result;
}

sub do_loop() {
    my $done = 0;
    while ( not $done ) {
        foreach my $font ( sort keys %all_files ) {
            &show_something($font);
            if (&check_quit) {
                $done = 1;
                last;
            }
        }
        last if ($opt_n);
    }
}

sub match_argv($) {
    my $file = shift;
    return 0 unless ( -f $file );
    return 0 unless ( $file =~ /\.psf(u)?(\.gz)?$/ );
    if ( $#ARGV >= 0 ) {
        $file =~ s/\.psf(u)?(\.gz)?$//;
        $file =~ s,^.*/,,;
        $file = lc $file;
        for my $n ( 0 .. $#ARGV ) {
            my $match = index( $file, lc $ARGV[$n] );
            return 1 if ( $match == 0 );
        }
    }
    else {
        return 1;
    }
    return 0;
}

sub scan_fontdir() {
    opendir( my $dh, $font_dir ) || die "can't opendir $font_dir: $!";
    my @files = readdir($dh);
    closedir $dh;
    for my $n ( 0 .. $#files ) {
        my $file = sprintf "%s/%s", $font_dir, $files[$n];
        next unless ( -f $file );
        next unless ( $file =~ /\.psf(u)?(\.gz)?$/ );
        $all_files{$file} = (1) if &match_argv($file);
    }
}

sub do_cleanup() {
    &set_utf8mode(1);
    &restore_font;
    ReadMode 0;    # Reset tty mode before exiting
}

sub signal_handler() {
    &do_cleanup;
    exit 1;
}

sub main::HELP_MESSAGE() {
    printf STDERR <<EOF
Usage: $0 [options] [codeset [codeset ...]]

Options:
-l         use ISO-8859-x grid rather than showconsolefonts
-L         show each ISO-8859-x encoding
-n         show which commands would be executed
-s         start in single-step mode
-t TIME    time-delay between steps
-u         leave UTF-8 mode on while printing
EOF
      ;
    exit;
}

# Fedora kbd-mist package
$font_dir = "/lib/kbd/consolefonts" if ( -d "/lib/kbd/consolefonts" );

&getopts('Llnst:u') || &main::HELP_MESSAGE;

$opt_n = 1 unless ( -t STDIN and -t STDOUT );
$opt_l       = 1            if ($opt_L);
$single_step = 1            if ($opt_s);
$delay_time  = 0.0 + $opt_t if ($opt_t);

&scan_fontdir;

$SIG{INT}  = \&signal_handler;
$SIG{QUIT} = \&signal_handler;
$SIG{TERM} = \&signal_handler;

ReadMode 3;    # Turn off controls keys
&set_utf8mode(0) unless ($opt_u);
&do_loop;
&do_cleanup;

1;
