Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Projets publics
Sympa
Commits
051e21df
Unverified
Commit
051e21df
authored
Dec 01, 2019
by
IKEDA Soji
Committed by
GitHub
Dec 01, 2019
Browse files
Merge pull request #816 from ikedas/issue-815 by ikedas
Family: Fixing bugs injected by #771 (#815)
parents
90c35054
9b562c6b
Changes
7
Hide whitespace changes
Inline
Side-by-side
Makefile.am
View file @
051e21df
...
...
@@ -34,6 +34,7 @@ check_SCRIPTS = \
t/compile_modules.t
\
t/compile_executables.t
\
t/compile_scenarios.t
\
t/Config_XML.t
\
t/Database_LDAP.t
\
t/parse_templates.t
\
t/pod-syntax.t
\
...
...
src/cgi/wwsympa.fcgi.in
View file @
051e21df
...
...
@@ -9746,7 +9746,7 @@ sub do_create_list {
creation_email => $param->{'user'}{'email'},
lang => $param->{'lang'},
status => $param->{'status'}, #FIXME
t
emplate
=> $in{'template'},
t
ype
=> $in{'template'},
topics => $in{'topics'},
description => $in{'info'},
custom_input => $in{'custom_input'},
...
...
src/lib/Sympa/Config_XML.pm
View file @
051e21df
...
...
@@ -30,252 +30,126 @@ package Sympa::Config_XML;
use
strict
;
use
warnings
;
use
Encode
qw()
;
use
English
qw(-no_match_vars)
;
use
XML::
LibXML
;
use
Sympa::
Log
;
my
$log
=
Sympa::
Log
->
instance
;
#########################################
# new
#########################################
# constructor of the class Config_XML :
# Constructor of the class Config_XML :
# parse the xml file
#
# IN : -$class
# -$fh : file handler on the xml file
#########################################
# -$file : path of XML file or file handle on the XML file.
sub
new
{
$log
->
syslog
('
debug2
',
'
(%s, %s)
',
@
_
);
my
$class
=
shift
;
my
$
path
=
shift
;
my
$
file
=
shift
;
my
$fh
;
unless
(
open
$fh
,
'
<
',
$path
)
{
$log
->
syslog
('
err
',
'
Can
\'
t open %s: $m
',
$path
);
return
bless
{}
=>
$class
;
if
(
ref
$file
)
{
$fh
=
$file
;
}
else
{
unless
(
open
$fh
,
'
<
',
$file
)
{
$log
->
syslog
('
err
',
'
Can
\'
t open %s: $m
',
$file
);
return
bless
{}
=>
$class
;
}
}
my
$self
=
{};
my
$parser
=
XML::
LibXML
->
new
();
my
$parser
=
XML::
LibXML
->
new
;
$parser
->
line_numbers
(
1
);
my
$doc
=
$parser
->
parse_fh
(
$fh
);
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
;
}
$self
->
{'
root
'}
=
$doc
->
documentElement
();
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
]
:
[]
;
}
return
bless
$self
=>
$class
;
return
bless
{
config
=>
$config
}
=>
$class
;
}
# Returns the hash structure.
sub
as_hashref
{
$log
->
syslog
('
debug2
',
'
(%s)
',
@
_
);
my
$self
=
shift
;
return
undef
unless
$self
->
{
root
};
return
undef
unless
$self
->
_createHash
;
my
$phash
=
{
%
{
$self
->
{
config
}
||
{}}};
# Compatibility: single topic on 6.2.24 or earlier.
$phash
->
{
topics
}
||=
$phash
->
{
topic
};
# In old documentation "moderator" was single or multiple editors.
my
$mod
=
$phash
->
{
moderator
};
$phash
->
{
editor
}
||=
(
ref
$mod
eq
'
ARRAY
')
?
$mod
:
(
ref
$mod
eq
'
HASH
')
?
[
$mod
]
:
[]
;
return
$phash
;
return
shift
->
{
config
}
||
undef
;
}
# Create a hash used to create a list. Check elements unicity when their are
# not declared multiple.
# Old name: Sympa::Config_XML::createHash().
sub
_createHash
{
my
$self
=
shift
;
unless
(
$self
->
{'
root
'}
->
nodeName
eq
'
list
')
{
$log
->
syslog
('
err
',
'
The root element must be called "list"
');
return
undef
;
}
unless
(
defined
$self
->
_getRequiredElements
())
{
$log
->
syslog
('
err
',
'
Error in required elements
');
return
undef
;
}
if
(
$self
->
{'
root
'}
->
hasChildNodes
())
{
my
$hash
=
_getChildren
(
$self
->
{'
root
'});
unless
(
$hash
)
{
$log
->
syslog
('
err
',
'
Error in list elements
');
return
undef
;
}
elsif
(
ref
$hash
eq
'
HASH
')
{
$self
->
{
config
}
=
{
%$hash
};
}
else
{
# a string
$log
->
syslog
('
err
',
'
The list
\'
s children are not homogeneous
');
return
undef
;
}
}
return
1
;
}
# Deprecated: No longer used.
#sub _createHash;
# Deprecated: No longer used.
#sub getHash;
#################################################################
# _getRequiredElements
#################################################################
# get all obligatory elements and store them :
# single : listname
# remove it in order to the later recursive call
#
# IN : -$self
# OUT : -1 or undef
#################################################################
sub
_getRequiredElements
{
$log
->
syslog
('
debug3
',
@
_
);
my
$self
=
shift
;
# listname element is obligatory
unless
(
$self
->
_getRequiredSingle
('
listname
'))
{
return
undef
;
}
return
1
;
}
####################################################
# _getMultipleAndRequiredChild : no used anymore
####################################################
# get all nodes with name $nodeName and check if
# they contain the child $childName and store them
#
# IN : -$self
# -$nodeName
# -$childName
# OUT : - the number of node with the name $nodeName
####################################################
sub
_getMultipleAndRequiredChild
{
my
$self
=
shift
;
my
$nodeName
=
shift
;
my
$childName
=
shift
;
$log
->
syslog
('
debug3
',
'
(%s, %s)
',
$nodeName
,
$childName
);
my
@nodes
=
$self
->
{'
root
'}
->
getChildrenByTagName
(
$nodeName
);
unless
(
defined
_verify_single_nodes
(
\
@nodes
))
{
return
undef
;
}
foreach
my
$o
(
@nodes
)
{
my
@child
=
$o
->
getChildrenByTagName
(
$childName
);
if
(
$#child
<
0
)
{
$log
->
syslog
('
err
',
'
Element "%s" is required for element "%s", line: %s
',
$childName
,
$nodeName
,
$o
->
line_number
());
return
undef
;
}
my
$hash
=
_getChildren
(
$o
);
unless
(
defined
$hash
)
{
$log
->
syslog
('
err
',
'
Error on _getChildren(%s)
',
$o
->
nodeName
);
return
undef
;
}
# Deprecated: No longer used.
#sub _getRequiredElements;
push
@
{
$self
->
{'
config
'}{
$nodeName
}},
$hash
;
$self
->
{'
root
'}
->
removeChild
(
$o
);
}
return
(
$#nodes
+
1
);
}
# No longer used.
#sub _getMultipleAndRequiredChild;
############################################
# _getRequiredSingle
############################################
# get the node with name $nodeName and check
# its unicity and store it
#
# IN : -$self
# -$nodeName
# OUT : -1 or undef
############################################
sub
_getRequiredSingle
{
my
$self
=
shift
;
# Old name: Sympa::Config_XML::_getRequiredSingle().
sub
_checkRequiredSingle
{
$log
->
syslog
('
debug3
',
'
(%s, %s, %s)
',
@
_
);
my
$root
=
shift
;
my
$nodeName
=
shift
;
$log
->
syslog
('
debug3
',
'
(%s)
',
$nodeName
);
my
@nodes
=
$self
->
{'
root
'}
->
getChildrenByTagName
(
$nodeName
);
unless
(
_verify_single_nodes
(
\
@nodes
))
{
return
undef
;
}
if
(
$#nodes
<
0
)
{
my
@nodes
=
$root
->
getChildrenByTagName
(
$nodeName
);
unless
(
@nodes
)
{
$log
->
syslog
('
err
',
'
Element "%s" is required for the list
',
$nodeName
);
return
undef
;
}
if
(
$#nodes
>
0
)
{
my
@error
;
foreach
my
$i
(
@nodes
)
{
push
(
@error
,
$i
->
line_number
());
}
}
elsif
(
1
<
scalar
@nodes
)
{
my
@error
=
map
{
$_
->
line_number
}
@nodes
;
$log
->
syslog
('
err
',
'
Only one element "%s" is allowed for the list, lines: %s
',
$nodeName
,
join
("
,
",
@error
));
return
undef
;
}
my
$node
=
shift
(
@nodes
);
if
(
$node
->
getAttribute
('
multiple
'))
{
}
elsif
(
$nodes
[
0
]
->
getAttribute
('
multiple
'))
{
$log
->
syslog
('
err
',
'
Attribute multiple=1 not allowed for the element "%s"
',
$nodeName
);
'
Attribute multiple not allowed for the element "%s"
',
$nodeName
);
return
undef
;
}
if
(
$nodeName
eq
'
type
')
{
## the list template creation without family context
my
$value
=
$node
->
textContent
;
$value
=~
s/^\s*//
;
$value
=~
s/\s*$//
;
$self
->
{
$nodeName
}
=
$value
;
}
else
{
my
$values
=
_getChildren
(
$node
);
unless
(
defined
$values
)
{
$log
->
syslog
('
err
',
'
Error on _getChildren(%s)
',
$node
->
nodeName
);
return
undef
;
}
if
(
ref
(
$values
)
eq
"
HASH
")
{
foreach
my
$k
(
keys
%$values
)
{
$self
->
{'
config
'}{
$nodeName
}{
$k
}
=
$values
->
{
$k
};
}
}
else
{
$self
->
{'
config
'}{
$nodeName
}
=
$values
;
}
my
$values
=
_getChildren
(
$nodes
[
0
]);
if
(
not
$values
or
ref
$values
)
{
return
undef
;
}
$self
->
{'
root
'}
->
removeChild
(
$node
);
return
1
;
}
##############################################
# _getChildren
##############################################
# get $node's children (elements, text,
# cdata section) and their values
# it is a recursive call
#
# Gets $node's children (elements, text, cdata section) and their values
# recursively.
# IN : -$node
# OUT : -$hash : hash of children and
# their contents if elements
# or
# $string : value of cdata section
# or of text content
##############################################
# OUT : -$hash : hash of children and their contents if elements, or
# $string : value of cdata section or of text content
sub
_getChildren
{
$log
->
syslog
('
debug3
',
'
(%s)
',
@
_
);
my
$node
=
shift
;
$log
->
syslog
('
debug3
',
'
(%s)
',
$node
->
nodeName
);
# return value
my
$hash
=
{};
...
...
@@ -287,28 +161,30 @@ sub _getChildren {
my
@nodeList
=
$node
->
childNodes
();
unless
(
_verify_single_nodes
(
\
@nodeList
))
{
return
undef
;
}
foreach
my
$child
(
@nodeList
)
{
my
$type
=
$child
->
nodeType
;
my
$childName
=
$child
->
nodeName
;
# ELEMENT_NODE
if
(
$type
==
1
)
{
# ELEMENT_NODE
my
$values
=
_getChildren
(
$child
);
unless
(
defined
$values
)
{
$log
->
syslog
('
err
',
'
Error on _getChildren(%s)
',
$childName
);
return
undef
;
}
return
undef
unless
$values
;
## multiple
if
(
$child
->
getAttribute
('
multiple
'))
{
push
@
{
$multiple_nodes
->
{
$childName
}},
$values
;
## single
}
else
{
# 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
;
}
if
(
ref
(
$values
)
eq
"
HASH
")
{
foreach
my
$k
(
keys
%$values
)
{
$hash
->
{
$childName
}{
$k
}
=
$values
->
{
$k
};
...
...
@@ -322,9 +198,8 @@ sub _getChildren {
$error
=
1
;
}
$return
=
"
hash
";
# TEXT_NODE
}
elsif
(
$type
==
3
)
{
# TEXT_NODE
my
$value
=
Encode::
encode_utf8
(
$child
->
nodeValue
);
$value
=~
s/^\s+//
;
unless
(
$value
eq
"")
{
...
...
@@ -334,9 +209,8 @@ sub _getChildren {
}
$return
=
"
string
";
}
# CDATA_SECTION_NODE
}
elsif
(
$type
==
4
)
{
# CDATA_SECTION_NODE
$string
=
$string
.
Encode::
encode_utf8
(
$child
->
nodeValue
);
if
(
$return
eq
"
hash
")
{
$error
=
1
;
...
...
@@ -369,68 +243,10 @@ sub _getChildren {
}
}
##################################################
# _verify_single_nodes
##################################################
# check the uniqueness(in a node list) for a node not
# declared multiple.
# (no attribute multiple = "1")
#
# IN : -$nodeList : ref on the array of nodes
# OUT : -1 or undef
##################################################
sub
_verify_single_nodes
{
my
$nodeList
=
shift
;
$log
->
syslog
('
debug3
',
'');
my
$error
=
0
;
my
%error_nodes
;
my
$nodeLines
=
_find_lines
(
$nodeList
);
foreach
my
$node
(
@$nodeList
)
{
if
(
$node
->
nodeType
==
1
)
{
# ELEMENT_NODE
unless
(
$node
->
getAttribute
("
multiple
"))
{
my
$name
=
$node
->
nodeName
;
if
(
$#
{
$nodeLines
->
{
$name
}}
>
0
)
{
$error_nodes
{
$name
}
=
1
;
}
}
}
}
foreach
my
$node
(
keys
%error_nodes
)
{
my
$lines
=
join
'
,
',
@
{
$nodeLines
->
{
$node
}};
$log
->
syslog
('
err
',
'
Element %s is not declared in multiple but it is: lines %s
',
$node
,
$lines
);
$error
=
1
;
}
if
(
$error
)
{
return
undef
;
}
return
1
;
}
# Deprecated: No longer used.
#sub _verify_single_nodes;
###############################################
# _find_lines
###############################################
# make a hash : keys are node names, values
# are arrays of their line occurrences
#
# IN : - $nodeList : ref on a array of nodes
# OUT : - $hash : ref on the hash defined
###############################################
sub
_find_lines
{
my
$nodeList
=
shift
;
$log
->
syslog
('
debug3
',
'');
my
$hash
=
{};
foreach
my
$node
(
@$nodeList
)
{
if
(
$node
->
nodeType
==
1
)
{
# ELEMENT_NODE
push
@
{
$hash
->
{
$node
->
nodeName
}},
$node
->
line_number
();
}
}
return
$hash
;
}
# Deprecated: No longer used.
#sub _find_lines;
1
;
src/lib/Sympa/Request/Handler/create_list.pm
View file @
051e21df
...
...
@@ -73,7 +73,7 @@ sub _twist {
my
$listname
=
lc
$param
->
{
listname
};
# Obligatory parameters.
foreach
my
$arg
(
qw(subject t
emplat
e topics)
)
{
foreach
my
$arg
(
qw(subject t
yp
e topics)
)
{
unless
(
defined
$param
->
{
$arg
}
and
$param
->
{
$arg
}
=~
/\S/
)
{
$self
->
add_stash
(
$request
,
'
user
',
'
missing_arg
',
{
argument
=>
$arg
});
...
...
@@ -113,11 +113,11 @@ sub _twist {
## Check the template supposed to be used exist.
my
$template_file
=
Sympa::
search_fullpath
(
$robot_id
,
'
config.tt2
',
subdir
=>
'
create_list_templates/
'
.
$param
->
{
t
emplat
e
});
subdir
=>
'
create_list_templates/
'
.
$param
->
{
t
yp
e
});
unless
(
defined
$template_file
)
{
$log
->
syslog
('
err
',
'
No template %s found
',
$param
->
{
t
emplat
e
});
$log
->
syslog
('
err
',
'
No template %s found
',
$param
->
{
t
yp
e
});
$self
->
add_stash
(
$request
,
'
user
',
'
unknown_template
',
{
tpl
=>
$param
->
{
t
emplat
e
}});
{
tpl
=>
$param
->
{
t
yp
e
}});
return
undef
;
}
...
...
@@ -171,10 +171,10 @@ sub _twist {
my
$config
=
'';
my
$template
=
Sympa::
Template
->
new
(
$robot_id
,
subdir
=>
'
create_list_templates/
'
.
$param
->
{
'
template
'
});
subdir
=>
'
create_list_templates/
'
.
$param
->
{
type
});
unless
(
$template
->
parse
(
$param
,
'
config.tt2
',
\
$config
))
{
$log
->
syslog
('
err
',
'
Can
\'
t parse %s/config.tt2: %s
',
$param
->
{
'
template
'
},
$template
->
{
last_error
});
$param
->
{
type
},
$template
->
{
last_error
});
$self
->
add_stash
(
$request
,
'
intern
');
return
undef
;
}
...
...
src/lib/Sympa/WWW/SOAP.pm
View file @
051e21df
...
...
@@ -626,7 +626,7 @@ sub createList {
],
subject
=>
$subject
,
creation_email
=>
$sender
,
t
emplate
=>
$list_tpl
,
t
ype
=>
$list_tpl
,
topics
=>
$topics
,
description
=>
$description
,
},
...
...
src/sbin/sympa.pl.in
View file @
051e21df
...
...
@@ -728,7 +728,7 @@ if ($main::options{'dump'} or $main::options{'dump_users'}) {
scenario_context
=>
{
skip
=>
1
}
);
unless
(
$spindle
and
$spindle
->
spin
and
_report
(
$spindle
))
{
print
f
STDERR
"
Could not create list
%s
\n
";
print
STDERR
"
Could not create list
\n
";
exit
1
;
}
exit
0
;
...
...
t/Config_XML.t
0 → 100644
View file @
051e21df
# -*- indent-tabs-mode: nil; -*-
# # vim:ft=perl:et:sw=4
use
strict
;
use
warnings
;
use
FindBin
qw($Bin)
;
use
IO::
Scalar
;
use
Test::
More
;
BEGIN
{
use_ok
('
Sympa::Config_XML
');
}
my
@in
=
do
{
local
$/
=
'';
<
DATA
>
};
is_deeply
(
Sympa::
Config_XML
->
new
(
IO::
Scalar
->
new
(
\
(
shift
@in
)))
->
as_hashref
,
{
'
owner
'
=>
[
{
'
email
'
=>
'
admin.etulistes@example.fr
',
'
gecos
'
=>
'
Administrateur listes etudiants
'
}
],
'
topics
'
=>
'
fst/etulistes
',
'
editor
'
=>
[]
,
'
subject
'
=>
'
FST Licence 1e annee Informatique-groupe 1
',
'
listname
'
=>
'
1liai1-1-s1-in-1
',
'
ldap
'
=>
{
'
select2
'
=>
'
first
',
'
scope2
'
=>
'
sub
',
'
suffix1
'
=>
'
ou=groups,dc=example,dc=fr
',
'
suffix2
'
=>
'
[attrs1]
',
'
attrs1
'
=>
'
member
',
'
user
'
=>
'
XXX
',
'
select1
'
=>
'
all
',
'
filter2
'
=>
'
(mail=*)
',
'
timeout1
'
=>
'
30
',
'
attrs2
'
=>
'
mail
',
'
scope1
'
=>
'
sub
',
'
host
'
=>
'
XXX
',
'
use_ssl
'
=>
'
yes
',
'
passwd
'
=>
'
XXX
',
'
filter1
'
=>
'
(uhaGroupeMail=1LIAI1-1-S1-IN-1@example.fr)
',
'
timeout2
'
=>
'
30
',
'
ssl_version
'
=>
'
sslv3
'
}
}
);
is_deeply
(
Sympa::
Config_XML
->
new
(
IO::
Scalar
->
new
(
\
(
shift
@in
)))
->
as_hashref
,
{
'
owner
'
=>
[{'
email
'
=>
'
bruno.malaval@example.fr
'}],
'
topics
'
=>
undef
,
'
editor
'
=>
[]
,
'
subject
'
=>
'
test-etc
',
'
listname
'
=>
'
di-test-xml
',
'
type
'
=>
'
intranet_list
'
}
);
is
(
Sympa::
Config_XML
->
new
(
IO::
Scalar
->
new
(
\
(
shift
@in
)))
->
as_hashref
,
undef
);
is
(
Sympa::
Config_XML
->
new
(
IO::
Scalar
->
new
(
\
(
shift
@in
)))
->
as_hashref
,
undef
);
done_testing
();
__END__
<?xml version="1.0" ?>
<list>
<listname>1liai1-1-s1-in-1</listname>
<subject>FST Licence 1e annee Informatique-groupe 1</subject>
<owner multiple="1">
<email>admin.etulistes@example.fr</email>
<gecos>Administrateur listes etudiants</gecos>
</owner>
<ldap>
<host>XXX</host>
<user>XXX</user>
<passwd>XXX</passwd>
<use_ssl>yes</use_ssl>
<ssl_version>sslv3</ssl_version>
<suffix1>ou=groups,dc=example,dc=fr</suffix1>
<timeout1>30</timeout1>
<attrs1>member</attrs1>
<filter1>(uhaGroupeMail=1LIAI1-1-S1-IN-1@example.fr)</filter1>