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

# $Id: hearse,v 1.12 2002/11/02 15:13:06 roderick Exp $
#
# Roderick Schertler <roderick@argon.org>
#
# Modified to support Linley's Dungeon Crawl by Darshan Shaligram
#                                               <darshansk@yahoo.com>

# 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 Errno			qw(ENOENT);
use Fcntl			qw(LOCK_EX LOCK_NB O_CREAT O_WRONLY);
use File::Basename		qw(basename dirname);
use Getopt::Long		  ();
use HTTP::Request		  ();
use LWP::UserAgent		  ();

# configuration

my @Bones_dir		= qw(/var/games/nethack /usr/games/lib/nethackdir 
                             /opt/crawl/lib .);
my $Bones_mode		= '660';
my $Config_file		= '/etc/nethack/hearse.conf';
my @Compress_suffix	= qw(.gz .z .Z);
my $Decompress_cmd	= 'gzip -dc';
my $Last_run_stamp_file = '.hearse.timestamp'; # rel. to bones dir, or absolute
my $Lock_tries		= 900;
my $Lock_sleep		= 1;
my @Role		= qw(Arc Bar Cav Hea Kni Mon Pri
				Rog Ran Sam Tou Val Wiz);
my $Run_as_user		= 'games';
my $Run_as_group	= 'games';
my $Server_url		= 'http://hearse.krollmark.com/bones.dll';
my $User_token_file	= '/etc/nethack/hearse.user-token';

# globals unlikely to need configuration

my # new line required for makemaker
    $VERSION = '1.2';

my $Bones_dir		= undef;
my $Debug		= 0;
my $Do_help		= 0;
my $Do_version		= 0;
my $Delete_uploaded	= 0;
my $Exit		= 0;
my $Force_download	= 0;		# intentionally undocumented
my @Local_bones		= ();
my $Lock_file		= undef;
my $Lwp_ua		= undef;	# LWP::UserAgent object
my $Me			= basename $0;
my $Quiet		= 0;
my $Quiet_cron		= 0;
my $Role_re		= do {
				my $r = join '|', map { quotemeta } @Role;
				qr/(?:$r)/
			    };

# Don't try set_ugid() tricks if we're running Windows. A user wanting to shoot
# himself in the foot is free to override this on the command line.
my $Run_as_me		= $^O eq 'MSWin32';

my $User_email		= undef;	# only used if there's no token already
my $User_token		= undef;

my %Option_spec = (
    	    	    	# short name, type, allow in config, var
    'bones-dir'		=> ['b', 's', 1, \$Bones_dir],
    'bones-mode'	=> [ '', 's', 1, \$Bones_mode],
    'config-file'	=> ['c', 's', 0, \$Config_file],
    'cron'		=> [ '',  '', 1, \$Quiet_cron],
    'debug'		=> [ '',  '', 1, \$Debug],
    'delete-uploaded'	=> [ '',  '', 1, \$Delete_uploaded],
    'help'		=> [ '',  '', 0, \$Do_help],
    'force-download'	=> [ '',  '', 0, \$Force_download],
    'lock-file'		=> [ '', 's', 1, \$Lock_file],
    'quiet'		=> ['q',  '', 1, \$Quiet],
    'run-as-me'		=> [ '',  '', 1, \$Run_as_me],
    'run-as-user'	=> [ '', 's', 1, \$Run_as_user],
    'run-as-group'	=> [ '', 's', 1, \$Run_as_group],
    'server-url'	=> [ '', 's', 1, \$Server_url],
    'stamp-file'	=> [ '', 's', 1, \$Last_run_stamp_file],
    'user-email'	=> [ '', 's', 1, \$User_email],
    'user-token'	=> [ '', 's', 1, \$User_token],
    'user-token-file'	=> [ '', 's', 1, \$User_token_file],
    'version'		=> [ '',  '', 0, \$Do_version],
);

# Bones file types are distinguished by name, for the moment.
my @Bones_handlers = (
    # NetHack
    [ qr/^bon[A-Z](0|$Role_re)\.([A-Z]|\d+)\z/i, \&get_nh_bones_version ],

    # Crawl
    [ qr/^bones./i, \&get_crawl_bones_version, \&unmangle_crawl_bones,
      'CRAWL' ],
);

my $Usage = <<EOF;
usage: $Me [switch]...

switches:
  -b, --bones-dir dir       (default first which exists: @Bones_dir)
      --bones-mode m        mode for created bones files ($Bones_mode)
  -c, --config-file f       ($Config_file)
      --cron                suppress "no bones to upload" message
      --debug               turn debugging on
      --delete-uploaded     delete bones files after uploading them
      --help                show this and then die
      --lock-file f         (the --user-token-file by default)
  -q, --quiet               suppress informational messages
      --run-as-me           disable --run-as-group/--run-as-user
      --run-as-user u	    set real/effective user  id ($Run_as_user)
      --run-as-group g	    set real/effective group id ($Run_as_group)
      --server-url url      ($Server_url)
      --stamp-file f	    timestamp file ($Last_run_stamp_file)
      --user-email addr     only used to get user token, if necessary
      --user-token tok      specify user token directly
      --user-token-file f   file which stores user token ($User_token_file)
      --version             show the version ($VERSION) and exit

See the man page or \`perldoc $Me\' for the full documentation.
EOF

sub BONES_VERSION_READER        () { 1 }
sub BONES_UNMANGLER             () { 2 }
sub BONES_TYPE                  () { 3 }

sub SERVER_CMD_NEW_USER		() { 'newuser' }
sub SERVER_CMD_BONES_CHECK	() { 'bonescheck' }
sub SERVER_CMD_UPLOAD		() { 'upload' }
sub SERVER_CMD_DOWNLOAD		() { 'download' }

sub HEADER_HEARSE		() { 'X-HEARSE' }
sub HEADER_TOKEN		() { 'X_USERTOKEN' }
sub HEADER_HEARSE_CRC		() { 'X_HEARSECRC' }
sub HEADER_BONES_CRC		() { 'X_BONESCRC' }
sub HEADER_BONES_TYPE           () { 'X_BONESTYPE' }
sub HEADER_VERSION		() { 'X_VER' }
    # 1 = incarnation = major, minor, patchlevel, editlevel
    # 2 = feature set
    # 3 = entity count
    # 4 = struct sizes = flag, obj, monst, you
    sub HEADER_VERSION_COUNT	() { 4 }
sub HEADER_ERROR		() { 'X_ERROR' }
    sub F_ERROR_FATAL		() { 'FATAL' }
    sub F_ERROR_INFO		() { 'INFO' }
sub HEADER_FILE_NAME		() { 'X_FILENAME' }
sub HEADER_USER_LEVELS		() { 'X_USERLEVELS' }
sub HEADER_WANTS_INFO		() { 'X_GIVEINFO' }
sub HEADER_CLIENT		() { 'X_CLIENTID' }
    sub F_CLIENT		() { 'UNIX-HEARSE CRAWL' }
sub HEADER_FORCE_UPDATE		() { 'X_FORCEUPDATE' }

sub ST_MTIME			() { 9 }

# Prepend the script name to the @MESSAGE.  If the last arg ends with a
# colon, append $!.

sub xwarndie_msg {
    my @msg = ("$Me: ", @_);
    $msg[$#msg] =~ s/:\z/: $!\n/;
    return @msg;
}

sub xdie {
    die xwarndie_msg @_;
}

sub xwarn {
    $Exit ||= 1;
    warn xwarndie_msg @_;
}

sub usage {
    xwarn @_ if @_;
    die $Usage;
}

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

sub info {
    print "$Me: ", @_, "\n" unless $Quiet;
}

sub data_dump {
    1 and require RS::Handy;	# "1 and" to hide from rpm's dependency calcs
    print RS::Handy::data_dump(@_);
}

# Given DESC and DIR_LIST, return the first directory from the list
# which exists, or die.

sub first_dir {
    my ($name, @d) = @_;
    for (@d) {
    	return $_ if -d;
    }
    xdie "can't find a $name directory, checked: @d\n";
}

# Ensure that a given directory exists, or die.

sub mkpath {
    my ($dir) = @_;

    return if -d $dir;
    require File::Path;
    File::Path::mkpath($dir, 1);
}

# Return an MD5 hash in hex, using whatever module is available.

{ my $md5_sub;
sub md5 {
    my ($rdata) = @_;

    if (!$md5_sub) {
	if (eval { require Digest::MD5 }) {
	    debug 'md5 using Digest::MD5';
	    $md5_sub = \&Digest::MD5::md5_hex;
	}
	elsif (eval { require MD5 }) {
	    debug 'md5 using MD5';
	    $md5_sub = sub { MD5->hexhash(shift) };
	}
	else {
	    xdie "can't find Perl module to make MD5 hashes,",
		    " install either Digest::MD5 or MD5";
	}
    }

    return $md5_sub->($$rdata);
} }

# Remove leading and trailing space from STR and return it.

sub trim {
    my ($s) = @_;

    $s =~ s/^\s+//;
    $s =~ s/\s+$//;
    return $s;
}

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

sub getopt;
sub configure_getopt {
    Getopt::Long->import(2.11);
    *getopt = \&Getopt::Long::GetOptions;

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

# Turn a text description into a boolean.

sub boolean {
    my ($val) = @_;

    if ($val =~ /^(on|true|yes|1)\z/i) {
	return 1;
    }
    elsif ($val =~ /^(off|false|no|0)\z/i) {
    	return 0;
    }
    else {
    	return;
    }
}

# Read the config file, updating globals appropriately.

sub process_config_file {
    local *FILE;

    debug "config file $Config_file";

    if (!open FILE, $Config_file) {
	return if $! == ENOENT;
	xdie "can't read $Config_file:";
    }

    local $. = 0;
    my $choke = sub {
    	xdie @_, " at $Config_file line $.\n";
    };
    while (<FILE>) {
	next if /^\s*#/;
	next if /^\s*$/;
	my ($var, $val) = map { trim $_ } split ' ', $_, 2;
	debug "config [$var] = [$val]";
	my $spec = $Option_spec{$var}
	    or $choke->("invalid config file option `$var'");
	my ($short, $type, $in_config, $ref) = @$spec;
	$in_config
	    or $choke->("$var can only be specified as a command line switch");
	if ($type eq 's') {
	    if ($val eq '-') {
    	    	$val = '';
	    }
	    elsif ($val eq '') {
		$choke->("no value specified for $var",
			    " (use `-' to turn a string setting off)");
	    }
	}
	elsif ($type eq '') {
	    $val = boolean $val;
	    defined $val
		or $choke->("invalid boolean value for $var,",
		    	    " use on/off/true/false/yes/no/1/0");
	}
	else {
	    xdie "invalid variable type `$type'\n";
	}
    	$$ref = $val;
    }

    close FILE
	or xdie "error closing $Config_file:";
}

sub ugid {
    my $rgid = (split ' ', $()[0];
    my ($egid, $supgroups) = split ' ', $), 2;
    return "ruid $< euid $> rgid $rgid egid $egid supgroups $supgroups";
}

# Set the real/effective user/group ids according to the $Run_as_*
# variables, or die trying.

sub set_ugid {
    return if $Run_as_me;

    debug "set_ugid before ", ugid;

    if ($Run_as_group ne '') {
	my $gid = getgrnam $Run_as_group;
	defined $gid
	    or xdie "invalid --run-as-group `$Run_as_group'\n";
    	my $want = "$gid $gid";
	$( = $gid;
	$) = $want;
	$( eq $want or xdie "error setting real gid (want $want, got $()\n";
	$) eq $want or xdie "error setting effective gid (want $want, got $))\n";
    }

    if ($Run_as_user ne '') {
	my $uid = getpwnam $Run_as_user;
	defined $uid
	    or xdie "invalid --run-as-user `$Run_as_user'\n";
	$> = $uid;
	$< = $uid;
	$< eq $uid or xdie "error setting real uid (want $uid, got $<)\n";
	$> eq $uid or xdie "error setting effective uid (want $uid, got $>)\n";
    }

    debug "set_ugid after ", ugid;
}

# Process args and do some other initializations.

sub init {
    # My output is often going to a non-terminal (cron); flush stdout so
    # it stays in the right order with stderr.

    $| = 1;

    # I want to process the configuration file before the command line
    # args, so that the command line can override settings from the
    # config file.  I need to process the command line to see if she
    # overrode the config file, however.  So, I actually parse the
    # command line args twice, both before and after reading the config
    # file.  This is okay because none of the command line args have
    # any side effects which go wrong when done twice.

    if (@ARGV) {
	my @opt;
	for my $name (keys %Option_spec) {
	    my ($short, $type, $in_config, $ref) = @{ $Option_spec{$name} };
	    $short = "|$short" if $short ne '';
	    $type = "=$type" if $type ne '';
	    push @opt, "$name$short$type" => $ref;
	}
	configure_getopt;
	my @orig_argv = @ARGV;
	getopt @opt or usage;
	process_config_file;
	@ARGV = @orig_argv;
	getopt @opt or usage;
	# Allow - to mean '' on the command line, as it does in a config
	# file.
	for (values %Option_spec) {
	    my $r = $_->[3];
	    $$r = '' if defined $$r && $$r eq '-';
	}
    }
    else {
	process_config_file;
    }

    usage if $Do_help;
    if ($Do_version) {
	print "$Me version $VERSION\n";
	exit;
    }
    if ($Debug) {
	require LWP::Debug;
	LWP::Debug::level('+');
    }

    if (defined $Bones_dir) {
	-d $Bones_dir
	    or xdie "--bones-dir $Bones_dir isn't a directory\n";
    }
    else {
    	$Bones_dir = first_dir 'bones', @Bones_dir;
    }
    debug "bones-dir $Bones_dir";

    my $mode = oct $Bones_mode
    	or xdie "invalid --bones-mode $Bones_mode\n";
    $Bones_mode = $mode;

    # If the timestamp file was specified with a relative path, put it
    # in the bones directory.  That's the most useful behavior when
    # running against multiple versions of the game.

    $Last_run_stamp_file = "$Bones_dir/$Last_run_stamp_file"
    	unless $Last_run_stamp_file =~ /^\//;

    # Without this HTTP::Headers will turn the _ into -.

    $HTTP::Headers::TRANSLATE_UNDERSCORE = 0;

    $Lwp_ua = LWP::UserAgent->new;
    $Lwp_ua->agent("$Me/$VERSION " . $Lwp_ua->agent);
    $Lwp_ua->env_proxy;
}

# Create an HTTP::Request object for the given SERVER_CMD_*.

{

my $first_req = 1;
my $client_crc; # postpone calculation until after $Debug is set

sub make_req {
    my ($cmd) = @_;

    $client_crc ||= md5 \do { F_CLIENT . " $VERSION" };

    my $uri = URI->new($Server_url);

    $uri->query_form(act => $cmd);
    my $req = HTTP::Request->new(
		($cmd eq SERVER_CMD_UPLOAD ? 'POST' : 'GET'), $uri);
    $req->header(HEADER_HEARSE_CRC, $client_crc);
    $req->header(HEADER_CLIENT, F_CLIENT);
    $req->header(HEADER_TOKEN, $User_token) if defined $User_token;

    $req->header(HEADER_WANTS_INFO, 'Y') if $first_req;
    $first_req = 0;

    return $req;
} }

# Take a header value or undef, return the string with leading and
# trailing spaces chopped, turning undef into ''.

sub clean_header {
    my ($s) = @_;

    return '' if !defined $s;
    $s =~ s/^\s+//;
    $s =~ s/\s+$//;
    return $s;
}

# Output an HTTP::Message (a request or response) for debugging.

sub debug_http_message {
    my ($r) = @_;

    return unless $Debug;

    my $s = '';

    if ($r->can('status_line')) {
	$s .= sprintf "<- %s\n", $r->status_line;
    }
    else {
	$s .= sprintf "-> %s %s\n", $r->method, $r->uri;
    }

    for (split /\n/, $r->headers_as_string) {
	$s .= "  $_\n";
    }

    my $body = $r->content;
    if (defined $body && $body ne '') {
    	$s .= "  content:\n";
	$body =~ s/([^\x20-\x7e])/sprintf '%%%02X', ord $1/eg;
	my $lines = 0;
	while ($body ne '') {
	    $s .= sprintf "    %s\n", substr $body, 0, 70, '';
	    $body = '[elided]' if ++$lines == 10;
	}
    }

    chomp $s;
    debug $s;
}

# Send a request to the server.  If this fails, die.  If the response
# contains an error or warning, display it.  If it was a fatal error,
# die.  Return a boolean telling whether there was a (non-fatal) error,
# and a response object.

sub server_cmd {
    my ($req) = @_;

    debug_http_message $req;
    my $resp = $Lwp_ua->request($req);
    debug_http_message $resp;

    if (!$resp->is_success) {
	xdie "error contacting server: ", $resp->status_line, "\n";
    }

    my $update	= clean_header $resp->header(HEADER_FORCE_UPDATE);
    my $error	= clean_header $resp->header(HEADER_ERROR);

    # Several parts of the protocol don't have much positive feedback.
    # The bonescheck and upload commands give back a 200 response with no
    # special headers on success.  As a perhaps paranoid guard against
    # talking to something which isn't the server, I've asked Alexis to
    # add HEADER_HEARSE to all the server's responses.

    if (!defined $resp->header(HEADER_HEARSE)) {
	xdie "server response lacks ", HEADER_HEARSE, " header\n";
    }
    elsif ($update ne '') {
    	xdie "server said to update client ($update)\n", $resp->content;
    }
    elsif ($error eq F_ERROR_INFO) {
    	(my $s = $resp->content) =~ s/^INFO: //;
	$s =~ /\S/
	    or xdie "server sent empty info message\n";
	$s =~ s/\n+\z//;
	info $s;
	return 1, $resp;
    }
    elsif ($error ne '') {
    	xwarn "server sent invalid ", HEADER_ERROR, " `$error'\n"
	    if $error ne F_ERROR_FATAL;
    	xdie "server sent error:\n", $resp->content;
    }

    return 0, $resp;
}

# Return true if TOKEN looks like a valid user token.

sub valid_user_token {
    my ($token) = @_;

    return defined $token && length $token && $token !~ /\s/;
}

# Read the user token from $User_token_file and return it if it's valid.

sub read_user_token_from_file {
    local *FILE;
    if (!open FILE, $User_token_file) {
	$! == ENOENT
	    or xdie "$User_token_file exists, but can't be read:";
	return;
    }

    my $token = <FILE>;
    chomp $token if defined $token;
    close FILE
	or xdie "error closing $User_token_file:";
    valid_user_token $token
	or xdie "$User_token_file doesn't contain a valid token,",
		" remove it and try again\n";

    return $token;
}

# Request a new user token from the server and return it.

sub request_new_user_token {
    if (!$User_email) {
    	xdie "you don't have a user token yet,",
	    'run "man hearse" for instructions';
    }

    info "requesting new user account for $User_email";

    my $req = make_req SERVER_CMD_NEW_USER;
    $req->header(HEADER_TOKEN, $User_email);

    my ($had_error, $resp) = server_cmd $req;

    my $token = clean_header $resp->header(HEADER_TOKEN);
    if (!defined $token) {
	xdie "successful response from server, but no token\n";
    }
    if (!valid_user_token $token) {
    	xdie "invalid token returned by server ($token)\n";
    }

    local *FILE;
    mkpath dirname $User_token_file;
    my $old_mask = umask 077;
    if (!open FILE, ">$User_token_file"
    	    or !print FILE "$token\n"
	    or !close FILE) {
	xdie "can't write to $User_token_file:";
    }
    umask $old_mask;

    return $token;
}

# Get $User_token filled in any way possible.

sub get_user_token {
    $User_token = read_user_token_from_file	if !defined $User_token;
    $User_token = request_new_user_token	if !defined $User_token;
    debug "user token = [$User_token]";
}

# Get a lock on the lock file or die.  (There's no unlock step, that
# happens at process exit.)

sub get_lock {
    my $file = $Lock_file;
    $file = $User_token_file if !defined $file;

    debug "lock file [$file]";
    return if !defined $file || $file eq '';

    open LOCK, "+<$file"
	or xdie "can't open $file read/write:";

    my $attempt = 0;
    while (1) {
    	$attempt++;
	flock LOCK, LOCK_EX | LOCK_NB
	    and return;
	info "waiting to lock $file" if $attempt == 1;
	last if $attempt == $Lock_tries;
	debug "sleep $Lock_sleep";
	sleep $Lock_sleep;
    }
    xdie "couldn't lock $file:";
}

# Return the time that the last bones upload was done.

sub last_upload_time {
    my @stat = stat $Last_run_stamp_file;
    my $t = @stat ? $stat[ST_MTIME] : 0;
    debug "last run ", scalar localtime $t;
    return $t;
}

# Set the last run time to now.

sub update_last_upload_time {
    local *FILE;

    debug "touch $Last_run_stamp_file";
    if (!open FILE, ">$Last_run_stamp_file"
    	    or !close FILE) {
	xdie "error writing to $Last_run_stamp_file:";
    }
}

# Return true if BONES is a valid uncompressed bones file name.

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

    # bon<dungeon code><0 | role code>.<level boneid | level number>

    return 
        # NetHack
        $file =~ /^bon[A-Z](0|$Role_re)\.([A-Z]|\d+)\z/i ||

        # Crawl
        $file =~ /^bones\.(?:\d\d[a-z]|lab)\z/i;
}

# Given a PATH, return the file name to use with the server and an
# open() arg used to read it.  This handles both removing directories
# from the path and undoing compression.  The open() might be on a
# pipe, so you can't expect to seek in the resulting filehandle.

sub crack_bones_file_name {
    my ($path) = @_;

    my $compressed = basename $path;

    # A bones file might be called bonG0.Z, so I have to avoid stripping
    # the .Z (which could also be compression).  Only try for uncompression
    # if the file name isn't already valid.

    my $uncompressed = valid_bones_file_name($compressed)
			? $compressed
			: basename $compressed, @Compress_suffix;

    return $uncompressed, ($compressed eq $uncompressed)
			    ? $path
			    : "$Decompress_cmd \Q$path\E|";
}

# Return true if a file named BONES (possibly compressed) exists locally.

sub bones_exists_locally {
    my ($bones_name) = @_;

    for my $ext ('', @Compress_suffix) {
	return 1 if stat "$Bones_dir/$bones_name$ext";
    }
    return 0;
}

# Figure out what kind of bonesfile we have, and return an appropriate foo.
sub get_bones_handler {
    my ($bones_name, $foo) = @_;

    xdie "No handler for null bones files\n" unless $bones_name;

    for my $handler (@Bones_handlers) {
        return $handler->[$foo] if ($bones_name =~ $handler->[0]);
    }
    xdie "Strange bones file: $bones_name\n";
    return;
}

sub get_nh_bones_version {
    my $rdata = shift;

    # The 4 version numbers are stored by Nethack as 4 unsigned longs
    # in host byte order at the start of the file.  I don't want to
    # read them in host order, though, because that would mask byte sex
    # differences between platforms.
    #
    # If the platform's longs aren't 4 bytes, though, I've got a
    # separate problem.  I need to read the right number of bytes
    # else I'll only get part of the version data, and what I do get
    # will end up in the wrong places.  I test for this using Perl
    # 5.6's 'L!' pack format (and just hope for the best for earlier
    # versions).  I haven't actually written the code to deal with
    # this case yet (it needs special handling because there's no
    # format to read a native-sized long but with a specific byte
    # order), I just detect it and choke.

    # punt for Perl < 5.6
    my $ulong_size = eval { length pack 'L!', 0 } || 4; 

    if ($ulong_size != 4) {
        xdie "size of unsigned long is $ulong_size rather than 4\n";
    }

    # struct version_info {
    #     unsigned long   incarnation;    /* actual version number */
    #     unsigned long   feature_set;    /* bitmask of config settings */
    #     unsigned long   entity_count;   /* # of monsters and objects */
    #     unsigned long   struct_sizes;   /* size of key structs */
    # };

    return unpack 'V' x HEADER_VERSION_COUNT, $$rdata;
}

# Note that this function actually modifies the input bones data.
sub get_crawl_bones_version {
    xdie "No bones data to obtain version from\n" unless @_;
    my $rdata = shift;

    # Crawl stores two bytes of bones version information. Note that
    # multiple Crawl versions may use the same bones version - all
    # bones-compatible Crawl binaries will use the same bones version.
    #
    # Hearse wants the bones version info in 4 longs, so we read our 2-byte
    # version info (network order, just as Crawl saves it), shift it into
    # the high word of the first long, and set the three remaining longs to
    # 0.
    #
    # Note that we don't care how big the platform's longs are, as we do for
    # NetHack's bones files, since Crawl's version info is not saved in
    # native-architecture longs, but in simple bytes.

    my @version = ((unpack 'n', $$rdata) << 16, 0, 0, 0);
    # Shove the version longs back into the bones file data, little-endian.
    $$rdata = (pack 'V' x HEADER_VERSION_COUNT, @version) . $$rdata;
    return @version;
}

sub unmangle_crawl_bones {
    xdie "No bones data to unmangle\n" unless @_;
    
    my $rdata = shift;
    # Strip off pseudo-version information we added.
    $$rdata = substr $$rdata, length(pack 'V') * HEADER_VERSION_COUNT;
}

sub read_version {
    my $bones_name = shift;
    return &{get_bones_handler($bones_name, BONES_VERSION_READER)}(shift);
}


# Load a bones file.  Return a list:  reference to bones data, CRC,
# VERSION_1/2/3/4.

sub load_bones {
    my ($bones_name, $open_spec) = @_;
    my ($data, $md5, @version);
    local *FILE;

    if (!open FILE, $open_spec) {
	xwarn "can't read $open_spec:";
	return;
    }
    binmode FILE;
    $data = do { local $/; <FILE> };
    if (!close FILE) {
	xwarn "error reading $open_spec: ", ${!} ? "$!\n" : "exit status $?\n";
	return;
    }

    # read_version() may change $data, depending on what kind of bones file we
    # have here.
    @version = read_version($bones_name, \$data);

    if (@version != HEADER_VERSION_COUNT) {
	xwarn "$open_spec is too short (", length($data), ")\n";
	return;
    }
    $md5 = md5 \$data;

    debug "file $bones_name";
    debug "         size ", length $data;
    debug "    version $_ $version[$_]" for 0..$#version;
    debug "          md5 $md5";

    return \$data, $md5, @version;
}

# Add the headers describing a bones file to an HTTP::Request.

sub add_bones_info_to_req {
    my ($req, $bones_name, $md5, @version) = @_;

    $req->header(HEADER_FILE_NAME, $bones_name);
    $req->header(HEADER_BONES_CRC, $md5);
    for (1..HEADER_VERSION_COUNT) {
	$req->header(HEADER_VERSION . $_, $version[$_ - 1]);
    }

    if (my $bones_type = get_bones_handler($bones_name, BONES_TYPE)) {
        $req->header(HEADER_BONES_TYPE, $bones_type);
    }
}

# Try to upload the given bones file to the server.  Return true if it
# was accepted.

sub upload_one_bones {
    my ($bones_name, $open_spec) = @_;
    local *FILE;

    info "$bones_name offering to server";
    debug "open_spec = [$open_spec]";

    my ($rdata, @bones_info) = load_bones $bones_name, $open_spec
	or return;
    unshift @bones_info, $bones_name;

    my $req;
    my ($had_error, $resp);

    # Ask the server whether it wants this bones file, but only if the bones
    # file is large-ish (large-ish being defined as more than 80 bytes for our
    # purposes). The request for confirming the upload will be more overhead
    # than just sending the file straight for very small bones files.
    if (length($$rdata) > 80) {
        $req = make_req SERVER_CMD_BONES_CHECK;
        add_bones_info_to_req $req, @bones_info;

        # Send the info about this bones file to the server.

        ($had_error, $resp) = server_cmd $req;
        # If the server doesn't want this file it returns an informational
        # error, which was printed by server_cmd.

        return if $had_error;
    }

    # Upload the file.

    $req = make_req SERVER_CMD_UPLOAD;
    $req->header('Content-Type', 'application/octet-stream');
    $req->header('Content-Transfer-Encoding', 'binary');
    add_bones_info_to_req $req, @bones_info;
    $req->content($$rdata);

    ($had_error, $resp) = server_cmd $req;
    info $had_error
	? "$bones_name upload failed"
	: "$bones_name uploaded";
    return !$had_error;
}

# Upload all the new bones files.  Return 2 booleans:  Whether any were
# accepted (and so I should try to download), and whether the last
# upload timestamp should be updated.

sub upload_new_bones {
    my ($since) = @_;

    my $any_tried = 0;
    my $any_uploaded = 0;

    local *DIR;
    opendir DIR, $Bones_dir
	or xdie "can't opendir $Bones_dir:";
    while (defined(my $file = readdir DIR)) {
    	my $path = "$Bones_dir/$file";
	my ($bones_name, $open_spec) = crack_bones_file_name $path;

    	# Skip non-bones files.

	next unless valid_bones_file_name $bones_name;

	# Keep track of the bones files present on this machine, the
	# server will want to know when the time comes to download.

	push @Local_bones, $bones_name;

	# Skip files created before the last time I uploaded.

	my @stat = stat $path;
	if (!@stat) {
	    xwarn "can't stat $path:";
	    next;
	}
	next unless $stat[ST_MTIME] > $since;

	info 'uploading bones' unless $any_tried;
    	$any_tried = 1;
	if (upload_one_bones $bones_name, $open_spec) {
	    $any_uploaded = 1;
	    if ($Delete_uploaded) {
		if (unlink $path) {
		    info "$bones_name deleted";
		    $bones_name eq pop @Local_bones or die;
		}
		else {
		    xwarn "error deleting $path:"
		}
	    }
	}
    }
    closedir DIR or xdie "error closing directory $Bones_dir:";

    info "no bones to upload" if !$any_tried && !$Quiet_cron;

    # The second returned boolean tells whether the last upload timestamp
    # should be updated.  My strategy is to update it any time I offered
    # bones to the server and didn't get a fatal error, even if the server
    # didn't accept the bones.
    #
    # The Windows implementation only updates the timestamp if the
    # server accepts at least one bones file.  There's a common case
    # for which this doesn't work when bones files are compressed:  If
    # you use "nethack -D" to check out a bones file without unlinking
    # it, nethack will uncompress then recompress it, thereby updating
    # it.  The next time I run I'll see it as new, and so I'll offer
    # it to the server.  The server rejects it since it already has
    # that one.  If there are no other local bones, I'll exit without
    # updating the timestamp, so the same thing will happen again on
    # the next run.
    #
    # To avoid this I update the timestamp whenever I offer any bones to
    # the server and I don't get a fatal error.  (I could update it even
    # when I don't offer any bones to the server, I don't just to avoid
    # the useless updates to the timestamp file for when I'm being run
    # often.)

    return $any_uploaded, $any_tried;
}

# Write a bones file called BONES using the given data.

sub write_bones {
    my ($bones_name, $rdata) = @_;
    local *FILE;

    my $unmangle = get_bones_handler($bones_name, BONES_UNMANGLER);
    &$unmangle($rdata) if defined $unmangle;

    my $already_have = "tried to write $bones_name,"
	    . " but we already have a bones file with that name\n";

    # Compression and Nethack's lack of locking make it impossible to do
    # this without races.  At least give it a shot.

    if (bones_exists_locally $bones_name) {
	xwarn $already_have;
	return;
    }

    my $tmp_path = "$Bones_dir/tmp.$Me.$bones_name";
    my $real_path = "$Bones_dir/$bones_name";

    my $unlink = sub {
    	unlink $tmp_path or xwarn "error unlinking $tmp_path:";
    };

    my $old_mask = umask 0;
    if (!sysopen FILE, $tmp_path, O_WRONLY | O_CREAT, $Bones_mode) {
	xwarn "can't write to $tmp_path:";
    	umask $old_mask;
	return;
    }
    binmode FILE;
    umask $old_mask;

    if (!print FILE $$rdata or !close FILE) {
    	xwarn "error writing to $tmp_path:";
    	$unlink->();
	return;
    }

    # When Nethack creates a bones file, it checks whether the file exists
    # before starting, then does a rename() at the end.  It doesn't care about
    # the race (somebody might have created one after the initial test), there's
    # no locking at all.  I do care about the race, though -- if somebody else
    # was playing on the system and they created a bones file in the interim,
    # I'd rather leave them the one they created than one I downloaded.

    # First, try linking the temporary name to the final name.  This fails if
    # the final name already exists.

    # link() appears to choke on some Windows perls, so we don't try it there.
    # Might we also need this hack for OS/2?

    if (!($^O eq 'MSWin32'? (rename $tmp_path, $real_path) : 
                            (link $tmp_path, $real_path))) {
	xwarn $already_have;
	$unlink->();
	return;
    }

    # Drop the temporary name. If we're on Windows, don't, since this file
    # doesn't exist any more (we renamed it to the real path upstairs).

    $unlink->() unless $^O eq 'MSWin32';

    # A bones file with this name might have been created and compressed
    # in the interim.  There's no safe way to deal with that (if I try
    # to erase mine, there's a separate race if another game tries to
    # used the compressed one (it overwrites mine)).  Having the
    # compressed one be used in preference to mine is the best course
    # anyway, so don't do anything special to try to detect a compressed
    # one at this point.

    return 1;
}

# Try to download one bones file.  Return true if successful.

sub download_one_bones {
    my $req = make_req SERVER_CMD_DOWNLOAD;
    $req->header(HEADER_USER_LEVELS,
    	    	    # The server chokes if you don't have any local
    	    	    # levels, but this can happen if you use
    	    	    # --delete-uploaded or --force-download.  Fill in a
    	    	    # bogus value to appease it.
		    join ',', @Local_bones ? @Local_bones : 'himom');

    my ($had_error, $resp) = server_cmd $req;
    return if $had_error;

    my $bones_name = clean_header $resp->header(HEADER_FILE_NAME);
    if (!defined $bones_name) {
	xdie "server didn't specify bones file name\n";
    }
    elsif (!valid_bones_file_name $bones_name) {
	xdie "server specified invalid bones file name `$bones_name'\n";
    }

    my $her_md5 = clean_header $resp->header(HEADER_BONES_CRC);
    if (defined $her_md5) {
    	my $my_md5 = md5 \$resp->content;
	if (lc $her_md5 ne lc $my_md5) {
	    xdie "downloaded file $bones_name has CRC mismatch,",
		    " hers $her_md5 mine $my_md5\n";
	}
    }

    # write_bones() tells me whether it was successful or not, but I
    # don't want to behave differently if it wasn't.  The server might
    # have sent me a bones which wasn't in @Local_bones but which was
    # created here since.

    if (write_bones $bones_name, $resp->content_ref) {
    	info "downloaded $bones_name";
	push @Local_bones, $bones_name;
    }

    return 1;
}

# Download as many bones files as the server will give us.

sub download_all_bones {
    info 'downloading bones';
    1 while download_one_bones;
}

sub main {
    init;
    @ARGV and usage "unknown non-switch args: @ARGV\n";

    get_user_token;

    # Don't bother trying to take a lock on Windows. This does introduce a mild
    # threat of concurrent hits on the server, but not all Windows perls seem
    # to have flock().
    get_lock unless $^O eq 'MSWin32';

    # Wait until after get_user_token and get_lock to drop privs, so I
    # can write to the directory containing $User_token_file, and the
    # lock file.

    set_ugid;

    my $since = last_upload_time;
    my ($uploaded, $do_update) = upload_new_bones $since;

    # The protocol says you only ask the server for bones if you uploaded
    # any.  Normally this is the only time any will be given to you anyway.
    # It can also happen when a new variant is opened up and there isn't a
    # reserve of bones built up yet.  The server remembers how many it owes
    # you in this case, but you'll only get them the next time you upload a
    # bones file.

    download_all_bones if $uploaded || $Force_download;

    # Wait until after downloading to update the timestamp as an easy
    # way to avoid trying to upload something I downloaded.  XXX An
    # unfortunate consequence is that a bones created locally while I'm
    # downloading will never be uploaded.

    update_last_upload_time if $do_update;

    return 0;
}

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

__END__

=head1 NAME

hearse - exchange Nethack and Crawl bones files with other players

=head1 SYNOPSIS

B<hearse>
[B<-b> | B<--bones-dir> I<dir>]
[B<--bones-mode> I<mode>]
[B<-c> | B<--config-file> I<file>]
[B<--cron>]
[B<--debug>]
[B<--delete-uploaded>]
[B<--help>]
[B<--lock-file> I<file>]
[B<-q> | B<--quiet>]
[B<--run-as-me>]
[B<--run-as-user> I<user>]
[B<--run-as-group> I<group>]
[B<--server-url> I<url>]
[B<--stamp-file> I<file>]
[B<--user-email> I<address>]
[B<--user-token> I<token>]
[B<--user-token-file> I<file>]
[B<--version>]

=head1 DESCRIPTION

Nethack sometimes saves the level on which you die (including your
stuff, what killed you, and your ghost) in a "bones file".  These files
get loaded into later Nethack games.  If you're the only Nethack player
on your system you'll only get bones files you created yourself.

B<hearse> lets you automatically exchange Nethack bones file with other
players.  When run it uploads any new bones files it finds on your
system, then downloads any bones files the server feels like giving it.
See L<http://www.argon.org/~roderick/hearse/> for more information.

In order to use the Hearse server, you've got to supply your email
address.  Do this by using the B<--user-email> switch the first time
you use the program, or by putting C<user-email I<address>> in the
config file.  Your email address will only be used to contact you
about Hearse, and will never be given to any third party.  If you
enter an invalid address, the server won't be able to support you if
you download a bad bones file, and will be forced to ban you if any of
your uploaded files are bad.

Hearse was set up as a service to the Nethack community.  Please respect
that; abuse of the service can only lead to it being removed.

Hearse also supports Dungeon Crawl bones files, but the support for 
Crawl is still experimental.

=head1 QUICK START

The defaults are set up for a Linux system using a nethack binary which
is either set-uid or set-gid games.  If this is what you've got, as root
run

    # hearse --user-email your@address.com

one time by hand, then put

    0 3 * * * root perl -we 'sleep rand 3600'; hearse --quiet

in /etc/crontab.

=head1 CONFIGURATION

B<hearse> comes with default values for its various configuration
settings which match the way many Linux systems are set up.  If any
of them don't match your system, you can either change them in a
configuration file, or you can specify the right values via command
line switches.  This last isn't as onerous as it sounds, because most
people run it from cron.  You can put the switches in the crontab
file and leave it at that.  If you'd rather use a configuration file,
you can use the default location (/etc/nethack/hearse.conf), or use
the B<-c> (aka B<--config-file>) switch to specify the file you'd
like to use.

The configuration file can specify all of the options for which it makes
sense, using the long version of the option name followed by the value.
Blank and commented lines are ignored in the usual fashion.  A string
value can be given as C<-> to mean the empty string.  Booleans can use
on/off/true/false/yes/no/1/0.  A sample F<hearse.conf> is included with
the distribution.  Eg,

    bones-dir		/local/games/nethackdir
    bones-mode		600
    quiet		on
    run-as-user		daemon
    run-as-group	-
    user-token-file	/local/games/nethackdir/hearse.user-token

=head1 PRIVILEGES

B<hearse> needs to run with permissions like those used by Nethack/Crawl
itself, so that it can read and write the bones files.  It should not
made set-uid or set-gid, though; it hasn't been audited for that.

The default configuration will try to set both the user and group ids to
C<games>.  Nethack itself will generally only be set-id to either one or
the other, but using both hurts nothing and allows B<hearse> to run
as-is on more systems.  This will only work if you run B<hearse> as
root.

For Dungeon Crawl, you'll probably want to set the group id to C<root>.

If you want to disable B<hearse>'s id setting and take care of it
externally you can use the B<--run-as-me> switch to turn it off, or
the B<--run-as-user> and B<--run-as-group> switches for finer grained
control.  Specify C<''> or C<-> for either of the latter to disable
just that thing.

On Windows, C<hearse> will not attempt to set user or group id unless
explicitly asked to do so (by means of command-line switches or the config
file), i.e. B<--run-as-me> is implied.

=head1 RUNNING FROM CRON

The normal way to use the program is to run it from cron, either daily or
on whatever schedule you like.  (There's no harm in running it often, if
it doesn't find any new bones files it doesn't even contact the server.)
If letting it manage its own permissions, you'd just run it as root.  Eg,
to run it some time in the 3:00 hour, put something like

    0 3 * * * root perl -we 'sleep rand 3600'; hearse --quiet

in /etc/crontab.  The randomization is to prevent the server from getting
hammered at the top of each time zone's 3:00 hour.

If you'd like to see what the server's doing, you can use B<--cron> rather
than B<--quiet>.  This will cause it to output its status message, but
only when it actually transfers a bones file.

=head1 RUNNING FOR MULTIPLE NETHACK VARIANTS (AND DUNGEON CRAWL)

If you use multiple Nethack variants which are supported by the Hearse
server, you can run B<hearse> for all of them.  The normal way to do
this is to run B<hearse> once for each variant, specifying the bones
directory on the command line

    # hearse -b /var/games/slashem

For Dungeon Crawl, you'd probably use something like (running with root
permissions)
    
    # hearse -b /opt/crawl/lib --run-as-me

leaving the rest of the configuration settings to be read from the
configuration file.  The last upload time is by default stored in the
bones directory, so everything just works.

The Hearse protocol requires that you have only a single concurrent
connection for each user account (it decides what kind of bones file to
send you based on the kind you most recently uploaded), so B<hearse>
does locking on the user token file in order to ensure this.  See the
B<--lock-file> switch for more info.

=head1 OPTIONS

=over 4

=item B<-b>, B<--bones-dir> I<dir>

Specify the bones directory.  By default the program uses the first of
/var/games/nethack, /usr/games/lib/nethackdir, /opt/crawl/lib and the current
directory, whichever exists.  The current directory option is intended for
Windows users.

=item B<--bones-mode> I<mode>

Specify the mode for the bones files B<hearse> creates.  The default is
660.

=item B<-c>, B<--config-file> I<file>

Specify an alternative configuration file.  The default is
/etc/nethack/hearse.conf.

=item B<--cron>

Suppress the "no bones to upload" message.  This makes it so that there's
no output at all when there's nothing to do, but you still see what's
going on when bones files are transfered.  This is a nice way to run it
from cron if you want to keep an eye on it.

=item B<--debug>

Turn debugging on.

=item B<--delete-uploaded>

Delete locally generated bones files after uploading them.  Some people
might want to do this in order to avoid changing the game's balance.
Since the server normally gives you 1 bones file for each one you upload,
if you delete your local bones after uploading them you'll end up with
the same number of bones you otherwise would have had, but they'll be
somebody else's rather than your own.

=item B<--help>

Show the usage message and die.

=item B<--lock-file> I<file>

The Hearse protocol requires that B<hearse> do locking to be sure that
only a single connection per user can happen at a time.  It does this by
locking the B<--user-token-file>.  You should not generally change this,
but if you have special requirements (that that file be read only, eg),
you can override it with this switch.  Use C<''> to disable locking
(which I do not recommend).

=item B<-q>, B<--quiet>

Don't output information messages.

=item B<--run-as-me>

Turn off both B<--run-as-user> and B<--run-as-group>.

=item B<--run-as-user> I<user>

Use I<user> as the real and effecitve user id, default C<games>.  You've
generally got to be root for this to work.

=item B<--run-as-group> I<group>

Use I<group> as the real and effecitve group id, default C<games>.
You've generally got to be root for this to work.

=item B<--server-url> I<url>

Specify the URL for the server program.  See the source or the B<--help>
message for the default.

=item B<--stamp-file> I<file>

B<hearse> only tries to upload bones files which were created since the
last time it sucessfully talked to the server.  The modification time of
the B<--stamp-file> (F<.hearse.timestamp> by default) tells it when that
was.  This path is taken relative to the B<--bones-dir> (unless it's
absolute).

=item B<--user-email> I<address>

Specify your email address.  You only have to do this the first time you
run B<hearse>.

=item B<--user-token> I<token>

Specify your user token directly.  You won't normally need to do this,
as B<hearse> requests the token from the server and stores it in the
B<--user-token-file> for later retrieval.

=item B<--user-token-file> I<file>

Specify the file used to store the user token, by default
F</etc/nethack/hearse.user-token>.

=item B<--version>

Show the version number and exit.

=back

=head1 AVAILABILITY

The code is licensed under the GNU GPL.  Check
L<http://www.argon.org/~roderick/hearse/> for updated versions.

=head1 AUTHOR

This Unix client was written by Roderick Schertler <roderick@argon.org>.
The client was modified to support Dungeon Crawl by Darshan Shaligram
<darshansk@yahoo.com>.
The Hearse protocol, server, and Windows client were written by Alexis
Manning <alexismanning@bigfoot.com>.

=cut