#! @PERL@
eval 'exec @PERL@ -S $0 ${1+"$@"}'
    if 0;

#
# Copyright (c) 1997, 98, 99, 2000, 01
#    Motoyuki Kasahara
#
# 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.
#

# Program name, program version and mailing address.
$progname='ebappendix';
$version = '@VERSION@';
$mailing_address = '@MAILING_ADDRESS@';

# Help message.
$help = "Usage: $progname [option...] [input-directory]
Options:
  -b BOOK-TYPE  --book-type BOOK-TYPE
                             make an appendix as BOOK-TYPE; eb or epwing
                             (default: depend on \`catalog(s).app\')
  -c CASE  --case CASE
                             output files which have filenames with CASE
                             letters; upper or lower
                             (default: depend on \`catalog(s).app\')
  -d  --debug  --verbose     debug mode
  -h  --help                 output this help, then exit
  -n  --no-catalog           don't output a catalog file
  -o DIRECTORY  --output-directory DIRECTORY
                             output files to DIRECTORY
                             (default: .)
  -s SUFFIX  --suffix SUFFIX
                             output files which have filenames with SUFFIX;
                             none, dot, version or both
                             (default: none)
  -t  --test                 only check for input files
  -v  --version              output version number, then exit

Argument:
  input-directory            input files at this directory
                             (default: .)

Report bugs to $mailing_address.
";

# Copyright message.
$copyright = "Copyright (c) 1997, 98, 99, 2000, 01
   Motoyuki Kasahara

This 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.
";

# `try ...' message.
$tryhelp = "try \`$0 --help\' for more information\n";

# Read files on the directory.
$indir = '.';

# Create files under the directory.
$outdir = '.';

# The maximum number of subbooks in a book.
$max_subbooks = 50;

# The maximum length of an alternation text for a character.
$maxlen_alt = 31;

# The maximum length of a subbook name.
$maxlen_subname = 8;

# Page size.
$size_page = 2048;

# File mode for mkdir.
$dirmode = umask ^ 0777;

# Command line options.
@long_options = ('-b --book-type        required-argument',
		 '-c --case             required-argument',
		 '-d --debug --verbose  no-argument',
		 '-h --help             no-argument',
		 '-n --no-catalog       no-argument',
		 '-o --output-directory required-argument',
		 '-s --suffix           required-argument',
		 '-t --test             no-argument',
		 '-v --version          no-argument');


#
# Parse command line options.
#
&getopt_initialize(@long_options);
while (($optname, $optarg) = &getopt_long) {
    if ($optname eq '-b') {
	if ($optarg !~ /^(eb|epwing)$/i) {
	    warn "$0: unknown book type \`$optarg\'\n";
	    die $tryhelp;
	}
	$disc = "\L$optarg";
    } elsif ($optname eq '-c') {
	if ($optarg !~ /^(upper|lower)$/i) {
	    warn "$0: unknown filename case \`$optarg\'\n";
	    die $tryhelp;
	}
	$case = "\L$optarg";
    } elsif ($optname eq '-d') {
	$debug = 1;
    } elsif ($optname eq '-h') {
	print $help;
	exit(0);
    } elsif ($optname eq '-n') {
	$no_catalog = 1;
    } elsif ($optname eq '-o') {
	$outdir = $optarg;
    } elsif ($optname eq '-s') {
	if ($optarg !~ /^(none|dot|version|both)$/i) {
	    warn "$0: unknown suffix type \`$optarg\'\n";
	    die $tryhelp;
	}
	$suffix = "\L$optarg";
    } elsif ($optname eq '-v') {
	print "$progname (EB Library) version $version\n";
	print $copyright;
	exit(0);
    } elsif ($optname eq '-t') {
	$check_only = 1;
    } else {
	die $tryhelp;
    }
}

$indir = shift if (0 < @ARGV);
if (@ARGV != 0) {
    warn "$0: too many arguments\n";
    die $tryhelp;
}

#
# Remove a slash (`/') in the tail of the directory names.
#
$indir =~ s/\/$//;
$outdir =~ s/\/$//;

#
# Compose filenames.
#
if (-f "$indir/CATALOG.APP") {
    $infile = "$indir/CATALOG.APP";
    $case = 'upper' if (!$case);
    $disc = 'eb' if (!$disc);
} elsif (-f "$indir/catalog.app") {
    $infile = "$indir/catalog.app";
    $case = 'lower' if (!$case);
    $disc = 'eb' if (!$disc);
} elsif (-f "$indir/CATALOGS.APP") {
    $infile = "$indir/CATALOGS.APP";
    $case = 'upper' if (!$case);
    $disc = 'epwing' if (!$disc);
} elsif (-f "$indir/catalogs.app") {
    $infile = "$indir/catalogs.app";
    $case = 'lower' if (!$case);
    $disc = 'epwing' if (!$disc);
} else {
    die "catalog(s).app: no such file\n";
}

if ($disc eq 'eb') {
    if ($case eq 'upper') {
	$outfile = "$outdir/CATALOG";
    } else {
	$outfile = "$outdir/catalog";
    }
} else {
    if ($case eq 'upper') {
	$outfile = "$outdir/CATALOGS";
    } else {
	$outfile = "$outdir/catalogs";
    }
}

if ($suffix eq 'dot') {
    $outfile .= '.';
} elsif ($suffix eq 'version') {
    $outfile .= ';1';
} elsif ($suffix eq 'both') {
    $outfile .= '.;1';
}

#
# Open the `CATALOG(S).APP' file to read.
#
if (!open(CATALOG_APP, $infile)) {
    die "$infile: cannot open the file, $!\n";
}

#
# Read a subbook list from `CATALOG(S).APP'.
#
while (<CATALOG_APP>) {
    s/^\s+//;
    s/\s+$//;
    next if (/^$/ || /^\#/);
    push(@subbooks, $_);
}

#
# Checks for subbook names.
#
die "$infile: no subbooks described\n" if (@subbooks == 0);
die "$infile: too many subbooks\n" if ($max_subbooks < @subbooks);
foreach $sub (@subbooks) {
    die "$infile: invalid subbook name \`$sub\'\n"
	if ($sub !~ /\w{1,$maxlen_subname}/);
}

#
# Close the file `CATALOG(S).APP'.
#
close(CATALOG_APP);

#
# Create the `CATALOG(S)' file.
#
if (!$check_only && !$no_catalog) {
    #
    # Open the `CATALOG(S)' file to write.
    #
    if (!open(CATALOG, "> $outfile")) {
	die "$outfile: cannot open the file, $!\n";
    }

    #
    # Write the number of subbooks in the book.
    #
    print CATALOG "\0", pack('C', scalar(@subbooks)), "\0" x 14;

    #
    # Write subbook names.
    #
    for ($i = 0; $i < @subbooks; $i++) {
	if ($disc eq 'eb') {
	    print CATALOG pack('C', $i + 1), "\0";
	    print CATALOG "\0" x 30;
	    print CATALOG "\U$subbooks[$i]",
	    "\0" x ($maxlen_subname - length($subbooks[$i]));
	} else {
	    print CATALOG pack('C', $i + 1), "\0";
	    print CATALOG "\0" x 80;
	    print CATALOG "\U$subbooks[$i]",
	    "\0" x ($maxlen_subname - length($subbooks[$i]));
	    print CATALOG "\0" x 74;
	}
    }

    #
    # Close the `CATALOG(S)' file.
    #
    close(CATALOG);
}

#
# Create `APPENDIX(or FUROKU)' files.
#
foreach $sub (@subbooks) {
    #
    # Compose filenames.
    #
    if ($case eq 'upper') {
	@findfiles = ("$indir/\U$sub.app", "$indir/\L$sub.app");
    } else {
	@findfiles = ("$indir/\L$sub.app", "$indir/\U$sub.app");
    }
    $infile = '';
    foreach (@findfiles) {
	if (-f $_) {
	    $infile = $_;
	    last;
	}
    }
    die "$findfiles[0]: no such file\n" if ($infile eq '');

    if ($disc eq 'eb') {
	if ($case eq 'upper') {
	    $outfile = "$outdir/\U$sub/APPENDIX";
	    @subdirs = ("$outdir/\U$sub");
	} else {
	    $outfile = "$outdir/\L$sub/appendix";
	    @subdirs = ("$outdir/\L$sub");
	}
    } else {
	if ($case eq 'upper') {
	    $outfile = "$outdir/\U$sub/DATA/FUROKU";
	    @subdirs = ("$outdir/\U$sub", "$outdir/\U$sub/DATA");
	} else {
	    $outfile = "$outdir/\L$sub/data/furoku";
	    @subdirs = ("$outdir/\L$sub", "$outdir/\L$sub/DATA");
	}
    }
    if ($suffix eq 'dot') {
	$outfile .= '.';
    } elsif ($suffix eq 'version') {
	$outfile .= ';1';
    } elsif ($suffix eq 'both') {
	$outfile .= '.;1';
    }

    #
    # Create sub directories if missing.
    #
    foreach (@subdirs) {
	if (! -d $_) {
	    if (mkdir($_, $dirmode)) {
		warn "$_: debug: directory created\n" if ($debug);
	    } else {
		warn "$_: cannot create the directory, $!\n";
		next;
	    }
	}
    }

    #
    # Open the `<SUBBOOK>.APP' file to read.
    #
    if (!open(SUBBOOK_APP, $infile)) {
	warn "$infile: cannot open the file, $!\n";
	next;
    }
    warn "$infile: debug: opened\n" if ($debug);

    $narrow_def = 0;
    $wide_def = 0;
    $narrow_start_def = 0;
    $wide_start_def = 0;
    $narrow_end_def = 0;
    $wide_end_def = 0;
    %narrow_alt = ();
    %wide_alt = ();
    %narrow_lineno = ();
    %wide_lineno = ();
    $stop_def = 0;
    $code_def = 0;
    $block = '';

    #
    # Parse each line in `<SUBBOOK>.APP'.
    #
    while (<SUBBOOK_APP>) {
	s/^\s+//;
	s/\s+$//;
	next if (/^$/ || /^\#/);

	($key, $arg) = split(/[ \t]+/, $_, 2);

	if ($key eq 'begin') {
	    #
	    # `begin ...'
	    #
	    die "$infile:$.: unexpected \`$key\'\n" if ($block ne '');
	    die "$infile:$.: missing argument to \`$key\'\n" if ($arg eq '');

	    if ($arg eq 'narrow') {
		#
		# `begin narrow'
		#
		die "$infile:$.: block \`$arg\' is redefined\n"
		    if (0 < $narrow_def++);

		$block = $arg;
		*start = *narrow_start;
		*start_def = *narrow_start_def;
		*end = *narrow_end;
		*end_def = *narrow_end_def;
		*alt = *narrow_alt;
		*lineno = *narrow_lineno;
		warn "$infile:$.: debug: $key $arg\n" if ($debug);

	    } elsif ($arg eq 'wide') {
		#
		# `begin wide'
		#
		die "$infile:$.: block \`$arg\' is redefined\n"
		    if (0 < $wide_def++);

		$block = $arg;
		*start = *wide_start;
		*start_def = *wide_start_def;
		*end = *wide_end;
		*end_def = *wide_end_def;
		*alt = *wide_alt;
		*lineno = *wide_lineno;
		warn "$infile:$.: debug: $key $arg\n" if ($debug);

	    } else {
		die "$infile:$.: invalid argument \`$arg\'\n";
	    }

	} elsif ($key eq 'end') {
	    #
	    # `end'
	    #
	    die "$infile:$.: unexpected \`$key\'\n" if ($block eq '');
	    die "$infile:$.: not allowed argument to \`$key\'\n"
		if ($arg ne '');

	    $block = '';
	    warn "$infile:$.: debug: $key\n" if ($debug);

	} elsif ($key eq 'range-start') {
	    #
	    # `range-start'
	    #
	    die "$infile:$.: unexpected \`$key\'\n"
		if ($block ne 'narrow' && $block ne 'wide');
	    die "$infile:$.: incorrect hexadecimal number.\n"
		if ($arg !~ /^0[xX]([0-9a-fA-F]{4})$/);
	    die "$infile:$.: \`$key\' is redefined\n" if (0 < $start_def++);

	    $start = hex($1);
	    warn "$infile:$.: debug: $key $arg\n" if ($debug);

	} elsif ($key eq 'range-end') {
	    #
	    # `range-end'
	    #
	    die "$infile:$.: unexpected \`$key\'\n"
		if ($block ne 'narrow' && $block ne 'wide');
	    die "$infile:$.: incorrect hexadecimal number.\n"
		if ($arg !~ /^0[xX]([0-9a-fA-F]{4})$/);
	    die "$infile:$.: \`$key\' is redefined\n" if (0 < $end_def++);

	    $end = hex($1);
	    warn "$infile:$.: debug: $key $arg\n" if ($debug);

	} elsif ($key =~ /^0[xX]/) {
	    #
	    # `0x<HEX><HEX><HEX><HEX>'
	    #
	    die "$infile:$.: unexpected \`$key\'\n"
		if ($block ne 'narrow' && $block ne 'wide');
	    die "$infile:$.: incorrect hexadecimal number.\n"
		if ($key !~ /^0[xX]([0-9a-fA-F]{4})$/);

	    $ch = hex($1);
	    $arg = &convert_to_euc($arg);
	    $len = length($arg);

	    die "$infile:$.: alternation string too long\n"
		if ($maxlen_alt < $len);
	    die "$infile:$.: character \`$key\' redefined\n"
		if (defined($alt{$ch}));

	    $alt{$ch} = $arg;
	    $lineno{$ch} = $.;
	    warn "$infile:$.: debug: $key\n" if ($debug);

	} elsif ($key eq 'character-code') {
	    #
	    # `character-code'
	    #
	    die "$infile:$.: unexpected \`$key\'\n" if ($block ne '');
	    die "$infile:$.: \`$key\' redefined\n" if (0 < $code_def++);
	    die "$infile:$.: invalid character code \`$arg\'\n"
		if ($arg !~ /^(JISX0208|ISO8859-1)$/i);
	    $code = "\U$arg";
	    warn "$infile:$.: debug: $key $arg\n" if ($debug);
		    
	} elsif ($key eq 'stop-code') {
	    #
	    # `stop-code'
	    #
	    die "$infile:$.: unexpected \`$key\'\n" if ($block ne '');
	    die "$infile:$.: \`$key\' redefined\n" if (0 < $stop_def++);
	    die "$infile:$.: invalid stop-code \`$arg\'\n"
		if ($arg !~ /^0x1f(09|41)\s*0x([0-9a-f]{2})([0-9a-f]{2})$/i);
	    @stop = (0x1f, hex($1), hex($2), hex($3));
	    warn "$infile:$.: debug: $key $arg\n" if ($debug);
		    
	} else {
	    die "$infile:$.: unknown keyword \`$key\'\n";
	}
    }
    # End of parsing each line in `<SUBBOOK>.APP'.

    #
    # Close the `<SUBBOOK>.APP' file.
    #
    close(SUBBOOK_APP);
    warn "$infile: debug: closed\n" if ($debug);

    #
    # Check for `character-code' definition.
    #
    die "$infile: missing \`character-code\'\n"
	if ($code_def == 0 && ($narrow_def != 0 || $wide_def != 0));
	
    #
    # Check for the range of alternation.
    #
    if (0 < $narrow_def) {
	die "$infile: missing \`range-start\' in the narrow block\n"
	    if ($narrow_start_def == 0);
	die "$infile: missing \`range-end\' in the narrow block\n"
	    if ($narrow_end_def == 0);

	if ($code eq 'JISX0208') {
	    $narrow_len = (($narrow_end >> 8) - ($narrow_start >> 8)) * 0x5e
		+ (($narrow_end & 0xff) - ($narrow_start & 0xff)) + 1;
	} else {
	    $narrow_len = (($narrow_end >> 8) - ($narrow_start >> 8)) * 0xfe
		+ (($narrow_end & 0xff) - ($narrow_start & 0xff)) + 1;
	}

	if ($code eq 'JISX0208') {
	    while (($key, $arg) = each(%narrow_alt)) {
		warn "$infile:$narrow_lineno{$key}: out of range\n"
		    if ($key < $narrow_start || $narrow_end < $key
			|| ($key & 0xff) < 0x21 || 0x7e < ($key & 0xff));
	    }
	} else {
	    while (($key, $arg) = each(%narrow_alt)) {
		warn "$infile:$narrow_lineno{$key}: out of range\n"
		    if ($key < $narrow_start || $narrow_end < $key
			|| ($key & 0xff) < 0x01 || 0xfe < ($key & 0xff));
	    }
	}
    }

    if (0 < $wide_def) {
	die "$infile: missing \`range-start\' in the wide block\n"
	    if ($wide_start_def == 0);
	die "$infile: missing \`range-end\' in the wide block\n"
	    if ($wide_end_def == 0);

	if ($code eq 'JISX0208') {
	    $wide_len = (($wide_end >> 8) - ($wide_start >> 8)) * 0x5e
		+ (($wide_end & 0xff) - ($wide_start & 0xff)) + 1;
	} else {
	    $wide_len = (($wide_end >> 8) - ($wide_start >> 8)) * 0xfe
		+ (($wide_end & 0xff) - ($wide_start & 0xff)) + 1;
	}

	if ($code eq 'JISX0208') {
	    while (($key, $arg) = each(%wide_alt)) {
		warn "$infile:$wide_lineno{$key}: out of range\n"
		    if ($key < $wide_start || $wide_end < $key
			|| ($key & 0xff) < 0x21 || 0x7f < ($key & 0xff));
	    }
	} else {
	    while (($key, $arg) = each(%wide_alt)) {
		warn "$infile:$wide_lineno{$key}: out of range\n"
		    if ($key < $wide_start || $wide_end < $key
			|| ($key & 0xff) < 0x01 || 0xfe < ($key & 0xff));
	    }
	}
    }

    if (!$check_only) {
	#
	# Create a subdirectory for the subbook, if missing.
	#
	if (!-d $outdir) {
	    if (mkdir($outdir, $dirmode)) {
		warn "$outdir: debug: directory cleated\n";
	    } else {
		die "$outdir: cannot create the directory, $!\n";
	    }
	}

	#
	# Open the file `APPENDIX (or FUROKU)' to read.
	#
	if (!open(APPENDIX, "> $outfile")) {
	    die "$outfile: cannot open the file, $!\n";
	}
	warn "$outfile: debug: opened\n" if ($debug);

	#
	# Fill the index page with zero.
	#
	seek(APPENDIX, 0, 0);
	print APPENDIX "\0" x $size_page;

	#
	# Output alternation text for narrow font characters.
	#
	if (0 < $narrow_def) {
	    $narrow_page = int(1 + tell(APPENDIX) / $size_page);

	    #
	    # Output alternation text.
	    #
	    $i = $narrow_start;
	    while ($i <= $narrow_end) {
		if (defined($narrow_alt{$i})) {
		    print APPENDIX $narrow_alt{$i}, "\0",
		    "\0" x ($maxlen_alt - length($narrow_alt{$i}));
		} else {
		    print APPENDIX "\0" x 32;
		}
		printf STDERR "$outfile: debug: wrote 0x%04x\n", $i
		    if ($debug);

		if ($code eq 'JISX0208') {
		    $i += (($i & 0xff) < 0x7e) ? 1 : 0xa3;
		} else {
		    $i += (($i & 0xff) < 0xfe) ? 1 : 3;
		}
	    }
	    $pad = $size_page - tell(APPENDIX) % $size_page;
	    print APPENDIX "\0" x $pad if ($pad != 0);
	}

	#
	# Output alternation text for wide font characters.
	#
	if (0 < $wide_def) {
	    $wide_page = 1 + int(tell(APPENDIX) / $size_page);

	    #
	    # Output alternation text.
	    #
	    $i = $wide_start;
	    while ($i <= $wide_end) {
		if (defined($wide_alt{$i})) {
		    print APPENDIX $wide_alt{$i}, "\0",
		    "\0" x ($maxlen_alt - length($wide_alt{$i}));
		} else {
		    print APPENDIX "\0" x 32;
		}
		printf STDERR "$outfile: debug: wrote 0x%04x\n", $i
		    if ($debug);

		if ($code eq 'JISX0208') {
		    $i += (($i & 0xff) < 0x7e) ? 1 : 0xa3;
		} else {
		    $i += (($i & 0xff) < 0xfe) ? 1 : 3;
		}
	    }
	    $pad = $size_page - tell(APPENDIX) % $size_page;
	    print APPENDIX "\0" x $pad if ($pad != 0);
	}

	#
	# Output a stop-code.
	#
	$stop_page = 1 + int(tell(APPENDIX) / $size_page);
	if (0 < $stop_def) {
	    print APPENDIX "\0\1", pack("C4", @stop);
	    warn "$outfile: debug: wrote stop-code\n" if ($debug);
	}
	$pad = $size_page - tell(APPENDIX) % $size_page;
	print APPENDIX "\0" x $pad if ($pad != 0);

	#
	# Output an index page.
	#
	seek(APPENDIX, 0, 0);
	print APPENDIX "\0\3", ($code eq 'JISX0208') ? "\0\002" : "\0\001",
	"\0" x 12;

	if (0 < $narrow_def) {
	    print APPENDIX pack("N", $narrow_page), "\0" x 6,
	    pack("n n", $narrow_start, $narrow_len), "\0\0";
	} else {
	    print APPENDIX "\0" x 16;
	}

	if (0 < $wide_def) {
	    print APPENDIX pack("N", $wide_page), "\0" x 6,
	    pack("n n", $wide_start, $wide_len), "\0\0";
	} else {
	    print APPENDIX "\0" x 16;
	}

	if (0 < $stop_def) {
	    print APPENDIX pack("N", $stop_page), "\0" x 12;
	} else {
	    print APPENDIX "\0" x 16;
	}

	close(APPENDIX);
	warn "$outfile: debug: closed\n" if ($debug);

    }
}

exit;

#
# Convert a string to EUC JP.
#
sub convert_to_euc {
    local($_) = $_[$[];
    while (/\033(\([BJ]|\$[\@B])/) {
	s/\033\$[\@B]([^\033]*)/&convert_to_euc_tr($1)/eg;
	s/\033\([BJ]([^\033]*)/$1/eg;
    }
    return $_;
}

sub convert_to_euc_tr {
    local($_) = $_[$[];
    tr/\041-\176/\241-\376/;
    return $_;
}

# Local Variables: 
# mode: perl
# End: 
