#!@PERL@
## Copyright (C) 2016-2017 Robert Krawitz
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2, or (at your option)
## any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program.  If not, see <https://www.gnu.org/licenses/>.

# Reference compression methods and other documentation from
# compress-checksums.
#
# This is believed back compatible with all earlier versions of the
# Gutenprint test case compression utility.

use strict;

my ($progname) = $0;

my (%old_modes, %old_printers, %new_modes, %new_printers);
my ($detail1) = 0;
my ($spc) = unpack("C", " ");

while ($#ARGV >= 0 && $ARGV[0] eq '-d') {
    $detail1++;
    shift @ARGV;
}

my (%asc_table);
map { $asc_table{pack("C", $_ + 128)} = pack("C", $_) . " "; } (0..127);
$asc_table{pack("C", 27)} = "=+";
$asc_table{pack("C", 26)} = "!+";
$asc_table{pack("C", 25)} = '"+';
$asc_table{pack("C", 24)} = ",+";
$asc_table{pack("C", 23)} = "'+";
$asc_table{pack("C", 22)} = "%+";
$asc_table{pack("C", 21)} = ">+";
$asc_table{pack("C", 20)} = "20+";
$asc_table{pack("C", 19)} = "19+";
$asc_table{pack("C", 18)} = "18+";
$asc_table{pack("C", 17)} = "17+";
$asc_table{pack("C", 16)} = "16+";
$asc_table{pack("C", 15)} = "15+";
$asc_table{pack("C", 14)} = "14+";
$asc_table{pack("C", 13)} = "13+";
$asc_table{pack("C", 12)} = "12+";
$asc_table{pack("C", 11)} = "11+";
$asc_table{pack("C", 9)} = "10+";	# 0xa is newline
$asc_table{pack("C", 8)} = "9+";
$asc_table{pack("C", 7)} = "8+";
$asc_table{pack("C", 6)} = "7+";
$asc_table{pack("C", 5)} = "6+";
$asc_table{pack("C", 4)} = "5+";
$asc_table{pack("C", 3)} = "4+";
$asc_table{pack("C", 2)} = "3+";
$asc_table{pack("C", 1)} = "2\+";

my (%respack_tbl);
$respack_tbl{"d"} = "draft";
$respack_tbl{"h"} = "high";
$respack_tbl{"m"} = "mono";
$respack_tbl{"p"} = "photo";
$respack_tbl{"s"} = "std";
$respack_tbl{"t"} = "tshirt";

my (%sub_table);
$sub_table{"P;"} = "PrintingMode";
$sub_table{"S;"} = "PageSize";
$sub_table{"D;"} = "DitherAlgorithm";
$sub_table{"R;"} = "Resolution";
$sub_table{"C;"} = "ColorCorrection";
$sub_table{"c;"} = "Color";
$sub_table{"M;"} = "MediaType";
$sub_table{"I;"} = "InputSlot";

my (%us_table);
$us_table{'>'} = "__";
$us_table{'%'} = "___";
$us_table{"'"} = "____";
$us_table{','} = "_____";
$us_table{'"'} = "______";
$us_table{'!'} = "_______";
$us_table{'='} = "________";

if ($#ARGV <= 0) {
    print_file($ARGV[0]);
} elsif ($#ARGV == 1) {
    compare_files($ARGV[0], $ARGV[1]);
} else {
    die "Usage: $0 [old_checksum_file] [new_checksum_file]\n";
}

sub get_printer($) {
    my ($mode) = @_;
    $mode =~ s/_PrintingMode.*//o;
    return $mode;
}

sub get_mode($) {
    my ($mode) = @_;
    $mode =~ s/.*_PrintingMode/PrintingMode/o;
    return $mode;
}

sub open_file($) {
    my ($file) = @_;
    my $in;
    # Might as well handle known compression methods directly
    if ($file =~ /\.bz2$/) {
	open($in, '-|', "@BZIP2@ -d -c $file") || die("Can't open checksum file $file: $!\n");
    } elsif ($file =~ /.gz$/) {
	open($in, '-|', "@GZIP@ -d -c $file") || die("Can't open checksum file $file: $!\n");
    } elsif ($file =~ /.xz$/) {
	open($in, '-|', "@XZ@ -d -c $file") || die("Can't open checksum file $file: $!\n");
    } elsif ($file =~ /.lrz$/) {
	open($in, '-|', "cat $file | @LRZIP@ -d -q") || die("Can't open checksum file $file: $!\n");
    } elsif ($file =~ /.zpaq$/) {
	my ($zpaq_base) = "@top_builddir@/scripts/wzpaq";
	if (substr($zpaq_base, 0, 1) ne '/') { # Relative path
	    $progname =~ s,[^/]*$,,;
	    $zpaq_base = "$progname$zpaq_base";
	}
	open($in, '-|', "$zpaq_base -d -c $file") || die("Can't open checksum file $file: $!\n");
    } elsif ($file =~ /.rz$/) {
	open($in, '-|', "@RZIP@ -d -c $file") || die("Can't open checksum file $file: $!\n");
    } else {
	open($in, '<', "$file") || die("Can't open checksum file $file: $!\n");
    }
    return $in;
}

sub initialize_file($) {
    my ($file) = @_;
    my (%ctx);
    if ($file eq '' || $file eq '-' || ! defined $file) {
	$ctx{"fh"} = \*STDIN;
    } else {
	$ctx{"fh"} = open_file($file);
    }
    $ctx{"sum"} = "";
    $ctx{"last_sum"} = "";
    $ctx{"kvals"} = [];
    $ctx{"pchunks"} = [];
    $ctx{"active"} = 1;
    $ctx{"lastdup"} = 0;
    return \%ctx;
}

sub break_subgroup($$$) {
    my ($pref, $group, $shared) = @_;
    if ($group =~ /^([^_]*)_(.*)/o) {
	my ($option) = $1;
	my ($values) = $2;
	my (@values) = split(/&/, $values);
	return join(" ", map { "${pref}${option}_${_}${shared}" } @values);
    }
}

sub break_group($$) {
    my ($pref, $group) = @_;
    my (@subgroups);
    my ($rest);
    if ($group =~ /\?/) {
	$group =~ /(^.*\?[^?_]*_[^?_]*)(_.*)/o;
	$rest = $2;
	my ($stuff) = $1;
	@subgroups = split(/\?/, $stuff);
    } elsif ($group =~ /^([^_]*_[^_]*)(_.*$)/o) {
	@subgroups = ($1);
	$rest = $2;
    }
    return join(" ", map {break_subgroup($pref, $_, $rest)} @subgroups);
}

sub fetch_next_line($) {
    my ($ctx) = @_;
    my ($fh) = $$ctx{"fh"};
    my ($inline);
    if (! ($inline = <$fh>)) {
	close($fh) if ($fh != \*STDIN);
	$$ctx{"active"} = 0;
	return 0;
    }
    chomp $inline;
    if ($inline =~ /^[0-9a-f]+ \*/o) {
	# Uncompressed!
	$$ctx{"literal"} = $inline;
	return 1;
    }
    delete $$ctx{"literal"};
    # Level 10
    # Level 9
    # Whitespace optimization -- set high bit.
    $inline =~ s/([\x01-\x09\x0b-\x1b\x80-\xff])/$asc_table{$1}/go;
    # All lines start with hash followed by printing mode, so if compression
    # removed that, we need to restore it.
    # Level 8
    $inline =~ s/^([0-9a-f]+ )\./$1P;_BW_/o;
    $inline =~ s/^([0-9a-f]+ )\,/$1P;_c;_/o;
    # Level 7
    $inline =~ s/([=!",'%>])/$us_table{$1}/go;
    # Level 3
    my ($tmpline) = "";
    while ($inline =~ /(([^()]*) )?([^() _]*_[^() _]*_)\(([^()_]+_)([^()_]+)(_[^()]*)((\))(.*)|$)/o) {
	my ($head) = $2;
	my ($pref) = $3;
	my ($stuff) = "$4$5$6";
	my ($tail) = $9;
	$tmpline .= "$head " . break_group($pref, $stuff);
	$inline = $tail;
    }
    $inline = "$tmpline$inline";
    #  Level 5
    $inline =~ s/([PSDRCcMI];)/$sub_table{$1}/go;
    # Restore printer name
    $inline =~ s/(^| )\*/$1/go;
    $inline =~ s/\.prn( |$)/$1/go;
    # Level 1
    my ($sum, @keys) = split(/ /o, $inline);
    $$ctx{"kvals"} = \@keys;
    $$ctx{"pchunks"} = [];

    # Level 4
    # Level 2 is subsumed here, because the checksum lengths will always
    # be identical at this compression level.
    my $osum = $$ctx{"sum"};
    if ($osum ne "" && ((length $sum) < (length $osum))) {
	$sum = substr($osum, 0, ((length $osum) - (length $sum))) . $sum;
    }
    $$ctx{"sum"} = $sum;
    return 1;
}

sub get_next_datum($) {
    my ($ctx) = @_;
    return undef if (! $$ctx{"active"});
    if ((scalar @{$$ctx{"kvals"}}) == 0) {
	return undef if (! fetch_next_line($ctx));
    }
    if (defined $$ctx{"literal"}) {
	my ($sum, $val) = split(/ /, $$ctx{"literal"});
	$val = substr($val, 1, -4);
	return [$sum, get_mode($val), get_printer($val)];
    }
    my (@chunks) = split(/_/o, shift(@{$$ctx{"kvals"}}), -1);
    my $pchunks = $$ctx{"pchunks"};
    # Level 6
    foreach my $i (0..$#chunks) {
	if ($chunks[$i] eq '') {
	    $chunks[$i] = $$pchunks[$i];
	} else {
	    if (substr($chunks[$i], 0, 1) eq '+') {
		substr($chunks[$i], 0, 1) =
		    substr($$pchunks[$i], 0, $$ctx{"lastdup"});
	    } elsif (substr($chunks[$i], 0, 1) eq '*') {
		substr($chunks[$i], 0, 1) = substr($$pchunks[$i], 0, 2);
	    } elsif ($chunks[$i] =~ /^([0-9]+)\+(.*)/o) {
		$chunks[$i] = substr($$pchunks[$i], 0, $1) . $2;
		$$ctx{"lastdup"} = $1;
	    }

	    if (substr($chunks[$i], -1) eq "\\") {
		substr($chunks[$i], -1) = substr($$pchunks[$i], -2);
	    } elsif ($chunks[$i] =~ m,(.*)/([0-9]+)$,o) {
		$chunks[$i] = $1 . substr($$pchunks[$i], -$2);
	    }
	}
    }
    my ($val) = join('_', @chunks);
    # Restore printer names
    my ($sep) = rindex($val, ':');
    my ($prn) = substr($val, $sep + 1);
    substr($val, $sep - 1) = '';
    # Level 5 (global)
    $val =~ s/\{([0-9]*)([dhmpst])([^|]*)\}/$1x$1dpi_${respack_tbl{$2}}$3/go;
    $val =~ s/Z\;/DitherAlgorithm/go;
    $$ctx{"pchunks"} = \@chunks;
    return [$$ctx{"sum"}, $val, $prn];
}

sub load_file($\%\%) {
    my ($file, $modes, $printers) = @_;
    my ($ctx) = initialize_file($file);
    my ($answer);
    while ($answer = get_next_datum($ctx)) {
	my ($sum) = $$answer[0];
	my ($val) = $$answer[1];
	my ($prn) = $$answer[2];
	$$modes{"*${prn}_$val"} = $sum;
	$$printers{$prn} = 1;
    }
}

sub print_changes($$@) {
    my ($tag, $detail, @changes) = @_;
    my ($prev_printer);
    return if ($#changes < 0);
    if (! $detail1) {
	print "$tag:\n";
    }
    foreach my $m (@changes) {
	my ($printer) = get_printer($m);
	my ($mode) = get_mode($m);
	if ($detail > 1) {
	    print "${printer}_${mode}\n";
	} elsif ($detail) {
	    if ($printer ne $prev_printer) {
		print "    $printer:\n";
		$prev_printer = $printer;
	    }
	    print "        $mode\n";
	} else {
	    print "    $mode\n";
	}
    }
    print "\n";
}

sub compare_files($$) {
    my ($file1, $file2) = @_;
    load_file($file1, %old_modes, %old_printers);
    load_file($file2, %new_modes, %new_printers);

    my (%only_old_printers, %only_new_printers);

    foreach my $new_printer (keys %new_printers) {
	if (! defined $old_printers{$new_printer}) {
	    $only_new_printers{$new_printer} = 1;
	}
    }

    foreach my $old_printer (keys %old_printers) {
	if (! defined $new_printers{$old_printer}) {
	    $only_old_printers{$old_printer} = 1;
	}
    }

    my (@only_old_modes, @only_new_modes, @changed_modes);

    sub mode_ne($$) {
	my ($new, $old) = @_;
	if (length $new == length $old) {
	    return ($new ne $old);
	} elsif (length $new < length $old) {
	    return ($new ne substr($old, 0, length $new));
	} else {
	    return ($old ne substr($new, 0, length $old));
	}
    }

    foreach my $old_mode (sort keys %old_modes) {
	next if defined $only_old_printers{get_printer($old_mode)};
	if (defined $new_modes{$old_mode}) {
	    if (mode_ne($new_modes{$old_mode}, $old_modes{$old_mode})) {
		push @changed_modes, $old_mode;
	    }
	} else {
	    push @only_old_modes, $old_mode;
	}
    }

    foreach my $new_mode (sort keys %new_modes) {
	next if defined $only_new_printers{get_printer($new_mode)};
	if (!defined $old_modes{$new_mode}) {
	    push @only_new_modes, $new_mode;
	}
    }

    my (@only_old_printers) = sort keys %only_old_printers;
    my (@only_new_printers) = sort keys %only_new_printers;

    if (! $detail1) {
	print "*** Changes from $ARGV[0] to $ARGV[1] ***\n\n";
	print_changes("Printers removed from $ARGV[1]", 0, @only_old_printers);
	print_changes("Printers added to $ARGV[1]", 0, @only_new_printers);
	print_changes("Modes removed from $ARGV[1]", 1, @only_old_modes);
	print_changes("Modes added to $ARGV[1]", 1, @only_new_modes);
    }
    print_changes("Changed printing modes", 1 + $detail1, @changed_modes);
}

sub print_file($) {
    my ($file) = @_;
    my ($ctx) = initialize_file($file);
    my ($answer);
    while ($answer = get_next_datum($ctx)) {
	my ($sum) = $$answer[0];
	my ($val) = $$answer[1];
	my ($prn) = $$answer[2];
	print "$sum *${prn}_$val.prn\n";
    }
}
