Review: extract versions more safely

Changes

@@ -1,6 +1,8 @@
 Revision history for Module-Metadata
 
 {{$NEXT}}
+  - now extracting module version a Safe compartment in a subprocess
+    (RT#89283)
 
 1.000027  2015-04-11 00:21:26Z
   - work around issues with an unconfigured Log::Contextual (Kent Fredric)

lib/Module/Metadata.pm

@@ -10,7 +10,6 @@ package Module::Metadata;
 # perl modules (assuming this may be expanded in the distant
 # parrot future to look at other types of modules).
 
-sub __clean_eval { eval $_[0] }
 use strict;
 use warnings;
 
@@ -25,6 +24,9 @@ BEGIN {
        } or *SEEK_SET = sub { 0 }
 }
 use version 0.87;
+use Module::Metadata::ExtractVersion 'eval_version';
+
+
 BEGIN {
   if ($INC{'Log/Contextual.pm'}) {
     require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
@@ -514,7 +516,7 @@ sub _parse_fh {
   my ($self, $fh) = @_;
 
   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
-  my( @packages, %vers, %pod, @pod );
+  my( @packages, %vers_raw, %vers, %pod, @pod );
   my $package = 'main';
   my $pod_sect = '';
   my $pod_data = '';
@@ -590,43 +592,39 @@ sub _parse_fh {
       push( @packages, $package ) unless grep( $package eq $_, @packages );
       $need_vers = defined $version ? 0 : 1;
 
-      if ( not exists $vers{$package} and defined $version ){
-        # Upgrade to a version object.
-        my $dwim_version = eval { _dwim_version($version) };
-        croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
-            unless defined $dwim_version;  # "0" is OK!
-        $vers{$package} = $dwim_version;
+      if ( not exists $vers_raw{$package}[0] and defined $version ){
+        $vers_raw{$package} = [ $version, $line ];
       }
 
     # VERSION defined with full package spec, i.e. $Module::VERSION
     } elsif ( $version_fullname && $version_package ) {
       push( @packages, $version_package ) unless grep( $version_package eq $_, @packages );
       $need_vers = 0 if $version_package eq $package;
 
-      unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
-      $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
-    }
+      unless ( defined $vers_raw{$version_package}[0] && length $vers_raw{$version_package}[0] ) {
+        $vers_raw{$version_package} = [ eval_version($line), $line ];
+      }
 
     # first non-comment line in undeclared package main is VERSION
-    } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
+    } elsif ( $package eq 'main' && $version_fullname && !exists($vers_raw{main}[0]) ) {
       $need_vers = 0;
-      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
-      $vers{$package} = $v;
+      my $v = eval_version($line);
+      $vers_raw{$package} = [ $v, $line ];
       push( @packages, 'main' );
 
     # first non-comment line in undeclared package defines package main
-    } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
+    } elsif ( $package eq 'main' && !exists($vers_raw{main}[0]) && $line =~ /\w/ ) {
       $need_vers = 1;
-      $vers{main} = '';
+      $vers_raw{main} = [ '', $line ];
       push( @packages, 'main' );
 
     # only keep if this is the first $VERSION seen
     } elsif ( $version_fullname && $need_vers ) {
       $need_vers = 0;
-      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+      my $v = eval_version($line);
 
-      unless ( defined $vers{$package} && length $vers{$package} ) {
-        $vers{$package} = $v;
+      unless ( exists $vers_raw{$package}[0]  && length $vers_raw{$package}[0] ) {
+        $vers_raw{$package} = [ $v, $line ];
       }
     }
 
@@ -636,62 +634,24 @@ sub _parse_fh {
     $pod{$pod_sect} = $pod_data;
   }
 
-  $self->{versions} = \%vers;
-  $self->{packages} = \@packages;
-  $self->{pod} = \%pod;
-  $self->{pod_headings} = \@pod;
-}
+  # Upgrade the found versions into version objects
+  foreach my $package (keys %vers_raw) {
+    # watch out for autovivification at the first level of the hash
+    delete($vers_raw{$package}), next if not exists $vers_raw{$package}[0];
+    my $version = eval { _dwim_version($vers_raw{$package}[0]) };
 
-{
-my $pn = 0;
-sub _evaluate_version_line {
-  my $self = shift;
-  my( $sigil, $variable_name, $line ) = @_;
-
-  # We compile into a local sub because 'use version' would cause
-  # compiletime/runtime issues with local()
-  $pn++; # everybody gets their own package
-  my $eval = qq{ my \$dummy = q#  Hide from _packages_inside()
-    #; package Module::Metadata::_version::p${pn};
-    use version;
-    sub {
-      local $sigil$variable_name;
-      $line;
-      \$$variable_name
-    };
-  };
-
-  $eval = $1 if $eval =~ m{^(.+)}s;
+    croak "Version '$vers_raw{$package}[0]' from $self->{filename} does not appear to be valid:\n$vers_raw{$package}[1]\n\nThe fatal error was: $@\n"
+      unless defined $version; # "0" is OK!
 
-  local $^W;
-  # Try to get the $VERSION
-  my $vsub = __clean_eval($eval);
-  # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
-  # installed, so we need to hunt in ./lib for it
-  if ( $@ =~ /Can't locate/ && -d 'lib' ) {
-    local @INC = ('lib',@INC);
-    $vsub = __clean_eval($eval);
+    $vers_raw{$package} = $vers_raw{$package}[0];
+    $vers{$package} = $version;
   }
-  warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
-    if $@;
-
-  (ref($vsub) eq 'CODE') or
-    croak "failed to build version sub for $self->{filename}";
-
-  my $result = eval { $vsub->() };
-  # FIXME: $eval is not the right thing to print here
-  croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
-    if $@;
-
-  # Upgrade it into a version object
-  my $version = eval { _dwim_version($result) };
-
-  # FIXME: $eval is not the right thing to print here
-  croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
-    unless defined $version; # "0" is OK!
 
-  return $version;
-}
+  $self->{versions_raw} = \%vers_raw;
+  $self->{versions} = \%vers;
+  $self->{packages} = \@packages;
+  $self->{pod} = \%pod;
+  $self->{pod_headings} = \@pod;
 }
 
 # Try to DWIM when things fail the lax version test in obvious ways

lib/Module/Metadata/ExtractVersion.pm

@@ -0,0 +1,190 @@
+package Module::Metadata::ExtractVersion;
+# ABSTRACT: Safe parsing of module $VERSION lines
+
+sub __clean_eval { eval $_[0] }
+
+use strict;
+use warnings;
+
+our $VERSION = '1.000028';
+
+use base 'Exporter';
+our @EXPORT_OK = qw/eval_version/;
+
+use File::Spec;
+use File::Temp 0.18;
+use IPC::Open3 qw(open3);
+use Symbol 'gensym';
+
+# Win32 is slow to spawn processes
+my $TIMEOUT = $^O eq 'MSWin32' ? 5 : 2;
+
+=func eval_version
+
+    my $version = eval_version( q[our $VERSION = "1.23"] );
+
+Given a (decoded) string (usually a single line) that contains a C<$VERSION>
+declaration, this function will evaluate it in a L<Safe> compartment in a
+separate process.  The extracted string is returned; it is B<not> validated
+against required syntax for versions at this level, so the caller should
+normally do something like C<< version::is_lax($version) >> before proceeding
+to use this data.
+
+=cut
+
+sub eval_version
+{
+    my ( $string, $timeout ) = @_;
+    $timeout = $TIMEOUT unless defined $timeout;
+
+    # what $VERSION are we looking for?
+    my ( $sigil, $var ) = $string =~ /([\$*])((?:[\w\:\']*)\bVERSION)\b.*\=/;
+    return unless $sigil && $var;
+
+    # munge string: remove "use version" as we do that already and the "use"
+    # will get stopped by the Safe compartment
+    $string =~ s/(?:use|require)\s+version[^;]*/1/;
+
+    # create test file
+    my $temp = File::Temp->new;
+    print {$temp} _pl_template( $string, $sigil, $var );
+    close $temp;
+
+    # detaint...
+    undef $ENV{PATH};
+    my $perl = $^X;
+    $perl = $1 if $perl =~ m{^(.+)}s;
+
+    my $rc;
+    my $result;
+    my $err = gensym;
+    my $pid = open3(my $in, my $out, $err, $perl, $temp);
+    my $killer;
+    if ($^O eq 'MSWin32') {
+        $killer = fork;
+        if (!defined $killer) {
+            die "Can't fork: $!";
+        }
+        elsif ($killer == 0) {
+            sleep $timeout;
+            kill 'KILL', $pid;
+            exit 0;
+        }
+    }
+    my $got = eval {
+        local $SIG{ALRM} = sub { die "alarm\n" };
+        alarm $timeout;
+        local $/;
+        $result = readline $out;
+        my $c = waitpid $pid, 0;
+        alarm 0;
+        ( $c != $pid ) || $?;
+    };
+    if ( $@ eq "alarm\n" ) {
+        kill 'KILL', $pid;
+        waitpid $pid, 0;
+        $rc = $?;
+    }
+    else {
+        $rc = $got;
+    }
+    if ($killer) {
+        kill 'KILL', $killer;
+        waitpid $killer, 0;
+    }
+
+    return if $rc || !defined $result; # error condition
+
+##  print STDERR "# C<< $string >> --> $result" if $result =~ /^ERROR/;
+    return if $result =~ /^ERROR/;
+
+    $result =~ s/[\r\n]+\z//;
+
+    # treat '' the same as undef: no version was found
+    undef $result if $result eq '';
+
+    return $result;
+}
+
+sub _pl_template {
+    my ( $string, $sigil, $var ) = @_;
+    return <<"HERE"
+use version;
+use Safe;
+use File::Spec;
+open STDERR, '>', File::Spec->devnull;
+open STDIN, '<', File::Spec->devnull;
+
+my \$comp = Safe->new;
+\$comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
+\$comp->share("*version::new");
+\$comp->share("*version::numify");
+\$comp->share_from('main', ['*version::',
+                            '*Exporter::',
+                            '*DynaLoader::']);
+\$comp->share_from('version', ['&qv']);
+
+my \$code = <<'END';
+    local $sigil$var;
+    \$$var = undef;
+    do {
+        $string
+    };
+    \$$var;
+END
+
+my \$result = \$comp->reval(\$code);
+print "ERROR: \$@\n" if \$@;
+exit unless defined \$result;
+
+eval { \$result = version->parse(\$result)->stringify };
+print \$result;
+
+HERE
+}
+
+1;
+
+=head1 SYNOPSIS
+
+    use Version::Eval qw/eval_version/;
+
+    my $version = eval_version( $unsafe_string );
+
+=head1 DESCRIPTION
+
+Package versions are defined by a string such as this:
+
+    package Foo;
+    our $VERSION = "1.23";
+
+If we want to know the version of a F<.pm> file, we can
+load it and check C<Foo->VERSION> for the package.  But that means any
+buggy or hostile code in F<Foo.pm> gets run.
+
+The safe thing to do is to parse out a string that looks like an assignment
+to C<$VERSION> and then evaluate it.  But even that could be hostile:
+
+    package Foo;
+    our $VERSION = do { my $n; $n++ while 1 }; # infinite loop
+
+This module executes a potential version string in a separate process in
+a L<Safe> compartment with a timeout to avoid as much risk as possible.
+
+Hostile code might still attempt to consume excessive resources, but the
+timeout should limit the problem.
+
+=head1 SEE ALSO
+
+=for :list
+* L<Parse::PMFile>
+* L<V>
+* L<use Module::Info>
+* L<Module::InstalledVersion>
+* L<Module::Version>
+
+=head1 AUTHOR
+
+This logic was written by Graham Knop, <haarg@haarg.org>.
+
+=cut

t/metadata.t

@@ -122,6 +122,11 @@ $Simple::VERSION = 1.23;
 package Simple;
 $Simple2::VERSION = '999';
 $VERSION = 1.23;
+---
+  '1.23' => <<'---', # Differentiate fully qualified $VERSION and unqualified, other order
+package Simple;
+$VERSION = 1.23;
+$Simple2::VERSION = '999';
 ---
   '1.23' => <<'---', # $VERSION declared as package variable from within 'main' package
 $Simple::VERSION = '1.23';