@@ -11,138 +11,178 @@ our $VERSION = '1.000028';
1111use base ' Exporter'
1212our @EXPORT_OK = qw/ eval_version/
1313
14- use Carp qw/ croak/
15- use version 0.87;
14+ use File::Spec;
15+ use File::Temp 0.18;
16+ use IPC::Open3 qw( open3)
17+ use Symbol ' gensym'
18+
19+ # Win32 is slow to spawn processes
20+ my $TIMEOUT = $^O eq ' MSWin32'
1621
1722=func eval_version
1823
24+ my $version = eval_version( q[our $VERSION = "1.23"] );
25+
1926Given a (decoded) string (usually a single line) that contains a C<$VERSION >
2027declaration, this function will evaluate it in a L<Safe> compartment in a
21- separate process. If the C<$VERSION > is a valid version string according to
22- L<version> , it will return it as a string, otherwise, it will return undef.
28+ separate process. The extracted string is returned; it is B<not > validated
29+ against required syntax for versions at this level, so the caller should
30+ normally do something like C<< version::is_lax($version) >> before proceeding
31+ to use this data.
2332
2433=cut
2534
2635sub eval_version
2736{
28- my (%args ) = @_ ;
29-
30- return _evaluate_version_line(
31- $args {sigil },
32- $args {variable_name },
33- $args {string },
34- $args {filename },
35- );
36- }
37+ my ( $string , $timeout ) = @_ ;
38+ $timeout = $TIMEOUT unless defined $timeout ;
39+
40+ # what $VERSION are we looking for?
41+ my ( $sigil , $var ) = $string =~ / ([\$ *])((?:[\w\:\' ]*)\b VERSION)\b .*\= /
42+ return unless $sigil && $var ;
43+
44+ # munge string: remove "use version" as we do that already and the "use"
45+ # will get stopped by the Safe compartment
46+ $string =~ s /\s +version[^;]*/ 1/
47+
48+ # create test file
49+ my $temp = File::Temp-> new;
50+ print {$temp } _pl_template( $string , $sigil , $var );
51+ close $temp ;
52+
53+ my $rc ;
54+ my $result ;
55+ my $err = gensym;
56+ my $pid = open3(my $in , my $out , $err , $^X, $temp );
57+ my $killer ;
58+ if ($^O eq ' MSWin32'
59+ $killer = fork ;
60+ if (!defined $killer ) {
61+ die " Can't fork: $! "
62+ }
63+ elsif ($killer == 0) {
64+ sleep $timeout ;
65+ kill ' KILL' $pid ;
66+ exit 0;
67+ }
68+ }
69+ my $got = eval {
70+ local $SIG {ALRM } = sub { die " alarm\n "
71+ alarm $timeout ;
72+ local $/ ;
73+ $result = readline $out ;
74+ my $c = waitpid $pid , 0;
75+ alarm 0;
76+ ( $c != $pid ) || $? ;
77+ };
78+ if ( $@ eq " alarm\n "
79+ kill ' KILL' $pid ;
80+ waitpid $pid , 0;
81+ $rc = $? ;
82+ }
83+ else {
84+ $rc = $got ;
85+ }
86+ if ($killer ) {
87+ kill ' KILL' $killer ;
88+ waitpid $killer , 0;
89+ }
3790
38- # transported directly from Module::Metadata
91+ return if $rc || ! defined $result ; # error condition
3992
40- {
41- my $pn = 0;
42- sub _evaluate_version_line {
43- my ( $sigil , $variable_name , $line , $filename ) = @_ ;
44-
45- # We compile into a local sub because 'use version' would cause
46- # compiletime/runtime issues with local()
47- $pn ++; # everybody gets their own package
48- my $eval = qq{ my \$ dummy = q# Hide from _packages_inside()
49- #; package Module::Metadata::_version::p${pn} ;
50- use version;
51- sub {
52- local $sigil$variable_name ;
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- my $vsub = __clean_eval($eval );
63- # some modules say $VERSION <equal sign> $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- $vsub = __clean_eval($eval );
68- }
69- warn " Error evaling version line '$eval ' in $filename : $@ \n "
70- if $@ ;
71-
72- (ref ($vsub ) eq ' CODE' or
73- croak " failed to build version sub for $filename "
74-
75- my $result = eval { $vsub -> () };
76- # FIXME: $eval is not the right thing to print here
77- croak " Could not get version from $filename by executing:\n $eval \n\n The fatal error was: $@ \n "
78- if $@ ;
79-
80- # Upgrade it into a version object
81- my $version = eval { _dwim_version($result ) };
82-
83- # FIXME: $eval is not the right thing to print here
84- croak " Version '$result ' from $filename does not appear to be valid:\n $eval \n\n The fatal error was: $@ \n "
85- unless defined $version ; # "0" is OK!
86-
87- return $version ;
88- }
93+ # # print STDERR "# C<< $string >> --> $result" if $result =~ /^ERROR/;
94+ return if $result =~ / ^ERROR/
95+
96+ $result =~ s /\r\n ]+\z //
97+
98+ # treat '' the same as undef: no version was found
99+ undef $result if $result eq ' '
100+
101+ return $result ;
89102}
90103
91- # Try to DWIM when things fail the lax version test in obvious ways
92- {
93- my @version_prep = (
94- # Best case, it just works
95- sub { return shift },
96-
97- # If we still don't have a version, try stripping any
98- # trailing junk that is prohibited by lax rules
99- sub {
100- my $v = shift ;
101- $v =~ s {} { $1 } i # 1.23-alpha or 1.23b
102- return $v ;
103- },
104-
105- # Activestate apparently creates custom versions like '1.23_45_01', which
106- # cause version.pm to think it's an invalid alpha. So check for that
107- # and strip them
108- sub {
109- my $v = shift ;
110- my $num_dots = () = $v =~ m {\. )} g
111- my $num_unders = () = $v =~ m {} g
112- my $leading_v = substr ($v ,0,1) eq ' v'
113- if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
114- $v =~ s {} {} g
115- $num_unders = () = $v =~ m {} g
116- }
117- return $v ;
118- },
119-
120- # Worst case, try numifying it like we would have before version objects
121- sub {
122- my $v = shift ;
123- no warnings ' numeric'
124- return 0 + $v ;
125- },
126-
127- );
128-
129- sub _dwim_version {
130- my ($result ) = shift ;
131-
132- return $result if ref ($result ) eq ' version'
133-
134- my ($version , $error );
135- for my $f (@version_prep ) {
136- $result = $f -> ($result );
137- $version = eval { version-> new($result ) };
138- $error ||= $@ if $@ ; # capture first failure
139- last if defined $version ;
140- }
104+ sub _pl_template {
105+ my ( $string , $sigil , $var ) = @_ ;
106+ return <<"HERE"
107+ use version;
108+ use Safe;
109+ use File::Spec;
110+ open STDERR, '>', File::Spec->devnull;
111+ open STDIN, '<', File::Spec->devnull;
112+
113+ my \$ comp = Safe->new;
114+ \$ comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
115+ \$ comp->share("*version::new");
116+ \$ comp->share("*version::numify");
117+ \$ comp->share_from('main', ['*version::',
118+ '*Exporter::',
119+ '*DynaLoader::']);
120+ \$ comp->share_from('version', ['&qv']);
121+
122+ my \$ code = <<'END';
123+ local $sigil$var ;
124+ \$ $var = undef;
125+ do {
126+ $string
127+ };
128+ \$ $var ;
129+ END
130+
131+ my \$ result = \$ comp->reval(\$ code);
132+ print "ERROR: \$ @\n " if \$ @;
133+ exit unless defined \$ result;
141134
142- croak $error unless defined $version ;
135+ eval { \$ result = version->parse(\$ result)->stringify };
136+ print \$ result;
143137
144- return $version ;
145- }
138+ HERE
146139}
147140
1481411;
142+
143+ =head1 SYNOPSIS
144+
145+ use Version::Eval qw/eval_version/;
146+
147+ my $version = eval_version( $unsafe_string );
148+
149+ =head1 DESCRIPTION
150+
151+ Package versions are defined by a string such as this:
152+
153+ package Foo;
154+ our $VERSION = "1.23";
155+
156+ If we want to know the version of a F<.pm> file, we can
157+ load it and check C<Foo- > VERSION> for the package. But that means any
158+ buggy or hostile code in F<Foo.pm> gets run.
159+
160+ The safe thing to do is to parse out a string that looks like an assignment
161+ to C<$VERSION > and then evaluate it. But even that could be hostile:
162+
163+ package Foo;
164+ our $VERSION = do { my $n; $n++ while 1 }; # infinite loop
165+
166+ This module executes a potential version string in a separate process in
167+ a L<Safe> compartment with a timeout to avoid as much risk as possible.
168+
169+ Hostile code might still attempt to consume excessive resources, but the
170+ timeout should limit the problem.
171+
172+ =head1 SEE ALSO
173+
174+ =over 4
175+
176+ * L<Parse::PMFile>
177+
178+ * L<V>
179+
180+ * L<use Module::Info>
181+
182+ * L<Module::InstalledVersion>
183+
184+ * L<Module::Version>
185+
186+ =back
187+
188+ =cut
0 commit comments