在 Perl 中使用 XML::DOM 构建哈希树

Question

我想使用 XML::DOM 模块解析一个简单的 XML 文档以进行哈希处理。

<?xml version ="1.0"?>
<Select>
  <book>
    <prop Name = "prop1" Title = "title1" />
    <prop Name = "prop2" Title = "title2" />
  </book>
  <fruit>
    <prop Name = "prop3" Title = "title3" />
    <prop Name = "prop4" Title = "title4" />
  </fruit>
</Select>

预期的输出是-

$VAR1 = {
  Select => {
    book  => {
               prop => [
                 { Name => "prop1", Title => "title1" },
                 { Name => "prop2", Title => "title2" },
               ],
             },
    fruit => {
               prop => [
                 { Name => "prop3", Title => "title3" },
                 { Name => "prop4", Title => "title4" },
               ],
             },
  },
}

我写的代码是：

use strict;
use XML::DOM;
use Data::Dumper;

my @stack;
my %hash;
push @stack,\%hash;

my $parser = new XML::DOM::Parser;
my $doc = $parser -> parsefile('demo.xml');
my $root = $doc->getDocumentElement();
my $rootnode = $root->getTagName;

################################################################

foreach my $node ($doc->getElementsByTagName($rootnode)){
    push @stack,$stack[$#stack]->{$rootnode};
    my @childnode = $node->getChildNodes();

    foreach my $child(@childnode){
        if($child->isElementNode){
            my $childname = $child->getNodeName();
            pop(@stack);
            push @stack,$stack[$#stack]->{$rootnode} = {$childname,{}};
            my @childnodes2 = $child->getChildNodes();

            foreach my $subchild(@childnodes2){
                if($subchild->isElementNode){
                    my $subchildname = $subchild->getNodeName();

                    my $name = $subchild->getAttributes->getNamedItem('Name')->getNodeValue;
                    my $title = $subchild->getAttributes->getNamedItem('Title')->getNodeValue;
                    pop(@stack);
                    push @stack,$stack[$#stack]->{$rootnode}->{$child->getNodeName()} = {$subchildname,{}};    #{} contains $name or $title
                }
            }
        }
    }
}

print Dumper(\%hash);

我认为，我无法正确推送和弹出数组。另外，我不想使用XML::Simple 和递归。

如何在 Perl 中做到这一点？

Answer 1

这是一个可能的解决方案，假设整个文档遵循严格的架构，其中一个 Select 作为根，任何不同名称的子节点（不会处理冲突），以及任意数量的 props这些子节点，其中Name 和Title 字段很有趣。

这是序言，我还使用了Carp 来更好地处理错误。

#!/usr/bin/perl

use strict; use warnings; use 5.012;
use XML::DOM;
use Data::Dumper;
use Carp;

这里是主要代码。它启动一个解析器（假设文档在特殊的DATA 文件句柄中），并将生成的文档传递给make_data_structure 子例程。我经常考虑让脚本die，尽早发现错误。

{
    my $xml_parser = XML::DOM::Parser->new;
    my $document_string = do{ local $/=undef; <DATA> };
    my $document = $xml_parser->parse($document_string) or die;

    my $data_structure = make_data_structure($document) or die;
    print Dumper $data_structure;
}

这是完成所有工作的子程序。它接受一个文档并返回一个符合您格式的 hashref。

sub make_data_structure {
    my ($document) = @_;
    my $root = $document->getDocumentElement;
    my $rootname = $root->getTagName // "undef";

    didnt_expect_anything(but=> "Select", as=> "the root tag", got=> $rootname)
        unless $rootname eq "Select";

    my $dsc = +{ $rootname => +{} };
    CHILD:
    for my $child ($root->getChildNodes) {
        next CHILD unless $child->isElementNode;

        my $childname = $child->getTagName
            // couldnt_get("the tag name", of=> "a $rootname child");

        $dsc->{$rootname}{$childname} = undef; # unneccessary iff we have props
        PROP:
        for my $prop ($child->getChildNodes) {
            next PROP unless $prop->isElementNode;

            my $propname = $prop->getTagName // "undef";

            die didnt_expect_anything(but=> "prop", got=> $propname)
                unless $propname eq "prop";

            my $attributes = $prop->getAttributes
                // couldnt_get("the attributes", of=> "a prop node");

            # for minimum code duplication, and maximum error handling,
            # use dataflow programming, and `map`. 
            my ($Name, $Title) =
                map { $_->getNodeValue // couldnt_get("the node value", of=>"the attribute") }
                map { $attributes->getNamedItem($_) // couldnt_get("the named item $_", of=> "the prop attributes") }
                    qw/Name Title/;
            my $propvalue = +{
                Name    => $Name,
                Title   => $Title,
            };

            push @{ $dsc->{$rootname}{$childname}{$propname} }, $propvalue;
        }
    }
    return $dsc;
}

以下是自定义错误处理子例程，以使上述代码更具表现力。

sub didnt_expect_anything {
    my %args = @_;
    my $expected = $args{but} // croak qq(required named argument "but" missing);
    my $role     = $args{as}  // "a tag name";
    my $instead  = $args{got} // croak qq(required named argument "got" missing);
    croak qq(Didn't expect anything but "$expected" as $role here, got "$instead");
}
sub couldnt_get {
    my ($what, %args) = @_;
    my $of_what = $args{of} // croak qq(required named argument "of" missing);
    croak qq(Couldn't get $what of $of_what);
}

当然，会产生正确的输出，但这不是到达那里的正确方法 - 使用 CPAN。

您的实现的部分问题是（除了缺少错误处理），您使用“堆栈”做了一些复杂的体操。

在外循环的第一次迭代之前，@stack 是 +{}（对空哈希的引用）。

$stack[$#stack]->{$rootnode} 行访问堆栈的最后一个元素（最好写为$stack[-1]），将值视为哈希引用，并查找名为$rootnode 的条目。这评估为undef。然后你将这个 value 压入堆栈。混乱随之而来。