mirror of
https://github.com/troydhanson/tpl.git
synced 2024-12-27 08:05:39 +08:00
307 lines
11 KiB
Perl
Executable File
307 lines
11 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
# tplxml
|
|
# by Troy Hanson 27 Feb 2006
|
|
# convert between tpl and XML
|
|
|
|
# Copyright (c) 2005-2006, Troy Hanson http://tpl.sourceforge.net
|
|
# All rights reserved.
|
|
#
|
|
# Redistribution and use in source and binary forms, with or without
|
|
# modification, are permitted provided that the following conditions are met:
|
|
#
|
|
# * Redistributions of source code must retain the above copyright
|
|
# notice, this list of conditions and the following disclaimer.
|
|
# * Redistributions in binary form must reproduce the above copyright
|
|
# notice, this list of conditions and the following disclaimer in
|
|
# the documentation and/or other materials provided with the
|
|
# distribution.
|
|
# * Neither the name of the copyright holder nor the names of its
|
|
# contributors may be used to endorse or promote products derived
|
|
# from this software without specific prior written permission.
|
|
#
|
|
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
|
|
# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
|
# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
|
|
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
|
|
# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
|
|
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
|
|
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
|
|
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
|
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
use strict;
|
|
use warnings;
|
|
use XML::Parser;
|
|
use FindBin;
|
|
use lib "$FindBin::Bin"; #locate Tpl.pm in same directory as tplxml
|
|
use Tpl;
|
|
use bytes;
|
|
|
|
sub quote_chars {
|
|
my $str = shift;
|
|
$$str =~ s/&/&/g; #order matters
|
|
$$str =~ s/</</g;
|
|
$$str =~ s/>/>/g;
|
|
}
|
|
sub unquote_chars {
|
|
my $str = shift;
|
|
$$str =~ s/</</g;
|
|
$$str =~ s/>/>/g;
|
|
$$str =~ s/&/&/g;
|
|
}
|
|
sub hex_chars {
|
|
my $str = shift;
|
|
my $hex;
|
|
for(my $i=0; $i < length $$str; $i++) {
|
|
my $byte = unpack("C",substr($$str,$i,1));
|
|
$hex .= sprintf("%02x", $byte);
|
|
}
|
|
$$str = $hex;
|
|
}
|
|
sub unhex_chars {
|
|
my $str = shift;
|
|
my $bytes;
|
|
for(my $i=0; $i < length $$str; $i+=2) {
|
|
my $hexbyte = substr($$str,$i,2);
|
|
$bytes .= pack("C", hex($hexbyte));
|
|
}
|
|
$$str= $bytes;
|
|
}
|
|
|
|
sub tpl2xml {
|
|
my $src = shift;
|
|
my (@out,@args);
|
|
|
|
# build list of references to hold output of unpacking
|
|
my ($fmt,@fxlens) = peek_fmt($src);
|
|
for(my ($i,$j,$k)=(0,0,0);$i<length($fmt);$i++) {
|
|
push @args, [] if substr($fmt,$i,2) =~ /^[iucfIU]\#$/; # octothorpic
|
|
push @args, \$out[$j++] if substr($fmt,$i,2) =~ /^[iuBscfIU][^\#]*$/;
|
|
push @args, $fxlens[$k++] if substr($fmt,$i,1) eq "#";
|
|
}
|
|
|
|
my $tpl = Tpl->tpl_map($fmt,@args);
|
|
$tpl->tpl_load($src);
|
|
$tpl->tpl_unpack(0);
|
|
|
|
# construct xml preamble
|
|
my $pre = qq{<?xml version="1.0" encoding="utf-8" ?>
|
|
<!DOCTYPE tplxml [
|
|
<!ELEMENT tplxml (A|i|u|I|U|B|s|c|f|fx)*>
|
|
<!ATTLIST tplxml
|
|
format CDATA #REQUIRED
|
|
fxlens CDATA #REQUIRED
|
|
>
|
|
<!ELEMENT i (#PCDATA)>
|
|
<!ELEMENT u (#PCDATA)>
|
|
<!ELEMENT I (#PCDATA)>
|
|
<!ELEMENT U (#PCDATA)>
|
|
<!ELEMENT B (#PCDATA)>
|
|
<!ELEMENT s (#PCDATA)>
|
|
<!ELEMENT c (#PCDATA)>
|
|
<!ELEMENT f (#PCDATA)>
|
|
<!ELEMENT A (el)*>
|
|
<!ELEMENT el (A|i|u|I|U|B|s|c|f|fx)+>
|
|
<!ELEMENT fx (i|u|I|U|c|f)*>
|
|
]>\n};
|
|
print $pre;
|
|
my $fxattr = join ",", @fxlens;
|
|
print qq{<tplxml format="$fmt" fxlens="$fxattr">\n};
|
|
tpl2xml_node($tpl,"A0",1);
|
|
print qq{</tplxml>\n};
|
|
}
|
|
|
|
sub tpl2xml_node {
|
|
my $tpl = shift;
|
|
my $node = shift;
|
|
my $indent = shift;
|
|
my $i = " " x $indent;
|
|
for my $c (@{ $tpl->{$node} }) {
|
|
if (ref($c)) {
|
|
my ($type,$addr,$fxlen) = @$c;
|
|
quote_chars $addr if $type eq 's';
|
|
hex_chars $addr if $type eq 'B';
|
|
if (not defined $fxlen) {
|
|
print qq{$i<$type>$$addr</$type>\n}; # singleton
|
|
} else {
|
|
# all elements of octothorpic fixed-len array
|
|
print qq{$i<fx>\n};
|
|
print qq{$i <$type>$addr->[$_]</$type>\n} for (0..$fxlen-1);
|
|
print qq{$i</fx>\n};
|
|
}
|
|
} else {
|
|
# A node
|
|
print qq{$i<A>\n};
|
|
my $idx = $1 if $c =~ /^A(\d+)$/;
|
|
while($tpl->tpl_unpack($idx) > 0) {
|
|
print qq{$i<el>\n};
|
|
tpl2xml_node($tpl,$c,$indent+1);
|
|
print qq{$i</el>\n};
|
|
}
|
|
print qq{$i</A>\n};
|
|
}
|
|
}
|
|
}
|
|
|
|
sub xml2tpl {
|
|
my $src = shift;
|
|
my $p = new XML::Parser( Style => 'Tree' );
|
|
my $tree = $p->parse($$src);
|
|
die "not a tpl xml document" unless $tree->[0] eq 'tplxml';
|
|
die "no format attribute" unless defined $tree->[1][0]->{format};
|
|
my $fmt = $tree->[1][0]->{format};
|
|
die "no fxlens attribute" unless defined $tree->[1][0]->{fxlens};
|
|
my @fxlens = split /,/, $tree->[1][0]->{fxlens};
|
|
|
|
# build list of references to variables for use in packing
|
|
my (@args,@out);
|
|
for(my ($i,$j,$k)=(0,0,0);$i<length($fmt);$i++) {
|
|
push @args, [] if substr($fmt,$i,2) =~ /^[iucfIU]\#$/; # octothorpic
|
|
push @args, \$out[$j++] if substr($fmt,$i,2) =~ /^[iuBscfIU][^\#]*$/;
|
|
push @args, $fxlens[$k++] if substr($fmt,$i,1) eq "#";
|
|
}
|
|
|
|
my $tpl = Tpl->tpl_map($fmt,@args);
|
|
xml2tpl_dfs($tpl,$tree->[1]);
|
|
$tpl->tpl_pack(0);
|
|
print $tpl->tpl_dump;
|
|
}
|
|
|
|
sub xml2tpl_dfs {
|
|
my $tpl = shift;
|
|
my $xml = shift;
|
|
|
|
my @next = @$xml; # ($attr,@tagvals) = $$xml;
|
|
shift @next; # discard <tplxml> attributes
|
|
my @tpltoks = @{ $tpl->{"A0"} }; #expected tokens when parsing
|
|
|
|
TAG: while (@next) {
|
|
my $xmltag = shift @next;
|
|
my $xmlval = shift @next;
|
|
|
|
# skip whitespace/newlines embedded between tags
|
|
next TAG if ($xmltag eq "0" and $xmlval =~ /^\s+$/);
|
|
|
|
# pack if necessary. consume tokens by look-ahead until non-pack token.
|
|
while (@tpltoks > 0 and $tpltoks[0] =~ /^P(\d+)$/) {
|
|
shift @tpltoks;
|
|
$tpl->tpl_pack($1);
|
|
}
|
|
|
|
# If tpl format specifies a non-array type should appear at this point
|
|
# in the XML tree, then validate the type matches the format and assign
|
|
# the value from the XML to the variable from which it'll be packed
|
|
my $tpltoken = shift @tpltoks;
|
|
my $octothorpic=0;
|
|
if (ref $tpltoken) {
|
|
my ($tpltype,$tpladdr,$fxlen) = @$tpltoken;
|
|
|
|
# This block is how we handle octothorpic (fixed length) arrays.
|
|
# If $fxlen is defined then an octothorpic <fx> node is expected.
|
|
# After finding the <fx> node we put its subnodes (the array elements)
|
|
# onto the @next array for immediate parsing and we use $fxlen:$remaining
|
|
# as a signet version of the $fxlen to induce the element-processing loop.
|
|
if (defined $fxlen) {
|
|
if ($fxlen =~ /^(\d+):(\d+)$/) { # $1==orig $fxlen, $2==remain $fxlen
|
|
$octothorpic=1;
|
|
unshift @tpltoks, [$tpltype, $tpladdr, $1.":".($2-1)] if $2 > 1;
|
|
} else { # octothorpic array expected; look for <fx> parent node
|
|
die "expected '<fx>' but got '<$xmltag>'" unless $xmltag eq 'fx';
|
|
@{ $tpladdr } = (); # Empty accumulator array for octothorpic values
|
|
unshift @tpltoks, [$tpltype, $tpladdr, "$fxlen:$fxlen"]; # x:x signet
|
|
shift @$xmlval; # discard 'A' attributes
|
|
unshift @next, @$xmlval; #parse xml subtree now (dfs)
|
|
next TAG; # proceed to children of <fx> node
|
|
}
|
|
}
|
|
|
|
if ($tpltype ne $xmltag) {
|
|
die "mismatch: xml has '$xmltag' where format specifies '$tpltype'";
|
|
}
|
|
# expect @$xmlval to be ({},0,'value') i.e. a single, terminal text node
|
|
if (@$xmlval > 3 || $xmlval->[1] ne '0') {
|
|
die "error: xml tag '$xmltag' cannot enclose sub-tags";
|
|
}
|
|
if ($octothorpic) {
|
|
push @{ $tpladdr }, $xmlval->[2];
|
|
} else {
|
|
$$tpladdr = $xmlval->[2];
|
|
}
|
|
unquote_chars $tpladdr if $tpltype eq 's';
|
|
unhex_chars $tpladdr if $tpltype eq 'B';
|
|
} elsif ($tpltoken =~ /^A(\d+)$/) {
|
|
# tpl format specifies an array should appear at this point in the XML
|
|
if ($xmltag ne 'A') {
|
|
die "mismatch: xml has '$xmltag' where format specifies 'A'";
|
|
}
|
|
shift @$xmlval; # discard 'A' attributes
|
|
|
|
# form token that means "replace me with tokens from A(n), x times"
|
|
# (where x is the number of elements contained by this array).
|
|
my $array_count=0;
|
|
for(my $i=0; $i < @$xmlval; $i+=2) {
|
|
$array_count++ if $xmlval->[$i] eq 'el';
|
|
}
|
|
|
|
unshift @tpltoks, "N$1:$array_count" if $array_count > 0;
|
|
unshift @next, @$xmlval; #parse xml subtree now (dfs)
|
|
} elsif ($tpltoken =~ /^N(\d+):(\d+)$/) {
|
|
if ($xmltag ne "el") {
|
|
die "mismatch: xml has '$xmltag' where array 'el' is expected";
|
|
}
|
|
# prepend A$1's tokens (and decremented N:count) to expected tokens
|
|
my ($n,$elsleft) = ($1, ($2 - 1));
|
|
unshift @tpltoks, "N$n:$elsleft" if $elsleft > 0;
|
|
unshift @tpltoks, "P$n"; # "pack me now" token
|
|
unshift @tpltoks, @{ $tpl->{"A$1"} };
|
|
|
|
shift @$xmlval; # discard 'el' attributes
|
|
unshift @next, @$xmlval; # proceed to parse el subtree (dfs)
|
|
} else {
|
|
die "internal error, unexpected token $tpltoken";
|
|
}
|
|
}
|
|
|
|
# pack if necessary. consume tokens by look-ahead until non-pack token.
|
|
while (@tpltoks > 0 and $tpltoks[0] =~ /^P(\d+)$/) {
|
|
shift @tpltoks;
|
|
$tpl->tpl_pack($1);
|
|
}
|
|
|
|
if (@tpltoks > 0) {
|
|
die "error: end of xml document reached but format requires more data";
|
|
}
|
|
}
|
|
|
|
sub peek_fmt {
|
|
my $buf = shift;
|
|
die "invalid tpl file" unless ($$buf =~ /^tpl/);
|
|
my $flags = CORE::unpack("C", substr($$buf,3,1));
|
|
my $UF = ($flags & 1) ? "N" : "V"; # big or little endian fxlens
|
|
my $fmt = (CORE::unpack("Z*", substr($$buf,8)));
|
|
my $num_octothorpes = scalar (my @o = ($fmt =~ /#/g));
|
|
my @fxlens;
|
|
my $fx = 8 + length($fmt) + 1;
|
|
for(my $i=0; $i < $num_octothorpes; $i++) {
|
|
my $fxlen_bytes = substr($$buf,$fx,4);
|
|
my $fxlen = unpack($UF, $fxlen_bytes);
|
|
push @fxlens, $fxlen;
|
|
$fx += 4;
|
|
}
|
|
return ($fmt,@fxlens);
|
|
}
|
|
|
|
##########################################################################
|
|
# Slurp input file, auto-detect if conversion is to tpl or XML, and run.
|
|
##########################################################################
|
|
|
|
undef $/;
|
|
my $src = <>;
|
|
our $to = (substr($src,0,3) eq "tpl") ? "xml" : "tpl";
|
|
xml2tpl(\$src) if $to eq "tpl";
|
|
tpl2xml(\$src) if $to eq "xml";
|
|
|