#! /usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
    if 0;

#                                                         -*- Perl -*-
# Copyright (C) 1997, 1998  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.

#
# 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;
#                                                         -*- Perl -*-
# Copyright (C) 1998, 1999  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 ='ebrefile';
$version = '2.3.6';
$mailing_address = 'm-kasahr@sra.co.jp';

#
# Help messages.
#
$help = "Usage: $progname [option...] [input-directory]
Options:
  -c CASE  --case CASE
                             output catalog(s) which has filename with CASE
                             letters; upper or lower
                             (default: depend on input catalog(s) file)
  -h  --help                 display this help, then exit
  -S SUBBOOK[,SUBBOOK...]  --subbook SUBBOOK[,SUBBOOK...]
                             import SUBBOOK to new catalog(s)
  -o DIRECTORY  --output-directory DIRECTORY
                             output catalog(s) to DIRECTORY
                             (default: .)
  -s SUFFIX  --suffix SUFFIX
                             output catalog(s) which has filenames with SUFFIX;
                             none or period
                             (default: none)
  -v  --version              display version number, then exit

Argument:
  input-directory            input catalog(s) at this directory
                             (default: .)

Report bugs to $mailing_address.
";

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

#
# Option list.
#
@option_list = ('-c --case              required-argument',
		'-h --help              no-argument',
		'-o --output-directory  required-argument',
		'-s --suffix            required-argument',
		'-S --subbook            required-argument',
		'-v --version           no-argument');

#
# CATALOG filename lookup table.
#
%catalogs = ('eb upper none',        'CATALOG',     
	     'eb upper period',      'CATALOG.',    
	     'eb upper version',     'CATALOG;1',   
	     'eb upper both',        'CATALOG.;1',
	     'eb lower none',        'catalog',     
	     'eb lower period',      'catalog.',    
	     'eb lower version',     'catalog;1',   
	     'eb lower both',        'catalog.;1',  
	     'epwing upper none',    'CATALOGS',    
	     'epwing upper period',  'CATALOGS.',   
	     'epwing upper version', 'CATALOGS;1', 
	     'epwing upper both',    'CATALOGS.;1',
	     'epwing lower none',    'catalogs',    
	     'epwing lower period',  'catalogs.',   
	     'epwing lower version', 'catalogs;1',  
	     'epwing lower both',    'catalogs.;1');

%backups = ('eb upper none',        'CATALOG.BAK',     
	    'eb upper period',      'CATALOG.BAK',    
	    'eb upper version',     'CATALOG.BAK;1',   
	    'eb upper both',        'CATALOG.BAK;1',
	    'eb lower none',        'catalog.bak',     
	    'eb lower period',      'catalog.bak',
	    'eb lower version',     'catalog.bak;1',   
	    'eb lower both',        'catalog.bak;1',  
	    'epwing upper none',    'CATALOGS.BAK',    
	    'epwing upper period',  'CATALOGS.BAK',   
	    'epwing upper version', 'CATALOGS.BAK;1', 
	    'epwing upper both',    'CATALOGS.BAK;1',
	    'epwing lower none',    'catalogs.bak',    
	    'epwing lower period',  'catalogs.bak',   
	    'epwing lower version', 'catalogs.bak;1',  
	    'epwing lower both',    'catalogs.bak;1');

#
# Parse command line options.
#
$case = '';
$suffix = '';
$indir = '.';
$outdir = '.';

&getopt_initialize(@option_list);
while (($optname, $optarg) = &getopt_long) {
    if ($optname eq '-c') {
        if ($optarg !~ /^(upper|lower)$/i) {
            warn "$0: unknown filename case \`$optarg\'\n";
            die $tryhelp;
        }
	$case = "\L$optarg";
    } elsif ($optname eq '-h') {
	print $help;
	exit(0);
    } elsif ($optname eq '-o') {
        $outdir = $optarg;
    } elsif ($optname eq '-s') {
        if ($optarg !~ /^(none|period|version|both)$/i) {
            warn "$0: unknown suffix type \`$optarg\'\n";
            warn $tryhelp;
            exit(1);
        }
        $suffix = "\L$optarg";
    } elsif ($optname eq '-S') {
	$optarg =~ s/^[ \t]+//;
	$optarg =~ s/[ \t]+$//;
	foreach $sub (split(/,[ \t]*/, $optarg)) {
	    $sub =~ tr/a-z/A-Z/;
	    die "$0: subbook \`$sub\' specified twice\n"
		if (grep($sub eq $_, @sub_imports));
	    push(@sub_imports, $sub);
	}
    } elsif ($optname eq '-v') {
 	print "$progname (EB Library) version $version\n";
	print "Copyright (c) 1998, 1999  Motoyuki Kasahara\n\n";
	print "This is free software; you can redistribute it and/or modify\n";
	print "it under the terms of the GNU General Public License as published by\n";
	print "the Free Software Foundation; either version 2, or (at your option)\n";
	print "any later version.\n\n";
	print "This program is distributed in the hope that it will be useful,\n";
	print "but WITHOUT ANY WARRANTY; without even the implied warranty\n";
	print "of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n";
	print "GNU General Public License for more details.\n";
	exit(0);
    } else {
	die $tryhelp;
    }
}

#
# Parse non-option arguments.
#
$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/\/$//;

#
# Determine a filename of the CATALOG file.
#
$infile = '';
loop: foreach $i ('eb', 'epwing') {
    foreach $j ('upper', 'lower') {
	foreach $k ('none', 'period', 'version', 'both') {
	    $_ = "$i $j $k";
	    if (-f "$indir/$catalogs{$_}") {
		$infile = "$indir/$catalogs{$_}";
		$disc = $i;
		$case = $j;
		$suffix = $k;
		last loop;
	    }
	}
    }
}
if ($infile eq '') {
    die "$0: no catalog(s) file\n";
}
$outfile = $outdir . '/' . $catalogs{"$disc $case $suffix"};
$bakfile = $outdir . '/' . $backups{"$disc $case $suffix"};

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

#
# Get the number of subbooks in this book.
#
if (read(READ, $buf, 16) != 16) {
    warn "$0: cannot read the file, $!: $infile\n";
    close(READ);
    exit(1);
}
$reserved1 = unpack('x2 C14', $buf);

#
# Scan the catalog.
#
$data_size = ($disc eq 'eb') ? 40 : 164;
$title_size = ($disc eq 'eb') ? 30 : 80;
for ($i = unpack('n', $buf); 0 < $i; $i--) {
    if (read(READ, $buf, $data_size) != $data_size) {
	warn "$0: cannot read the file, $!: $infile\n";
	close(READ);
	exit(1);
    }
    $sub = unpack("x2 x$title_size A8", $buf);
    $sub =~ s/ .*//;
    $sub =~ tr/a-z/A-Z/;
    push(@sub_all, $sub);
    $sub_data{$sub} = $buf;
}

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

#
# Check the subbook list.
#
foreach $sub (@sub_imports) {
    die "$0: unknown subbook \`$sub\'\n" if (!grep($sub eq $_, @sub_all));
}

#
# If `-S' option is not specified, import all subbooks.
#
@sub_imports = @sub_all if (@sub_imports == 0);

#
# Backup $outfile, if required.
#
if (-f $outfile) {
    if (!rename($outfile, $bakfile)) {
	die "$0: cannot rename the file, $!: $outfile to $bakfile\n";
    }
}

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

#
# Write a header part.
#
$buf = pack("n C14", scalar(@sub_imports), $reserved1);
if (!print(WRITE $buf)) {
    warn "$0: cannot read the file, $!: $outfile\n";
    close(WRITE);
    exit(1);
}

#
# Write subbook data.
#
foreach $sub (@sub_all) {
    if (grep($sub eq $_, @sub_imports) && !print(WRITE $sub_data{$sub})) {
	warn "$0: cannot read the file, $!: $outfile\n";
	close(WRITE);
	exit(1);
    }
}

#
# Fill padding data.
#
if (16 + $data_size * @sub_imports < 2048) {
    $buf = "\0" x (2048 - (16 + $data_size * @sub_imports));
    if (!print(WRITE $buf)) {
	warn "$0: cannot read the file, $!: $outfile\n";
	close(WRITE);
	exit(1);
    }
}

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

# Local Variables: 
# mode: perl
# End: 
