From 01780834bae6e14f7d6eb94ea4fe37f62f92e968 Mon Sep 17 00:00:00 2001 From: Ilia Ross Date: Sun, 5 Jul 2026 01:56:56 +0200 Subject: [PATCH] Fix to extract XML-RPC helpers from CGI entry point MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ⓘ 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 --- t/xmlrpc.t | 17 ++---- xmlrpc-lib.pl | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++ xmlrpc.cgi | 153 +------------------------------------------------ 3 files changed, 163 insertions(+), 162 deletions(-) create mode 100644 xmlrpc-lib.pl diff --git a/t/xmlrpc.t b/t/xmlrpc.t index 5229c0dd7..8ec2e3d55 100644 --- a/t/xmlrpc.t +++ b/t/xmlrpc.t @@ -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 body # parse_xml_value - parsed XML 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. diff --git a/xmlrpc-lib.pl b/xmlrpc-lib.pl new file mode 100644 index 000000000..90c089506 --- /dev/null +++ b/xmlrpc-lib.pl @@ -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 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 = "\n\n"; + foreach my $v (@$perlv) { + $xmlrv .= "\n"; + $xmlrv .= &encode_xml_value($v); + $xmlrv .= "\n"; + } + $xmlrv .= "\n\n"; + return $xmlrv; + } +elsif (ref($perlv) eq "HASH") { + # Convert to struct XML format + my $xmlrv = "\n"; + foreach my $k (keys %$perlv) { + $xmlrv .= "\n"; + $xmlrv .= "".&html_escape($k)."\n"; + $xmlrv .= "\n"; + $xmlrv .= &encode_xml_value($perlv->{$k}); + $xmlrv .= "\n"; + $xmlrv .= "\n"; + } + $xmlrv .= "\n"; + return $xmlrv; + } +elsif ($perlv =~ /^\-?\d+$/) { + # Return an integer + return "$perlv\n"; + } +elsif ($perlv =~ /^\-?\d*\.\d+$/) { + # Return a double + return "$perlv\n"; + } +elsif ($perlv =~ /^[\40-\377]*$/) { + # Return a scalar + return "".&html_escape($perlv)."\n"; + } +else { + # Contains non-printable characters, so return as base64 + return "".&encode_base64($perlv)."\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 = "\n"; +$xmlerr .= "\n"; +$xmlerr .= "\n"; +$xmlerr .= &encode_xml_value( { 'faultCode' => $code, + 'faultString' => $msg }); +$xmlerr .= "\n"; +$xmlerr .= "\n"; +$xmlerr .= "\n"; +return $xmlerr; +} + +1; diff --git a/xmlrpc.cgi b/xmlrpc.cgi index f6795e853..05b4d5513 100755 --- a/xmlrpc.cgi +++ b/xmlrpc.cgi @@ -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 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 = "\n\n"; - foreach my $v (@$perlv) { - $xmlrv .= "\n"; - $xmlrv .= &encode_xml_value($v); - $xmlrv .= "\n"; - } - $xmlrv .= "\n\n"; - return $xmlrv; - } -elsif (ref($perlv) eq "HASH") { - # Convert to struct XML format - my $xmlrv = "\n"; - foreach my $k (keys %$perlv) { - $xmlrv .= "\n"; - $xmlrv .= "".&html_escape($k)."\n"; - $xmlrv .= "\n"; - $xmlrv .= &encode_xml_value($perlv->{$k}); - $xmlrv .= "\n"; - $xmlrv .= "\n"; - } - $xmlrv .= "\n"; - return $xmlrv; - } -elsif ($perlv =~ /^\-?\d+$/) { - # Return an integer - return "$perlv\n"; - } -elsif ($perlv =~ /^\-?\d*\.\d+$/) { - # Return a double - return "$perlv\n"; - } -elsif ($perlv =~ /^[\40-\377]*$/) { - # Return a scalar - return "".&html_escape($perlv)."\n"; - } -else { - # Contains non-printable characters, so return as base64 - return "".&encode_base64($perlv)."\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 = "\n"; -$xmlerr .= "\n"; -$xmlerr .= "\n"; -$xmlerr .= &encode_xml_value( { 'faultCode' => $code, - 'faultString' => $msg }); -$xmlerr .= "\n"; -$xmlerr .= "\n"; -$xmlerr .= "\n"; -return $xmlerr; -}