Skip to content

Commit a0ce932

Browse files
karenetheridgekarenetheridge
committed
extract version much more safely
1 parent 0b6488a commit a0ce932

File tree

6 files changed

+345
-145
lines changed

6 files changed

+345
-145
lines changed

‎Changes

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,8 @@ Release history for Module-Metadata
44
- eliminated dependency on IO::File (and by virtue, XS) - thanks, leont!
55
- removed cruft in test infrastructure left behind from separation from
66
Module::Build (ether)
7+
- now extracting module version a Safe compartment in a subprocess
8+
(RT#89283)
79

810
1.000019 - 2013-10-06
911
- warnings now disabled inside during the evaluation of generated version

‎Makefile.PL

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,11 @@ WriteMakefile(
2222
'vars' => 0,
2323
'version' => 0.87,
2424
'warnings' => 0,
25+
'Exporter' => 0,
26+
'File::Temp' =>'0.18',
27+
'IPC::Open3' => 0,
28+
'Symbol' => 0,
29+
'Safe' => 0,
2530
$] < 5.008
2631
? ( 'IO::Scalar' => 0 )
2732
: ()

‎lib/Module/Metadata.pm

Lines changed: 3 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -590,23 +590,13 @@ sub _parse_fh {
590590
$need_vers = 0 if $version_package eq $package;
591591

592592
unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
593-
$vers{$version_package} = eval_version(
594-
sigil => $version_sigil,
595-
variable_name => $version_fullname,
596-
string => $line,
597-
filename => $self->{filename},
598-
);
593+
$vers{$version_package} = eval_version($line);
599594
}
600595

601596
# first non-comment line in undeclared package main is VERSION
602597
} elsif ( !exists($vers{main}) && $package eq 'main' && $version_fullname ) {
603598
$need_vers = 0;
604-
my $v = eval_version(
605-
sigil => $version_sigil,
606-
variable_name => $version_fullname,
607-
string => $line,
608-
filename => $self->{filename},
609-
);
599+
my $v = eval_version($line);
610600
$vers{$package} = $v;
611601
push( @packages, 'main' );
612602

@@ -619,12 +609,7 @@ sub _parse_fh {
619609
# only keep if this is the first $VERSION seen
620610
} elsif ( $version_fullname && $need_vers ) {
621611
$need_vers = 0;
622-
my $v = eval_version(
623-
sigil => $version_sigil,
624-
variable_name => $version_fullname,
625-
string => $line,
626-
filename => $self->{filename},
627-
);
612+
my $v = eval_version($line);
628613

629614
unless ( defined $vers{$package} && length $vers{$package} ) {
630615
$vers{$package} = $v;

‎lib/Module/Metadata/ExtractVersion.pm

Lines changed: 158 additions & 119 deletions
Original file line numberDiff line numberDiff line change
@@ -6,139 +6,178 @@ package Module::Metadata::ExtractVersion;
66
use parent 'Exporter';
77
our @EXPORT_OK = qw/eval_version/;
88

9-
use Carp qw/croak/;
9+
use File::Spec;
10+
use File::Temp 0.18;
11+
use IPC::Open3 qw(open3);
12+
use Symbol 'gensym';
13+
14+
# Win32 is slow to spawn processes
15+
my $TIMEOUT = $^O eq 'MSWin32' ? 5 : 2;
1016

1117
=func eval_version
1218
19+
my $version = eval_version( q[our $VERSION = "1.23"] );
20+
1321
Given a (decoded) string (usually a single line) that contains a C<$VERSION>
1422
declaration, this function will evaluate it in a L<Safe> compartment in a
15-
separate process. If the C<$VERSION> is a valid version string according to
16-
L<version>, it will return it as a string, otherwise, it will return undef.
23+
separate process. The extracted string is returned; it is B<not> validated
24+
against required syntax for versions at this level, so the caller should
25+
normally do something like C<< version::is_lax($version) >> before proceeding
26+
to use this data.
1727
1828
=cut
1929

2030
sub eval_version
2131
{
22-
my (%args) = @_;
23-
24-
return _evaluate_version_line(
25-
$args{sigil},
26-
$args{variable_name},
27-
$args{string},
28-
$args{filename},
29-
);
30-
}
32+
my ( $string, $timeout ) = @_;
33+
$timeout = $TIMEOUT unless defined $timeout;
34+
35+
# what $VERSION are we looking for?
36+
my ( $sigil, $var ) = $string =~ /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
37+
return unless $sigil && $var;
38+
39+
# munge string: remove "use version" as we do that already and the "use"
40+
# will get stopped by the Safe compartment
41+
$string =~ s/(?:use|require)\s+version[^;]*/1/;
42+
43+
# create test file
44+
my $temp = File::Temp->new;
45+
print {$temp} _pl_template( $string, $sigil, $var );
46+
close $temp;
47+
48+
my $rc;
49+
my $result;
50+
my $err = gensym;
51+
my $pid = open3(my $in, my $out, $err, $^X, $temp);
52+
my $killer;
53+
if ($^O eq 'MSWin32') {
54+
$killer = fork;
55+
if (!defined $killer) {
56+
die "Can't fork: $!";
57+
}
58+
elsif ($killer == 0) {
59+
sleep $timeout;
60+
kill 'KILL', $pid;
61+
exit 0;
62+
}
63+
}
64+
my $got = eval {
65+
local $SIG{ALRM} = sub { die "alarm\n" };
66+
alarm $timeout;
67+
local $/;
68+
$result = readline $out;
69+
my $c = waitpid $pid, 0;
70+
alarm 0;
71+
( $c != $pid ) || $?;
72+
};
73+
if ( $@ eq "alarm\n" ) {
74+
kill 'KILL', $pid;
75+
waitpid $pid, 0;
76+
$rc = $?;
77+
}
78+
else {
79+
$rc = $got;
80+
}
81+
if ($killer) {
82+
kill 'KILL', $killer;
83+
waitpid $killer, 0;
84+
}
3185

32-
# transported directly from Module::Metadata
33-
{
34-
my $pn = 0;
35-
sub _evaluate_version_line {
36-
my( $sigil, $variable_name, $line, $filename ) = @_;
37-
38-
# Some of this code came from the ExtUtils:: hierarchy.
39-
40-
# We compile into $vsub because 'use version' would cause
41-
# compiletime/runtime issues with local()
42-
my $vsub;
43-
$pn++; # everybody gets their own package
44-
my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
45-
#; package Module::Metadata::_version::p$pn;
46-
use version;
47-
no strict;
48-
no warnings;
49-
50-
\$vsub = sub {
51-
local $sigil$variable_name;
52-
\$$variable_name=undef;
53-
$line;
54-
\$$variable_name
55-
};
56-
}};
57-
58-
$eval = $1 if $eval =~ m{^(.+)}s;
59-
60-
local $^W;
61-
# Try to get the $VERSION
62-
eval $eval;
63-
# some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
64-
# installed, so we need to hunt in ./lib for it
65-
if ( $@ =~ /Can't locate/ && -d 'lib' ) {
66-
local @INC = ('lib',@INC);
67-
eval $eval;
68-
}
69-
warn "Error evaling version line '$eval' in $filename: $@\n"
70-
if $@;
71-
(ref($vsub) eq 'CODE') or
72-
croak "failed to build version sub for $filename";
73-
my $result = eval { $vsub->() };
74-
croak "Could not get version from $filename by executing:\n$eval\n\nThe fatal error was: $@\n"
75-
if $@;
76-
77-
# Upgrade it into a version object
78-
my $version = eval { _dwim_version($result) };
79-
80-
croak "Version '$result' from $filename does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
81-
unless defined $version; # "0" is OK!
82-
83-
return $version;
84-
}
85-
}
86+
return if $rc || !defined $result; # error condition
8687

87-
# Try to DWIM when things fail the lax version test in obvious ways
88-
{
89-
my @version_prep = (
90-
# Best case, it just works
91-
sub { return shift },
92-
93-
# If we still don't have a version, try stripping any
94-
# trailing junk that is prohibited by lax rules
95-
sub {
96-
my $v = shift;
97-
$v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
98-
return $v;
99-
},
100-
101-
# Activestate apparently creates custom versions like '1.23_45_01', which
102-
# cause version.pm to think it's an invalid alpha. So check for that
103-
# and strip them
104-
sub {
105-
my $v = shift;
106-
my $num_dots = () = $v =~ m{(\.)}g;
107-
my $num_unders = () = $v =~ m{(_)}g;
108-
my $leading_v = substr($v,0,1) eq 'v';
109-
if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
110-
$v =~ s{_}{}g;
111-
$num_unders = () = $v =~ m{(_)}g;
112-
}
113-
return $v;
114-
},
115-
116-
# Worst case, try numifying it like we would have before version objects
117-
sub {
118-
my $v = shift;
119-
no warnings 'numeric';
120-
return 0 + $v;
121-
},
122-
123-
);
124-
125-
sub _dwim_version {
126-
my ($result) = shift;
127-
128-
return $result if ref($result) eq 'version';
129-
130-
my ($version, $error);
131-
for my $f (@version_prep) {
132-
$result = $f->($result);
133-
$version = eval { version->new($result) };
134-
$error ||= $@ if $@; # capture first failure
135-
last if defined $version;
136-
}
88+
## print STDERR "# C<< $string >> --> $result" if $result =~ /^ERROR/;
89+
return if $result =~ /^ERROR/;
13790

138-
croak $error unless defined $version;
91+
$result =~ s/[\r\n]+\z//;
13992

140-
return $version;
141-
}
93+
# treat '' the same as undef: no version was found
94+
undef $result if $result eq '';
95+
96+
return $result;
97+
}
98+
99+
sub _pl_template {
100+
my ( $string, $sigil, $var ) = @_;
101+
return <<"HERE"
102+
use version;
103+
use Safe;
104+
use File::Spec;
105+
open STDERR, '>', File::Spec->devnull;
106+
open STDIN, '<', File::Spec->devnull;
107+
108+
my \$comp = Safe->new;
109+
\$comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
110+
\$comp->share("*version::new");
111+
\$comp->share("*version::numify");
112+
\$comp->share_from('main', ['*version::',
113+
'*Exporter::',
114+
'*DynaLoader::']);
115+
\$comp->share_from('version', ['&qv']);
116+
117+
my \$code = <<'END';
118+
local $sigil$var;
119+
\$$var = undef;
120+
do {
121+
$string
122+
};
123+
\$$var;
124+
END
125+
126+
my \$result = \$comp->reval(\$code);
127+
print "ERROR: \$@\n" if \$@;
128+
exit unless defined \$result;
129+
130+
eval { \$result = version->parse(\$result)->stringify };
131+
print \$result;
132+
133+
HERE
142134
}
143135

144136
1;
137+
138+
=head1 SYNOPSIS
139+
140+
use Version::Eval qw/eval_version/;
141+
142+
my $version = eval_version( $unsafe_string );
143+
144+
=head1 DESCRIPTION
145+
146+
Package versions are defined by a string such as this:
147+
148+
package Foo;
149+
our $VERSION = "1.23";
150+
151+
If we want to know the version of a F<.pm> file, we can
152+
load it and check C<Foo->VERSION> for the package. But that means any
153+
buggy or hostile code in F<Foo.pm> gets run.
154+
155+
The safe thing to do is to parse out a string that looks like an assignment
156+
to C<$VERSION> and then evaluate it. But even that could be hostile:
157+
158+
package Foo;
159+
our $VERSION = do { my $n; $n++ while 1 }; # infinite loop
160+
161+
This module executes a potential version string in a separate process in
162+
a L<Safe> compartment with a timeout to avoid as much risk as possible.
163+
164+
Hostile code might still attempt to consume excessive resources, but the
165+
timeout should limit the problem.
166+
167+
=head1 SEE ALSO
168+
169+
=over 4
170+
171+
* L<Parse::PMFile>
172+
173+
* L<V>
174+
175+
* L<use Module::Info>
176+
177+
* L<Module::InstalledVersion>
178+
179+
* L<Module::Version>
180+
181+
=back
182+
183+
=cut

0 commit comments

Comments
 (0)