Fix unsafe fast RPC deserialization without dropping Data::Dumper support

https://github.com/webmin/webmin/pull/2886#issuecomment-6207458026

fastrpc.cgi

@@ -142,6 +142,8 @@ while(1) {
 		$rawarg .= $got;
 		}
 	print STDERR "fastrpc[$$]: raw $rawarg\n" if ($gconfig{'rpcdebug'});
+
+	# Mirror the request's wire format in the response
 	my $dumper = substr($rawarg, 0, 5) eq '$VAR1' ? 1 : 0;
 	my $arg = &unserialise_variable($rawarg);
 

t/web-lib-funcs-encoding.t

@@ -10,6 +10,7 @@ use warnings;
 use Test::More;
 use File::Basename qw(dirname);
 use File::Spec;
+use Scalar::Util ();
 
 my $script = File::Spec->rel2abs(
 	File::Spec->catfile(dirname(__FILE__), '..', 'web-lib-funcs.pl'));
@@ -148,13 +149,299 @@ subtest 'serialise_variable / unserialise_variable' => sub {
 	is(main::serialise_variable([1,2]),  'ARRAY,VAL%2C1,VAL%2C2',
 	   'array wire format (one level of urlize wrapping)');
 
-	# Data::Dumper path — opt-in via the second arg.
+	# Enable Data::Dumper format with the optional second argument.
 	my $d = main::serialise_variable({k=>'v'}, 1);
-	like($d, qr/^\$VAR1\s*=/, 'dumper mode emits Data::Dumper format');
+	like($d, qr/^\$VAR1 = /, 'Data::Dumper mode emits an assignment');
 	is_deeply(main::unserialise_variable($d), {k=>'v'},
-	   'dumper-format round-trips through the $VAR1 detector');
+	   'Data::Dumper format round-trips');
+
+	# Remote object names must not load or bless local classes.
+	my $object = main::unserialise_variable(
+		'OBJECT RPC::Untrusted,VAL%2Ck,VAL%2Cv');
+	is_deeply($object, {k=>'v'}, 'object data is retained');
+	is(ref($object), 'HASH', 'object data is not blessed');
 };
 
+# Data::Dumper format
+#
+# Fast RPC uses Data::Dumper for serialization. unserialise_variable() parses
+# it as data instead of calling eval. Supported forms must preserve shared and
+# cyclic references, and input must never execute code.
+subtest 'Data::Dumper format' => sub {
+	require Data::Dumper;
+	require JSON::PP;
+
+	# Spot-check the supported scalar, reference, object and container forms.
+	my $str = 'x';
+	my $shared = [ 1 ];
+	my $v = { 'int' => 42, 'neg' => -7, 'float' => 1.5, 'undef' => undef,
+		  'quote' => "it's \\ ok", 'utf8' => "caf\x{e9} \x{263a}",
+		  'bin' => join('', map { chr } 0..255), 'nl' => "a\nb",
+		  'sref' => \$str, 'rref' => \\'y', 'a' => $shared, 'b' => $shared,
+		  'obj' => bless({ 'x' => 1 }, 'RPC::Untrusted'),
+		  'sobj' => bless(\$str, 'RPC::Untrusted'),
+		  'empty' => [], 'eh' => {} };
+	$v->{'self'} = $v;
+	# Data::Dumper cannot preserve a reference to a hash value if it sees that
+	# reference first. Sorting keys makes this test deterministic.
+	$v->{'slot'} = \$v->{'quote'};
+	for my $opts ([ 'compact', 0, 0, 0 ], [ 'indented', 2, 0, 0 ],
+		      [ 'useqq', 1, 1, 0 ], [ 'pure Perl', 2, 0, 1 ]) {
+		my ($name, $indent, $useqq, $useperl) = @$opts;
+		my $dd = Data::Dumper->new([ $v ], [ 'VAR1' ]);
+		$dd->Purity(1)->Indent($indent)->Useqq($useqq)->Useperl($useperl)
+		   ->Sortkeys(1);
+		my $got = main::unserialise_variable($dd->Dump());
+		ok(same_graph($got, $v), "$name output preserves data and links");
+		is($got->{'self'}, $got, "$name cyclic reference is restored");
+		is($got->{'a'}, $got->{'b'}, "$name shared reference is restored");
+		is($got->{'slot'}, \$got->{'quote'}, "$name slot reference is restored");
+		is(ref($got->{'obj'}), 'HASH', "$name object is not blessed");
+		is(ref($got->{'sobj'}), 'SCALAR', "$name scalar object is not blessed");
+		# Match eval's number-versus-string behavior.
+		is(JSON::PP->new->encode([ $got->{'int'}, $got->{'float'} ]),
+		   '[42,"1.5"]', "$name preserves number and string types");
+		}
+	delete($v->{'slot'});
+
+	# Convert executable and runtime-only values to inert data.
+	my $odd = main::unserialise_variable(
+		q{$VAR1 = [sub { "DUMMY" },*::STDOUT,\*{'::odd name'},qr/a\/b/i,do{my $o}];});
+	is_deeply($odd, [ undef, undef, \undef, '(?^i:a\/b)', undef ],
+		  'code refs, globs and regexps are not recreated');
+
+	# Ignore global options to keep the wire format stable.
+	{
+		no warnings 'once';
+		local $Data::Dumper::Indent = 2;
+		local $Data::Dumper::Terse = 1;
+		local $Data::Dumper::Useqq = 1;
+		local $Data::Dumper::Deparse = 1;
+		local $Data::Dumper::Varname = 'X';
+		local $Data::Dumper::Purity = 0;
+		local $Data::Dumper::Pad = 'BAD';
+		my $out = main::serialise_variable($v, 1);
+		like($out, qr/^\$VAR1 = \{'/, 'sender ignores global Dumper options');
+		ok(same_graph(main::unserialise_variable($out), $v),
+		   'sender output round-trips with links');
+		local $SIG{'__WARN__'} = sub { };
+		my $code = main::serialise_variable({ 'c' => sub { 1 } }, 1);
+		like($code, qr/sub \{ "DUMMY" \}/, 'sender never deparses code');
+	}
+
+	# Compare supported option combinations with trusted eval output.
+	srand(2886);
+	my ($count, @fail) = (0);
+	for my $round (1..400) {
+		my $data = random_graph();
+		for my $indent (0, 1, 2) {
+			for my $useqq (0, 1) {
+				for my $useperl (0, 1) {
+					my $dd = Data::Dumper->new([ $data ], [ 'VAR1' ]);
+					$dd->Purity(1)->Indent($indent)->Useqq($useqq)
+					   ->Useperl($useperl)->Quotekeys($round % 2)
+					   ->Sortkeys(1);
+					# Include trailing commas when indented output supports them.
+					$dd->Trailingcomma(1)
+						if ($indent && $dd->can('Trailingcomma'));
+					my $dump = $dd->Dump();
+					my ($want, $err) = eval_dumper($dump);
+					next if ($err);
+					$count++;
+					my $got = main::unserialise_variable($dump);
+					push(@fail, $dump) if (!same_graph($got, $want));
+					}
+				}
+			}
+		}
+	ok($count > 2000, "compared $count random dumps with eval");
+	is(scalar(@fail), 0, 'parser matches eval for every random dump')
+		|| diag("first mismatch:\n$fail[0]");
+
+	# Reject hostile input without executing it.
+	our $ran = 0;
+	my @hostile = (
+		q{$VAR1 = {}; $main::ran = 1;},
+		q{$VAR1 = "@{[ $main::ran = 1 ]}";},
+		q{$VAR1 = "${\ ($main::ran = 1)}";},
+		q{$VAR1 = do { $main::ran = 1 };},
+		q{$VAR1 = sub { $main::ran = 1 };},
+		q{$VAR1 = [ 1 ]; $VAR1->[0] = $main::ran;},
+		q{$VAR1 = [ 1 ]; $VAR1->[0] = &main::ran();},
+		q{$VAR1 = [ 1 ]; ${\ ($main::ran = 1)} = 1;},
+		q{$VAR1 = [ 1 ]; $VAR1->[5] = $VAR1;},
+		q{$VAR1 = {}; $VAR1->{'a'} = $VAR1;},
+		q{$VAR1 = { 'a' => 1 }; $VAR1->{'a'} = $VAR1->{'b'};},
+		q{$VAR1 = { 'a' => 1 }; $VAR1->{'a'} = ${$VAR1->{'a'}};},
+		q{$VAR1 = { 'a' => 'main::ran' }; ${$VAR1->{'a'}} = $VAR1;},
+		q{$VAR1 = [ 1 ]; $VAR1->[0] = 1;},
+		q{$VAR1 = { 'a' => 1 }; $VAR1{'a'} = $VAR1;},
+		q{$VAR1 = 'a' . system('true');},
+		q{$VAR1 = {}; BEGIN { $main::ran = 1 }},
+		q{$VAR1 = \&main::ran;},
+		q{$VAR1 = "\N{U+263A}";},
+		q{$VAR1 = "\u\LX";},
+		q{$VAR1 = bless( {}, 'X' )->new;},
+		q{$VAR1 = {} or $main::ran = 1;},
+		'$VAR1 = '.('[' x 5000).(']' x 5000).';',
+		q{$VAR1 = 'unterminated;},
+		);
+	for my $h (@hostile) {
+		is(main::unserialise_variable($h), undef,
+		   'refused: '.substr($h, 0, 50));
+		}
+	my $re = main::unserialise_variable(q{$VAR1 = qr/(?{ $main::ran = 1 })/;});
+	is(ref($re), '', 'regexp with code is returned as a plain string');
+	my $obj = main::unserialise_variable(
+		q{$VAR1 = bless( {'REALNAME' => '/nonexistent','CLEANUP' => 1}, 'File::Temp::Dir' );});
+	is(ref($obj), 'HASH', 'object with a DESTROY method is not blessed');
+	is($ran, 0, 'no hostile input was executed');
+};
+
+# eval_dumper(string)
+# Evaluates trusted, test-generated output for comparison with the old RPC
+# decoder. Returns the value and any error. Never pass external input.
+sub eval_dumper
+{
+	my ($dump) = @_;
+	no strict;
+	no warnings;
+	my $VAR1;
+	eval $dump;
+	return ($VAR1, $@);
+}
+
+# same_graph(a, b, [&seen])
+# Compares values and reference identities, including shared slots and cycles.
+# Objects compare by their underlying type because the parser does not bless.
+sub same_graph
+{
+	my ($x, $y, $seen) = @_;
+	$seen ||= {};
+
+	# Compare terminal values before tracking reference identities.
+	return !defined($y) if (!defined($x));
+	return 0 if (!defined($y));
+	my ($tx, $ty) = (Scalar::Util::reftype($x) || '',
+			 Scalar::Util::reftype($y) || '');
+	return 0 if ($tx ne $ty);
+	return $x eq $y if ($tx eq '');
+	my ($ax, $ay) = (Scalar::Util::refaddr($x), Scalar::Util::refaddr($y));
+	if (exists($seen->{"x$ax"}) || exists($seen->{"y$ay"})) {
+		# A repeated reference must point to the matching value in both graphs.
+		return ($seen->{"x$ax"} || 0) == $ay && ($seen->{"y$ay"} || 0) == $ax;
+	}
+	$seen->{"x$ax"} = $ay;
+	$seen->{"y$ay"} = $ax;
+	if ($tx eq 'HASH') {
+		# Compare slots so references to hash values must also match.
+		my @kx = sort keys %$x;
+		return 0 if (join("\0", @kx) ne join("\0", sort keys %$y));
+		for my $k (@kx) {
+			return 0 if (!same_graph(\$x->{$k}, \$y->{$k}, $seen));
+		}
+		return 1;
+	}
+	elsif ($tx eq 'ARRAY') {
+		# Compare slots so references to array elements must also match.
+		return 0 if (@$x != @$y);
+		for my $i (0..$#$x) {
+			return 0 if (!same_graph(\$x->[$i], \$y->[$i], $seen));
+		}
+		return 1;
+	}
+	elsif ($tx eq 'SCALAR' || $tx eq 'REF') {
+		return same_graph($$x, $$y, $seen);
+	}
+	return 1;
+}
+
+# random_graph()
+# Builds nested data with edge-case strings, shared references, cycles,
+# references to elements and objects.
+sub random_graph
+{
+	my @pool;
+	my $root = random_value(\@pool, 0);
+	return $root if (!@pool);
+	for (1..int(rand(5))) {
+		my $from = $pool[int(rand(@pool))];
+		my $to = $pool[int(rand(@pool))];
+		my $link = $to;
+		my $r = rand();
+		if ($r < 0.2) {
+			$link = \$to;
+		}
+		elsif ($r < 0.4 && ref($to) eq 'HASH' && %$to) {
+			$link = \$to->{(sort keys %$to)[0]};
+		}
+		elsif ($r < 0.5 && ref($to) eq 'ARRAY' && @$to) {
+			$link = \$to->[0];
+		}
+		elsif ($r < 0.6) {
+			$link = bless([ $to ], 'RPC::Untrusted');
+		}
+		my $type = Scalar::Util::reftype($from);
+		if ($type eq 'HASH') {
+			$from->{'link'.int(rand(3))} = $link;
+		}
+		elsif ($type eq 'ARRAY') {
+			push(@$from, $link);
+		}
+		else {
+			$$from = $link;
+		}
+	}
+	return $root;
+}
+
+# random_value(&pool, depth)
+# Returns a random scalar or container and adds containers to the pool.
+sub random_value
+{
+	my ($pool, $depth) = @_;
+	my $r = rand();
+	my $v;
+	if ($depth > 3 || $r < 0.35) {
+		# Bound recursion and make scalar leaves common.
+		return random_string();
+	}
+	elsif ($r < 0.6) {
+		$v = [ map { random_value($pool, $depth+1) } 1..int(rand(4)) ];
+	}
+	elsif ($r < 0.85) {
+		$v = { map { (random_string() // 'u' => random_value($pool, $depth+1)) }
+			   1..int(rand(4)) };
+	}
+	elsif ($r < 0.95) {
+		my $inner = random_value($pool, $depth+1);
+		$v = \$inner;
+	}
+	else {
+		$v = bless({ 'x' => random_value($pool, $depth+1) },
+			   'RPC::Untrusted');
+	}
+	push(@$pool, $v);
+	return $v;
+}
+
+# random_string()
+# Returns a hard-to-quote scalar containing bytes, Unicode, quotes, sigils,
+# numbers or number-like strings.
+sub random_string
+{
+	my @fixed = ('', 'plain', "it's", 'back\\slash', '$x @y', "a\nb",
+		     '007', '1.5', '-0', '12345678901', 42, -7, 0, undef,
+		     "\x{263a}\x{1f600}", "caf\x{e9}", "\0\x7f\x80\xff");
+
+	# Usually choose a fixed edge case so every run covers common forms.
+	return $fixed[int(rand(@fixed))] if (rand() < 0.7);
+
+	# Otherwise generate arbitrary byte or Unicode content.
+	return join('', map { chr(rand() < 0.1 ? int(rand(0x3000)) : int(rand(256))) }
+			     1..int(rand(20)));
+}
+
 # convert_to_json / convert_from_json
 #
 # Thin wrappers over JSON::XS or JSON::PP. We test the wrapper contract —

web-lib-funcs.pl

@@ -9251,7 +9251,7 @@ if ($serv->{'fast'} || !$sn) {
 			}
 		elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
 		       $line =~ /^1\s+(\S+)\s+(\S+)/) {
-			# Started ok .. connect and save SID
+			# Connect and cache the negotiated fast RPC version
 			&close_http_connection($con);
 			my ($port, $sid, $version) = ($1, $2, $3);
 			my $error;
@@ -9262,6 +9262,7 @@ if ($serv->{'fast'} || !$sn) {
 			$remote_server_version{$sn} = $version;
 			}
 		else {
+			# Reject a malformed fast RPC startup response
 			while($stuff = &read_http_connection($con)) {
 				$line .= $stuff;
 				}
@@ -9312,7 +9313,7 @@ if ($serv->{'fast'} || !$sn) {
 			return &$main::remote_error_handler("RPC error : $2");
 			}
 		elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/) {
-			# Started ok .. connect and save SID
+			# Connect and cache the local fast RPC version
 			close(SOCK);
 			close(RPCOUTr);
 			my ($port, $sid, $version) = ($1, $2, $3);
@@ -9322,7 +9323,7 @@ if ($serv->{'fast'} || !$sn) {
 			$fast_fh_cache{$sn} = [ $sid, $version ];
 			}
 		else {
-			# Unexpected response
+			# Reject a malformed local fast RPC startup response
 			local $_;
 			while(<RPCOUTr>) {
 				$line .= $_;
@@ -9332,7 +9333,7 @@ if ($serv->{'fast'} || !$sn) {
 				"Bad response from fastrpc.cgi : $line");
 			}
 		}
-	# Got a connection .. send off the request
+	# Use Data::Dumper only when the peer advertises parser support
 	my ($fh, $version) = @{$fast_fh_cache{$sn}};
 	my $dumper = &compare_version_numbers($version, 2.014) >= 0;
 	my $tostr = &serialise_variable($str, $dumper);
@@ -9521,23 +9522,30 @@ $remote_multi_callback_err = $err;
 
 =head2 serialise_variable(variable, [data-dumper-format])
 
-Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
-into a url-encoded string. In the cases of arrays and hashes, it is recursively
-called on each member to serialize the entire object.
+Converts a scalar or reference into Webmin's RPC wire format. The legacy format
+recursively URL-encodes arrays and hashes. If data-dumper-format is set,
+Data::Dumper preserves shared and cyclic references.
 
 =cut
 sub serialise_variable
 {
 my ($var, $dumper) = @_;
 if ($dumper) {
-	# Convert to Data::Dumper format
+	# Preserve shared and cyclic references for peers that support this format
 	eval "use Data::Dumper";
 	if (!$@) {
-		$Data::Dumper::Purity = 1;
-		return Dumper($var);
+		# Override global options to keep the wire format stable
+		my $dd = Data::Dumper->new([ $var ], [ 'VAR1' ]);
+		$dd->Purity(1)->Indent(0)->Terse(0)->Useqq(0)->Deparse(0)
+		   ->Pair(' => ')->Quotekeys(1)->Freezer('')->Toaster('')
+		   ->Bless('bless')->Maxdepth(0)->Deepcopy(0)->Pad('');
+		return $dd->Dump();
 		}
 	}
+
+# Fall back to the legacy format for older peers or if Data::Dumper is missing
 if (!defined($var)) {
+	# Preserve undef as a distinct wire type
 	return 'UNDEF';
 	}
 my $r = ref($var);
@@ -9560,11 +9568,11 @@ elsif ($r eq 'REF') {
 	$rv = &serialise_variable(${$var});
 	}
 elsif ($r eq 'CODE') {
-	# Code not handled
+	# Never transfer executable code
 	$rv = undef;
 	}
 elsif ($r) {
-	# An object - treat as a hash
+	# Transfer an object's fields without executing class code
 	$r = "OBJECT ".&urlize($r);
 	$rv = join(",", map { &urlize(&serialise_variable($_)).",".
 			      &urlize(&serialise_variable($var->{$_})) }
@@ -9575,18 +9583,18 @@ return ($r ? $r : 'VAL').",".$rv;
 
 =head2 unserialise_variable(string)
 
-Converts a string created by serialise_variable() back into the original
-scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
-object, the same class is used on this system, if available.
+Decodes a value created by serialise_variable(). Data::Dumper input is parsed
+without evaluating Perl and returns undef if it contains unsupported syntax.
+Objects become plain data so a remote peer cannot load or bless a local class.
 
 =cut
 sub unserialise_variable
 {
 my ($str) = @_;
 if (substr($str, 0, 5) eq '$VAR1') {
-	# In Data::Dumper format
-	$rv = eval $str.' $VAR1;';
-	return $rv;
+	# Parse Data::Dumper input as data rather than evaluating Perl code
+	my $rv = eval { local $SIG{'__DIE__'}; &unserialise_dumper_data($str) };
+	return $@ ? undef : $rv;
 	}
 my @v = split(/,/, $str);
 my $rv;
@@ -9619,19 +9627,349 @@ elsif ($v[0] eq 'UNDEF') {
 	$rv = undef;
 	}
 elsif ($v[0] =~ /^OBJECT\s+([A-Za-z0-9_:]+)$/) {
-	# An object hash that we have to re-bless
-	my $cls = $1;
+	# Keep the object's data without loading its remote-selected class
 	$rv = { };
 	for(my $i=1; $i<@v; $i+=2) {
 		$rv->{&unserialise_variable(&un_urlize($v[$i]))} =
 			&unserialise_variable(&un_urlize($v[$i+1]));
 		}
-	eval "use $cls";
-	bless $rv, $cls;
 	}
 return $rv;
 }
 
+# unserialise_dumper_data(string)
+# Parses supported Data::Dumper output generated with Purity, without evaluating
+# Perl. Code refs, globs and placeholders become undef, regexps become strings,
+# and objects become plain data. Dies on unsupported syntax.
+sub unserialise_dumper_data
+{
+my ($str) = @_;
+my $s = \$str;
+pos($str) = 0;
+
+# Read the main value
+$str =~ /\G\$VAR1\s*=/gc || die "Missing \$VAR1 assignment\n";
+my $root = &unserialise_dumper_value($s, 0);
+$str =~ /\G\s*;/gc || die "Missing ; after value\n";
+
+# Apply the assignments that link shared and cyclic references
+while(1) {
+	$str =~ /\G\s+/gc;
+	last if (pos($str) == length($str));
+	my $target = &unserialise_dumper_path($s, \$root);
+	$str =~ /\G\s*=\s*/gc || die "Missing = in reference link\n";
+	my $value;
+	if ($str =~ /\G\\/gc) {
+		# Reference to an existing slot, like \$VAR1->{'a'}
+		$value = &unserialise_dumper_path($s, \$root);
+		}
+	else {
+		# Copy of an existing value, like $VAR1->{'a'}
+		$value = ${&unserialise_dumper_path($s, \$root)};
+		}
+	$str =~ /\G\s*;/gc || die "Missing ; after reference link\n";
+	$$target = $value;
+	}
+return $root;
+}
+
+# unserialise_dumper_value(&string, depth)
+# Reads one Data::Dumper value at the current string position. Each match must
+# consume input because Perl rejects consecutive zero-length //g matches at the
+# same position.
+sub unserialise_dumper_value
+{
+my ($s, $depth) = @_;
+$depth < 1000 || die "Data is nested too deeply\n";
+$$s =~ /\G\s+/gc;
+if ($$s =~ /\G'/gc) {
+	return &unserialise_dumper_single($s);
+	}
+elsif ($$s =~ /\G"/gc) {
+	return &unserialise_dumper_double($s);
+	}
+elsif ($$s =~ /\G(-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][-+]?[0-9]+)?)(?![A-Za-z0-9_.])/gc) {
+	# Unquoted number
+	return $1 + 0;
+	}
+elsif ($$s =~ /\G\{/gc) {
+	# Hash of key => value pairs
+	my $rv = { };
+	return $rv if ($$s =~ /\G\s*\}/gc);
+	while(1) {
+		$$s =~ /\G\s+/gc;
+		my $key = &unserialise_dumper_key($s);
+		$$s =~ /\G\s*=>/gc || die "Missing => in hash\n";
+		$rv->{$key} = &unserialise_dumper_value($s, $depth+1);
+		if ($$s =~ /\G\s*,/gc) {
+			# More pairs, or a trailing comma
+			return $rv if ($$s =~ /\G\s*\}/gc);
+			}
+		elsif ($$s =~ /\G\s*\}/gc) {
+			# Accept a closing brace without a trailing comma
+			return $rv;
+			}
+		else {
+			# Reject all other separators
+			die "Missing , or } in hash\n";
+			}
+		}
+	}
+elsif ($$s =~ /\G\[/gc) {
+	# Array of values
+	my $rv = [ ];
+	return $rv if ($$s =~ /\G\s*\]/gc);
+	while(1) {
+		push(@$rv, &unserialise_dumper_value($s, $depth+1));
+		if ($$s =~ /\G\s*,/gc) {
+			# More values, or a trailing comma
+			return $rv if ($$s =~ /\G\s*\]/gc);
+			}
+		elsif ($$s =~ /\G\s*\]/gc) {
+			# Accept a closing bracket without a trailing comma
+			return $rv;
+			}
+		else {
+			# Reject all other separators
+			die "Missing , or ] in array\n";
+			}
+		}
+	}
+elsif ($$s =~ /\G\\/gc) {
+	# Reference to a new scalar, like \'text'
+	my $v = &unserialise_dumper_value($s, $depth+1);
+	return \$v;
+	}
+elsif ($$s =~ /\Gundef(?![A-Za-z0-9_:])/gc) {
+	return undef;
+	}
+elsif ($$s =~ /\Gbless\(/gc) {
+	# Object, kept as plain data without its class
+	my $rv = &unserialise_dumper_value($s, $depth+1);
+	$$s =~ /\G\s*,\s*/gc || die "Missing , in bless\n";
+	if ($$s =~ /\G'/gc) {
+		&unserialise_dumper_single($s);
+		}
+	elsif ($$s =~ /\G"/gc) {
+		&unserialise_dumper_double($s);
+		}
+	else {
+		# Reject a malformed or executable class expression
+		die "Missing class name in bless\n";
+		}
+	$$s =~ /\G\s*\)/gc || die "Missing ) in bless\n";
+	return $rv;
+	}
+elsif ($$s =~ /\Gdo\{my \$o\}/gc) {
+	# Placeholder that a later reference link fills in
+	return undef;
+	}
+elsif ($$s =~ /\Gdo\{\\\(my \$o =/gc) {
+	# Scalar ref, as used for blessed scalar refs
+	my $v = &unserialise_dumper_value($s, $depth+1);
+	$$s =~ /\G\s*\)\}/gc || die "Missing )} in scalar ref\n";
+	return \$v;
+	}
+elsif ($$s =~ /\Gsub \{ "DUMMY" \}/gc) {
+	# Code refs are not transferred
+	return undef;
+	}
+elsif ($$s =~ /\Gqr\//gc) {
+	# Regexp, returned as its pattern string without compiling it
+	my $pat = '';
+	while(1) {
+		if ($$s =~ /\G([^\/\\]+)/gc) {
+			$pat .= $1;
+			}
+		elsif ($$s =~ /\G(\\.)/gcs) {
+			$pat .= $1;
+			}
+		elsif ($$s =~ /\G\//gc) {
+			last;
+			}
+		else {
+			# Reject an incomplete regexp instead of compiling it
+			die "Unterminated regexp\n";
+			}
+		}
+	my $flags = $$s =~ /\G([a-z]+)/gc ? $1 : '';
+	return "(?^$flags:$pat)";
+	}
+elsif ($$s =~ /\G\*(?:[A-Za-z_][A-Za-z0-9_]*)?(?:::[A-Za-z0-9_]+)+/gc) {
+	# Globs are not transferred
+	return undef;
+	}
+elsif ($$s =~ /\G\*\{/gc) {
+	# Glob with an unusual name, like *{'::odd name'}
+	if ($$s =~ /\G'/gc) {
+		&unserialise_dumper_single($s);
+		}
+	elsif ($$s =~ /\G"/gc) {
+		&unserialise_dumper_double($s);
+		}
+	else {
+		# Reject any other glob expression
+		die "Invalid glob name\n";
+		}
+	$$s =~ /\G\}/gc || die "Missing } in glob\n";
+	return undef;
+	}
+elsif (substr($$s, pos($$s), 1) eq '$') {
+	# Match eval by using undef until a later assignment resolves this link
+	&unserialise_dumper_path($s);
+	return undef;
+	}
+die "Unsupported data at position ".pos($$s)."\n";
+}
+
+# unserialise_dumper_path(&string, [&root])
+# Reads a path such as ${$VAR1->{'a'}}->[0]. If root is supplied, returns a
+# reference to the existing slot. Without root, only validates the syntax.
+sub unserialise_dumper_path
+{
+my ($s, $root) = @_;
+my $slot;
+if ($$s =~ /\G\$\{/gc) {
+	# Follow a scalar reference such as ${$VAR1}
+	my $inner = &unserialise_dumper_path($s, $root);
+	$$s =~ /\G\}/gc || die "Missing } in reference path\n";
+	if ($root) {
+		# Resolve the dereference only when an actual root was supplied
+		my $type = ref($$inner);
+		$type eq 'SCALAR' || $type eq 'REF' ||
+			die "Reference path does not match the data\n";
+		$slot = $$inner;
+		}
+	}
+elsif ($$s =~ /\G\$VAR1(?![A-Za-z0-9_:])/gc) {
+	# Start at the root value
+	$slot = $root;
+	}
+else {
+	# Reject paths that do not begin at the serialized root
+	die "Invalid reference path\n";
+	}
+
+# Follow hash and array subscripts. The first requires an arrow because Perl
+# would otherwise parse a different variable.
+my $need_arrow = 1;
+while(1) {
+	my $arrow = $$s =~ /\G->/gc;
+	my $next = substr($$s, pos($$s), 1);
+	if ($next ne '{' && $next ne '[') {
+		$arrow && die "Missing subscript in reference path\n";
+		last;
+		}
+	$need_arrow && !$arrow && die "Missing -> in reference path\n";
+	$need_arrow = 0;
+	if ($$s =~ /\G\{/gc) {
+		# Refuse links to hash elements outside the parsed data
+		my $key = &unserialise_dumper_key($s);
+		$$s =~ /\G\}/gc || die "Missing } in reference path\n";
+		next if (!$root);
+		ref($$slot) eq 'HASH' && exists($$slot->{$key}) ||
+			die "Reference path does not match the data\n";
+		$slot = \$$slot->{$key};
+		}
+	elsif ($$s =~ /\G\[([0-9]+)\]/gc) {
+		# Refuse links to array elements outside the parsed data
+		my $i = $1;
+		next if (!$root);
+		ref($$slot) eq 'ARRAY' && $i < @{$$slot} ||
+			die "Reference path does not match the data\n";
+		$slot = \$$slot->[$i];
+		}
+	else {
+		# Reject an unsupported path component
+		die "Invalid subscript in reference path\n";
+		}
+	}
+return $slot;
+}
+
+# unserialise_dumper_key(&string)
+# Reads a quoted, bare-word or integer hash key.
+sub unserialise_dumper_key
+{
+my ($s) = @_;
+if ($$s =~ /\G'/gc) {
+	return &unserialise_dumper_single($s);
+	}
+elsif ($$s =~ /\G"/gc) {
+	return &unserialise_dumper_double($s);
+	}
+elsif ($$s =~ /\G(-?[A-Za-z_][A-Za-z0-9_]*|-?(?:0|[1-9][0-9]*))(?![A-Za-z0-9_'"])/gc) {
+	return $1;
+	}
+die "Invalid hash key at position ".pos($$s)."\n";
+}
+
+# unserialise_dumper_single(&string)
+# Reads a single-quoted string. Only \\ and \' are escapes.
+sub unserialise_dumper_single
+{
+my ($s) = @_;
+my $rv = '';
+while(1) {
+	if ($$s =~ /\G([^'\\]+)/gc) {
+		$rv .= $1;
+		}
+	elsif ($$s =~ /\G'/gc) {
+		return $rv;
+		}
+	elsif ($$s =~ /\G\\([\\'])/gc) {
+		$rv .= $1;
+		}
+	elsif ($$s =~ /\G\\/gc) {
+		# Preserve a backslash that does not escape a quote or backslash
+		$rv .= "\\";
+		}
+	else {
+		# Reject an incomplete quoted string
+		die "Unterminated string\n";
+		}
+	}
+}
+
+# unserialise_dumper_double(&string)
+# Reads a double-quoted string without using Perl interpolation. Rejects an
+# unescaped $ or @ and unsupported escapes.
+sub unserialise_dumper_double
+{
+my ($s) = @_;
+my $rv = '';
+while(1) {
+	if ($$s =~ /\G([^"\\\$\@]+)/gc) {
+		$rv .= $1;
+		}
+	elsif ($$s =~ /\G"/gc) {
+		return $rv;
+		}
+	elsif ($$s =~ /\G\\x\{([0-9A-Fa-f]{1,8})\}/gc) {
+		$rv .= chr(hex($1));
+		}
+	elsif ($$s =~ /\G\\x([0-9A-Fa-f]{1,2})/gc) {
+		$rv .= chr(hex($1));
+		}
+	elsif ($$s =~ /\G\\([0-7]{1,3})/gc) {
+		$rv .= chr(oct($1));
+		}
+	elsif ($$s =~ /\G\\([nrtfbae])/gc) {
+		# Named control character
+		$rv .= { 'n' => "\n", 'r' => "\r", 't' => "\t", 'f' => "\f",
+			 'b' => "\b", 'a' => "\a", 'e' => "\e" }->{$1};
+		}
+	elsif ($$s =~ /\G\\([^A-Za-z0-9])/gc) {
+		# Escaped punctuation, like \" or \$
+		$rv .= $1;
+		}
+	else {
+		# Reject interpolation and unsupported Perl escapes
+		die "Invalid double-quoted string\n";
+		}
+	}
+}
+
 =head2 other_groups(user)
 
 Returns a list of secondary groups a user is a member of, as a list of