#! /usr/bin/perl

#                                                         -*- Perl -*-
# Copyright (c) 1997-2006  Motoyuki Kasahara
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of the project nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

#
# This program is a Perl package running on Perl 4.036 or later.
# The package provides routines to process command line options like
# as GNU getopt_long().
#
# Version:
#     2.0
#
# Interface:
#
#   &getopt_initialize(LIST)
#     Set a list of command line options and initialize internal data
#     for &getopt_long.
#     You must call the routine before calling &getopt_long.
#     Format of each element in the LIST is:
#
#         `CANONICAL-OPTION-NAME [ALIAS-OPTION-NAME...] ARGUMENT-FLAG'
#
#     CANONICAL-OPTION-NAME, ALIAS-OPTION-NAME and ARGUMENT-FLAG fields
#     are separated by spaces or tabs.
#
#     CANONICAL-OPTION-NAME and ALIAS-OPTION-NAME must be either a single
#     character option including preceding `-' (e.g. `-v'), or a long
#     name option including preceding `--' (e.g. `--version').  Whether
#     CANONICAL-OPTION-NAME is single character option or long name
#     option is not significant.
#
#     ARGUMENT-FLAG must be `no-argument', `required-argument' or 
#     `optional-argument'.  If it is set to `required-argument', the
#     option always takes an argument.  If set to `optional-argument',
#     an argument to the option is optional.
#
#     You can put a special element `+' or `-' at the first element in
#     LIST.  See `Details about Option Processing:' for details.
#     If succeeded to initialize, 1 is returned.  Otherwise 0 is
#     returned.
#
#   &getopt_long
#     Get a option name, and if exists, its argument of the leftmost
#     option in @ARGV.
#
#     An option name and its argument are returned as a list with two
#     elements; the first element is CANONICAL-OPTION-NAME of the option,
#     and second is its argument.
#     Upon return, the option and its argument are removed from @ARGV.
#     When you have already got all options in @ARGV, an empty list is
#     returned.  In this case, only non-option elements are left in
#     @ARGV.
#
#     When an error occurs, an error message is output to standard
#     error, and the option name in a returned list is set to `?'.
#
# Example:
#
#     &getopt_intialize('--help -h no-argument', '--version -v no-argument')
#         || die;
#
#     while (($name, $arg) = &getopt_long) {
#         die "For help, type \`$0 --help\'\n" if ($name eq '?');
#         $opts{$name} = $arg;
#     }
#
# Details about Option Processing:
#
#   * There are three processing modes:
#     1. PERMUTE
#        It permutes the contents of ARGV as it scans, so that all the
#        non-option ARGV-elements are at the end.  This mode is default.
#     2. REQUIRE_ORDER
#        It stops option processing when the first non-option is seen.
#        This mode is chosen if the environment variable POSIXLY_CORRECT
#        is defined, or the first element in the option list is `+'.
#     3. RETURN_IN_ORDER
#        It describes each non-option ARGV-element as if it were the
#        argument of an option with an empty name.
#        This mode is chosen if the first element in the option list is
#        `-'.
#
#   * An argument starting with `-' and not exactly `-', is a single
#     character option.
#     If the option takes an argument, it must be specified at just
#     behind the option name (e.g. `-f/tmp/file'), or at the next
#     ARGV-element of the option name (e.g. `-f /tmp/file').
#     If the option doesn't have an argument, other single character
#     options can be followed within an ARGV-element.  For example,
#     `-l -g -d' is identical to `-lgd'.
#     
#   * An argument starting with `--' and not exactly `--', is a long
#     name option.
#     If the option has an argument, it can be specified at behind the
#     option name preceded by `=' (e.g. `--option=argument'), or at the
#     next ARGV-element of the option name (e.g. `--option argument').
#     Long name options can be abbreviated as long as the abbreviation
#     is unique.
#
#   * The special argument `--' forces an end of option processing.
#

{
    package getopt_long;

    $initflag = 0;
    $REQUIRE_ORDER = 0;
    $PERMUTE = 1;
    $RETURN_IN_ORDER = 2;
}


#
# Initialize the internal data.
#
sub getopt_initialize {
    local(@fields);
    local($name, $flag, $canon);
    local($_);

    #
    # Determine odering.
    #
    if ($_[$[] eq '+') {
	$getopt_long'ordering = $getopt_long'REQUIRE_ORDER;
	shift(@_);
    } elsif ($_[$[] eq '-') {
	$getopt_long'ordering = $getopt_long'RETURN_IN_ORDER;
	shift(@_);
    } elsif (defined($ENV{'POSIXLY_CORRECT'})) {
 	$getopt_long'ordering = $getopt_long'REQUIRE_ORDER;
    } else {
	$getopt_long'ordering = $getopt_long'PERMUTE;
    }

    #
    # Parse an option list.
    #
    %getopt_long'optnames = ();
    %getopt_long'argflags = ();

    foreach (@_) {
	@fields = split(/[ \t]+/, $_);
	if (@fields < 2) {
	    warn "$0: (getopt_initialize) too few fields \`$arg\'\n";
	    return 0;
	}
	$flag = pop(@fields);
	if ($flag ne 'no-argument' && $flag ne 'required-argument'
	    && $flag ne 'optional-argument') {
	    warn "$0: (getopt_initialize) invalid argument flag \`$flag\'\n";
	    return 0;
	}

	$canon = '';
	foreach $name (@fields) {
	    if ($name !~ /^-([^-]|-.+)$/) {
		warn "$0: (getopt_initialize) invalid option name \`$name\'\n";
		return 0;
	    } elsif (defined($getopt_long'optnames{$name})) {
		warn "$0: (getopt_initialize) redefined option \`$name\'\n";
		return 0;
	    }
	    $canon = $name if ($canon eq '');
	    $getopt_long'optnames{$name} = $canon;
	    $getopt_long'argflags{$name} = $flag;
	}
    }

    $getopt_long'endflag = 0;
    $getopt_long'shortrest = '';
    @getopt_long'nonopts = ();

    $getopt_long'initflag = 1;
}


#
# When it comes to the end of options, restore PERMUTEd non-option
# arguments to @ARGV.
#
sub getopt_end {
    $getopt_long'endflag = 1;
    unshift(@ARGV, @getopt_long'nonopts);
}


#
# Scan elements of @ARGV for getting an option.
#
sub getopt_long {
    local($name, $arg) = ('', 1);
    local($patt, $key, $ambig, $ch);
    local($_);

    &getopt_initialize(@_) if (!$getopt_long'initflag);
    return () if ($getopt_long'endflag);

    #
    # Take the next argument from @ARGV.
    #
    if ($getopt_long'shortrest ne '') {
	$_ = '-'.$getopt_long'shortrest;
    } elsif (@ARGV == 0) {
	&getopt_end;
	return ();
    } elsif ($getopt_long'ordering == $getopt_long'REQUIRE_ORDER) {
	$_ = shift(@ARGV);
	if (!/^-./) {
	    push(@getopt_long'nonopts, $_);
	    &getopt_end;
	    return ();
	}
    } elsif ($getopt_long'ordering == $getopt_long'PERMUTE) {
	for (;;) {
	    if (@ARGV == 0) {
		&getopt_end;
		return ();
	    }
	    $_ = shift(@ARGV);
	    last if (/^-./);
	    push(@getopt_long'nonopts, $_);
	}
    } else {			# RETURN_IN_ORDER
	$_ = shift(@ARGV);
    }

    #
    # Check for the special option `--'.
    #
    if ($_ eq '--' && $getopt_long'shortrest eq '') {
	#
	# `--' indicates the end of the option list.
	#
	&getopt_end;
	return ();
    }

    #
    # Check for long and short options.
    #
    if (/^(--[^=]+)/ && $getopt_long'shortrest eq '') {
	#
	# Long style option, which start with `--'.
	# Abbreviations for option names are allowed as long as
	# they are unique.
	#
	$patt = $1;
	if (defined($getopt_long'optnames{$patt})) {
	    $name = $patt;
	} else {
	    $ambig = 0;
	    foreach $key (keys(%getopt_long'optnames)) {
		if (index($key, $patt) == 0) {
		    if ($name eq '') {
			$name = $key;
		    } else {
			$ambig = 1;
		    }
		}
	    }
	    if ($ambig) {
		warn "$0: option \`$_\' is ambiguous\n";
		return ('?', '');
	    }
	    if ($name eq '') {
		warn "$0: unrecognized option \`$_\'\n";
		return ('?', '');
	    }
	}

	if ($getopt_long'argflags{$name} eq 'required-argument') {
	    if (/=(.*)$/) {
		$arg = $1;
	    } elsif (0 < @ARGV) {
		$arg = shift(@ARGV);
	    } else {
		warn "$0: option \`$_\' requires an argument\n";
		return ('?', '');
	    }
	} elsif ($getopt_long'argflags{$name} eq 'optional-argument') {
	    if (/=(.*)$/) {
		$arg = $1;
	    } elsif (0 < @ARGV && $ARGV[$[] !~ /^-./) {
		$arg = shift(@ARGV);
	    } else {
		$arg = '';
	    }
	} elsif (/=(.*)$/) {
	    warn "$0: option \`$name\' doesn't allow an argument\n";
	    return ('?', '');
	}
    } elsif (/^(-(.))(.*)/) {
	#
	# Short style option, which start with `-' (not `--').
	#
	($name, $ch, $getopt_long'shortrest) = ($1, $2, $3);

	if (defined($getopt_long'optnames{$name})) {
	    if ($getopt_long'argflags{$name} eq 'required-argument') {
		if ($getopt_long'shortrest ne '') {
		    $arg = $getopt_long'shortrest;
		    $getopt_long'shortrest = '';
		} elsif (0 < @ARGV) {
		    $arg = shift(@ARGV);
		} else {
		    # 1003.2 specifies the format of this message.
		    warn "$0: option requires an argument -- $ch\n";
		    return ('?', '');
		}
	    } elsif ($getopt_long'argflags{$name} eq 'optional-argument') {
		if ($getopt_long'shortrest ne '') {
		    $arg = $getopt_long'shortrest;
		    $getopt_long'shortrest = '';
		} elsif (0 < @ARGV && $ARGV[$[] !~ /^-./) {
		    $arg = shift(@ARGV);
		} else {
		    $arg = '';
		}
	    }
	} elsif (defined($ENV{'POSIXLY_CORRECT'})) {
	    # 1003.2 specifies the format of this message.
	    warn "$0: illegal option -- $ch\n";
	    return ('?', '');
	} else {
	    warn "$0: invalid option -- $ch\n";
	    return ('?', '');
	}
    } else {
	#
	# Only RETURN_IN_ORDER falled into here.
	#
	$arg = $_;
    }

    return ($getopt_long'optnames{$name}, $arg);
}

1;
#
# Copyright (c) 1997-2006  Motoyuki Kasahara
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of the project nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#

require 5.005;
use File::Basename;

# Program name, program version and mailing address.
my $progname='ebappendix';
my $version = '4.5-20200413';
my $mailing_address = 'kzhr@d1.dion.ne.jp';

# Help message.
my $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\')
  -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: .)
  -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.
";

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

# Disc type: `eb' or `epwing'.
my $disc = '';

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

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

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

# Subbook list.
my @subbooks = ();

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

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

# Page size.
my $size_page = 2048;

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

# Test mode flag.
my $check_only = 0;

# Debug mode flag.
my $debug = 0;

# No-catalog mode.
my $no_catalog = 0;

# Show help then exit.
my $help_only = 0;

# Show version then exit.
my $version_only = 0;

# Command line options.
@long_options = ('-b --book-type        required-argument',
                 '-d --debug --verbose  no-argument',
                 '-h --help             no-argument',
                 '-n --no-catalog       no-argument',
                 '-o --output-directory 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 = lc($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 '-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.
#
my $infile = find_file($indir, 'catalog.app', 'undef');
if (!defined($infile)) {
    $infile = find_file($indir, 'catalogs.app', 'undef');
}
if (!defined($infile)) {
    die "catalog(s).app: no such file\n";
}

if ($disc ne 'eb' && $disc ne 'epwing') {
    if (basename($infile) =~ /^catalog\.app/i) {
	$disc = 'eb';
    } else {
	$disc = 'epwing';
    }
}

my $outfile;
if ($disc eq 'eb') {
    $outfile = find_file($outdir, 'catalog', 'default');
} else {
    $outfile = find_file($outdir, 'catalogs', 'default');
}

#
# 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, lc($_));
}

#
# Checks for subbook names.
#
die "$infile: no subbooks described\n" if (@subbooks == 0);
die "$infile: too many subbooks\n" if ($max_subbooks < @subbooks);
foreach my $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 (my $i = 0; $i < @subbooks; $i++) {
	if ($disc eq 'eb') {
	    print CATALOG pack('C', $i + 1), "\0";
	    print CATALOG "\0" x 30;
	    print CATALOG uc($subbooks[$i]);
	    print CATALOG "\0" x ($maxlen_subname - length($subbooks[$i]));
	} else {
	    print CATALOG pack('C', $i + 1), "\0";
	    print CATALOG "\0" x 80;
	    print CATALOG uc($subbooks[$i]);
	    print CATALOG "\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 my $sub (@subbooks) {
    #
    # Compose filenames.
    #
    $infile = find_file($indir, "$sub.app");
    die "$sub.app: no such file\n" if (!defined($infile));

    if ($disc eq 'eb') {
	$outfile = find_file($outdir, "$sub/appendix", 'default');
    } else {
	$outfile = find_file($outdir, "$sub/data/furoku", 'default');
    }
    $outfile =~ s|//+|/|g;

    #
    # 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);

    my $narrow_def = 0;
    my $narrow_start = 0;
    my $narrow_start_def = 0;
    my $narrow_end = 0;
    my $narrow_end_def = 0;
    my $narrow_len = 0;
    my %narrow_alt = ();
    my %narrow_lineno = ();

    my $wide_def = 0;
    my $wide_start = 0;
    my $wide_start_def = 0;
    my $wide_end = 0;
    my $wide_end_def = 0;
    my $wide_len = 0;
    my %wide_alt = ();
    my %wide_lineno = ();

    my @stop = ();
    my $stop_def = 0;
    my $code = 'JISX0208';
    my $code_def = 0;
    my $block = '';

    my $start     = \$narrow_start;
    my $start_def = \$narrow_start_def;
    my $end       = \$narrow_end;
    my $end_def   = \$narrow_end_def;
    my $alt       = \%narrow_alt;
    my $lineno    = \%narrow_lineno;

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

	my ($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})$/);

	    my $ch = hex($1);
	    $arg = &convert_to_euc($arg);
	    my $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|UTF-8)$/i);
	    $code = uc($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' || $code eq 'UTF-8') {
	    $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' || $code eq 'UTF-8') {
	    while (my ($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 (my ($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' || $code eq 'UTF-8') {
	    $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' || $code eq 'UTF-8') {
	    while (my ($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 (my ($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));
	    }
	}
    }

    next if ($check_only);

    #
    # Create a subdirectory for the subbook, if missing.
    #
    my $outsubdir = dirname($outfile);
    if (mkinstalldirs($outsubdir, $dirmode)) {
	warn "$outdir: debug: directory cleated\n" if ($debug);
    } 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.
    #
    my $narrow_page = 0;
    if (0 < $narrow_def) {
	$narrow_page = int(1 + tell(APPENDIX) / $size_page);

	#
	# Output alternation text.
	#
	my $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' || $code eq 'UTF-8') {
		$i += (($i & 0xff) < 0x7e) ? 1 : 0xa3;
	    } else {
		$i += (($i & 0xff) < 0xfe) ? 1 : 3;
	    }
	}
	my $pad = $size_page - tell(APPENDIX) % $size_page;
	print APPENDIX "\0" x $pad if ($pad != 0);
    }

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

	#
	# Output alternation text.
	#
	my $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' || $code eq 'UTF-8') {
		$i += (($i & 0xff) < 0x7e) ? 1 : 0xa3;
	    } else {
		$i += (($i & 0xff) < 0xfe) ? 1 : 3;
	    }
	}
	my $pad = $size_page - tell(APPENDIX) % $size_page;
	print APPENDIX "\0" x $pad if ($pad != 0);
    }

    #
    # Output a stop-code.
    #
    my $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);
    }
    my $pad = $size_page - tell(APPENDIX) % $size_page;
    print APPENDIX "\0" x $pad if ($pad != 0);

    #
    # Output an index page.
    #
    my %character_code_table = (
	'ISO8859-1' => "\0\001",
	'JISX0208' => "\0\002",
	'UTF-8' => "\0\004",
	);
    seek(APPENDIX, 0, 0);
    print APPENDIX "\0\3", $character_code_table{$code}, "\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;

#
# Find file $target under $dir.
#
sub find_file {
    my ($dir, $target, $mode) = @_;
    my $result = $dir;
    my @target_entries = split(/\/+/, $target);

    for (my $i = 0; $i < @target_entries; $i++) {
	my $found;
	my $normalized_target_entry = lc($target_entries[$i]);
	$normalized_target_entry =~ s/;\d$//;
	$normalized_target_entry =~ s/\.$//;

	if (opendir(DIR, $result)) {
	    while (my $entry = readdir(DIR)) {
		if ($i < @target_entries - 1) {
		    next if (! -d "$result/$entry");
		} else {
		    next if (! -f "$result/$entry");
		}
		my $normalized_entry = lc($entry);
		$normalized_entry =~ s/;\d$//;
		$normalized_entry =~ s/\.$//;
		if ($normalized_target_entry eq $normalized_entry) {
		    $found = $entry;
		    last;
		}
	    }
	    closedir(DIR);
	}

	if (defined($found)) {
	    $result = $result . '/' . $found;
	} elsif ($mode eq 'undef') {
	    return undef;
	} else {
	    $result = $result . '/' . $target_entries[$i];
	}
    }

    return $result;
}

sub dirname {
    my ($dir) = @_;
    my $result;

    if ($dir !~ /\//) {
	$result = '.';
    } else {
	$result = $dir;
	$result =~ s/\/+[^\/]+$//;
    }

    return $result;
}

sub mkinstalldirs {
    my ($dir, $mode) = @_;
    my $path = '';

    foreach my $d (split(/\/+/, $dir)) {
	if ($path eq '') {
	    $path = ($dir =~ /^\//) ? '/' : $d;
	} else {
	    $path = "$path/$d";
	}
	next if (-d $path);
	return 0 if (!mkdir($path, $mode));
    }

    return 1;
}

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

sub convert_to_euc_tr {
    my ($s) = @_;
    $s =~ tr/\041-\176/\241-\376/;
    return $s;
}

# Local Variables: 
# mode: perl
# End: