From: Markus Armbruster Date: Wed, 8 Mar 2006 18:07:30 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: v4.3.0~16 X-Git-Url: http://git.pond.sub.org/?p=empserver;a=commitdiff_plain;h=1bd3b7264d5bc84354db968efe6996089bd1b27c;hp=d273b4eb08c10dca887428cd4688637654b4203c *** empty log message *** --- diff --git a/scripts/xdump.pl b/scripts/xdump.pl new file mode 100644 index 000000000..2c56d02b2 --- /dev/null +++ b/scripts/xdump.pl @@ -0,0 +1,256 @@ +#!/usr/bin/perl +# +# xdump example program. +# Copyright (C) 2006 Markus Armbruster +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +# Connect to server, xdump everything into tables, then print the +# tables. +# +# A table is an array of records. +# A record is a hash mapping field names to values. +# +# This is just an example! Error handling is anemic. Tables and +# records just beg to be objects, but aren't. + +use warnings; +use strict; +use Empire; +use Dumpvalue; + +# Map table name to meta table reference +my %meta_by_name = (); +# Map table uid to meta table reference +my @meta_by_uid = (); +# Map table name to table reference +my %table_by_name = (); +# Map table uid to table reference +my @table_by_uid = (); + +# The meta meta table +my @meta_meta; +# The meta-type symbol table +my @meta_type; + +my $empire = new Empire(-host => '127.0.0.1', + -port => 6664, + -country => '1', + -player => '1', + -user => 'xdump.pl'); +my $dumper = new Dumpvalue; + +# xdump meta meta +{ + my $mmd = send_cmd('xdump meta meta'); + @meta_meta = (); + $table_by_name{meta} = $meta_by_name{meta} = \@meta_meta; + # find field names + parse_xdump($mmd, undef, \&store_meta_meta_record); + # parse for real (requires field names) + parse_xdump($mmd, undef); +} + +# xdump table +{ + # xdump meta table + $meta_by_name{table} = []; + parse_xdump(send_cmd('xdump meta table'), undef); + # table's first field is record uid, and its table field is the table uid: + my $tuid = $meta_by_name{table}->[0]->{table}; + $meta_by_uid[$tuid] = $meta_by_name{table}; + + # xdump table + $table_by_uid[$tuid] = $table_by_name{table} = []; + parse_xdump(send_cmd('xdump table *'), $tuid); +} + +# complete work for xdump meta meta +{ + # find the meta table uid + my ($meta) = grep { defined $_ && $_->{name} eq 'meta' } + @{$table_by_name{table}}; + my $tuid = $meta->{uid}; + # enter it into @*_by_uid + $meta_by_uid[$tuid] = $meta_by_name{meta}; + $table_by_uid[$tuid] = $table_by_name{meta}; +} + +# xdump meta-type +{ + # lookup record with name => 'type' in meta meta: + my ($mmt) = grep {$_->{name} eq 'type'} @meta_meta; + # its table field is uid of table meta-type: + my $tuid = $mmt->{table}; + # lookup table meta-type's name: + my $name = $table_by_name{table}->[$tuid]->{name}; + + # xdump meta meta-type + $meta_by_uid[$tuid] = $meta_by_name{$name} = []; + parse_xdump(send_cmd("xdump meta $tuid"), $tuid); + + # xdump meta-type + @meta_type = (); + $table_by_uid[$tuid] = $table_by_name{$name} = \@meta_type; + parse_xdump(send_cmd("xdump $tuid *"), $tuid); +} + +# xdump rest +for my $tab (@{$table_by_name{table}}) { + # skip holes: + next unless exists $tab->{name}; + # skip tables already dumped: + next if defined $meta_by_name{$tab->{name}}; + + # xdump meta $tab + $meta_by_uid[$tab->{uid}] = $meta_by_name{$tab->{name}} = []; + parse_xdump(send_cmd("xdump meta $tab->{uid}"), $tab->{uid}); + + # xdump $tab + $table_by_uid[$tab->{uid}] = $table_by_name{$tab->{name}} = []; + parse_xdump(send_cmd("xdump $tab->{uid} *"), $tab->{uid}); +} + +# xdump ver +{ + # pick an unused tuid: + my $tuid = $#meta_by_uid + 1; + # hack the table of tables: + push @{$table_by_name{table}}, {uid => $tuid, name => 'version'}; + # xdump meta ver + $meta_by_uid[$tuid] = $meta_by_name{version} = []; + parse_xdump(send_cmd('xdump meta ver'), $tuid); + # xdump ver + $table_by_uid[$tuid] = $table_by_name{version} = []; + parse_xdump(send_cmd('xdump ver'), $tuid); +} + +$dumper->dumpValue(\@table_by_uid); + + +sub send_cmd { + my ($cmd) = @_; + $empire->empcmd($cmd); + my ($status, $data) = $empire->empreadline($cmd); + die unless ($status eq $Empire::C_PROMPT); + return $data; +} + +sub parse_xdump { + my ($data, $tuid, $store_record) = @_; + $store_record = \&store_record unless defined $store_record; + + # parse header + ($_, $data) = split(/\n/, $data, 2); + /^XDUMP (meta )?(\S+) ([0-9])+$/ + or die; + my $meta = defined $1; + my $name = $2; + my $timestamp = $3; + + # parse body + my $n = 0; + while ($data !~ /^\//) { + ($_, $data) = split(/\n/, $data, 2); + my @fld = split(/ /); + &$store_record($tuid, $meta, $name, $n, \@fld, $timestamp); + $n++; + } + + # parse footer + $data =~ /^\/([0-9]+)$/ + or die; + $n == $1 + or die; +} + +sub store_record { + my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_; + my ($meta_table, $table); + + # find table to update and its meta table + if ($meta) { + $meta_table = \@meta_meta; + $table = $meta_by_name{$name}; + } else { + $meta_table = $meta_by_name{$name}; + $table = $table_by_name{$name}; + $idx = $fld->[0] + if has_record_uid($tuid); + } + + # update record + my $record = $table->[$idx] || {}; + my $fldidx = 0; + for (my $i = 0; $i <= $#{$meta_table}; $i++) { + my $n = is_array($meta_table->[$i]); + my $j; + do { + # update field + my $fldname = $meta_table->[$i]->{name}; + die unless defined $fld->[$fldidx]; + $record->{$fldname} = eval_fld($fld->[$fldidx++]); + } while (++$j < $n); + } + $table->[$idx] = $record; +} + +sub store_meta_meta_record { + my ($tuid, $meta, $name, $idx, $fld, $timestamp) = @_; + die unless $name eq 'meta'; + my $val = eval_fld($fld->[0]); + die if $idx == 0 && $val ne 'name'; + $meta_meta[$idx] = {name => $val, len => 0}; +} + +sub eval_fld { + my ($fld) = @_; + if ($fld =~ /\A[-+.0-9]/) { + # sloppy, doesn't flag malformed numbers + return $fld + 0; + } elsif ($fld =~ /\A\"(.*)\"/) { + # sloppy, doesn't junk after string + $fld = $1; + $fld =~ s/\\([0-7][0-7][0-7])/ chr(oct($1)) /eg; + return $fld; + } + die; +} + +sub has_record_uid { + # a table has record uids if the first field's table is the table's uid + my ($tuid) = @_; + die unless defined $tuid; + die unless defined $meta_by_uid[$tuid]; + die unless defined $meta_by_uid[$tuid]->[0]; + die unless defined $meta_by_uid[$tuid]->[0]->{table}; + return $meta_by_uid[$tuid]->[0]->{table} == $tuid; +} + +sub sym_by_value { + my ($symtab, $value) = @_; + my ($sym) = grep { $_->{value} == $value } @{$symtab}; + return $sym->{name}; +} + +sub is_array { + my ($meta) = @_; + my $len = $meta->{len}; + # non-zero $len means array, except for format 'c' + if ($len == 0 || sym_by_value(\@meta_type, $meta->{type}) eq 'c') { + return 0; + } + return $len; +}