1
0
Fork 0
mirror of git://git.psyced.org/git/psyclpc synced 2024-08-15 03:20:16 +00:00
psyclpc/etc/savefile-parse.pl

210 lines
4.9 KiB
Perl
Raw Normal View History

2009-03-03 03:27:01 +00:00
#!/usr/bin/perl -w
######
#
# Parse a mudmode (save_value) string
#
# A single variable value is parsed and represented as perl data structure.
# So a string like '({"a",3,(["b":2,]),})' gets ['a',3,{'b'=>2}]
#
# Fiona 23-Mai-03
#
use Data::Dumper;
$parse_err = undef; # Global error messages
%unquote = (
'r' => "\r",
'f' => "\f",
'v' => "\v",
'n' => "\n",
't' => "\t",
'b' => "\b",
'a' => "\a",
);
# parse a single value
#
# Knows: int, string, array, float, mapping
# (Todo: ref_to_array/mapping, closures)
#
# arguments: source string
# reference to start index of value
# returns value in perl
# set start index to next char (if any) or -1
#
# If an error occured -1 will be returned and $parse_err set
sub get_value {
my ($offsp, $str, $ret, $ret2, $data);
$str = $_[0];
$offsp = $_[1];
# check for float
#
# [German:Koresh@OuterSpace] OS would encode it as #-1.00000001e-01# but
# not sure everybody does it this way.
# [German:Fiona] means ({-0.1}) becomes ({#-1.00000001e-01#,}) ?
# [German] Koresh@OuterSpace nods wildly
# [German] Koresh@OuterSpace also notes that mudos does not seem to include
# the # in floats: it just writes it as ({-1.00000e-08,})
#
# LDmud float
# -9.999999997672e-02=fffd:9999999a
pos($str) = $$offsp;
$str =~ m/\G#?(-?\d.\d*[eE][-+]\d\d)(#|=[0-9a-f:]+)?/sg;
if (defined $1) {
$$offsp = pos($str);
return $1;
}
# check for int (check *after* floats)
pos($str) = $$offsp;
$str =~ m/\G(-?\d+)/sg;
if (defined $1) {
$$offsp = pos($str);
return $1;
}
# check for string
pos($str) = $$offsp;
if ($str =~ m/\G"((?:[^"\\]+|\\.)*)"/sg ) {
$$offsp = pos($str);
# unquote string
$ret = $1;
$ret =~ s/\\(.)/$unquote{$1}||$1/esg;
return $ret;
}
# check for array
pos($str) = $$offsp;
if ($str =~ m/\G\({/sg ) {
$$offsp = pos($str);
$data = [];
if ($str =~ m/\G}\)/sg ) {
$$offsp += 2;
return $data;
}
# recurse array
while (1) {
$ret = get_value($str, $offsp);
return -1 if ($parse_err || $offsp == -1);
push @{$data}, $ret;
pos($str) = $$offsp;
if (not ($str =~ m/\G,/sg )) {
pos($str) = $$offsp;
$str =~ m/\G(.{0,8})/sg;
$parse_err = "Comma missing in array near '$1'";
return -1;
}
$$offsp += 1;
if ($str =~ m/\G}\)/sg ) {
$$offsp += 2;
return $data;
}
}
# notreached
}
# check for mapping
#
# MudOS has no 2dimensional Mappings, so we dont support them
# (perl is unable to represent them anyhow)
# Zero-width mappings are impossible with mudmode/perl, so emulate them.
pos($str) = $$offsp;
if ($str =~ m/\G\(\[/sg ) {
$$offsp = pos($str);
$data = {};
if ($str =~ m/\G]\)/sg ) {
$$offsp += 2;
return $data;
}
# recurse array
while (1) {
$ret = get_value($str, $offsp);
return -1 if ($parse_err || $offsp == -1);
pos($str) = $$offsp;
if (not ($str =~ m/\G[:,]/sg )) {
pos($str) = $$offsp;
if ($str =~ m/\G;/sg ) {
$parse_err = 'Multidimensional mapping not supported near ';
} else {
$parse_err = 'Colon missing in mapping near ';
}
pos($str) = $$offsp;
$str =~ m/\G(.{0,8})/sg;
$parse_err = $parse_err . "'$1'";
return -1;
}
$$offsp += 1;
pos($str) = $$offsp-1;
if ($str =~ m/\G,/sg ) { # zero width, gets simulated...
$ret2 = 0;
} else {
$ret2 = get_value($str, $offsp);
return -1 if ($parse_err || $offsp == -1);
pos($str) = $$offsp;
if (not ($str =~ m/\G,/sg )) {
pos($str) = $$offsp;
$str =~ m/\G(.{0,8})/sg;
$parse_err = "Comma missing in mapping near '$1'";
return -1;
}
$$offsp += 1;
}
$$data{$ret} = $ret2;
if ($str =~ m/\G]\)/sg ) {
$$offsp += 2;
return $data;
}
}
# notreached
}
# check for parse error
pos($str) = $$offsp;
$str =~ m/\G(.{1,8})/sg;
if (defined $1) {
$parse_err = "Unknown variable type near '$1'";
return -1;
}
# end of string
$$offsp = -1;
return -1;
}
######
#
# Sample usage
#
$str = '({1234,45,({12,-1,({0,}),}),"fla\nb\"ber",-1.110999999642e+02=7:90e66667,({}),(["b":"a","c":({1,-2,}),]),([1,2,3,]),})';
#$str='({"error",5,"*gjs",0,"Test-PerlMud-i3",0,"unk-src","router does not know you",({"startup-req-3",5,"Test-PerlMud-i3",0,"",0,1016,4156424,330,0,0,0,"PerlLib v1","PerlLib v1","Perlv5.6.1","Perl","restricted access","castaway@desert-island.m.isar.de",(["channel":1,"nntp":0,"file":0,"amcp":0,"rcp":0,"emoteto":1,"auth":0,"who":1,"smtp":0,"mail":0,"finger":1,"ucache":1,"locate":1,"news":0,"http":0,"ftp":0,"tell":1,]),0,}),})';
$posi = 0;
$ret = get_value($str, \$posi);
if ($parse_err) {
print("ERROR $parse_err\n");
} else {
print(Dumper($ret));
}