michael/webmin
1
0
Fork 0
mirror of https://github.com/webmin/webmin.git synced 2026-07-25 10:50:31 +01:00
Code Issues Actions 3 Packages Projects Releases Wiki Activity

Fix to extract XML-RPC helpers from CGI entry point
Some checks failed
Tests / prove (push) Has been cancelled
Details
Package and upload artifacts / build (push) Has been cancelled
Details
Close inactive / close-inactive (push) Has been cancelled
Details

Browse Source 
ⓘ Move XML-RPC marshalling helpers into `xmlrpc-lib.pl`, remove the caller guard from `xmlrpc.cgi`, and preserve coverage through direct library tests plus the CGI invocation regression.

https://github.com/webmin/webmin/pull/2763
This commit is contained in:
Ilia Ross
2026-07-05 01:56:56 +02:00
parent 9c76a2c809
commit 01780834ba
3 changed files with 163 additions and 162 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
t/xmlrpc.t
View File

@@ -1,13 +1,8 @@
#!/usr/bin/perl
# Unit tests for xmlrpc.cgi helper subs.
# Unit tests for XML-RPC helper subs.
#
# xmlrpc.cgi is loaded like miniserv loads Perl CGIs; its top-level body
# (ACL check, reading
# the request, dispatching the call, emitting the response) is skipped unless
# it is invoked directly or via Webmin's CGI environment, so loading it only
# defines the subs plus loads WebminCore.
#
# Most subs under test are the XML <-> Perl marshalling layer:
# The XML <-> Perl marshalling layer lives in xmlrpc-lib.pl so tests can
# load it directly without changing xmlrpc.cgi's executable CGI/API flow:
# encode_xml_value - Perl scalar/hashref/arrayref -> XML-RPC <value> body
# parse_xml_value - parsed XML <value> node -> Perl scalar/ref
# find_xmls - recursive element search over an XML::Parser tree
@@ -29,10 +24,10 @@ my $root = File::Spec->rel2abs(
File::Spec->catdir(dirname(__FILE__), '..'));
chdir($root) or die "chdir $root: $!";
my $script = File::Spec->catfile($root, 'xmlrpc.cgi');
my $loaded = do $script;
my $lib = File::Spec->catfile($root, 'xmlrpc-lib.pl');
my $loaded = do $lib;
die $@ if $@;
die "do $script: $!" if (!defined($loaded) && $!);
die "do $lib: $!" if (!defined($loaded) && $!);
# XML::Parser is only needed to build the parsed-tree inputs for
# parse_xml_value and the round-trip tests. Probe for it once.

155
xmlrpc-lib.pl Normal file
View File

@@ -0,0 +1,155 @@
# Common XML-RPC request and response marshalling functions
BEGIN { push(@INC, "."); };
use WebminCore;
use strict;
use warnings;
# parse_xml_value(&value)
# Given a <value> object, returns a Perl scalar, hash ref or array ref for
# the contents
sub parse_xml_value
{
my ($value) = @_;
my ($scalar) = &find_xmls([ "int", "i4", "boolean", "string", "double" ],
$value, 1);
my ($date) = &find_xmls([ "dateTime.iso8601" ], $value, 1);
my ($base64) = &find_xmls("base64", $value, 1);
my ($struct) = &find_xmls("struct", $value, 1);
my ($array) = &find_xmls("array", $value, 1);
if ($scalar) {
return $scalar->[1]->[2];
}
elsif ($date) {
# Need to decode date
# XXX format?
}
elsif ($base64) {
# Convert to binary
return &decode_base64($base64->[1]->[2]);
}
elsif ($struct) {
# Parse member names and values
my %rv;
foreach my $member (&find_xmls("member", $struct, 1)) {
my ($name) = &find_xmls("name", $member, 1);
my ($value) = &find_xmls("value", $member, 1);
my $perlv = &parse_xml_value($value);
$rv{$name->[1]->[2]} = $perlv;
}
return \%rv;
}
elsif ($array) {
# Parse data values
my @rv;
my ($data) = &find_xmls("data", $array, 1);
foreach my $value (&find_xmls("value", $data, 1)) {
my $perlv = &parse_xml_value($value);
push(@rv, $perlv);
}
return \@rv;
}
else {
# Fallback - just a string directly in the value
return $value->[1]->[2];
}
}
# encode_xml_value(string|int|&hash|&array)
# Given a Perl object, returns XML lines representing it for return to a caller
sub encode_xml_value
{
my ($perlv) = @_;
if (ref($perlv) eq "ARRAY") {
# Convert to array XML format
my $xmlrv = "<array>\n<data>\n";
foreach my $v (@$perlv) {
$xmlrv .= "<value>\n";
$xmlrv .= &encode_xml_value($v);
$xmlrv .= "</value>\n";
}
$xmlrv .= "</data>\n</array>\n";
return $xmlrv;
}
elsif (ref($perlv) eq "HASH") {
# Convert to struct XML format
my $xmlrv = "<struct>\n";
foreach my $k (keys %$perlv) {
$xmlrv .= "<member>\n";
$xmlrv .= "<name>".&html_escape($k)."</name>\n";
$xmlrv .= "<value>\n";
$xmlrv .= &encode_xml_value($perlv->{$k});
$xmlrv .= "</value>\n";
$xmlrv .= "</member>\n";
}
$xmlrv .= "</struct>\n";
return $xmlrv;
}
elsif ($perlv =~ /^\-?\d+$/) {
# Return an integer
return "<int>$perlv</int>\n";
}
elsif ($perlv =~ /^\-?\d*\.\d+$/) {
# Return a double
return "<double>$perlv</double>\n";
}
elsif ($perlv =~ /^[\40-\377]*$/) {
# Return a scalar
return "<string>".&html_escape($perlv)."</string>\n";
}
else {
# Contains non-printable characters, so return as base64
return "<base64>".&encode_base64($perlv)."</base64>\n";
}
}
# find_xmls(name|&names, &config, [depth])
# Returns the XMLs object with some name, by recursively searching the XML
sub find_xmls
{
my ($name, $conf, $depth) = @_;
my @m = ref($name) ? @$name : ( $name );
if (&indexoflc($conf->[0], @m) >= 0) {
# Found it!
return ( $conf );
}
else {
# Need to recursively scan all sub-elements, except for the first
# which is just the tags of this element
if (defined($depth) && !$depth) {
# Gone too far .. stop
return ( );
}
my $list = $conf->[1];
# A char-data leaf has a plain string here, not a child list. There
# is nothing to scan, so stop before dereferencing it as an array.
ref($list) eq 'ARRAY' || return ( );
my @rv;
for(my $i=1; $i<@$list; $i+=2) {
my @srv = &find_xmls($name,
[ $list->[$i], $list->[$i+1] ],
defined($depth) ? $depth-1 : undef);
push(@rv, @srv);
}
return @rv;
}
return ( );
}
# make_error_xml(code, message)
# Returns an XML methodResponse fault document for the given code and message
sub make_error_xml
{
my ($code, $msg) = @_;
my $xmlerr = "<methodResponse>\n";
$xmlerr .= "<fault>\n";
$xmlerr .= "<value>\n";
$xmlerr .= &encode_xml_value( { 'faultCode' => $code,
'faultString' => $msg });
$xmlerr .= "</value>\n";
$xmlerr .= "</fault>\n";
$xmlerr .= "</methodResponse>\n";
return $xmlerr;
}
1;

153
xmlrpc.cgi
View File

@@ -12,8 +12,6 @@ use WebminCore;
use POSIX;
use Socket;
if (!caller || $ENV{'GATEWAY_INTERFACE'}) {
if (!$ENV{'GATEWAY_INTERFACE'}) {
# Command-line mode
$no_acl_check++;
@@ -28,6 +26,8 @@ if (!$ENV{'GATEWAY_INTERFACE'}) {
$> == 0 || die "xmlrpc.cgi must be run as root";
}
require './xmlrpc-lib.pl';
$main::allow_rpc_only = 1;
$force_lang = $default_lang;
$trust_unknown_referers = 2; # Only trust if referer was not set
@@ -157,139 +157,6 @@ if (!$command_line) {
}
print $xmlrv;
} # end of script/CGI request handler
# parse_xml_value(&value)
# Given a <value> object, returns a Perl scalar, hash ref or array ref for
# the contents
sub parse_xml_value
{
my ($value) = @_;
my ($scalar) = &find_xmls([ "int", "i4", "boolean", "string", "double" ],
$value, 1);
my ($date) = &find_xmls([ "dateTime.iso8601" ], $value, 1);
my ($base64) = &find_xmls("base64", $value, 1);
my ($struct) = &find_xmls("struct", $value, 1);
my ($array) = &find_xmls("array", $value, 1);
if ($scalar) {
return $scalar->[1]->[2];
}
elsif ($date) {
# Need to decode date
# XXX format?
}
elsif ($base64) {
# Convert to binary
return &decode_base64($base64->[1]->[2]);
}
elsif ($struct) {
# Parse member names and values
my %rv;
foreach my $member (&find_xmls("member", $struct, 1)) {
my ($name) = &find_xmls("name", $member, 1);
my ($value) = &find_xmls("value", $member, 1);
my $perlv = &parse_xml_value($value);
$rv{$name->[1]->[2]} = $perlv;
}
return \%rv;
}
elsif ($array) {
# Parse data values
my @rv;
my ($data) = &find_xmls("data", $array, 1);
foreach my $value (&find_xmls("value", $data, 1)) {
my $perlv = &parse_xml_value($value);
push(@rv, $perlv);
}
return \@rv;
}
else {
# Fallback - just a string directly in the value
return $value->[1]->[2];
}
}
# encode_xml_value(string|int|&hash|&array)
# Given a Perl object, returns XML lines representing it for return to a caller
sub encode_xml_value
{
my ($perlv) = @_;
if (ref($perlv) eq "ARRAY") {
# Convert to array XML format
my $xmlrv = "<array>\n<data>\n";
foreach my $v (@$perlv) {
$xmlrv .= "<value>\n";
$xmlrv .= &encode_xml_value($v);
$xmlrv .= "</value>\n";
}
$xmlrv .= "</data>\n</array>\n";
return $xmlrv;
}
elsif (ref($perlv) eq "HASH") {
# Convert to struct XML format
my $xmlrv = "<struct>\n";
foreach my $k (keys %$perlv) {
$xmlrv .= "<member>\n";
$xmlrv .= "<name>".&html_escape($k)."</name>\n";
$xmlrv .= "<value>\n";
$xmlrv .= &encode_xml_value($perlv->{$k});
$xmlrv .= "</value>\n";
$xmlrv .= "</member>\n";
}
$xmlrv .= "</struct>\n";
return $xmlrv;
}
elsif ($perlv =~ /^\-?\d+$/) {
# Return an integer
return "<int>$perlv</int>\n";
}
elsif ($perlv =~ /^\-?\d*\.\d+$/) {
# Return a double
return "<double>$perlv</double>\n";
}
elsif ($perlv =~ /^[\40-\377]*$/) {
# Return a scalar
return "<string>".&html_escape($perlv)."</string>\n";
}
else {
# Contains non-printable characters, so return as base64
return "<base64>".&encode_base64($perlv)."</base64>\n";
}
}
# find_xmls(name|&names, &config, [depth])
# Returns the XMLs object with some name, by recursively searching the XML
sub find_xmls
{
my ($name, $conf, $depth) = @_;
my @m = ref($name) ? @$name : ( $name );
if (&indexoflc($conf->[0], @m) >= 0) {
# Found it!
return ( $conf );
}
else {
# Need to recursively scan all sub-elements, except for the first
# which is just the tags of this element
if (defined($depth) && !$depth) {
# Gone too far .. stop
return ( );
}
my $list = $conf->[1];
# A char-data leaf has a plain string here, not a child list. There
# is nothing to scan, so stop before dereferencing it as an array.
ref($list) eq 'ARRAY' || return ( );
my @rv;
for(my $i=1; $i<@$list; $i+=2) {
my @srv = &find_xmls($name,
[ $list->[$i], $list->[$i+1] ],
defined($depth) ? $depth-1 : undef);
push(@rv, @srv);
}
return @rv;
}
return ( );
}
# error_exit(code, message)
# Output an XML error message
sub error_exit
@@ -311,19 +178,3 @@ if (!$command_line) {
print $xmlerr;
exit($command_line ? $code : 0);
}
# make_error_xml(code, message)
# Returns an XML methodResponse fault document for the given code and message
sub make_error_xml
{
my ($code, $msg) = @_;
my $xmlerr = "<methodResponse>\n";
$xmlerr .= "<fault>\n";
$xmlerr .= "<value>\n";
$xmlerr .= &encode_xml_value( { 'faultCode' => $code,
'faultString' => $msg });
$xmlerr .= "</value>\n";
$xmlerr .= "</fault>\n";
$xmlerr .= "</methodResponse>\n";
return $xmlerr;
}