diff --git a/Changes b/Changes index f9bc029..494bffe 100644 --- a/Changes +++ b/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) diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm index 191fc41..1fb2e76 100644 --- a/lib/Module/Metadata.pm +++ b/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,12 +592,8 @@ 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 @@ -603,30 +601,30 @@ sub _parse_fh { 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 $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 diff --git a/lib/Module/Metadata/ExtractVersion.pm b/lib/Module/Metadata/ExtractVersion.pm new file mode 100644 index 0000000..d739099 --- /dev/null +++ b/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 compartment in a +separate process. The extracted string is returned; it is B 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 CVERSION> for the package. But that means any +buggy or hostile code in F 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 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 +* L +* L +* L +* L + +=head1 AUTHOR + +This logic was written by Graham Knop, . + +=cut diff --git a/t/metadata.t b/t/metadata.t index 5985f0d..6dd523e 100644 --- a/t/metadata.t +++ b/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';