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

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