#!/usr/bin/env perl
# $Id: find-xterm-fonts,v 1.23 2020/05/16 20:40:46 tom Exp $
# -----------------------------------------------------------------------------
# Copyright 2018,2020 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.
# -----------------------------------------------------------------------------
# Find the X font-files which are used in xterm/uxterm app-defaults files, and
# for some systems (where the packaging system is useful) followup with the
# packages containing those files.

use warnings;
use strict;
use diagnostics;

use Getopt::Std;

our ( $opt_c, $opt_m, $opt_u );

our %opened;    # hash of files that were opened/read

our %app_defaults;    # font resource-specification to font-pattern
our %font_aliases;    # font-alias to font-pattern
our %font_dirs;       # font-directory to font-patterns
our %font_files;      # font-patterns to font-files

our %used_files;      # font-patterns to font-files (used)
our %need_fonts;      # font-patterns without font-files

our @app_defaults = qw(
  /usr/share/X11/app-defaults
  /usr/X11/share/X11/app-defaults
  /usr/X11/lib/X11/app-defaults
  /usr/lib/X11/app-defaults
  /etc/X11/app-defaults
  /usr/pkg/lib/X11/app-defaults
  /usr/X11R7/lib/X11/app-defaults
  /usr/X11R6/lib/X11/app-defaults
  /usr/X11R5/lib/X11/app-defaults
  /usr/X11R4/lib/X11/app-defaults
  /usr/local/lib/X11/app-defaults
  /usr/local/share/X11/app-defaults
  /usr/lib64/X11/app-defaults
  /usr/X11R6/share/X11/app-defaults
  /opt/sfw/lib/X11/app-defaults
);
our @font_dirs = qw(
  /usr/share/fonts/X11
  /usr/share/X11/fonts
  /opt/X11/lib/X11/fonts
  /usr/share/fonts
  /usr/local/share/fonts
  /usr/X11R7/lib/X11/fonts
  /usr/X11R6/lib/X11/fonts
  /usr/X11R5/lib/X11/fonts
  /usr/openwin/lib
  /usr/X11/lib/X11/fonts
);

sub read_file($) {
    my $path = shift;
    my @result;
    if ( open( my $fh, '<', $path ) ) {
        $opened{$path}++;
        @result = <$fh>;
        close $fh;
        for my $n ( 0 .. $#result ) {
            chomp $result[$n];
            $result[$n] =~ s/\s+$//;
            $result[$n] =~ s/^\s+//;
        }
    }
    return @result;
}

sub find_font_files($) {
    my $path = shift;
    if ( opendir( my $dh, $path ) ) {
        my @data = sort readdir($dh);
        closedir $dh;
        for my $n ( 0 .. $#data ) {
            next if ( $data[$n] =~ /^\.{1,2}$/ );
            my $full = sprintf "%s/%s", $path, $data[$n];
            if ( -d $full ) {
                &find_font_files($full);
            }
            elsif ( -l $full ) {
                next;
            }
            elsif ( $data[$n] eq "fonts.dir" ) {
                my @data = &read_file($full);
                for my $p ( 0 .. $#data ) {
                    next if ( $data[$p] =~ /^!/ );
                    my @cols = split /\s+/, $data[$p];
                    next unless ( $#cols == 1 );
                    $font_files{ $cols[1] } = sprintf "%s/%s", $path, $cols[0];
                }
            }
            elsif ( $data[$n] eq "fonts.alias" ) {
                my @data = &read_file($full);
                for my $p ( 0 .. $#data ) {
                    next if ( $data[$p] =~ /^!/ );
                    $data[$p] =~ s/"//g;
                    my @cols = split /\s+/, $data[$p];
                    next unless ( $#cols == 1 );
                    $font_aliases{ $cols[0] } = $cols[1];
                }
            }
        }
    }
}

sub find_font_dirs($) {
    my $path = "";
    for my $n ( 0 .. $#font_dirs ) {
        if ( -d $font_dirs[$n] ) {
            $path = $font_dirs[$n];
            &find_font_files($path);
        }
    }
    if ( $path eq "" ) {
        printf "? cannot find font-tree\n";
    }
}

sub find_app_defaults($) {
    my $class = shift;
    my $path  = "";
    for my $n ( 0 .. $#app_defaults ) {
        my $full = $app_defaults[$n] . "/" . $class;
        if ( -f $full ) {
            $path = $full;
            last;
        }
    }
    if ( !-f $path ) {
        printf "? no such app-defaults file $class\n";
        return;
    }
    printf "# opening $path\n";
    my @data = &read_file($path);
    for my $n ( 0 .. $#data ) {
        next
          unless ( $data[$n] =~ /^\s*([[:alnum:]_]*[\*.])*font\d*\s*:/ );
        printf "\t%s\n", $data[$n];
        my $name = $data[$n];
        $name =~ s/\s*:.*//;
        $name = $class . $name;
        my $value = $data[$n];
        $value =~ s/^[^:]*:\s*//;
        $app_defaults{$name} = $value;
    }
}

sub find_xvile_defaults() {
    my @list = split ':', $ENV{PATH};
    for my $p ( 0 .. $#list ) {
        my $path = $list[$p];
        next unless ( $path =~ /^\/..*$/ );
        my $leaf;
        foreach $leaf ( "vile", "xvile", "xmvile", "xtvile" ) {
            $path = $list[$p];
            $path =~ s,/[^/]*$,/share/$leaf,;
            $path .= "/vilemenu.rc";
            last if ( -f $path );
        }
        next if ( $opened{$path} );
        my @menu = &read_file($path);
        next unless ( $#menu >= 0 );
        printf "# opening %s\n", $path;

        for my $m ( 0 .. $#menu ) {
            next unless ( $menu[$m] =~ /:setv\s+\$font\s/ );
            my $name  = $menu[$m];
            my $value = $name;
            $name =~ s/^[^:]*:(\w+):setv\s+\$font\s.*/*vilemenu.$1/;
            $value =~ s/^.*:setv\s+\$font\s+//;
            $value =~ s/"//g;
            next unless ( $value =~ /^[[:alnum:]*-]+$/ );
            printf "\t%s\t%s\n", $name, $value;
            $app_defaults{$name} = $value;
        }
    }
}

sub find_xlfd($) {
    my $xlfd = shift;
    $xlfd = "^" . $xlfd;
    $xlfd =~ s/\*/[^-]*/g;
    $xlfd .= "(-.*)?\$";
    my $result = "";
    for my $pattern ( sort keys %font_files ) {
        if ( $pattern =~ m/$xlfd/ ) {
            $result = $pattern;
            last;
        }
    }
    return $result;
}

sub report_fonts_used() {
    my %resources;
    my $missing = 0;
    for my $resource ( keys %app_defaults ) {
        my $pattern = $app_defaults{$resource};
        $pattern = $font_aliases{$pattern} if ( $font_aliases{$pattern} );
        my $match = &find_xlfd($pattern);
        if ( $match ne "" ) {
            my $pathname = $font_files{$match};
            $resources{$resource}  = $pathname;
            $used_files{$pathname} = $match;
        }
        else {
            $missing++ unless ( $need_fonts{$pattern} );
            $need_fonts{$pattern} = $resource;
        }
    }
    printf "\n";
    printf "Font-files used:\n";
    for my $pathname ( sort keys %used_files ) {
        printf "\t%s\n", $pathname;
        for my $resource ( sort keys %resources ) {
            printf "\t-> %s\n", $resource
              if ( $resources{$resource} eq $pathname );
        }
    }
    printf "\n";
    if ( $missing != 0 ) {
        printf "%d font-files missing:\n", $missing;
        for my $pattern ( sort keys %need_fonts ) {
            printf "%s %s\n", $pattern, $need_fonts{$pattern};
        }
    }
    else {
        printf "No font-files missing\n";
    }
}

sub report_packages($) {
    my $prog = "";
    my %package;
    my %packages;
    if ( -f "/usr/bin/dlocate" ) {
        $prog = "dlocate";
    }
    elsif ( -f "/usr/bin/rpm" or -f "/bin/rpm" ) {
        $prog = "rpm -qf";
    }
    elsif ( -f "/usr/bin/pacman" ) {

        # Arch
        $prog = "pacman -Q -o";
    }
    elsif ( -f "/usr/sbin/pkg" ) {

        # FreeBSD ports
        $prog = "/usr/sbin/pkg which";
    }
    elsif ( -f "/usr/sbin/pkg_info" ) {

        # NetBSD (pkgsrc)
        $prog = "/usr/sbin/pkg_info -F";
    }

    # caveat: NetBSD and OpenBSD put xterm in the base system, and the package
    # information does not cover that.
    if ( $prog ne "" ) {
        for my $path ( keys %used_files ) {
            my $package = `$prog $path 2>/dev/null`;
            chomp $package;
            if ( $package eq $path or $package eq "" ) {
                next;
            }
            elsif ( $prog =~ /pkg_info/
                and $package =~ /^Information for [^:]+:\n.*/ )
            {
                my @info = split /\n/, $package;
                $info[0] =~ s/^.*\s//;
                $info[0] =~ s/:$//;
                $package = $info[0];
            }
            elsif ( $package =~ /:\s+/ ) {

                # dlocate
                my @cols = split /:\s+/, $package;
                next unless ( $#cols == 1 );
                $package = $cols[0];
                $package{$path} = $package;
            }
            elsif ( $package =~ /\s+is\s+owned\s+by\s+/ ) {

                # pacman
                my @cols = split /\s+is\s+owned\s+by\s+/, $package;
                next unless ( $#cols == 1 );
                $package = $cols[1];
                $package{$path} = $package;
            }
            elsif ( $package =~ /\s+was\s+installed\s+by\s+package\s+/ ) {

                # pacman
                my @cols = split /\s+was\s+installed\s+by\s+package\s+/,
                  $package;
                next unless ( $#cols == 1 );
                $package = $cols[1];
                $package{$path} = $package;
            }
            else {
                # rpm
                $package{$path} = $package;
            }
            $packages{$package} += 1;
        }
        printf "\n";
        printf "Packages providing font-files:\n";
        printf "\n";
        for my $package ( sort keys %packages ) {
            printf "%s\n", $package;
            for my $path ( sort keys %package ) {
                printf "\t%s\n", $path if ( $package eq $package{$path} );
            }
        }
    }
}

sub main::HELP_MESSAGE() {
    printf <<EOF;
Usage: $0 [options] [file1 [file2 [...]]]

Options:
    -c   class    look for "class*" and "Uclass*" resources
    -m            look for xvile's menus, which list fonts
    -u            add U-prefixed classes, e.g., UXTerm vs XTerm.

If -c option is omitted, this uses the app-defaults for XTerm.
EOF
    exit 1;
}

$Getopt::Std::STANDARD_HELP_VERSION = 1;
&getopts('c:mu') || &main::HELP_MESSAGE;
&main::HELP_MESSAGE if ( $#ARGV >= 0 );

if ($opt_c) {
    &find_app_defaults($opt_c);
    &find_app_defaults( "U" . $opt_c ) if ($opt_u);
}
else {
    &find_app_defaults("XTerm");
    &find_app_defaults("UXTerm");
    &find_app_defaults("KOI8RXTerm");
}

&find_xvile_defaults if ($opt_m);

&find_font_dirs;

&report_fonts_used;
&report_packages;

1;
