*** empty log message ***

diff --git a/scripts/xdump.pl b/scripts/xdump.pl
new file mode 100644 (file)
index 0000000..2c56d02
--- /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;
+}