#!/usr/bin/perl -w
use strict;

# $Id: bones-info,v 1.6 2005/03/13 12:07:17 roderick Exp $
#
# Roderick Schertler <roderick@argon.org>
#
# Print some info about a Nethack bones file.

# Copyright (C) 2002 Roderick Schertler
#
# 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 of the License, 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.
#
# For a copy of the GNU General Public License write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

use Getopt::Long ();

# BS == byte sex
sub BS_AUTO	() { 0 }
sub BS_LITTLE	() { 1 }
sub BS_BIG	() { 2 }

(my $Me = $0) =~ s-.*/--;
my $Byte_sex	= BS_LITTLE;
my $Debug	= 0;
my $Exit	= 0;
my $Num_fmt	= 'u';
my $Verbose	= 0;
my $Version	= q$Revision: 1.6 $ =~ /(\d\S+)/ ? $1 : '?';

my @Option_spec = (
    'auto|a'		=> sub { $Byte_sex = BS_AUTO },
    'big-endian|b'	=> sub { $Byte_sex = BS_BIG },
    'debug!'		=> \$Debug,
    'help'		=> sub { usage() },
    'hexadecimal|x'	=> sub { $Num_fmt = 'x' },
    'little-endian|l'	=> sub { $Byte_sex = BS_LITTLE },
    'verbose|v' 	=> \$Verbose,
    'version'		=> sub { print "$Me version $Version\n"; exit },
);

my $Usage = <<EOF;
usage: $Me [switch]...
switches:
  -a, --auto           try to guess at byte sex of each input file
  -b, --big-endian     read version bytes in big endian (Mac) order
      --debug          turn debugging on
      --help           show this and then die
  -x, --hexadecimal    output in hex rather than decimal
  -l, --little-endian  read version bytes in little endian order (default)
  -v, --verbose        display detailed bones info
      --version        show the version ($Version) and exit
Use \`perldoc $Me\' to see the full documentation.
EOF

# A @v array contains
#
#    $v[0] "little" or "big", byte sex used to read the data
#    $v[1] version_info.incarnation;    /* actual version number */
#    $v[2] version_info.feature_set;    /* bitmask of config settings */
#    $v[3] version_info.entity_count;   /* # of monsters and objects */
#    $v[4] version_info.struct_sizes;   /* size of key structs */
#
# A @vdec array comes is the result of "decode_version @v", it replaces
# the 4 version_info elements with array refs.  The elements of the sub
# arrays are indexed by the below subs.

my @Feature	= qw(
    UNKNOWN-0
    REINCARNATION
    SINKS
    UNKNOWN-3
    UNKNOWN-4
    UNKNOWN-5
    KOPS
    MAIL
    UNKNOWN-8
    UNKNOWN-9
    TOURIST
    STEED
    GOLDOBJ
    UNKNOWN-13
    UNKNOWN-14
    UNKNOWN-15
    UNKNOWN-16
    TEXTCOLOR
    INSURANCE
    ELBERETH
    EXP_ON_BOTL
    SCORE_ON_BOTL
    UNKNOWN-22
    TIMED_DELAY
    UNKNOWN-24
    UNKNOWN-25
    UNKNOWN-26
    ZEROCOMP
    RLECOMP
    UNKNOWN-29
    UNKNOWN-30
    UNKNOWN-31
);

sub V1_VERSION_MAJOR	() { 0 }
sub V1_VERSION_MINOR	() { 1 }
sub V1_PATCH_LEVEL	() { 2 }
sub V1_EDIT_LEVEL	() { 3 }

sub V3_ARTIFACTS	() { 0 }
sub V3_OBJECTS		() { 1 }
sub V3_MONSTERS		() { 2 }

sub V4_FLAG		() { 0 }
sub V4_OBJ		() { 1 }
sub V4_MONST		() { 2 }
sub V4_YOU		() { 3 }

sub debug {
    print STDERR "debug: ", @_, "\n" if $Debug;
}

sub usage {
    warn "$Me: ", @_ if @_;
    # Use exit() rather than die(), as Getopt::Long does eval().
    print STDERR $Usage;
    exit 1;
}

# Getopt::Long has some really awful defaults.  This function configures
# it to use more sane settings.

sub getopt {
    Getopt::Long->import(2.11);

    # I'm setting this environment variable lest he sneaks more bad
    # defaults into the module.
    local $ENV{POSIXLY_CORRECT} = 1;
    Getopt::Long::config qw(
        default
        no_autoabbrev
        no_getopt_compat
        require_order
        bundling
        no_ignorecase
    );

    return Getopt::Long::GetOptions @_;
}

sub init {
    getopt @Option_spec or usage;
}

# Decode raw version info values.

sub decode_version {
    my @v = @_;
    my (@v1, @v2, @v3, @v4);

    $v1[V1_VERSION_MAJOR]	= ($v[1] & (255 << 24)) >> 24;
    $v1[V1_VERSION_MINOR]	= ($v[1] & (255 << 16)) >> 16;
    $v1[V1_PATCH_LEVEL]		= ($v[1] & (255 << 8)) >> 8;
    $v1[V1_EDIT_LEVEL]		= ($v[1] & 255);

    @v2 = split //, unpack "b*", pack "V", $v[2];

    $v3[V3_ARTIFACTS]	= ($v[3] & (255 << 24)) >> 24;
    $v3[V3_OBJECTS]	= ($v[3] & (4095 << 12)) >> 12;
    $v3[V3_MONSTERS]	= ($v[3] & 4095);

    $v4[V4_FLAG]	= ($v[4] & (255 << 24)) >> 24;
    $v4[V4_OBJ]		= ($v[4] & (127 << 17)) >> 17;
    $v4[V4_MONST]	= ($v[4] & (127 << 10)) >> 10;
    $v4[V4_YOU]		= ($v[4] & 1023);

    return $v[0], \@v1, \@v2, \@v3, \@v4;
}

# Return true if it looks like the given version info is invalid.

sub invalid_version {
    my (@vdec) = decode_version @_;
    return 1 if $vdec[1][V1_VERSION_MAJOR] < 3;
    return 1 if $vdec[4][V4_MONST] > 1000;
    return 1 if grep { $vdec[2][$_] && $Feature[$_] =~ /^UNKNOWN/ }
		    0..$#{ $vdec[2] };
    return 0;
}

# Output version info info in verbose form.

sub verbose {
    my ($file, $size, @vin) = @_;
    my @vdec = decode_version @vin;

    print "$file: $size bytes\n";

    printf "       read as: %s endian\n", $vin[0];

    printf "   incarnation: %-10$Num_fmt (%s)\n", $vin[1],
	join '.', @{ $vdec[1] };

    my $l = sprintf "   feature_set: %-10$Num_fmt (", $vin[2];
    my @f = map { $Feature[$_] } grep { $vdec[2][$_] } 0..$#Feature;
    my $w = 78;
    while (@f) {
	my $s = "$l" . shift @f; # always eat at least 1 @f
	$s .= ' ' . shift @f while @f && length("$s $f[0]") <= $w;
	$s .= ")" unless @f;
	print "$s\n";
	$l = ' ' x length $l;
    }
    print "$l)\n" if $l =~ /\S/; # no feature were set

    printf "  entity_count: %-10$Num_fmt (%s)\n", $vin[3], join ', ',
    	"$vdec[3][V3_ARTIFACTS] artifacts",
    	"$vdec[3][V3_OBJECTS] objects",
    	"$vdec[3][V3_MONSTERS] monsters";

    printf "  struct_sizes: %-10$Num_fmt (%s)\n", $vin[4], join ', ',
    	"$vdec[4][V4_FLAG] flag",
    	"$vdec[4][V4_OBJ] obj",
    	"$vdec[4][V4_MONST] monst",
    	"$vdec[4][V4_YOU] you";

    print "\n";
}

sub one_file {
    my ($file) = @_;

    my $open = $file;
    $open = "gzip -dc \Q$file\E |"
	if $file =~ /\.(gz|z|Z)\z/;
    if (!open FILE, $open) {
	warn "$Me: can't read $open: $!\n";
	$Exit ||= 1;
	return;
    }

    my $data		= do { local $/; <FILE> };
    my $size		= length $data;
    my @v_little	= (little => unpack 'V' x 4, $data);
    my @v_big		= (big    => unpack 'N' x 4, $data);

    my @v;
    if ($Byte_sex == BS_AUTO) {
	my $good_little	= !invalid_version @v_little;
	my $good_big	= !invalid_version @v_big;
	if (!($good_little ^ $good_big)) {
	    warn "$Me: can't intuit byte sex of $file\n";
	    $Exit ||= 1;
	    return;
	}
	@v = $good_little ? @v_little : @v_big;
    }
    else {
	@v = $Byte_sex == BS_LITTLE ? @v_little : @v_big;
    }

    if ($Verbose) {
	verbose $file, $size, @v;
    }
    else {
	my $n = "%-10$Num_fmt";
	printf "%-11s sex=%s v1=$n v2=$n v3=$n v4=$n\n",
	    $file, substr($v[0], 0, 1), @v[1..4];
    }
}

sub main {
    init;
    @ARGV or die "$Me: no files specified\n";
    one_file $_ for @ARGV;
    return 0;
}

$Exit = main || $Exit;
$Exit = 1 if $Exit && !($Exit % 256);
exit $Exit;

__END__

=head1 NAME

bones-info - display information about a Nethack bones file

=head1 SYNOPSIS

B<bones-info>
[B<-a | --auto>]
[B<-b | --big-endian>]
[B<--debug>]
[B<--help>]
[B<-x | --hexadecimal>]
[B<-l | --little-endian>]
[B<-v | --verbose>]
[B<--version>]
I<file>...

=head1 DESCRIPTION

B<bones-info> displays information about a Nethack bones file.  By
default it shows what byte sex it used to read the file and the 4
version numbers which constitute the feature set and platform for the
Nethack binary which generated it.

=head1 ENDIANNESS (aka BYTE SEX)

Normally B<bones-info> reads the bones file in little endian order,
regardless of the byte sex of the current system, mostly because it was
originally written to help with diagnosing problems with
L<hearse|hearse> and that's the most useful behavior for that purpose.
You can use the B<--auto>, B<--big-endian>, and B<--little-endian>
switches to change this.

B<--auto> is particularly useful (and appropriate) when using B<--verbose>.

=head1 OPTIONS

=over 4

=item B<-a>, B<--auto>

Try to guess the right byte sex (little endian or big endian) for each
input file.  If there doesn't seem to be a right choice, B<bones-info>
will output a warning, set a non-zero exit status, and move on to the
next file.

=item B<-b>, B<--big-endian>

Read the bones files in big endian order, such as is used by Macs.  See
also L</--auto>.

=item B<--debug>

Turn debugging on.

=item B<--help>

Show the usage message and die.

=item B<-x>, B<--hexadecimal>

Output numbers in hexadecimal form.

=item B<-l>, B<--little-endian>

Read the bones files in little endian order, such as is used by Intel
hardware.  This is the default, I include it so that you don't have to
check what the default is if you know you want it a certain way.

=item B<-v>, B<--verbose>

Output more info about the bones file.  This tries to decode the 4
version numbers.  Its useful when you want to see what the differences
are between two sets of version numbers.  You'd normally want to use
B<--auto> when you use B<--verbose>.

=item B<--version>

Show the version number and exit.

=back

=head1 EXAMPLES

Output the values as used by the L<hearse|hearse> server:

 $ bones-info *
 bonD0.0     sex=l v1=1        v2=2          v3=3          v4=4
 bonD0.4.gz  sex=l v1=50593792 v2=10357958   v3=555422078  v4=2759955912
 bonD0.8.Z   sex=l v1=1027     v2=3322682880 v3=2115050273 v4=3365241252
 bonD0.19    sex=l v1=50528512 v2=10357830   v3=555409789  v4=2558629316
 bonM0.1     sex=l v1=50593792 v2=404622406  v3=555417981  v4=2759955916
 bonM0.T     sex=l v1=50593792 v2=1969222    v3=555417981  v4=2759955912

Output the real values as seen on the system which wrote the file (by
guessing the byte sex of the file):

 $ bones-info --auto *
 bones-info: can't intuit byte sex of bonD0.0
 bonD0.4.gz  sex=l v1=50593792 v2=10357958   v3=555422078  v4=2759955912
 bonD0.8.Z   sex=b v1=50593792 v2=1969350    v3=555422078  v4=2759955912
 bonD0.19    sex=l v1=50528512 v2=10357830   v3=555409789  v4=2558629316
 bonM0.1     sex=l v1=50593792 v2=404622406  v3=555417981  v4=2759955916
 bonM0.T     sex=l v1=50593792 v2=1969222    v3=555417981  v4=2759955912
 zsh: exit 1     bones-info --auto *

Decode the version numbers:

 $ bones-info --auto --verbose bonD0.4.gz bonD0.8.Z
 bonD0.4.gz: 18389 bytes
        read as: little endian
    incarnation: 50593792   (3.4.0.0)
    feature_set: 10357958   (REINCARNATION SINKS KOPS MAIL TOURIST STEED
                             TEXTCOLOR INSURANCE ELBERETH EXP_ON_BOTL
                             TIMED_DELAY)
   entity_count: 555422078  (33 artifacts, 433 objects, 382 monsters)
   struct_sizes: 2759955912 (164 flag, 64 obj, 101 monst, 456 you)

 bonD0.8.Z: 22296 bytes
        read as: big endian
    incarnation: 50593792   (3.4.0.0)
    feature_set: 1969350    (REINCARNATION SINKS KOPS MAIL TOURIST STEED
                             TEXTCOLOR INSURANCE ELBERETH EXP_ON_BOTL)
   entity_count: 555422078  (33 artifacts, 433 objects, 382 monsters)
   struct_sizes: 2759955912 (164 flag, 64 obj, 101 monst, 456 you)

 $ _

=head1 BUGS

Unsigned longs are assumed to be 4 bytes.

The --auto byte sex detection isn't robust.

It'd be nice to be provide --verbose output for bones files from older
versions.

=head1 AVAILABILITY

This program is distributed with the Unix Hearse client.  The code is
licensed under the GNU GPL.  Check http://www.argon.org/~roderick/hearse/
for updated versions.

=head1 AUTHOR

Roderick Schertler <roderick@argon.org>

=cut