0ct0pu5/wesnoth
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cleaned the utils dir of some obsolete and/or non-functional scripts

Browse source
This commit is contained in:
Gunter Labes 2009-06-16 01:50:42 +00:00
parent fee0c34b87
commit 4af80f26ce
8 changed files with 2 additions and 1517 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
utils/README
View file

@ -1,6 +1,6 @@
This is a directory of miscellaneous developer tools for Battle Of Wesnoth,
This is a directory of miscellaneous developer tools for Battle for Wesnoth,
mostly to support packaging, code integrity checks, and control of the
Wesnoth campaign server.
Wesnoth servers.
Tools that work on data (WML, maps, images, sounds) no longer belong here.
Go to data/tools for those.

103
utils/SConstruct
View file

@ -1,103 +0,0 @@
# vi: syntax=python
import glob
"""
Runs this as:
scons -f utils/SConstruct [editor=1] [server=1]
from within the wesnoth toplevel directory. It expects to have all kinds of
windows dependencies in the parent directory, like this:
../wesnoth/(you are here)
../win-deps/...
and it will create/use a build directory in the parent folder as well:
../build/...
For details see the cross-compiling instructions on the Wiki.
"""
editor = ARGUMENTS.get("editor", "")
wesnothd = ARGUMENTS.get("server", "")
#sources = glob.glob("src/*.cpp") +\
# glob.glob("src/widgets/*.cpp") +\
# glob.glob("src/serialization/*.cpp") +\
# glob.glob("src/sdl_ttf/*.c")
#sources.remove("src/loadscreen_empty.cpp")
#sources.remove("src/animated_editor.cpp")
def parse_automake(filename, variable):
"""Crude helper function to parse an automake file."""
sources = []
am = file(filename).read()
x = am.find(variable)
while 1:
done = False
while am[x] != '\\':
if am[x] == '\n':
done = True
break
x += 1
if done: break
x += 1
while am[x].isspace(): x += 1
name = ""
while not am[x].isspace():
name += am[x]
x += 1
sources.append("src/" + name)
return sources
# read the sources from the automake file
sources = parse_automake("src/Makefile.am", "libwesnoth_core_a_SOURCES")
sources += parse_automake("src/Makefile.am", "wesnoth_SOURCES")
# there shouldn't be doubles, but well, let's remove them :)
sources = list(set(sources))
# read editor sources from automake file
editor_sources = parse_automake("src/Makefile.am", "libwesnoth_core_a_SOURCES")
editor_sources += parse_automake("src/Makefile.am", "wesnoth_editor_SOURCES")
editor_sources = list(set(editor_sources))
# read the server sources from the automake file
wesnothd_sources = parse_automake("src/Makefile.am", "libwesnoth_core_a_SOURCES")
wesnothd_sources += parse_automake("src/Makefile.am", "wesnothd_SOURCES")
wesnothd_sources = list(set(wesnothd_sources))
env = Environment()
# The cross compiler to use
env["CC"] = "i586-mingw32msvc-gcc"
env["CXX"] = "i586-mingw32msvc-g++"
# Dependencies: SDL, SDL_net, SDL_mixer, SDL_image, freetype, libintl
# This is where I put the dependency headers
env.Append(CPPPATH = ["../win-deps/include"])
# This is where I put the dependency libs
env.Append(LIBPATH = ["../win-deps/lib"])
# Compilation settings
env.Append(CCFLAGS = ["-O2", "-mthreads", "-DHAVE_PYTHON"])
env.Append(LINKFLAGS = ["-s", "-mwindows", "-lmingwthrd"])
env.Append(CPPPATH = ["src", "src/widgets"])
env.Append(LIBS = ["mingw32", "SDLmain", "SDL", "SDL_net", "SDL_mixer", "SDL_image",
"intl", "wsock32", "freetype", "boost-iostreams", "z"])
# Scons stuff
env.BuildDir("../build", "src")
env.SConsignFile("sconsign")
# Windows stuff
env["PROGSUFFIX"] = ".exe"
# Compile it!
env.Program("wesnoth", ["../build/" + x[4:] for x in sources])
if editor:
env.Program("wesnoth_editor", ["../build/" + x[4:] for x in editor_sources])
if wesnothd:
env.Program("wesnothd", ["../build/" + x[4:] for x in wesnothd_sources])

387
utils/mp-lobby-logger.pl
View file

@ -1,387 +0,0 @@
#!/usr/bin/perl
use strict;
use warnings;
use wml;
use IO::Socket;
use POSIX qw(strftime);
use Getopt::Std;
use Data::Dumper;
#my $usage = "Usage: $0 [-dgjnqs] [-e count] [-l logfile] [-h [host]] [-p [port]] [-t [timestampformat]] [-u username]";
my %opts = ();
getopts('dgjqsl:ne:h:p:t:u:',\%opts);
my $USERNAME = 'log';
$USERNAME = $opts{'u'} if $opts{'u'};
my $HOST = '127.0.0.1';
$HOST = 'server.wesnoth.org' if exists $opts{'h'};
$HOST = $opts{'h'} if $opts{'h'};
my $PORT = '15000';
$PORT = '14999' if exists $opts{'p'};
$PORT = $opts{'p'} if $opts{'p'};
my $logtimestamp = "%Y%m%d %T ";
my $timestamp = "%Y%m%d %T ";
$timestamp = $opts{'t'} if $opts{'t'};
$timestamp = '' unless exists $opts{'t'};
my $writestats = $opts{'s'};
my $statsfile = "/tmp/wesnoth.stats_" . $HOST . "_" . $PORT;
my $showjoins = $opts{'j'};
my $showgames = $opts{'g'};
my $showturns = $opts{'n'};
my $dumpunknown = $opts{'d'};
my $quiet = $opts{'q'};
my $logfile = $opts{'l'};
if (exists $opts{'l'}) {open(LOG, ">> $logfile") or die "can't open $logfile: $!";}
select LOG; $| = 1;
my $LOGIN_RESPONSE = "[login]\nusername=\"$USERNAME\"\n[/login]";
my $VERSION_RESPONSE = "[version]\nversion=\"test\"\n[/version]";
my @users = ();
my @games = ();
my %outgoing_schemas = ();
my %incoming_schemas = ();
sub connect($$) {
my ($host,$port) = @_;
my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port, Proto => 'tcp', Type => SOCK_STREAM)
or die "Could not connect to $host:$port: $@\n";
print $sock pack('N',0) or die "Could not send initial handshake";
my $connection_num = "";
read $sock, $connection_num, 4;
die "Could not read connection number" if length($connection_num) != 4;
$outgoing_schemas{$sock} = [];
$incoming_schemas{$sock} = [];
return $sock;
}
sub disconnect($) {
my ($sock) = @_;
delete($outgoing_schemas{$sock});
delete($incoming_schemas{$sock});
close $sock;
}
sub read_packet($) {
my ($sock) = @_;
my $buf = '';
read $sock, $buf, 4;
die "Could not read length" if length($buf) != 4;
my $len = unpack('N',$buf);
my $res = "\0";
my $count = 0;
while($len > $count) {
$buf = '';
my $bytes = $len - $count;
read $sock, $buf, $bytes or die "Error reading socket: $!";
substr($res, $count, length $buf) = $buf;
$count += length $buf;
}
$res = substr($res,0,$len-1);
return &wml::read_binary($incoming_schemas{$sock},$res);
}
sub write_packet($$) {
my ($sock,$doc) = @_;
my $data = &wml::write_binary($outgoing_schemas{$sock},$doc);
$data .= chr 0;
my $header = pack('N',length $data);
print $sock "$header$data" or die "Error writing to socket: $!";
}
sub write_bad_packet($$) {
my ($sock, $doc) = @_;
my $data = &wml::write_binary($outgoing_schemas{$sock},$doc);
$data .= chr 0;
my $header = pack('N', (length $data) * 2);
print $sock "$header$data" or die "Error writing to socket: $!";
}
sub timestamp {
return strftime($timestamp, localtime());
}
sub logtimestamp {
return strftime($logtimestamp, localtime());
}
sub login($) {
my $sock = shift;
my $response;
my $tries = 0;
my $logged_in = 'no';
until($logged_in eq 'yes') {
$tries++;
$response = &read_packet($sock);
#print STDERR Dumper($response);
# server asks for the version string
if (&wml::has_child($response, 'version')) {
$logged_in = 'version';
$tries = 0;
&write_packet($sock, &wml::read_text($VERSION_RESPONSE));
# server asks for a login name
} elsif (&wml::has_child($response, 'mustlogin')) {
$logged_in = 'mustlogin';
$tries = 0;
&write_packet($sock, &wml::read_text($LOGIN_RESPONSE));
# server sends the join lobby response
} elsif (&wml::has_child($response, 'join_lobby')) {
$logged_in = 'join_lobby';
$tries = 0;
# server sends the initial list of games and players
} elsif (&wml::has_child($response, 'gamelist')) {
$logged_in = 'yes';
foreach (@ {$response->{'children'}}) {
if ($_->{'name'} eq 'gamelist') {
@games = @ {$_->{'children'}};
} elsif ($_->{'name'} eq 'user') {
$users[@users] = $_;
}
}
} elsif (my $error = &wml::has_child($response, 'error')) {
print STDERR "Error: $error->{'attr'}->{'message'}.\n" and die;
} else {
if ($logged_in eq 'no') {
print STDERR "Warning: Server didn't ask for version or login yet and gave no error. ($tries)\n" . Dumper($response);
} elsif ($logged_in eq 'version') {
print STDERR "Warning: Server didn't ask us to log in yet and gave no error. ($tries)\n" . Dumper($response);
} elsif ($logged_in eq 'mustlogin') {
print STDERR "Warning: Server didn't ask us to join the lobby yet and gave no error. ($tries)\n" . Dumper($response);
} elsif ($logged_in eq 'join_lobby') {
print STDERR "Warning: Server didn't send the initial gamelist yet and gave no error. ($tries)\n" . Dumper($response);
}
# give up after 10 unknown packets
print STDERR "Giving up...\n" if $tries == 10 and die;
}
}
my $userlist = @users . " users:";
foreach (@users) {
$userlist .= " " . $_->{'attr'}->{'name'};
}
$userlist .= "\n";
print STDERR $userlist if $showjoins;
print LOG $userlist if $logfile;
my $gamelist = @games . " games:";
foreach (@games) {
$gamelist .= " \"" . $_->{'attr'}->{'name'} . "\"";
}
$gamelist .= "\n";
print STDERR $gamelist if $showgames;
print LOG $gamelist if $logfile;
}
sub serverstats() {
open STATS, ">" . $statsfile;
print STATS "users: " . ($#users + 1) . "\ngames: " . ($#games + 1) . "\n";
close STATS;
}
# make several connections and send packets with a wrong length then sleep indefinitely
if (my $count = $opts{'e'}) {
for (1..$count) {
my $socket = &connect($HOST,$PORT);
&write_bad_packet($socket, &wml::read_text($VERSION_RESPONSE));
}
sleep();
}
print STDERR "Connecting to $HOST:$PORT as $USERNAME.\n" unless $quiet;
print LOG "Connecting to $HOST:$PORT as $USERNAME.\n" if $logfile;
my $socket = &connect($HOST,$PORT);
defined($socket) or die "Error: Can't connect to the server.";
&login($socket);
&serverstats() if $writestats;
while (1) {
my $response = &read_packet($socket);
foreach (@ {$response->{'children'}}) {
if ($_->{'name'} eq 'message') {
my $sender = $_->{'attr'}->{'sender'};
my $message = $_->{'attr'}->{'message'};
if ($message =~ s,^/me,,) {
print STDERR &timestamp . "* $sender$message\n" unless $quiet;
print LOG &logtimestamp . "* $sender$message\n" if $logfile;
} else {
print STDERR &timestamp . "<$sender> $message\n" unless $quiet;
print LOG &logtimestamp . "<$sender> $message\n" if $logfile;
}
} elsif ($_->{'name'} eq 'whisper') {
my $sender = $_->{'attr'}->{'sender'};
my $message = $_->{'attr'}->{'message'};
if ($message =~ s,^/me,,) {
print STDERR &timestamp . "*$sender$message*\n" unless $quiet;
print LOG &logtimestamp . "*$sender$message*\n" if $logfile;
} else {
print STDERR &timestamp . "*$sender* $message\n" unless $quiet;
print LOG &logtimestamp . "*$sender* $message\n" if $logfile;
}
} elsif ($_->{'name'} eq 'gamelist_diff') {
foreach (@ {$_->{'children'}}) {
my $userindex = $_->{'attr'}->{'index'};
if ($_->{'name'} eq 'insert_child') {
if (my $user = &wml::has_child($_, 'user')) {
my $username = $user->{'attr'}->{'name'};
print STDERR &timestamp . "--> $username has logged on. ($userindex)\n" if $showjoins;
print LOG &logtimestamp . "--> $username has logged on. ($userindex)\n" if $logfile;
my $index = @users;
print STDERR "Warning: userlist out of sync: local index = $index vs remote index = $userindex\n" if $userindex != $index;
$users[$index] = $user;
&serverstats() if $writestats;
} else {
print STDERR "[gamelist_diff]:" . Dumper($_) if $dumpunknown;
}
} elsif ($_->{'name'} eq 'delete_child') {
if (my $user = &wml::has_child($_, 'user')) {
my $username = $users[$userindex]->{'attr'}->{'name'};
print STDERR &timestamp . "<-- $username has logged off. ($userindex)\n" if $showjoins;
print LOG &logtimestamp . "<-- $username has logged off. ($userindex)\n" if $logfile;
splice(@users,$userindex,1);
&serverstats() if $writestats;
} else {
print STDERR "[gamelist_diff]:" . Dumper($_) if $dumpunknown;
}
} elsif ($_->{'name'} eq 'change_child') {
if (my $user = &wml::has_child($_, 'user')) {
foreach (@ {$user->{'children'}}) {
if ($_->{'name'} eq 'insert' and $userindex < @users) {
my $username = $users[$userindex]->{'attr'}->{'name'};
if ($_->{'attr'}->{'available'} eq "yes") {
my $game_id = $users[$userindex]->{'attr'}->{'game_id'};
my $location = $users[$userindex]->{'attr'}->{'location'};
$users[$userindex]->{'attr'}->{'game_id'} = "";
$users[$userindex]->{'attr'}->{'location'} = "";
print STDERR &timestamp . "++> $username has left a game: \"$location\" ($game_id)\n" if $showjoins and $showgames;
print LOG &logtimestamp . "++> $username has left a game: \"$location\" ($game_id)\n" if $logfile;
} elsif ($_->{'attr'}->{'available'} eq "no") {
my $game_id = $_->{'attr'}->{'game_id'};
my $location = $_->{'attr'}->{'location'};
$users[$userindex]->{'attr'}->{'game_id'} = $game_id;
$users[$userindex]->{'attr'}->{'location'} = $location;
print STDERR &timestamp . "<++ $username has joined a game: \"$location\" ($game_id)\n" if $showjoins and $showgames;
print LOG &logtimestamp . "<++ $username has joined a game: \"$location\" ($game_id)\n" if $logfile;
}
} elsif ($_->{'name'} eq 'delete') {
} else {
print STDERR "[gamelist_diff][change_child][user]:" . Dumper($_) if $dumpunknown;
}
}
#print STDERR "[gamelist_diff][change_child]:" . Dumper($user) if $dumpunknown;
} elsif (my $gamelist = &wml::has_child($_, 'gamelist')) {
foreach (@ {$gamelist->{'children'}}) {
my $gamelistindex = $_->{'attr'}->{'index'};
if ($_->{'name'} eq 'insert_child') {
if (my $game = &wml::has_child($_, 'game')) {
my $gamename = $game->{'attr'}->{'name'};
my $gameid = $game->{'attr'}->{'id'};
my $era = "unknown"; # some eras don't set the id
$era = $game->{'attr'}->{'mp_era'} if $game->{'attr'}->{'mp_era'};
my $scenario = "unknown"; # some scenarios don't set the id
$scenario = $game->{'attr'}->{'mp_scenario'} if $game->{'attr'}->{'mp_scenario'};
my $xp = "100%"; # scenarios might not set XP
$xp = $game->{'attr'}->{'experience_modifier'} if $game->{'attr'}->{'experience_modifier'};
my $gpv = $game->{'attr'}->{'mp_village_gold'};
my $fog = $game->{'attr'}->{'mp_fog'};
my $shroud = $game->{'attr'}->{'mp_shroud'};
my $timer = "none"; # reloads may not set the timer
$timer = $game->{'attr'}->{'mp_countdown'} if $game->{'attr'}->{'mp_countdown'};
my $observer = $game->{'attr'}->{'observer'};
print STDERR &timestamp . "+++ A new game has been created: \"$gamename\" ($gamelistindex, $gameid).\n" if $showgames;
print LOG &logtimestamp . "+++ A new game has been created: \"$gamename\" ($gamelistindex, $gameid).\n" if $logfile;
my $settings = "Settings: map: \"$scenario\" era: \"$era\" XP: $xp GPV: $gpv fog: $fog shroud: $shroud observers: $observer timer: $timer";
if ($timer =~ "yes") {
my $treservoir = "-";
$treservoir = $game->{'attr'}->{'mp_countdown_reservoir_time'} if $game->{'attr'}->{'mp_countdown_reservoir_time'};
my $tinit = "-";
$tinit = $game->{'attr'}->{'mp_countdown_init_time'} if $game->{'attr'}->{'mp_countdown_init_time'};
my $taction = "-";
$taction = $game->{'attr'}->{'mp_countdown_action_bonus'} if $game->{'attr'}->{'mp_countdown_action_bonus'};
my $tturn = "-";
$tturn = $game->{'attr'}->{'mp_countdown_turn_bonus'} if $game->{'attr'}->{'mp_countdown_turn_bonus'};
$settings .= " reservoir time: $treservoir init time: $tinit action bonus: $taction turn bonus: $tturn";
}
print STDERR &timestamp . $settings . "\n" if $showgames;
print LOG &logtimestamp . $settings . "\n" if $logfile;
$games[@games] = $game;
&serverstats() if $writestats;
} else {
print "[gamelist_diff][change_child][gamelist]:" . Dumper($_) if $dumpunknown;
}
} elsif ($_->{'name'} eq 'delete_child') {
if (my $game = &wml::has_child($_, 'game')) {
my $gamename = $games[$gamelistindex]->{'attr'}->{'name'};
my $gameid = $games[$gamelistindex]->{'attr'}->{'id'};
my $turn = $games[$gamelistindex]->{'attr'}->{'turn'};
if (defined($turn)) {
print STDERR &timestamp . "--- A game ended at turn $turn: \"$gamename\". ($gamelistindex, $gameid)\n" if $showgames;
print LOG &logtimestamp . "--- A game ended at turn $turn: \"$gamename\". ($gamelistindex, $gameid)\n" if $logfile;
} else {
print STDERR &timestamp . "--- A game was aborted: \"$gamename\". ($gamelistindex, $gameid)\n" if $showgames;
print LOG &logtimestamp . "--- A game was aborted: \"$gamename\". ($gamelistindex, $gameid)\n" if $logfile;
}
splice(@games,$gamelistindex,1);
&serverstats() if $writestats;
} else {
print STDERR "[gamelist_diff][change_child][gamelist]:" . Dumper($_) if $dumpunknown;
}
} elsif ($_->{'name'} eq 'change_child') {
if (my $game = &wml::has_child($_, 'game')) {
foreach (@ {$game->{'children'}}) {
if ($_->{'name'} eq 'insert' and $gamelistindex < @games) {
if (my $turn = $_->{'attr'}->{'turn'}) {
my $gamename = $games[$gamelistindex]->{'attr'}->{'name'};
my $gameid = $games[$gamelistindex]->{'attr'}->{'id'};
if ($turn =~ /^1\//) {
print STDERR &timestamp . "*** A game has started: \"$gamename\". ($gamelistindex, $gameid)\n" if $showgames;
print LOG &logtimestamp . "*** A game has started: \"$gamename\". ($gamelistindex, $gameid)\n" if $logfile;
} else {
print STDERR &timestamp . "Turn changed to $turn in game: \"$gamename\". ($gamelistindex, $gameid)\n" if $showgames and $showturns;
print LOG &logtimestamp . "Turn changed to $turn in game: \"$gamename\". ($gamelistindex, $gameid)\n" if $logfile;
}
$games[$gamelistindex]->{'attr'}->{'turn'} = $turn;
}
} elsif ($_->{'name'} eq 'delete') {
} else {
print "[gamelist_diff][change_child][gamelist][change_child][game]:" . Dumper($_) if $dumpunknown;
}
}
} else {
print STDERR "[gamelist_diff][change_child][gamelist]:" . Dumper($_) if $dumpunknown;
}
} else {
print STDERR "[gamelist_diff][change_child][gamelist]:" . Dumper($_) if $dumpunknown;
}
}
} else {
print STDERR "[gamelist_diff]:" . Dumper($_) if $dumpunknown;
}
} else {
print STDERR "[gamelist_diff]:" . Dumper($_) if $dumpunknown;
}
}
# [observer] and [observer_quit] should be deprecated they are redundant to parts of [gamelist_diff]
} elsif ($_->{'name'} eq 'observer') {
# my $username = $_->{'attr'}->{'name'};
# print &timestamp . "++> $username has joined the lobby.\n";
} elsif ($_->{'name'} eq 'observer_quit') {
# my $username = $_->{'attr'}->{'name'};
# print &timestamp . "<++ $username has left the lobby.\n";
} else {
print STDERR Dumper($_) if $dumpunknown;
}
}
}
print "Connection closed.\n\n" unless $quiet;
close(LOG);

51
utils/slacknoth
View file

@ -1,51 +0,0 @@
#!/bin/sh
if [ "$3" = "" ]
then
echo "slacknoth v0.2 - Creates a Wesnoth package for Slackware Linux"
echo "- by Skovbaer (Mark Michelsen)"
echo ""
echo "Usage: slacknoth [version tag] [architecture e.g. i386 or athlon]"
echo " [wesnoth root e.g. /usr/games/src/wesnoth]"
echo ""
exit 0;
fi
cd $3
mkdir -p /wesnothpack/wesnoth-$1
echo "Configuring..."
./autogen.sh
./configure --prefix=/usr --enable-server --enable-tools
make clean
echo "Compiling and gathering package contents..."
make DESTDIR=/wesnothpack/wesnoth-$1 CXXFLAGS="-g -O2 -fno-omit-frame-pointer -march=$2" install -i -k
mkdir -p /wesnothpack/wesnoth-$1/usr/doc/wesnoth-$1
cp -Rf changelog COPYING copyright INSTALL MANUAL* README /wesnothpack/wesnoth-$1/usr/doc/wesnoth-$1
echo "Cleaning up source..."
make clean
cd /wesnothpack/wesnoth-$1
echo "Stripping binaries..."
strip usr/bin/*
echo "Adding package info..."
mkdir install
echo wesnoth: Battle for Wesnoth $1 > install/slack-desc
echo wesnoth: Copyright \(C\) 2003-`date +%Y` by David White \<davidnwhite@verizon.net\> >> install/slack-desc
echo wesnoth: http://www.wesnoth.org/ >> install/slack-desc
echo wesnoth: Made with Slacknoth: Mark Michelsen \<skovbaer@femgramskovbaerte.dk\> >> install/slack-desc
echo wesnoth: >> install/slack-desc
echo wesnoth: Battle for Wesnoth is a fantasy turn-based strategy game. >> install/slack-desc
echo wesnoth: Battle for control of villages, using a variety of units which have >> install/slack-desc
echo wesnoth: advantages and disadvantages in different types of terrains and >> install/slack-desc
echo wesnoth: against different types of attacks. Units gain experience and advance >> install/slack-desc
echo wesnoth: levels, and are carried over from one scenario to the next campaign. >> install/slack-desc
echo wesnoth: >> install/slack-desc
echo "Building package..."
tar cf wesnoth-$1-$2-1.tar .
gzip -9 wesnoth-$1-$2-1.tar
mv -f wesnoth-$1-$2-1.tar.gz wesnoth-$1-$2-1.tgz
echo "Moving package to $3 ..."
mv -f wesnoth-$1-$2-1.tgz $3
cd $3
echo "Removing temporary directory..."
rm -Rf /wesnothpack
echo "And that's it, we're done!"
echo "If everything went all right, you should have the package"
echo "$3/wesnoth-$1-$2-1.tgz"

291
utils/unit.pl
View file

@ -1,291 +0,0 @@
use wml;
#helper functions we want eval to be able to see
sub decimal($)
{
sprintf "%.2f", $_[0];
}
my $expression = '';
my @sortby = ();
my @filter = ();
my @where = ();
my @heading = ();
my @fold = ();
while(my $arg = shift @ARGV) {
if($arg eq '--sortby') {
my $sortby = shift @ARGV or die "need argument to --sortby option";
unshift @sortby, $sortby;
} elsif($arg eq '--filter') {
my $filter = shift @ARGV or die "need argument to --filter option";
push @filter, $filter;
} elsif($arg eq '--where') {
my $where = shift @ARGV or die "need argument to --where option";
push @where, $where;
} elsif($arg eq '--prelude') {
my $prelude = shift @ARGV or die "need argument to --prelude option";
open PRELUDE, "<$prelude" or die "could not open prelude '$prelude'";
my @prelude = <PRELUDE>;
close PRELUDE;
push @where, (join '',@prelude);
} elsif($arg eq '--heading') {
my $heading = shift @ARGV or die "need argument to --heading option";
@heading = split ',', $heading or die "could not evaluate heading: $!";
} elsif($arg eq '--fold') {
my $fold = shift @ARGV or die "need argument to --fold option";
push @fold, $fold;
} elsif($arg eq '--help') {
print "Wesnoth Unit Analysis Tool. Usage: $0 [options] <expression>
<expression> is a Perl expression which will be evaluated for each unit with the results output. There is a set of parentheses assumed around <expression>, so a comma-separated list of expressions is valid.
A valid Wesnoth cache must be provided on stdin.
Options:
--sortby: sort by the given expression
--filter: evaluates the given expression, and will only display results for the unit if the filter evaluates to true
--where: executes the given code before executing any other expression for each unit
--prelude: like --where, but opens up a given file and runs the script in it.
";
} else {
die "unrecognized argument '$arg'. Use --help for help." if $expression;
$expression = $arg;
}
}
die "must give an expression to evaluate" unless $expression;
my $text = '';
read STDIN, $text, 10000000;
my $doc = &wml::read_binary([],$text) or die "could not read document";
$text = '';
my $units = 0;
foreach my $item (@{$doc->{'children'}}) {
if($item->{'name'} eq 'units') {
$units = $item;
last;
}
}
die "could not find [units] section" unless $units;
my %movetypes = ();
my @units = ();
my @results = ();
my $columns = 0;
foreach my $item (@{$units->{'children'}}) {
if($item->{'name'} eq 'unit') {
push @units, $item;
} elsif($item->{'name'} eq 'movetype') {
$movetypes{$item->{'attr'}->{'name'}} = $item;
}
}
foreach my $unit (@units) {
my $unitname = $unit->{'attr'}->{'id'};
my $movetype = $unit->{'attr'}->{'movement_type'};
$movetype = $movetypes{$movetype};
if($movetype) {
foreach my $item (@{$movetype->{'children'}}) {
&apply_unit_movetype($unit,$item);
}
}
foreach my $item (@{$unit->{'children'}}) {
&apply_unit_movetype($unit,$item);
}
}
sub apply_unit_movetype
{
my ($unit,$mod) = @_;
my %attr = %{$mod->{'attr'}};
if($mod->{'name'} eq 'movement_costs') {
while(my ($name,$value) = each(%attr)) {
$unit->{'attr'}->{'move_' . $name} = $value;
}
} elsif($mod->{'name'} eq 'defense') {
while(my ($name,$value) = each(%attr)) {
$unit->{'attr'}->{'defense_' . $name} = $value;
}
} elsif($mod->{'name'} eq 'resistance') {
while(my ($name,$value) = each(%attr)) {
$unit->{'attr'}->{'resist_' . $name} = $value;
}
}
}
foreach my $filter (@filter) {
my @new_units = ();
foreach my $unit (@units) {
my $res = &evaluate_expression($unit,$filter);
next unless $res;
my $pass = 1;
foreach my $item (@$res) {
unless($item) {
$pass = 0;
last;
}
}
push @new_units, $unit if $pass;
}
@units = @new_units;
}
foreach my $sortby (@sortby) {
@units = sort {
my ($resa,$resb) = (&evaluate_expression($a,$sortby),
&evaluate_expression($b,$sortby));
return 0 unless $resa or $resb;
return -1 unless $resa;
return 1 unless $resb;
while(@$resa or @$resb) {
my ($itema,$itemb) = (shift @$resa,shift @$resb);
my $res = &compare_values($itema,$itemb);
return $res if $res;
}
return 0;
} @units;
}
my $nfields = 0;
foreach my $unit (@units) {
my $res = &evaluate_expression($unit,"$expression");
push @results, $res;
$nfields = scalar(@$res) if scalar(@$res) > $nfields;
}
foreach my $fold (@fold) {
my @row = ();
for my $index ( 0 .. $nfields) {
my @items = ();
foreach my $res (@results) {
if($index < scalar(@$res)) {
push @items, $res->[$index];
} else {
push @items, '';
}
}
push @row, eval "$fold";
}
push @results, \@row;
}
unshift @results, \@heading if @heading;
my @cols = (0) x $columns;
foreach my $result (@results) {
next unless $result;
my @items = @$result;
for(my $col = 0; $col != @items; ++$col) {
my $len = length $items[$col];
$cols[$col] = $len if $len > $cols[$col];
}
}
while(@results) {
my $res = shift @results;
my $col = 0;
foreach my $field (@$res) {
print $field;
my $whitespace = ' ' x (2 + $cols[$col] - (length $field));
print $whitespace;
++$col;
}
print "\n";
}
sub evaluate_expression
{
my ($unit,$expression) = @_;
my @attacks = ();
my @melee = ();
my @ranged = ();
my ($attack_name,$attack_damage,$attack_strikes,$attack_type,$attack_range,$attack_special) = ('',0,0,'','','');
my ($melee_name,$melee_damage,$melee_strikes,$melee_type,$melee_special) = ('',0,0,'','','');
my ($ranged_name,$ranged_damage,$ranged_strikes,$ranged_type,$ranged_special) = ('',0,0,'','');
foreach my $attack (@{$unit->{'children'}}) {
next unless $attack->{'name'} eq 'attack';
my %attr = %{$attack->{'attr'}};
push @attacks, \%attr;
my $power = $attr{'damage'}*$attr{'number'};
if($attr{'range'} eq 'short') {
if($power > $melee_damage*$melee_strikes) {
$melee_name = $attr{'name'};
$melee_damage = $attr{'damage'};
$melee_strikes = $attr{'number'};
$melee_type = $attr{'type'};
$melee_special = $attr{'special'};
}
push @melee, \%attr;
} else {
if($power > $ranged_damage*$ranged_strikes) {
$ranged_name = $attr{'name'};
$ranged_damage = $attr{'damage'};
$ranged_strikes = $attr{'number'};
$ranged_type = $attr{'type'};
$ranged_special = $attr{'special'};
}
push @ranged, \%attr;
}
if($power > $attack_damage*$attack_strikes) {
$attack_name = $attr{'name'};
$attack_damage = $attr{'damage'};
$attack_strikes = $attr{'number'};
$attack_type = $attr{'type'};
$attack_range = $attr{'range'};
$attack_special = $attr{'special'};
}
}
my ($secondary_name,$secondary_damage,$secondary_strikes,$secondary_type,$secondary_special) =
($melee_name,$melee_damage,$melee_strikes,$melee_type,$melee_special);
($secondary_name,$secondary_damage,$secondary_strikes,$secondary_type,$secondary_special) =
($ranged_name,$ranged_damage,$ranged_strikes,$ranged_type,$ranged_special)
if $attack_range eq 'short';
my $script = '{';
my %attr = %{$unit->{'attr'}};
while(my ($key,$value) = each(%attr)) {
$value =~ s/[^\s\w\.\,\-\:\;]//g;
$$key = $value;
}
foreach my $where (@where) {
$script .= "$where;";
}
$script .= "\[$expression\]\}";
my $result = eval($script);
while(my ($key,$value) = each(%attr)) {
$$key = '';
}
return $result;
}
sub compare_values
{
my ($a,$b) = @_;
return $a <=> $b if $a =~ /^[-\d\.]+$/ and $b =~ /^[-\d\.]+$/;
return $a cmp $b;
}

63
utils/update_unit_tree
View file

@ -1,63 +0,0 @@
#!/bin/sh
#
# Make a local copy of the HTML unit tree.
# Meant to be run on the wesnoth server site.
if [ $# -ne 1 ]; then
echo "Syntax: $0 <wesnoth version>"
exit 1
fi
VERSION=$1
SITE=$HOME/html/units
SOURCE=$HOME/source
if ! [ -d $SOURCE ]; then
echo "'$SOURCE' not found."
exit 1
fi
BRANCH=Development
case $VERSION in
1.2 ) cd $SOURCE/1.2 || exit 1
BRANCH=Stable
;;
1.3.* ) cd $SOURCE/trunk || exit 1
;;
1.4 ) cd $SOURCE/1.4 || exit 1
BRANCH=Stable
;;
trunk ) cd $SOURCE/trunk || exit 1
;;
* ) echo "Unknown version."
exit 1
;;
esac
if [ -d $SITE/$VERSION ] && [ "$BRANCH" != "Stable" ] && [ "$VERSION" != "trunk" ]; then
echo "'$SITE/$VERSION' already exists."
exit 1
fi
#echo 'svn update...'
#svn update
#svn status
if [ "$VERSION" = "trunk"]; then
data/tools/wmlunits -d data/ -o $SITE/temp || exit 1
rm -rf $SITE/$VERSION
# move the generated files to their proper place
mv $SITE/temp $SITE/$VERSION
else
cd data/tools/unit_tree/ || exit 1
# make sure we update with the right version
sed -i -e "s/\(my \$version = '\).*\(';\)/\1$VERSION\2/" units.pl
./units.pl || exit 1
rm -rf $SITE/$VERSION
# move the generated files to their proper place
mv files $SITE/$VERSION
cp -p templates/units.css $SITE/$VERSION
# revert to prevent future conflicts if $version changed
svn revert units.pl
fi
if [ "$VERSION" != "trunk" ] && ! [ $(grep "<p><a href=\"$VERSION/index.html\">$VERSION ($BRANCH)</a></p>" $SITE/index.html) ]; then
# insert a link for the new version
sed -i -e "s,\(<p><a href=\"trunk/index.html\">Trunk</a></p>\),\1\n<p><a href=\"$VERSION/index.html\">$VERSION ($BRANCH)</a></p>," $SITE/index.html
fi

272
utils/weblist.pl
View file

@ -1,272 +0,0 @@
#!/usr/bin/perl
use wml;
use wml_net;
use CGI qw/:standard -no_xhtml/;
use Time::gmtime;
use strict;
my ($host,$port) = ('add-ons.wesnoth.org', 15002);
my $style = 'http://www.wesnoth.org/mw/skins/glamdrol/main.css';
my $socket = eval {&wml_net::connect($host,$port)};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
if (!defined($socket)) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error connecting to the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Error connecting to the campaign server.'), end_html;
exit;
}
eval {
&wml_net::write_packet($socket,&wml::read_text('
[request_campaign_list]
[/request_campaign_list]'));
};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
my $response = eval {&wml_net::read_packet($socket)};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
if (!defined($response)) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Error accessing the campaign server.'), end_html;
exit;
}
if (my $error = &wml::has_child($response, 'error')) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p($error->{'attr'}->{'message'}), end_html;
exit;
}
my $campaign_list = &wml::has_child($response, 'campaigns');
if (!$campaign_list) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error retrieving campaign list.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('No', em('campaigns'), 'data returned.'), end_html;
exit;
}
print header, start_html(-style=>{'src'=>$style},
-title=>'Wesnoth campaigns available for download.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
my @campaigns = &wml::get_children($campaign_list,'campaign');
my $myurl = url(-relative=>1);
my $sort = 'timestamp_down';
if (defined(param('sort'))) {
if (scalar(@{[param('sort')]}) != 1) {
print p('Mutplie sort columns ignored.');
}
else {
$sort = param('sort');
}
}
my $title_sort = 'title_up';
my $version_sort = 'version_down';
my $author_sort = 'author_up';
my $timestamp_sort = 'timestamp_down';
my $size_sort = 'size_up';
my $downloads_sort = 'downloads_down';
$title_sort = 'title_down' if $sort eq 'title_up';
$version_sort = 'version_up' if $sort eq 'version_down';
$author_sort = 'author_down' if $sort eq 'author_up';
$timestamp_sort = 'timestamp_up' if $sort eq 'timestamp_down';
$size_sort = 'size_down' if $sort eq 'size_up';
$downloads_sort = 'downloads_up' if $sort eq 'downloads_down';
print p('Windows users may want to install',
a({href=>'http://www.7-zip.org/'}, '7-zip'),
"to handle tar gzipped archives (campaign downloads are in this format).",
'This is a', a({href=>'http://www.debian.org/intro/free'}, 'free'),
'and zero cost program that will handle a variety of archive formats.');
print p('Column headings are linked to alternate sort orders.');
print p('Campaign titles are linked to tar gzipped archives of the respective campaigns.');
print p('The downloaded campaign archives should be extracted in ~/.wesnoth/data/campaigns/ on *nix systems.',
a({href=>'mailto:bruno@wolff.to'}, 'I'),
'would appreciate people telling me what the corresponding directory is for other operating systems.');
my @rows = ();
foreach my $campaign (@campaigns) {
foreach my $field ('icon', 'name', 'title', 'version', 'author', 'timestamp',
'description', 'size', 'downloads') {
$campaign->{'attr'}->{$field} =~ s/\001[^\003]*\003//g;
$campaign->{'attr'}->{$field} =~ s/[\001-\037\177-\237]/ /g;
}
$campaign->{'attr'}->{'name'} =~ s;\s|/|\\;;g;
my $title = $campaign->{'attr'}->{'name'};
$title =~ s/_/ /g;
$campaign->{'attr'}->{'title'} = $title
if $campaign->{'attr'}->{'title'} =~ m/^\s*$/;
}
my @sorted = ();
if ($sort eq 'title_down') {
@sorted = sort {uc($b->{'attr'}->{'title'}) cmp uc($a->{'attr'}->{'title'})}
@campaigns;
}
elsif ($sort eq 'title_up') {
@sorted = sort {uc($a->{'attr'}->{'title'}) cmp uc($b->{'attr'}->{'title'})}
@campaigns;
}
elsif ($sort eq 'version_down') {
@sorted = sort {uc($b->{'attr'}->{'version'}) cmp uc($a->{'attr'}->{'version'})}
@campaigns;
}
elsif ($sort eq 'version_up') {
@sorted = sort {uc($a->{'attr'}->{'version'}) cmp uc($b->{'attr'}->{'version'})}
@campaigns;
}
elsif ($sort eq 'author_down') {
@sorted = sort {uc($b->{'attr'}->{'author'}) cmp uc($a->{'attr'}->{'author'})}
@campaigns;
}
elsif ($sort eq 'author_up') {
@sorted = sort {uc($a->{'attr'}->{'author'}) cmp uc($b->{'attr'}->{'author'})}
@campaigns;
}
elsif ($sort eq 'timestamp_down') {
@sorted = sort {$b->{'attr'}->{'timestamp'} <=> $a->{'attr'}->{'timestamp'}}
@campaigns;
}
elsif ($sort eq 'timestamp_up') {
@sorted = sort {$a->{'attr'}->{'timestamp'} <=> $b->{'attr'}->{'timestamp'}}
@campaigns;
}
elsif ($sort eq 'size_down') {
@sorted = sort {$b->{'attr'}->{'size'} <=> $a->{'attr'}->{'size'}}
@campaigns;
}
elsif ($sort eq 'size_up') {
@sorted = sort {$a->{'attr'}->{'size'} <=> $b->{'attr'}->{'size'}}
@campaigns;
}
elsif ($sort eq 'downloads_down') {
@sorted = sort {$b->{'attr'}->{'downloads'} <=> $a->{'attr'}->{'downloads'}}
@campaigns;
}
elsif ($sort eq 'downloads_up') {
@sorted = sort {$a->{'attr'}->{'downloads'} <=> $b->{'attr'}->{'downloads'}}
@campaigns;
}
else {
@sorted = @campaigns;
}
foreach my $campaign (@sorted) {
my @row = ();
my $iname = $campaign->{'attr'}->{'icon'};
if ($iname !~ m/^\s*$/) {
$iname =~ s;^.*(/|\\);;;
$iname =~ s/\..*$//;
$iname =~ s/-|_/ /g;
push @row, img({src=>'images/'.$campaign->{'attr'}->{'icon'},
alt=>$iname});
}
else {
push @row, 'No icon provided';
}
push @row, a({href=>($campaign->{'attr'}->{'name'}).'.tgz'},
escapeHTML($campaign->{'attr'}->{'title'}));
push @row, escapeHTML($campaign->{'attr'}->{'version'});
my $trans = '';
my $first = 1;
my $last = '';
my @lang = &wml::get_children($campaign,'translation');
foreach my $lang (sort {$a->{'attr'}->{'language'} cmp
$b->{'attr'}->{'language'}} @lang) {
if (!$first) {
$first = 0;
$trans = $lang->{'attr'}->{'language'};
$last = $trans;
}
else {
$trans .= ' ';
if ($last ne $lang->{'attr'}->{'language'}) {
$trans .= $lang->{'attr'}->{'language'};
$last = $lang->{'attr'}->{'language'};
}
}
}
$trans =~ s/\001[^\003]*\003//g;
$trans =~ s/[\001-\037\177-\237]/ /g;
push @row, escapeHTML($trans);
push @row, escapeHTML($campaign->{'attr'}->{'author'});
if ($campaign->{'attr'}->{'timestamp'} =~ m/^\d+$/) {
push @row, escapeHTML(gmctime($campaign->{'attr'}->{'timestamp'}) . ' GMT');
}
else {
push @row, 'Unknown';
}
push @row, escapeHTML($campaign->{'attr'}->{'description'});
my $size = $campaign->{'attr'}->{'size'};
$size += 512;
$size -= $size % 1024;
$size /= 1024;
push @row, escapeHTML("$size KiB");
push @row, escapeHTML($campaign->{'attr'}->{'downloads'});
push @rows, td(\@row);
}
print table({frame=>'border',rules=>'all'},
col, col({align=>'char'}), col, col,
thead(Tr(th(['Icon',
a({href=>$myurl . '?sort=' . $title_sort}, 'Title'),
a({href=>$myurl . '?sort=' . $version_sort}, 'Version'),
'Translations',
a({href=>$myurl . '?sort=' . $author_sort}, 'Author'),
a({href=>$myurl . '?sort=' . $timestamp_sort}, 'Last Updated'),
'Description',
a({href=>$myurl . '?sort=' . $size_sort}, 'Size'),
a({href=>$myurl . '?sort=' . $downloads_sort}, 'Downloads')]))),
tbody(Tr(\@rows))
);
print end_html;

348
utils/webtgz.pl
View file

@ -1,348 +0,0 @@
#!/usr/bin/perl
use wml;
use wml_net;
use Archive::Tar;
use CGI qw/:standard -no_xhtml/;
use strict;
my ($host, $port) = ("add-ons.wesnoth.org", 15002);
my $style = 'http://www.wesnoth.org/mw/skins/glamdrol/main.css';
my $socket = eval {&wml_net::connect($host,$port)};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
if (!defined($socket)) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error connecting to the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Error connecting to the campaign server.'), end_html;
exit;
}
my $name = url(-relative=>1);
if ($name =~ m/^(.*)\.tgz$/) {
$name = $1;
}
else {
print header, start_html(-style=>{'src'=>$style},
-title=>'Invalid campaign name URL.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Campaigns are only available as gzipped tar archives (.tgz files).'),
end_html;
exit;
}
if ($name =~ m/^\./) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Invalid campaign name.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(em($name),
'is an invalid campaign name because it begins with a period.'),
end_html;
exit;
}
if ($name =~ m;/;) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Invalid campaign name.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(em($name),
'is an invalid campaign name because it contains a forward slash (/).'),
end_html;
exit;
}
if ($name =~ m/^$/) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Invalid campaign name.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(em($name),
'is an invalid campaign name because it is the empty string.'),
end_html;
exit;
}
eval {
&wml_net::write_packet($socket,&wml::read_text("
[request_campaign_list]
name=\"$name\"
[/request_campaign_list]"));
};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
my $response = eval {&wml_net::read_packet($socket)};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
if (!defined($response)) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Error accessing the campaign server.'), end_html;
exit;
}
if (my $error = &wml::has_child($response, 'error')) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($error->{'attr'}->{'message'})), end_html;
exit;
}
my $campaign_list = &wml::has_child($response, 'campaigns');
if (!$campaign_list) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error retrieving campaign list.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('No', em('campaigns'), 'data returned.'), end_html;
exit;
}
my @campaigns = &wml::get_children($campaign_list,'campaign');
my $version = undef;
my $timestamp = '';
foreach my $campaign (@campaigns) {
foreach my $field ('name', 'version', 'timestamp') {
$campaign->{'attr'}->{$field} = ''
unless defined($campaign->{'attr'}->{$field});
$campaign->{'attr'}->{$field} =~ s/\001[^\003]*\003//g;
$campaign->{'attr'}->{$field} =~ s/[\001-\037\177-\237]/ /g;
}
$campaign->{'attr'}->{'name'} =~ s;\s|/|\\;;g;
if ($name eq $campaign->{'attr'}->{'name'}) {
$version = $campaign->{'attr'}->{'version'};
$timestamp = $campaign->{'attr'}->{'timestamp'};
last;
}
}
undef @campaigns;
if (!defined($version)) {
unlink("version/$name.ver");
unlink("tgz/$name.tgz");
unlink("timestamp/$name.ver");
print header, start_html(-style=>{'src'=>$style},
-title=>'Error retrieving campaign information.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('No information was retrievable for the campaign', em($name) . '.'),
end_html;
exit;
}
my $cached = 1;
if (open(VERS, "<version/$name.ver")) {
my $vers = <VERS>;
$cached = 0 unless $vers eq $version;
close VERS;
}
else {
$cached = 0;
}
if (open(VERS, "<timestamp/$name.ver")) {
my $ts = <VERS>;
$cached = 0 unless $ts eq $timestamp;
close VERS;
}
else {
$cached = 0;
}
if (!$cached) {
unlink("version/$name.ver");
unlink("tgz/$name.tgz");
unlink("timestamp/$name.ver");
my $archive = Archive::Tar->new();
eval {
&wml_net::write_packet($socket, &wml::read_text("
[request_campaign]
name=\"$name\"
[/request_campaign]"));
};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
my $response = eval {&wml_net::read_packet($socket)};
if ($@ ne '') {
print header, start_html(-style=>{'src'=>$style},
-title=>'Error accessing the campaign server.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($@)), end_html;
exit;
}
if (!defined($response)) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Campaign server error while attempting to retrieve campaign.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Campaign server error while attempting to retrieve campaign.'),
end_html;
exit;
}
if (my $error = &wml::has_child($response, 'error')) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Campaign server error while attempting to retrieve campaign.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p(escapeHTML($error->{'attr'}->{'message'})), end_html;
exit;
}
$version = $response->{'attr'}->{'version'}
if defined($response->{'attr'}->{'version'});
$timestamp = $response->{'attr'}->{'timestamp'}
if defined($response->{'attr'}->{'timestamp'});
&archive_dir($archive, $response, '');
$archive->write("tgz/$name.$$", 1);
if (!open(VERS, ">version/$name.$$")) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Unable to cache campaign.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Unable to cache campaign.'),
end_html;
exit;
}
print VERS $version;
close VERS;
if (!open(VERS, ">timestamp/$name.$$")) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Unable to cache campaign.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Unable to cache campaign.'),
end_html;
exit;
}
print VERS $timestamp;
close VERS;
rename "tgz/$name.$$", "tgz/$name.tgz";
rename "version/$name.$$", "version/$name.ver";
rename "timestamp/$name.$$", "timestamp/$name.ver";
undef $archive;
undef $response;
}
if (!open(TGZ, "<tgz/$name.tgz")) {
print header, start_html(-style=>{'src'=>$style},
-title=>'Unable to read cached copy of the campaign.');
print div({id=>'header'}, div({id=>'logo'}, a({href=>'http://www.wesnoth.org/'},
img({alt=>'Wesnoth logo',
src=>'http://wesnoth.org/mw/skins/glamdrol/wesnoth-logo.jpg'}))));
print p('Unable to read cached copy of the campaign.'),
end_html;
exit;
}
print "Content-Type: application/x-gzip\r\n",
"Content-disposition: attachment; filename=\"$name.tgz\"\r\n\r\n";
my $buf;
while (read(TGZ, $buf, 16384)) {
print $buf;
}
exit;
sub archive_dir
{
my ($archive, $doc, $dest) = @_;
my $name = $doc->{'attr'}->{'name'};
my $path;
if ($name ne '') {
if ($dest eq '') {
$path = $name;
}
else {
$path = "$dest/$name";
}
}
else {
$path = $dest;
}
foreach my $dir (&wml::get_children($doc, 'dir')) {
&archive_dir($archive, $dir, $path);
}
foreach my $file (&wml::get_children($doc, 'file')) {
my $filename;
if ($path eq '') {
$filename = $file->{'attr'}->{'name'};
}
else {
$filename = "$path/" . $file->{'attr'}->{'name'};
}
my @contents = split(//, $file->{'attr'}->{'contents'});
my $contents = '';
while(@contents) {
my $char = shift @contents;
if (1 == ord $char) {
$char = chr(ord(shift @contents) - 1);
}
$contents .= $char;
}
$archive->add_data($filename, $contents,
{'uname'=>'root', 'gname'=>'root', 'uid'=>0, 'gid'=>0, 'mode'=>0644});
}
}