git.pond.sub.org Git - empserver/blob - scripts/xdump.pl

   1 #!/usr/bin/perl
   2 #
   3 # xdump example program.
   4 # Copyright (C) 2006-2012 Markus Armbruster
   5 #
   6 # Empire is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 # Connect to server, xdump everything into tables, then print the
  20 # tables.
  21 #
  22 # A table is an array of records.
  23 # A record is a hash mapping field names to values.
  24 #
  25 # This is just an example!  Error handling is anemic.  Tables and
  26 # records just beg to be objects, but aren't.
  27
  28 use warnings;
  29 use strict;
  30 use Empire;
  31 use Dumpvalue;
  32
  33 # Map table name to meta table reference
  34 my %meta_by_name = ();
  35 # Map table uid to meta table reference
  36 my @meta_by_uid = ();
  37 # Map table name to table reference
  38 my %table_by_name = ();
  39 # Map table uid to table reference
  40 my @table_by_uid = ();
  41
  42 # The meta meta table
  43 my @meta_meta;
  44 # The meta-type symbol table
  45 my @meta_type;
  46
  47 my $empire = new Empire(-host => '127.0.0.1',
  48                         -port => 6664,
  49                         -country => '1',
  50                         -player => '1',
  51                         -user => 'xdump.pl');
  52 my $dumper = new Dumpvalue;
  53
  54 # xdump meta meta
  55 {
  56     my $mmd = send_cmd('xdump meta meta');
  57     @meta_meta = ();
  58     $table_by_name{meta} = $meta_by_name{meta} = \@meta_meta;
  59     # find field names
  60     parse_xdump($mmd, undef, \&store_meta_meta_record);
  61     # parse for real (requires field names)
  62     parse_xdump($mmd, undef);
  63 }
  64
  65 # xdump table
  66 {
  67     # xdump meta table
  68     $meta_by_name{table} = [];
  69     parse_xdump(send_cmd('xdump meta table'), undef);
  70     # table's first field is record uid, and its table field is the table uid:
  71     my $tuid = $meta_by_name{table}->[0]->{table};
  72     $meta_by_uid[$tuid] = $meta_by_name{table};
  73
  74     # xdump table
  75     $table_by_uid[$tuid] = $table_by_name{table} = [];
  76     parse_xdump(send_cmd('xdump table *'), $tuid);
  77 }
  78
  79 # complete work for xdump meta meta
  80 {
  81     # find the meta table uid
  82     my ($meta) = grep { defined $_ && $_->{name} eq 'meta' }
  83                       @{$table_by_name{table}};
  84     my $tuid = $meta->{uid};
  85     # enter it into @*_by_uid
  86     $meta_by_uid[$tuid] = $meta_by_name{meta};
  87     $table_by_uid[$tuid] = $table_by_name{meta};
  88 }
  89
  90 # xdump meta-type
  91 {
  92     # lookup record with name => 'type' in meta meta:
  93     my ($mmt) = grep {$_->{name} eq 'type'} @meta_meta;
  94     # its table field is uid of table meta-type:
  95     my $tuid = $mmt->{table};
  96     # lookup table meta-type's name:
  97     my $name = $table_by_name{table}->[$tuid]->{name};
  98
  99     # xdump meta meta-type
 100     $meta_by_uid[$tuid] = $meta_by_name{$name} = [];
 101     parse_xdump(send_cmd("xdump meta $tuid"), $tuid);
 102
 103     # xdump meta-type
 104     @meta_type = ();
 105     $table_by_uid[$tuid] = $table_by_name{$name} = \@meta_type;
 106     parse_xdump(send_cmd("xdump $tuid *"), $tuid);
 107 }
 108
 109 # xdump rest
 110 for my $tab (@{$table_by_name{table}}) {
 111     # skip holes:
 112     next unless exists $tab->{name};
 113     # skip tables already dumped:
 114     next if defined $meta_by_name{$tab->{name}};
 115
 116     # xdump meta $tab
 117     $meta_by_uid[$tab->{uid}] = $meta_by_name{$tab->{name}} = [];
 118     parse_xdump(send_cmd("xdump meta $tab->{uid}"), $tab->{uid});
 119
 120     # xdump $tab
 121     $table_by_uid[$tab->{uid}] = $table_by_name{$tab->{name}} = [];
 122     parse_xdump(send_cmd("xdump $tab->{uid} *"), $tab->{uid});
 123 }
 124
 125 $dumper->dumpValue(\@table_by_uid);
 126
 127
 128 sub send_cmd {
 129     my ($cmd) = @_;
 130     $empire->empcmd($cmd);
 131     my ($status, $data) = $empire->empreadline($cmd);
 132     die unless ($status eq $Empire::C_PROMPT);
 133     return $data;
 134 }
 135
 136 sub parse_xdump {
 137     my ($data, $tuid, $store_record) = @_;
 138     $store_record = \&store_record unless defined $store_record;
 139
 140     # parse header
 141     ($_, $data) = split(/\n/, $data, 2);
 142     /^XDUMP (meta )?(\S+) ([0-9])+$/
 143         or die;
 144     my $meta = defined $1;
 145     my $name = $2;
 146     my $timestamp = $3;
 147
 148     # parse body
 149     my $n = 0;
 150     while ($data !~ /^\//) {
 151         ($_, $data) = split(/\n/, $data, 2);
 152         my @fld = split(/ /);
 153         &$store_record($tuid, $meta, $name, $n, \@fld, $timestamp);
 154         $n++;
 155     }
 156
 157     # parse footer
 158     $data =~ /^\/([0-9]+)$/
 159         or die;
 160     $n == $1
 161         or die;
 162 }
 163
 164 sub store_record {
 165     my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_;
 166     my ($meta_table, $table);
 167
 168     # find table to update and its meta table
 169     if ($meta) {
 170         $meta_table = \@meta_meta;
 171         $table = $meta_by_name{$name};
 172     } else {
 173         $meta_table = $meta_by_name{$name};
 174         $table = $table_by_name{$name};
 175         $idx = $fld->[0]
 176             if has_record_uid($tuid);
 177     }
 178
 179     # update record
 180     my $record = $table->[$idx] || {};
 181     my $fldidx = 0;
 182     for (my $i = 0; $i <= $#{$meta_table}; $i++) {
 183         my $n = is_array($meta_table->[$i]);
 184         my $j;
 185         do {
 186             # update field
 187             my $fldname = $meta_table->[$i]->{name};
 188             die unless defined $fld->[$fldidx];
 189             $record->{$fldname} = eval_fld($fld->[$fldidx++]);
 190         } while (++$j < $n);
 191     }
 192     $table->[$idx] = $record;
 193 }
 194
 195 sub store_meta_meta_record {
 196     my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_;
 197     die unless $name eq 'meta';
 198     my $val = eval_fld($fld->[0]);
 199     die if $idx == 0 && $val ne 'name';
 200     $meta_meta[$idx] = {name => $val, len => 0};
 201 }
 202
 203 sub eval_fld {
 204     my ($fld) = @_;
 205     if ($fld =~ /\A[-+.0-9]/) {
 206         # sloppy, doesn't flag malformed numbers
 207         return $fld + 0;
 208     } elsif ($fld =~ /\A\"(.*)\"/) {
 209         # sloppy, doesn't junk after string
 210         $fld = $1;
 211         $fld =~ s/\\([0-7][0-7][0-7])/ chr(oct($1)) /eg;
 212         return $fld;
 213     }
 214     die;
 215 }
 216
 217 sub has_record_uid {
 218     # a table has record uids if the first field's table is the table's uid
 219     my ($tuid) = @_;
 220     die unless defined $tuid;
 221     die unless defined $meta_by_uid[$tuid];
 222     die unless defined $meta_by_uid[$tuid]->[0];
 223     die unless defined $meta_by_uid[$tuid]->[0]->{table};
 224     return $meta_by_uid[$tuid]->[0]->{table} == $tuid;
 225 }
 226
 227 sub sym_by_value {
 228     my ($symtab, $value) = @_;
 229     my ($sym) = grep { $_->{value} == $value } @{$symtab};
 230     return $sym->{name};
 231 }
 232
 233 sub is_array {
 234     my ($meta) = @_;
 235     my $len = $meta->{len};
 236     # non-zero $len means array, except for format 'c'
 237     if ($len == 0 || sym_by_value(\@meta_type, $meta->{type}) eq 'c') {
 238         return 0;
 239     }
 240     return $len;
 241 }