added Perl-based command line tool to access the campaign server
This commit is contained in:
Dave White
parent
37b11bbc6c
commit
5663963f04
3 changed files with 563 additions and 0 deletions
157
utils/campaigns_client.pl
Executable file
157
utils/campaigns_client.pl
Executable file
|
|
@ -0,0 +1,157 @@
|
|||
use wml;
|
||||
use wml_net;
|
||||
use strict;
|
||||
|
||||
my $command = 'ls';
|
||||
my $download = '';
|
||||
my $download_to = '';
|
||||
my ($host,$port) = ("campaigns.wesnoth.org",15002);
|
||||
my @fields = ('name','title','author','size','version','filename','downloads');
|
||||
|
||||
while(@ARGV) {
|
||||
my $arg = shift @ARGV;
|
||||
if($arg eq '--host') {
|
||||
$host = shift @ARGV;
|
||||
} elsif($arg eq '--port') {
|
||||
$port = shift @ARGV;
|
||||
} elsif($arg eq '--help') {
|
||||
print "Wesnoth Campaigns Client. Connects to the Wesnoth campaign server and performs various operations.
|
||||
Format: $0 [<options>] <command> [<parameters>]
|
||||
Commands:
|
||||
ls (default): lists the campaigns stored on the server. The fields to be displayed for each campaign may be given as a parameter, as a list of comma-seperated values. Valid fields are name, title, author, size, version, filename, and downloads
|
||||
terms: queries the server for terms under which it may be used
|
||||
download <campaign name> [<path>]: downloads the given campaign into the directory given by the path. The files and directories created in the process will be printed to standard out.
|
||||
Options:
|
||||
--host: the host to connect to (defaults to campaigns.wesnoth.org)
|
||||
--port: the port to connect to (defaults to 15002)
|
||||
--help: displays this text and exits
|
||||
";
|
||||
exit;
|
||||
} elsif($arg eq 'ls') {
|
||||
$command = 'ls';
|
||||
my $fields = shift @ARGV;
|
||||
if($fields) {
|
||||
@fields = split /,/, $fields;
|
||||
}
|
||||
} elsif($arg eq 'terms') {
|
||||
$command = 'terms';
|
||||
} elsif($arg eq 'download') {
|
||||
$command = 'download';
|
||||
$download = shift @ARGV or die "download option must include a campaign to download";
|
||||
$download_to = shift @ARGV or '.';
|
||||
} else {
|
||||
die "Unknown argument '$arg'";
|
||||
}
|
||||
}
|
||||
|
||||
my $socket = &wml_net::connect($host,$port);
|
||||
|
||||
if($command eq 'ls') {
|
||||
&wml_net::write_packet($socket,&wml::read_text('
|
||||
[request_campaign_list]
|
||||
[/request_campaign_list]'));
|
||||
my $response = &wml_net::read_packet($socket);
|
||||
&check_error($response);
|
||||
|
||||
my $campaign_list = &wml::has_child($response,'campaigns') or die "Unrecognized response to request for campaigns";
|
||||
my @campaigns = &wml::get_children($campaign_list,'campaign');
|
||||
foreach my $campaign (@campaigns) {
|
||||
my $first = 1;
|
||||
foreach my $field (@fields) {
|
||||
print "|" unless $first;
|
||||
$first = 0;
|
||||
my $value = $campaign->{'attr'}->{$field};
|
||||
$value =~ s/\n/ /g;
|
||||
$value =~ s/\r//g;
|
||||
print $value;
|
||||
}
|
||||
|
||||
print "\n";
|
||||
}
|
||||
|
||||
exit;
|
||||
} elsif($command eq 'terms') {
|
||||
&wml_net::write_packet($socket,&wml::read_text('
|
||||
[request_terms]
|
||||
[/request_terms]'));
|
||||
my $response = &wml_net::read_packet($socket);
|
||||
&check_error($response);
|
||||
print &extract_message($response);
|
||||
exit;
|
||||
} elsif($command eq 'download') {
|
||||
mkdir $download_to;
|
||||
&wml_net::write_packet($socket,&wml::read_text("
|
||||
[request_campaign]
|
||||
name=\"$download\"
|
||||
[/request_campaign]"));
|
||||
my $response = &wml_net::read_packet($socket);
|
||||
&check_error($response);
|
||||
|
||||
print &unarchive_dir($response,$download_to);
|
||||
exit;
|
||||
}
|
||||
|
||||
sub check_error
|
||||
{
|
||||
my ($doc) = @_;
|
||||
if(my $error = &wml::has_child($doc,'error')) {
|
||||
my $msg = $error->{'attr'}->{'message'};
|
||||
die "Server responded with error: $msg";
|
||||
}
|
||||
}
|
||||
|
||||
sub extract_message
|
||||
{
|
||||
my ($doc) = @_;
|
||||
if(my $error = &wml::has_child($doc,'message')) {
|
||||
return $error->{'attr'}->{'message'};
|
||||
}
|
||||
|
||||
return "";
|
||||
}
|
||||
|
||||
sub unarchive_dir
|
||||
{
|
||||
my $log = '';
|
||||
my ($doc,$dest) = @_;
|
||||
my $name = $doc->{'attr'}->{'name'};
|
||||
my $path = "$dest/$name";
|
||||
mkdir $path;
|
||||
$log .= "$path\n";
|
||||
foreach my $dir (&wml::get_children($doc,'dir')) {
|
||||
$log .= &unarchive_dir($dir,$path);
|
||||
}
|
||||
|
||||
foreach my $file (&wml::get_children($doc,'file')) {
|
||||
my $filename = "$path/" . $file->{'attr'}->{'name'};
|
||||
open FILE, ">$filename";
|
||||
binmode(FILE);
|
||||
my @chars = split //, $file->{'attr'}->{'contents'};
|
||||
while(@chars) {
|
||||
my $char = shift @chars;
|
||||
if(1 == ord $char) {
|
||||
$char = shift @chars;
|
||||
}
|
||||
|
||||
print FILE $char;
|
||||
}
|
||||
close FILE;
|
||||
|
||||
$log .= "$filename\n";
|
||||
}
|
||||
|
||||
return $log;
|
||||
}
|
||||
|
||||
my $doc = &wml_net::read_packet($socket);
|
||||
die "Expected login" unless &wml::has_child($doc,'mustlogin');
|
||||
|
||||
&wml_net::write_packet($socket,&wml::read_text("
|
||||
[login]
|
||||
username=monitor
|
||||
[/login]"));
|
||||
|
||||
print &wml::write_text(&wml_net::read_packet($socket));
|
||||
print &wml::write_text(&wml_net::read_packet($socket));
|
||||
|
||||
close $socket;
|
||||
339
utils/wml.pm
Executable file
339
utils/wml.pm
Executable file
|
|
@ -0,0 +1,339 @@
|
|||
package wml;
|
||||
use strict;
|
||||
|
||||
$wml::open_element = 0, $wml::close_element = 1, $wml::schema_item = 2,
|
||||
$wml::literal_word = 3, $wml::first_word = 4, $wml::end_words = 256;
|
||||
|
||||
$wml::max_schema_size = $wml::end_words - $wml::first_word;
|
||||
$wml::max_schema_item_length = 20;
|
||||
|
||||
sub read_literal_word
|
||||
{
|
||||
my $word = "";
|
||||
my ($chars) = @_;
|
||||
while(@$chars) {
|
||||
my $char = shift @$chars;
|
||||
if((ord $char) == 0) {
|
||||
return $word;
|
||||
}
|
||||
|
||||
$word .= $char;
|
||||
}
|
||||
|
||||
die "Unexpected end of input";
|
||||
}
|
||||
|
||||
sub read_word
|
||||
{
|
||||
my ($schema,$chars) = @_;
|
||||
@$chars or die "Unexpected end of input";
|
||||
my $char = shift @$chars;
|
||||
my $code = ord $char;
|
||||
if($code == $wml::literal_word) {
|
||||
return &read_literal_word($chars);
|
||||
} elsif($code == $wml::schema_item) {
|
||||
my $word = &read_literal_word($chars);
|
||||
push @$schema, $word;
|
||||
return &read_word($schema,$chars);
|
||||
} elsif($code < $wml::first_word) {
|
||||
die "Unexpected character '$code' when word was expected";
|
||||
} else {
|
||||
my $index = $code - $wml::first_word;
|
||||
if($index >= @$schema) {
|
||||
die "Word '$index' ($code) not found in schema";
|
||||
}
|
||||
|
||||
return $schema->[$index];
|
||||
}
|
||||
}
|
||||
|
||||
sub add_child
|
||||
{
|
||||
my ($doc,$child_name) = @_;
|
||||
my $new_element = {'name' => $child_name, 'children' => [], 'attr' => {}};
|
||||
push(@{$doc->{'children'}}, $new_element);
|
||||
return $new_element;
|
||||
}
|
||||
|
||||
sub read_binary
|
||||
{
|
||||
my ($schema,$input) = @_;
|
||||
|
||||
my $doc = {'name' => '', 'children' => [], 'attr' => {}};
|
||||
my @stack = ($doc);
|
||||
my $cur = $doc;
|
||||
|
||||
my @chars = split //, $input;
|
||||
|
||||
while(@chars) {
|
||||
my $char = shift @chars;
|
||||
my $code = ord $char;
|
||||
my $remaining = $#chars + 1;
|
||||
if($code == $wml::open_element) {
|
||||
my $word = &read_word($schema,\@chars);
|
||||
$cur = &add_child($cur,$word);
|
||||
push @stack, $cur;
|
||||
} elsif($code == $wml::close_element) {
|
||||
pop @stack or die "Illegal close element found";
|
||||
$cur = $stack[$#stack] or die "Illegal close element found";
|
||||
} elsif($code == $wml::schema_item) {
|
||||
my $word = &read_literal_word(\@chars);
|
||||
push @$schema, $word;
|
||||
} else {
|
||||
unshift @chars, $char;
|
||||
my $name = &read_word($schema,\@chars);
|
||||
my $value = &read_literal_word(\@chars);
|
||||
$cur->{'attr'}->{$name} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
if($#stack != 0) {
|
||||
my $stack = $#stack;
|
||||
die "Unexpected end of input: $stack items still unclosed";
|
||||
}
|
||||
|
||||
return $doc;
|
||||
}
|
||||
|
||||
sub read_text
|
||||
{
|
||||
my ($text) = @_;
|
||||
my @chars = split //, $text;
|
||||
|
||||
my $doc = {'name' => '', 'children' => [], 'attr' => {}};
|
||||
my @stack = ($doc);
|
||||
my $cur = $doc;
|
||||
|
||||
my $token = '';
|
||||
my $state = 'SEEK';
|
||||
my $name = '';
|
||||
|
||||
|
||||
foreach my $char (@chars) {
|
||||
if($state eq 'SEEK') {
|
||||
next if $char =~ /\s/;
|
||||
if($char eq '[') {
|
||||
$state = 'ELEMENT';
|
||||
$token = '';
|
||||
} else {
|
||||
$state = 'NAME';
|
||||
$token .= $char;
|
||||
}
|
||||
} elsif($state eq 'NAME') {
|
||||
if($char eq '=') {
|
||||
$name = $token;
|
||||
$state = 'VALUE';
|
||||
$token = '';
|
||||
} else {
|
||||
$token .= $char unless $char =~ /\s/;
|
||||
}
|
||||
} elsif($state eq 'VALUE') {
|
||||
if($char eq "\n" or $char eq "\r") {
|
||||
my @names = ($name);
|
||||
my @values = ($token);
|
||||
|
||||
if($name =~ /,/) {
|
||||
@names = split /,/, $name;
|
||||
@values = split /,/, $token;
|
||||
}
|
||||
|
||||
while(@names and @values) {
|
||||
my $name = shift @names;
|
||||
my $value = shift @values;
|
||||
|
||||
$cur->{'attr'}->{$name} = $value;
|
||||
}
|
||||
$state = 'SEEK';
|
||||
$token = '';
|
||||
} elsif($char eq '"') {
|
||||
$state = 'VALUE_QUOTE';
|
||||
} else {
|
||||
$token .= $char;
|
||||
}
|
||||
} elsif($state eq 'VALUE_QUOTE') {
|
||||
if($char eq "\\") {
|
||||
$state = 'VALUE_BACKSLASH';
|
||||
} elsif($char eq '"') {
|
||||
$state = 'VALUE';
|
||||
} else {
|
||||
$token .= $char;
|
||||
}
|
||||
} elsif($state eq 'VALUE_BACKSLASH') {
|
||||
$token .= $char;
|
||||
$state = 'VALUE_QUOTE';
|
||||
} elsif($state eq 'ELEMENT') {
|
||||
if($char eq '/' and $token eq '') {
|
||||
$state = 'CLOSE_ELEMENT';
|
||||
} elsif($char eq ']') {
|
||||
$cur = &add_child($cur,$token);
|
||||
push @stack, $cur;
|
||||
$state = 'SEEK';
|
||||
$token = '';
|
||||
} else {
|
||||
$token .= $char;
|
||||
}
|
||||
} elsif($state eq 'CLOSE_ELEMENT') {
|
||||
if($char eq ']') {
|
||||
my $expected = $cur->{'name'};
|
||||
$expected eq $token or die "close element '$token' doesn't match current open element '$expected'";
|
||||
pop @stack or die "illegal close element '$token'";
|
||||
$cur = $stack[$#stack];
|
||||
$token = '';
|
||||
$state = 'SEEK';
|
||||
} else {
|
||||
$token .= $char;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if($state eq 'VALUE') {
|
||||
my @names = ($name);
|
||||
my @values = ($token);
|
||||
|
||||
if($name =~ /,/) {
|
||||
@names = split /,/, $name;
|
||||
@values = split /,/, $token;
|
||||
}
|
||||
|
||||
while(@names and @values) {
|
||||
my $name = shift @names;
|
||||
my $value = shift @values;
|
||||
|
||||
$cur->{'attr'}->{$name} = $value;
|
||||
}
|
||||
} elsif($state ne 'SEEK' or $#stack != 0) {
|
||||
die "unexpected end of WML document: state is '$state', stack size is $#stack";
|
||||
}
|
||||
|
||||
return $doc;
|
||||
}
|
||||
|
||||
sub write_word_literal($)
|
||||
{
|
||||
my ($word) = @_;
|
||||
return $word . "\0";
|
||||
}
|
||||
|
||||
sub write_word
|
||||
{
|
||||
my $res = '';
|
||||
my ($schema,$schema_lookup,$word) = @_;
|
||||
if(exists $schema_lookup->{$word}) {
|
||||
return chr($wml::first_word + $schema_lookup->{$word});
|
||||
}
|
||||
|
||||
my $pos = scalar(@$schema);
|
||||
if($pos < $wml::max_schema_size and length($word) < $wml::max_schema_item_length) {
|
||||
push @$schema, $word;
|
||||
$schema_lookup->{$word} = $pos;
|
||||
return chr($wml::schema_item) . &write_word_literal($word) . chr($wml::first_word + $pos);
|
||||
} else {
|
||||
return chr($wml::literal_word) . &write_word_literal($word);
|
||||
}
|
||||
}
|
||||
|
||||
sub write_binary_internal
|
||||
{
|
||||
my $res = '';
|
||||
my ($schema,$schema_lookup,$doc) = @_;
|
||||
foreach my $name (keys %{$doc->{'attr'}}) {
|
||||
my $value = $doc->{'attr'}->{$name};
|
||||
$res .= &write_word($schema,$schema_lookup,$name) . &write_word_literal($value);
|
||||
}
|
||||
|
||||
foreach my $child (@{$doc->{'children'}}) {
|
||||
my $name = $child->{'name'};
|
||||
$res .= chr($wml::open_element) .
|
||||
&write_word($schema,$schema_lookup,$name) .
|
||||
&write_binary_internal($schema,$schema_lookup,$child) .
|
||||
chr($wml::close_element);
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub write_binary
|
||||
{
|
||||
my ($schema,$doc) = @_;
|
||||
|
||||
my %schema_lookup = ();
|
||||
my $i = 0;
|
||||
foreach my $word (@$schema) {
|
||||
$schema_lookup{$word} = $i;
|
||||
++$i;
|
||||
}
|
||||
|
||||
return &write_binary_internal($schema,\%schema_lookup,$doc);
|
||||
}
|
||||
|
||||
sub write_text
|
||||
{
|
||||
my $doc = shift @_;
|
||||
my $indent = shift @_ or 0;
|
||||
my $res = '';
|
||||
foreach my $name (keys %{$doc->{'attr'}}) {
|
||||
my $value = $doc->{'attr'}->{$name};
|
||||
$res .= "\t" x $indent;
|
||||
$res .= "$name=\"$value\"\n";
|
||||
}
|
||||
|
||||
foreach my $child (@{$doc->{'children'}}) {
|
||||
my $name = $child->{'name'};
|
||||
$res .= "\t" x $indent;
|
||||
$res .= "[$name]\n";
|
||||
$res .= &write_text($child,$indent+1);
|
||||
$res .= "\t" x $indent;
|
||||
$res .= "[/$name]\n";
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub output_document
|
||||
{
|
||||
my $doc = shift @_;
|
||||
my $indent = 0;
|
||||
$indent = shift @_ if @_;
|
||||
foreach my $name (keys %{$doc->{'attr'}}) {
|
||||
my $value = $doc->{'attr'}->{$name};
|
||||
print ' ' x $indent;
|
||||
print "$name=\"$value\"\n";
|
||||
}
|
||||
|
||||
foreach my $child (@{$doc->{'children'}}) {
|
||||
my $name = $child->{'name'};
|
||||
print ' ' x $indent;
|
||||
print "[$name]\n";
|
||||
&output_document($child,$indent+1);
|
||||
print ' ' x $indent;
|
||||
print "[/$name]\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub has_child
|
||||
{
|
||||
my ($doc,$name) = @_;
|
||||
foreach my $child (@{$doc->{'children'}}) {
|
||||
if($child->{'name'} eq $name) {
|
||||
return $child;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub get_children
|
||||
{
|
||||
my ($doc,$name) = @_;
|
||||
my @res = ();
|
||||
|
||||
foreach my $child (@{$doc->{'children'}}) {
|
||||
if($child->{'name'} eq $name) {
|
||||
push @res, $child;
|
||||
}
|
||||
}
|
||||
|
||||
return @res;
|
||||
}
|
||||
|
||||
'Wesnoth Markup Language parser';
|
||||
67
utils/wml_net.pm
Executable file
67
utils/wml_net.pm
Executable file
|
|
@ -0,0 +1,67 @@
|
|||
package wml_net;
|
||||
use strict;
|
||||
use wml;
|
||||
use IO::Socket;
|
||||
|
||||
%wml_net::outgoing_schemas = ();
|
||||
%wml_net::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;
|
||||
|
||||
$wml_net::outgoing_schemas{$sock} = [];
|
||||
$wml_net::incoming_schemas{$sock} = [];
|
||||
return $sock;
|
||||
}
|
||||
|
||||
sub disconnect
|
||||
{
|
||||
my ($sock) = @_;
|
||||
delete($wml_net::outgoing_schemas{$sock});
|
||||
delete($wml_net::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 = '';
|
||||
while($len != length $res) {
|
||||
$buf = '';
|
||||
my $bytes = $len - length $res;
|
||||
read $sock, $buf, $bytes or die "Error reading socket: $!";
|
||||
$res .= $buf;
|
||||
}
|
||||
|
||||
$res = substr($res,0,length($res)-1);
|
||||
|
||||
return &wml::read_binary($wml_net::incoming_schemas{$sock},$res);
|
||||
}
|
||||
|
||||
sub write_packet
|
||||
{
|
||||
my ($sock,$doc) = @_;
|
||||
|
||||
my $data = &wml::write_binary($wml_net::outgoing_schemas{$sock},$doc);
|
||||
my $header = pack('N',length $data);
|
||||
print $sock "$header$data" or die "Error writing to socket: $!";
|
||||
}
|
||||
|
||||
'Wesnoth network protocol';
|
||||
Loading…
Add table
Reference in a new issue