Config_XML.pm 7.26 KB
Newer Older
1
2
3
4
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$

5
# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11
12
13
# Copyright 2019 The Sympa Community. See the AUTHORS.md file
# at the top-level directory of this distribution and at
# <https://github.com/sympa-community/sympa.git>.
14
15
16
17
18
19
20
21
22
23
24
25
#
# 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
26
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
27

28
package Sympa::Config_XML;
29

30
use strict;
31
use warnings;
IKEDA Soji's avatar
IKEDA Soji committed
32
use Encode qw();
33
use English qw(-no_match_vars);
34
35
use XML::LibXML;

36
37
38
use Sympa::Log;

my $log = Sympa::Log->instance;
39

40
# Constructor of the class Config_XML :
41
42
#   parse the xml file
#
43
# IN : -$class
44
#      -$file : path of XML file or file handle on the XML file.
45
sub new {
46
    $log->syslog('debug2', '(%s, %s)', @_);
47
    my $class = shift;
48
    my $file  = shift;
49
50

    my $fh;
51
52
53
54
    if (ref $file) {
        $fh = $file;
    } else {
        unless (open $fh, '<', $file) {
55
            $log->syslog('err', 'Can\'t open %s: %s', $file, $ERRNO);
56
57
            return bless {} => $class;
        }
58
    }
59

60
    my $parser = XML::LibXML->new;
61
    $parser->line_numbers(1);
62
63
64
65
66
67
    my $doc = eval { $parser->parse_fh($fh) };
    unless ($doc) {
        $log->syslog('err', '%s',
            (ref $EVAL_ERROR) ? $EVAL_ERROR->as_string : $EVAL_ERROR);
        return bless {} => $class;
    }
68

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    my $root = $doc->documentElement;
    my $config;
    if ($root) {
        unless ($root->nodeName eq 'list') {
            $log->syslog('err', 'The root element must be called "list"');
        } elsif (not _checkRequiredSingle($root, 'listname')) {
            ;
        } else {
            my $hash = _getChildren($root);
            if (ref $hash eq 'HASH' and %$hash) {
                $config = $hash;
            }
        }
    }

    if ($config) {
        # Compatibility: single topic on 6.2.24 or earlier.
        $config->{topics} ||= $config->{topic};
        # In old documentation "moderator" was single or multiple editors.
        my $mod = $config->{moderator};
        $config->{editor} ||=
            (ref $mod eq 'ARRAY') ? $mod : (ref $mod eq 'HASH') ? [$mod] : [];
    }
92

93
    return bless {config => $config} => $class;
94
95
}

96
97
# Returns the hash structure.
sub as_hashref {
98
    return shift->{config} || undef;
99
100
101
}

# Old name: Sympa::Config_XML::createHash().
102
103
# Deprecated: No longer used.
#sub _createHash;
104

105
106
# Deprecated: No longer used.
#sub getHash;
107

108
109
# Deprecated: No longer used.
#sub _getRequiredElements;
110

111
112
# No longer used.
#sub _getMultipleAndRequiredChild;
113

114
115
116
117
# Old name: Sympa::Config_XML::_getRequiredSingle().
sub _checkRequiredSingle {
    $log->syslog('debug3', '(%s, %s, %s)', @_);
    my $root     = shift;
118
119
    my $nodeName = shift;

120
121
    my @nodes = $root->getChildrenByTagName($nodeName);
    unless (@nodes) {
122
        $log->syslog('err', 'Element "%s" is required for the list',
123
124
            $nodeName);
        return undef;
125
126
    } elsif (1 < scalar @nodes) {
        my @error = map { $_->line_number } @nodes;
127
        $log->syslog('err',
128
            'Only one element "%s" is allowed for the list, lines: %s',
129
130
            $nodeName, join(", ", @error));
        return undef;
131
    } elsif ($nodes[0]->getAttribute('multiple')) {
132
        $log->syslog('err',
133
            'Attribute multiple not allowed for the element "%s"', $nodeName);
134
135
136
        return undef;
    }

137
138
139
    my $values = _getChildren($nodes[0]);
    if (not $values or ref $values) {
        return undef;
140
    }
141

142
143
144
    return 1;
}

145
146
# Gets $node's children (elements, text, cdata section) and their values
# recursively.
147
# IN :  -$node
148
149
# OUT : -$hash : hash of children and their contents if elements, or
#        $string : value of cdata section or of text content
150
sub _getChildren {
151
    $log->syslog('debug3', '(%s)', @_);
152
153
    my $node = shift;

154
    # return value
155
    my $hash   = {};
156
    my $string = "";
157
158
159
    my $return = "empty";    # "hash", "string", "empty"

    my $error          = 0;  # children not homogeneous
160
161
162
163
164
    my $multiple_nodes = {};

    my @nodeList = $node->childNodes();

    foreach my $child (@nodeList) {
165
166
        my $type      = $child->nodeType;
        my $childName = $child->nodeName;
167

168
        if ($type == 1) {
169
            # ELEMENT_NODE
170
            my $values = _getChildren($child);
171
            return undef unless $values;
172
173
174
175

            if ($child->getAttribute('multiple')) {
                push @{$multiple_nodes->{$childName}}, $values;
            } else {
176
177
178
179
180
181
182
183
184
185
186
187
                # Verify single nodes.
                my @sisters = $node->getChildrenByTagName($childName);
                if (1 < scalar @sisters) {
                    $log->syslog(
                        'err',
                        'Element "%s" is not declared in multiple but it is: lines %s',
                        $childName,
                        join(', ', map { $_->line_number } @sisters)
                    );
                    return undef;
                }

188
189
190
191
192
193
194
195
196
197
198
199
200
201
                if (ref($values) eq "HASH") {
                    foreach my $k (keys %$values) {
                        $hash->{$childName}{$k} = $values->{$k};
                    }
                } else {
                    $hash->{$childName} = $values;
                }
            }

            if ($return eq "string") {
                $error = 1;
            }
            $return = "hash";
        } elsif ($type == 3) {
202
            # TEXT_NODE
203
204
205
206
207
208
209
210
211
212
            my $value = Encode::encode_utf8($child->nodeValue);
            $value =~ s/^\s+//;
            unless ($value eq "") {
                $string = $string . $value;
                if ($return eq "hash") {
                    $error = 1;
                }
                $return = "string";
            }
        } elsif ($type == 4) {
213
            # CDATA_SECTION_NODE
214
215
216
217
218
219
220
221
222
            $string = $string . Encode::encode_utf8($child->nodeValue);
            if ($return eq "hash") {
                $error = 1;
            }
            $return = "string";
        }

        ## error
        if ($error) {
223
            $log->syslog('err',
224
225
                '(%s) The children are not homogeneous, line %s',
                $node->nodeName, $node->line_number());
226
227
            return undef;
        }
228
229
230
    }

    ## return
231
232
    foreach my $array (keys %$multiple_nodes) {
        $hash->{$array} = $multiple_nodes->{$array};
233
234
235
    }

    if ($return eq "hash") {
236
        return $hash;
237
    } elsif ($return eq "string") {
238
239
240
241
242
        $string =~ s/^\s*//;
        $string =~ s/\s*$//;
        return $string;
    } else {    # "empty"
        return "";
243
244
245
    }
}

246
247
# Deprecated: No longer used.
#sub _verify_single_nodes;
248

249
250
# Deprecated: No longer used.
#sub _find_lines;
251

252
1;