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

   1 #!/usr/bin/perl
   2 #
   3 # xdump example program.
   4 # Copyright (C) 2006-2011 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 # xdump ver
 126 {
 127     # pick an unused tuid:
 128     my $tuid = $#meta_by_uid + 1;
 129     # hack the table of tables:
 130     push @{$table_by_name{table}}, {uid => $tuid, name => 'version'};
 131     # xdump meta ver
 132     $meta_by_uid[$tuid] = $meta_by_name{version} = [];
 133     parse_xdump(send_cmd('xdump meta ver'), $tuid);
 134     # xdump ver
 135     $table_by_uid[$tuid] = $table_by_name{version} = [];
 136     parse_xdump(send_cmd('xdump ver'), $tuid);
 137 }
 138
 139 $dumper->dumpValue(\@table_by_uid);
 140
 141
 142 sub send_cmd {
 143     my ($cmd) = @_;
 144     $empire->empcmd($cmd);
 145     my ($status, $data) = $empire->empreadline($cmd);
 146     die unless ($status eq $Empire::C_PROMPT);
 147     return $data;
 148 }
 149
 150 sub parse_xdump {
 151     my ($data, $tuid, $store_record) = @_;
 152     $store_record = \&store_record unless defined $store_record;
 153
 154     # parse header
 155     ($_, $data) = split(/\n/, $data, 2);
 156     /^XDUMP (meta )?(\S+) ([0-9])+$/
 157         or die;
 158     my $meta = defined $1;
 159     my $name = $2;
 160     my $timestamp = $3;
 161
 162     # parse body
 163     my $n = 0;
 164     while ($data !~ /^\//) {
 165         ($_, $data) = split(/\n/, $data, 2);
 166         my @fld = split(/ /);
 167         &$store_record($tuid, $meta, $name, $n, \@fld, $timestamp);
 168         $n++;
 169     }
 170
 171     # parse footer
 172     $data =~ /^\/([0-9]+)$/
 173         or die;
 174     $n == $1
 175         or die;
 176 }
 177
 178 sub store_record {
 179     my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_;
 180     my ($meta_table, $table);
 181
 182     # find table to update and its meta table
 183     if ($meta) {
 184         $meta_table = \@meta_meta;
 185         $table = $meta_by_name{$name};
 186     } else {
 187         $meta_table = $meta_by_name{$name};
 188         $table = $table_by_name{$name};
 189         $idx = $fld->[0]
 190             if has_record_uid($tuid);
 191     }
 192
 193     # update record
 194     my $record = $table->[$idx] || {};
 195     my $fldidx = 0;
 196     for (my $i = 0; $i <= $#{$meta_table}; $i++) {
 197         my $n = is_array($meta_table->[$i]);
 198         my $j;
 199         do {
 200             # update field
 201             my $fldname = $meta_table->[$i]->{name};
 202             die unless defined $fld->[$fldidx];
 203             $record->{$fldname} = eval_fld($fld->[$fldidx++]);
 204         } while (++$j < $n);
 205     }
 206     $table->[$idx] = $record;
 207 }
 208
 209 sub store_meta_meta_record {
 210     my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_;
 211     die unless $name eq 'meta';
 212     my $val = eval_fld($fld->[0]);
 213     die if $idx == 0 && $val ne 'name';
 214     $meta_meta[$idx] = {name => $val, len => 0};
 215 }
 216
 217 sub eval_fld {
 218     my ($fld) = @_;
 219     if ($fld =~ /\A[-+.0-9]/) {
 220         # sloppy, doesn't flag malformed numbers
 221         return $fld + 0;
 222     } elsif ($fld =~ /\A\"(.*)\"/) {
 223         # sloppy, doesn't junk after string
 224         $fld = $1;
 225         $fld =~ s/\\([0-7][0-7][0-7])/ chr(oct($1)) /eg;
 226         return $fld;
 227     }
 228     die;
 229 }
 230
 231 sub has_record_uid {
 232     # a table has record uids if the first field's table is the table's uid
 233     my ($tuid) = @_;
 234     die unless defined $tuid;
 235     die unless defined $meta_by_uid[$tuid];
 236     die unless defined $meta_by_uid[$tuid]->[0];
 237     die unless defined $meta_by_uid[$tuid]->[0]->{table};
 238     return $meta_by_uid[$tuid]->[0]->{table} == $tuid;
 239 }
 240
 241 sub sym_by_value {
 242     my ($symtab, $value) = @_;
 243     my ($sym) = grep { $_->{value} == $value } @{$symtab};
 244     return $sym->{name};
 245 }
 246
 247 sub is_array {
 248     my ($meta) = @_;
 249     my $len = $meta->{len};
 250     # non-zero $len means array, except for format 'c'
 251     if ($len == 0 || sym_by_value(\@meta_type, $meta->{type}) eq 'c') {
 252         return 0;
 253     }
 254     return $len;
 255 }