Extends {@link PerlModuleBase} to leverage module initialization and method registration.
+ * + *The bundled {@code File/Spec/Unix.pm} installs {@code canonpath}, {@code catdir} and + * {@code catfile} with {@code *name = \&_pp_name unless defined &name}, so those three keep the + * Java implementations below. Every other sub in that file is defined unconditionally and + * therefore shadows the Java method of the same name once {@code File::Spec} is loaded.
*/ public class FileSpec extends PerlModuleBase { @@ -77,6 +82,33 @@ public static void initialize() { } } + /** + * Wraps a freshly built path in a {@link RuntimeList}, carrying over the taint of every + * path component the caller supplied. + * + *The Perl originals of these methods build their answer with {@code join}, {@code s///} + * and string concatenation, all of which propagate taint, so a tainted component must taint + * the result here too. Only the caller's arguments are considered: none of these methods + * consults the operating system, so none of them introduces taint of its own. The invocant + * in {@code args[0]} is a class name or object and is never part of the result.
+ * + * @param result The path value produced by the Java implementation. + * @param args The full argument array, including the invocant at index 0. + * @return A {@link RuntimeList} holding the possibly tainted result. + */ + private static RuntimeList withArgumentTaint(RuntimeScalar result, RuntimeArray args) { + int count = args.size() - 1; + if (count <= 0) { + return result.getList(); + } + RuntimeScalar[] inputs = new RuntimeScalar[count]; + for (int i = 0; i < count; i++) { + inputs[i] = args.get(i + 1); + } + // propagateTaint() may hand back a different scalar, so use its return value. + return result.propagateTaint(inputs).getList(); + } + /** * Converts a path to a canonical form, removing redundant separators and up-level references. * @@ -92,9 +124,9 @@ public static RuntimeList canonpath(RuntimeArray args, int ctx) { // Empty string stays empty (Perl 5 behavior) if (path.isEmpty()) { - return new RuntimeScalar("").getList(); + return withArgumentTaint(new RuntimeScalar(""), args); } - + // These Java methods are installed in File::Spec::Unix. Platform // subclasses (including File::Spec::Win32) override them in Perl, so // their behavior must remain Unix-specific even on a Windows host. @@ -113,8 +145,8 @@ public static RuntimeList canonpath(RuntimeArray args, int ctx) { if (canonPath.isEmpty()) { canonPath = "."; } - - return new RuntimeScalar(canonPath).getList(); + + return withArgumentTaint(new RuntimeScalar(canonPath), args); } /** @@ -176,7 +208,10 @@ public static RuntimeList catdir(RuntimeArray args, int ctx) { RuntimeArray canonArgs = new RuntimeArray(); canonArgs.push(new RuntimeScalar("dummy")); canonArgs.push(new RuntimeScalar(result.toString())); - return canonpath(canonArgs, ctx); + String canonical = canonpath(canonArgs, ctx).elements.get(0).toString(); + // The intermediate scalars above are clean, so the taint of the caller's + // components has to be re-applied to the final answer. + return withArgumentTaint(new RuntimeScalar(canonical), args); } /** @@ -193,7 +228,7 @@ public static RuntimeList catfile(RuntimeArray args, int ctx) { if (args.size() == 2) { return canonpath(args, ctx); } - return new RuntimeScalar("").getList(); + return withArgumentTaint(new RuntimeScalar(""), args); } // Last real arg is the file component; everything before is directories @@ -219,17 +254,19 @@ public static RuntimeList catfile(RuntimeArray args, int ctx) { String filePart = canonpath(fileCanonArgs, ctx).elements.get(0).toString(); // Combine: if dir is empty, just return the file + // The catdir/canonpath calls above ran on clean copies, so the caller's + // taint is re-applied to whichever combination is returned. if (dir.isEmpty()) { - return new RuntimeScalar(filePart).getList(); + return withArgumentTaint(new RuntimeScalar(filePart), args); } - + // Ensure proper separator between dir and file String separator = "/"; char lastChar = dir.charAt(dir.length() - 1); if (lastChar == '/' || lastChar == '\\') { - return new RuntimeScalar(dir + filePart).getList(); + return withArgumentTaint(new RuntimeScalar(dir + filePart), args); } - return new RuntimeScalar(dir + separator + filePart).getList(); + return withArgumentTaint(new RuntimeScalar(dir + separator + filePart), args); } /** diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index ee0625a5be..9858bc7562 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -62,6 +62,8 @@ public static void initialize() { internals.registerMethod("stack_refcounted", null); internals.registerMethod("V", "V", null); internals.registerMethod("getcwd", "getcwd", null); + internals.registerMethod("logical_cwd", "logical_cwd", null); + internals.registerMethod("taint_propagate", "taintPropagate", "@"); internals.registerMethod("abs_path", "abs_path", ";$"); // PerlOnJava-only probe: report whether a fully qualified sub // name was installed via typeglob assignment (e.g. Exporter @@ -900,12 +902,116 @@ public static RuntimeList isInitializedStateVariable(RuntimeArray args, int ctx) * This provides a native Java implementation that works on all platforms, * which Cwd.pm will use instead of shell-based fallbacks. * + *This is the physical current directory: {@code chdir} + * canonicalizes the target, so symlinks such as macOS {@code /tmp -> + * /private/tmp} are already resolved. Cwd.pm aliases {@code getcwd} and + * {@code fastcwd} to this method; the logical forms {@code cwd} and + * {@code fastgetcwd} use {@link #logical_cwd} instead. + * + *
The path comes from the operating system, so it is tainted under + * {@code -T} exactly like {@code Cwd::getcwd} in standard Perl. + * * @param args Unused arguments * @param ctx The context in which the method is called * @return RuntimeScalar with the current working directory path */ public static RuntimeList getcwd(RuntimeArray args, int ctx) { - return new RuntimeScalar(RuntimeEnvironment.currentDirectory()).getList(); + return new RuntimeScalar(RuntimeEnvironment.currentDirectory()) + .taintFromExternalInput() + .getList(); + } + + /** + * Returns the logical current working directory, the value that + * {@code Cwd::cwd} and {@code Cwd::fastgetcwd} return in standard Perl. + * + *
On Unix-like systems those two functions shell out to {@code /bin/pwd}, + * which runs in its default logical mode: it reports {@code $ENV{PWD}} when + * that variable can be trusted and otherwise falls back to the + * {@code getcwd(3)} answer. So after {@code cd /tmp} on macOS, + * {@code cwd()} yields {@code /tmp} while {@code getcwd()} yields + * {@code /private/tmp}. + * + *
{@code $ENV{PWD}} is never trusted blindly — a stale value left behind + * by a plain {@code chdir}, or a hostile one, must not make {@code cwd()} + * lie. It is accepted only when it is an absolute path that names the very + * same directory as {@code .}, which is decided by + * {@link java.nio.file.Files#isSameFile} (a device+inode comparison on + * Unix, the same test {@code pwd} performs). Anything else — unset, empty, + * relative, nonexistent, or a different directory — falls back to the + * physical path. + * + *
Like {@link #getcwd}, the result describes the operating system's idea + * of the current directory and is therefore tainted under {@code -T}. + * + * @param args Unused arguments + * @param ctx The context in which the method is called + * @return RuntimeScalar with the logical current working directory path + */ + public static RuntimeList logical_cwd(RuntimeArray args, int ctx) { + String physical = RuntimeEnvironment.currentDirectory(); + String logical = trustedEnvPwd(physical); + return new RuntimeScalar(logical != null ? logical : physical) + .taintFromExternalInput() + .getList(); + } + + /** + * Returns a copy of a computed value with taint propagated from the supplied + * source values. Bundled Perl modules use this at platform boundaries where + * a path is assembled in Perl but the individual string operations have not + * retained the source scalar's taint metadata. + * + * @param args the computed value followed by zero or more taint sources + * @param ctx the calling context + * @return the computed value, with taint from any source preserved + */ + public static RuntimeList taintPropagate(RuntimeArray args, int ctx) { + if (args.size() == 0) { + return new RuntimeScalar().getList(); + } + RuntimeScalar result = new RuntimeScalar(args.get(0)); + for (int i = 1; i < args.size(); i++) { + result = result.propagateTaint(args.get(i)); + } + return result.getList(); + } + + /** + * Returns {@code $ENV{PWD}} when it can stand in for the physical current + * directory, or {@code null} when it cannot be trusted. + * + * @param physical the physical current directory + * @return the trusted logical path, or {@code null} + */ + private static String trustedEnvPwd(String physical) { + RuntimeScalar pwd = GlobalVariable.getGlobalHash("main::ENV").get("PWD"); + if (pwd == null || !pwd.getDefinedBoolean()) { + return null; + } + String candidate = pwd.toString(); + // An empty or relative PWD is meaningless as an absolute answer, and a + // path with a NUL byte cannot reach the file system at all. + if (candidate.isEmpty() || candidate.indexOf('\0') >= 0) { + return null; + } + try { + java.nio.file.Path candidatePath = java.nio.file.Paths.get(candidate); + if (!candidatePath.isAbsolute()) { + return null; + } + // Same directory? On Unix this compares device and inode numbers, + // so any symlinked alias of the current directory is accepted and + // any stale or hostile value is rejected. + if (java.nio.file.Files.isSameFile(candidatePath, java.nio.file.Paths.get(physical))) { + return candidate; + } + } catch (java.io.IOException | RuntimeException e) { + // Nonexistent path, unreadable parent, or an unparseable name: + // treat PWD as untrustworthy and use the physical path. + return null; + } + return null; } /** @@ -913,6 +1019,11 @@ public static RuntimeList getcwd(RuntimeArray args, int ctx) { * This provides a reliable, platform-independent way to get absolute paths, * which Cwd.pm will use instead of Perl-based implementations. * + *
Like the XS {@code Cwd::abs_path}, the resolved path is derived from + * the file system, so it is tainted under {@code -T} regardless of whether + * the argument was tainted. Cwd.pm aliases + * abs_path/realpath/fast_abs_path/fast_realpath to this method. + * * @param args The path to resolve (first argument), or "." if not provided * @param ctx The context in which the method is called * @return RuntimeScalar with the absolute path, or undef if the path doesn't exist @@ -925,7 +1036,11 @@ public static RuntimeList abs_path(RuntimeArray args, int ctx) { // produced bare "-I" flags and broke Inline's config subprocess. if (path.startsWith("jar:")) { if (Jar.isJarDirectory(path) || Jar.exists(path)) { - return new RuntimeScalar(path).getList(); + // The embedded library path is echoed back unchanged; it carries + // no operating-system data of its own, so only the caller's taint + // is propagated. Inline uses these paths to build -I flags. + RuntimeScalar jarPath = new RuntimeScalar(path); + return (args.size() > 0 ? jarPath.propagateTaint(args.get(0)) : jarPath).getList(); } return new RuntimeScalar().getList(); } @@ -937,7 +1052,9 @@ public static RuntimeList abs_path(RuntimeArray args, int ctx) { if (!file.exists()) { return new RuntimeScalar().getList(); // return undef } - return new RuntimeScalar(file.getCanonicalPath()).getList(); + return new RuntimeScalar(file.getCanonicalPath()) + .taintFromExternalInput() + .getList(); } catch (java.io.IOException e) { return new RuntimeScalar().getList(); // return undef on error } diff --git a/src/main/perl/lib/Cwd.pm b/src/main/perl/lib/Cwd.pm index adec24caed..9367bd4673 100644 --- a/src/main/perl/lib/Cwd.pm +++ b/src/main/perl/lib/Cwd.pm @@ -76,18 +76,49 @@ sub _vms_efs { } -# PerlOnJava provides Internals::getcwd/abs_path which work on all platforms. -# Check early to prevent XSLoader from being loaded (which would fail). These -# aliases intentionally replace the pure-Perl definitions compiled below, so -# keep them quiet even when a caller has dynamically enabled global warnings. +# PerlOnJava provides Internals::getcwd/logical_cwd/abs_path, which work on all +# platforms. Check early to prevent XSLoader from being loaded (which would +# fail). These aliases intentionally replace the pure-Perl definitions compiled +# below, so keep them quiet even when a caller has dynamically enabled global +# warnings. +# +# Internals::getcwd is the PHYSICAL path (symlinks resolved), matching the +# getcwd(3) syscall used by the XS Cwd::getcwd. +# Internals::logical_cwd is the LOGICAL path: a validated $ENV{PWD} if it names +# the current directory, otherwise the physical path. +# This is what `pwd` reports, which is how standard Perl +# implements cwd() on Unix (see _backtick_pwd below). +# +# Which name gets which form is platform-dependent in standard Perl, so follow +# its %METHOD_MAP table below: +# * Unix-like (darwin, linux, *bsd, solaris, ...): cwd() and fastgetcwd() are +# _backtick_pwd (logical); getcwd() is XS and fastcwd() walks up with +# chdir('..') -- both physical. +# * MSWin32/NT/dos/os2/VMS/qnx: all four names are aliases for one +# platform-specific function, so there is no logical/physical split. +# * cygwin/amigaos: all four names resolve to _backtick_pwd, i.e. all logical. { no warnings qw(redefine prototype); local $^W = 0; if (eval { Internals::getcwd(); 1 }) { - *getcwd = \&Internals::getcwd; - *cwd = sub { Internals::getcwd() }; - *fastcwd = \&cwd; - *fastgetcwd = \&cwd; + my $physical = \&Internals::getcwd; + my $logical = defined &Internals::logical_cwd + ? \&Internals::logical_cwd + : $physical; + + if ($^O =~ /\A(?:MSWin32|NT|dos|os2|VMS|qnx)\z/) { + # No logical form on these platforms. + $logical = $physical; + } + elsif ($^O eq 'cygwin' or $^O eq 'amigaos') { + # Everything goes through `pwd` on these platforms. + $physical = $logical; + } + + *getcwd = $physical; + *fastcwd = $physical; + *cwd = $logical; + *fastgetcwd = $logical; } if (eval { Internals::abs_path('.'); 1 }) { *abs_path = \&Internals::abs_path; diff --git a/src/main/perl/lib/File/Spec/Win32.pm b/src/main/perl/lib/File/Spec/Win32.pm index 3964b01dd2..2d072cf2c0 100644 --- a/src/main/perl/lib/File/Spec/Win32.pm +++ b/src/main/perl/lib/File/Spec/Win32.pm @@ -15,6 +15,15 @@ my $DRIVE_RX = '[a-zA-Z]:'; my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; +# The Java-backed File::Spec::Unix methods retain taint explicitly. Win32 +# overrides several of them in Perl, where the intermediate regex and string +# operations can otherwise lose a caller's taint metadata. Preserve it at the +# public method boundary, matching native Perl's path operations. +sub _taint_result { + my ($result, @sources) = @_; + return Internals::taint_propagate($result, @sources); +} + =head1 NAME @@ -133,42 +142,46 @@ complete path ending with a filename sub catfile { shift; + my @sources = @_; # Legacy / compatibility support # - shift, return _canon_cat( "/", @_ ) + shift, return _taint_result(_canon_cat( "/", @_ ), @sources) if !@_ || $_[0] eq ""; # Compatibility with File::Spec <= 3.26: # catfile('A:', 'foo') should return 'A:\foo'. - return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + return _taint_result(_canon_cat( ($_[0].'\\'), @_[1..$#_] ), @sources) if $_[0] =~ m{^$DRIVE_RX\z}o; - return _canon_cat( @_ ); + return _taint_result(_canon_cat( @_ ), @sources); } sub catdir { shift; + my @sources = @_; # Legacy / compatibility support # - return "" + return _taint_result("") unless @_; - shift, return _canon_cat( "/", @_ ) + shift, return _taint_result(_canon_cat( "/", @_ ), @sources) if $_[0] eq ""; # Compatibility with File::Spec <= 3.26: # catdir('A:', 'foo') should return 'A:\foo'. - return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + return _taint_result(_canon_cat( ($_[0].'\\'), @_[1..$#_] ), @sources) if $_[0] =~ m{^$DRIVE_RX\z}o; - return _canon_cat( @_ ); + return _taint_result(_canon_cat( @_ ), @sources); } sub path { - my @path = split(';', $ENV{PATH}); + my $env_path = $ENV{PATH}; + my @path = split(';', $env_path); s/"//g for @path; @path = grep length, @path; + @path = map { _taint_result($_, $env_path) } @path; unshift(@path, "."); return @path; } @@ -187,8 +200,8 @@ On Win32 makes sub canonpath { # Legacy / compatibility support # - return $_[1] if !defined($_[1]) or $_[1] eq ''; - return _canon_cat( $_[1] ); + return _taint_result($_[1], $_[1]) if !defined($_[1]) or $_[1] eq ''; + return _taint_result(_canon_cat( $_[1] ), $_[1]); } =item splitpath @@ -218,7 +231,9 @@ sub splitpath { $path =~ m{^ ( $VOL_RX ? ) (.*) }sox; $volume = $1; - $directory = $2; + # Unlike the capture-derived fields, the no-file directory is the + # caller's path itself and must retain its taint. + $directory = _taint_result($2, $path); } else { $path =~ @@ -234,6 +249,12 @@ sub splitpath { return ($volume,$directory,$file); } +sub join { + shift; + my @sources = @_; + return _taint_result(_canon_cat(@_), @sources); +} + =item splitdir @@ -289,6 +310,7 @@ the $volume become significant. sub catpath { my ($self,$volume,$directory,$file) = @_; + my @sources = ($volume, $directory, $file); # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume @@ -313,7 +335,7 @@ sub catpath { $volume .= $file ; - return $volume ; + return _taint_result($volume, @sources); } sub _same { @@ -326,12 +348,12 @@ sub rel2abs { my $is_abs = $self->file_name_is_absolute($path); # Check for volume (should probably document the '2' thing...) - return $self->canonpath( $path ) if $is_abs == 2; + return _taint_result($self->canonpath( $path ), $path, $base) if $is_abs == 2; if ($is_abs) { # It's missing a volume, add one my $vol = ($self->splitpath( Cwd::getcwd() ))[0]; - return $self->canonpath( $vol . $path ); + return _taint_result($self->canonpath( $vol . $path ), $path, $vol); } if ( !defined( $base ) || $base eq '' ) { @@ -357,7 +379,13 @@ sub rel2abs { $path_file ) ; - return $self->canonpath( $path ) ; + return _taint_result($self->canonpath( $path ), $path, $base); +} + +sub abs2rel { + my ($self, $path, $base) = @_; + my $result = File::Spec::Unix::abs2rel(@_); + return _taint_result($result, $path, $base); } =back diff --git a/src/test/resources/unit/cwd_logical_physical.t b/src/test/resources/unit/cwd_logical_physical.t new file mode 100644 index 0000000000..6de983327d --- /dev/null +++ b/src/test/resources/unit/cwd_logical_physical.t @@ -0,0 +1,95 @@ +use strict; +use warnings; +use Test::More; +use Cwd (); +use File::Temp qw(tempdir); + +# Standard Perl's Cwd distinguishes the LOGICAL current directory from the +# PHYSICAL one on Unix-like systems: +# +# cwd() logical - `pwd`, which reports a trusted $ENV{PWD} +# fastgetcwd() logical - a synonym for cwd() +# getcwd() physical - getcwd(3), symlinks resolved +# fastcwd() physical - walks up with chdir('..') +# +# PerlOnJava used to alias all four to one physical builtin. Verified against +# system perl v5.42 on darwin before being used to drive the fix. +# +# On the platforms where standard Perl aliases all four names to a single +# platform function there is nothing to distinguish, so only run the split +# assertions elsewhere. +my $HAS_SPLIT = $^O !~ /\A(?:MSWin32|NT|dos|os2|VMS|qnx|cygwin|amigaos)\z/; + +my $tmp = tempdir(CLEANUP => 1); + +# Build our own symlink instead of relying on the test runner's cwd (or on +# /tmp happening to be a symlink, which is true on darwin but not on Linux). +my $real = "$tmp/real"; +my $link = "$tmp/link"; +mkdir $real or die "mkdir $real: $!"; +if (!symlink($real, $link)) { + plan skip_all => "symlinks unavailable: $!"; +} + +my $physical = Cwd::abs_path($real); +plan skip_all => "cannot resolve $real" unless defined $physical && length $physical; + +# abs_path() of the symlink must agree: this is the physical answer. +is(Cwd::abs_path($link), $physical, 'abs_path resolves the symlink'); + +my $origin = Cwd::getcwd(); +chdir $link or plan skip_all => "cannot chdir to $link: $!"; + +# getcwd()/fastcwd() are physical no matter what the environment claims. +{ + local $ENV{PWD} = $link; + is(Cwd::getcwd(), $physical, 'getcwd() is physical'); + is(Cwd::fastcwd(), $physical, 'fastcwd() is physical'); + + if ($HAS_SPLIT) { + is(Cwd::cwd(), $link, 'cwd() honours a valid $ENV{PWD} (logical)'); + is(Cwd::fastgetcwd(), $link, 'fastgetcwd() honours a valid $ENV{PWD}'); + } + else { + is(Cwd::cwd(), $physical, 'cwd() is physical on this platform'); + is(Cwd::fastgetcwd(), $physical, 'fastgetcwd() is physical on this platform'); + } +} + +# A $ENV{PWD} that does not name the current directory must never be trusted: +# cwd() falls back to the physical path. This is what keeps a stale value left +# behind by a plain chdir, or a hostile one, from making cwd() lie. +my %untrusted = ( + 'a stale but existing directory' => $tmp, + 'a nonexistent path' => "$tmp/no-such-directory", + 'a relative path' => 'link', + 'an empty string' => '', +); +for my $why (sort keys %untrusted) { + local $ENV{PWD} = $untrusted{$why}; + is(Cwd::cwd(), $physical, "cwd() ignores $why"); + is(Cwd::fastgetcwd(), $physical, "fastgetcwd() ignores $why"); +} + +# With PWD absent there is no logical answer at all. +{ + my $saved = delete $ENV{PWD}; + is(Cwd::cwd(), $physical, 'cwd() falls back to the physical path with no $ENV{PWD}'); + is(Cwd::fastgetcwd(), $physical, 'fastgetcwd() falls back with no $ENV{PWD}'); + $ENV{PWD} = $saved if defined $saved; +} + +# Any symlinked alias of the current directory is a legitimate logical answer, +# because the trust test compares the directories themselves (device+inode), +# not the spelling of the path. +if ($HAS_SPLIT) { + my $alias = "$tmp/alias"; + if (symlink($real, $alias)) { + local $ENV{PWD} = $alias; + is(Cwd::cwd(), $alias, 'cwd() accepts a different symlink to the same directory'); + } +} + +chdir $origin or die "cannot chdir back to $origin: $!"; + +done_testing; diff --git a/src/test/resources/unit/taint_cwd.t b/src/test/resources/unit/taint_cwd.t new file mode 100644 index 0000000000..7147d70fef --- /dev/null +++ b/src/test/resources/unit/taint_cwd.t @@ -0,0 +1,49 @@ +#!perl -T +use strict; +use warnings; +use Cwd (); +use Scalar::Util qw(tainted); +use Test::More; + +# The current working directory is operating-system data, so standard Perl +# taints every Cwd entry point under -T. Verified against system perl before +# being used to drive the PerlOnJava fix (GitHub issue #1125). +for my $name (qw(getcwd cwd fastcwd fastgetcwd)) { + my $code = Cwd->can($name); + ok($code, "Cwd::$name is available"); + my $value = $code->(); + ok(defined $value && length $value, "Cwd::$name returns a path"); + ok(tainted($value), "Cwd::$name is tainted under -T"); +} + +for my $name (qw(abs_path realpath fast_abs_path fast_realpath)) { + my $code = Cwd->can($name); + ok($code, "Cwd::$name is available"); + my $value = $code->('.'); + ok(defined $value && length $value, "Cwd::$name('.') returns a path"); + ok(tainted($value), "Cwd::$name('.') is tainted under -T"); +} + +# A clean literal argument does not produce a clean result: abs_path resolves +# the path against the file system, so the answer is OS-derived either way. +ok(tainted(Cwd::abs_path('/')), "abs_path('/') is tainted for a clean argument"); + +# Data::Compare guards plugin discovery with +# "register_plugins() unless tainted(getcwd()) || !chdir $cwd", so copies and +# derived strings must keep the taint too. +my $copy = Cwd::getcwd(); +ok(tainted($copy), 'a copy of getcwd() stays tainted'); +ok(tainted("$copy/sub"), 'interpolating getcwd() propagates taint'); + +# The tainted directory cannot reach chdir without being laundered first. +my $chdir_ok = eval { chdir Cwd::getcwd(); 1 }; +ok(!$chdir_ok, 'chdir rejects the tainted getcwd() value'); +like($@, qr/^Insecure dependency in chdir while running with -T switch/, + 'chdir reports the Perl security error for a tainted directory'); + +# Laundering through a regexp match restores a usable value. +my ($laundered) = Cwd::getcwd() =~ /\A(.*)\z/s; +ok(!tainted($laundered), 'a laundered copy of getcwd() is clean'); +ok(chdir($laundered), 'the laundered directory can be used with chdir'); + +done_testing; diff --git a/src/test/resources/unit/taint_filespec.t b/src/test/resources/unit/taint_filespec.t new file mode 100644 index 0000000000..a92f361d2e --- /dev/null +++ b/src/test/resources/unit/taint_filespec.t @@ -0,0 +1,150 @@ +#!perl -T +use strict; +use warnings; +use File::Spec (); +use Scalar::Util qw(tainted); +use Test::More; + +# File::Spec derives its answers from its arguments and, for the methods that +# need a base directory, from Cwd::getcwd(). The current directory is +# operating-system data, so standard Perl taints exactly those results and +# leaves the purely lexical path manipulations clean. Every expectation below +# was recorded from system perl 5.42 under -T before being used to drive the +# PerlOnJava fix; keep them in sync with real perl, not with PerlOnJava. + +# A tainted string to feed through the path-manipulation methods. +my $dirty = $ENV{PATH}; +ok(tainted($dirty), '$ENV{PATH} is tainted under -T'); + +# A top-level name that will not collide with a real component of the +# directory the test happens to run in, so the abs2rel expectations below stay +# independent of the checkout location. +my $abs = '/zzz_taint_probe/leaf'; + +# --------------------------------------------------------------------------- +# rel2abs: taints exactly when the current directory has to be consulted. +# --------------------------------------------------------------------------- +ok(tainted(File::Spec->rel2abs('x')), + "rel2abs('x') is tainted: the missing base comes from getcwd()"); +ok(!tainted(File::Spec->rel2abs($abs)), + 'rel2abs() of an absolute path is clean: no base is needed'); +ok(!tainted(File::Spec->rel2abs('x', '/base')), + 'rel2abs() with an absolute base is clean'); +ok(!tainted(File::Spec->rel2abs($abs, '/base')), + 'rel2abs() with an absolute path and base is clean'); +ok(tainted(File::Spec->rel2abs('x', 'rel_base')), + 'rel2abs() with a relative base is tainted: the base is resolved via getcwd()'); +ok(tainted(File::Spec->rel2abs('x', '')), + "rel2abs() with an empty base falls back to getcwd() and is tainted"); +ok(tainted(File::Spec->rel2abs('.')), + "rel2abs('.') is tainted"); + +# --------------------------------------------------------------------------- +# abs2rel: the getcwd()-derived components cancel out against each other, so +# only a relative *path* argument leaves operating-system data in the answer. +# --------------------------------------------------------------------------- +ok(!tainted(File::Spec->abs2rel($abs)), + 'abs2rel() of an absolute path is clean even though the base is getcwd()'); +ok(tainted(File::Spec->abs2rel('x')), + 'abs2rel() of a relative path is tainted: the path is resolved via getcwd()'); +ok(!tainted(File::Spec->abs2rel($abs, '/base')), + 'abs2rel() with an absolute path and base is clean'); +ok(tainted(File::Spec->abs2rel('x', '/base')), + 'abs2rel() of a relative path against an absolute base is tainted'); +ok(!tainted(File::Spec->abs2rel($abs, 'rel_base')), + 'abs2rel() with a relative base is clean: the base taint cancels out'); +ok(!tainted(File::Spec->abs2rel('/a/b', '/a/b')), + 'abs2rel() of equal paths returns a clean curdir'); + +# --------------------------------------------------------------------------- +# Constants and lexical manipulations: never tainted for clean inputs. +# --------------------------------------------------------------------------- +ok(!tainted(File::Spec->curdir), 'curdir is clean'); +ok(!tainted(File::Spec->updir), 'updir is clean'); +ok(!tainted(File::Spec->rootdir), 'rootdir is clean'); +ok(!tainted(File::Spec->devnull), 'devnull is clean'); +ok(!tainted(File::Spec->case_tolerant), 'case_tolerant is clean'); +ok(!tainted(File::Spec->canonpath('a/./b')), 'canonpath() of a clean path is clean'); +ok(!tainted(File::Spec->canonpath('')), 'canonpath() of the empty string is clean'); +ok(!tainted(File::Spec->catfile('a', 'b')), 'catfile() of clean parts is clean'); +ok(!tainted(File::Spec->catdir('a', 'b')), 'catdir() of clean parts is clean'); +ok(!tainted(File::Spec->catdir()), 'catdir() with no arguments is clean'); +ok(!tainted(File::Spec->join('a', 'b')), 'join() of clean parts is clean'); +ok(!tainted(File::Spec->catpath('', 'a/b', 'c')), 'catpath() of clean parts is clean'); +ok(!tainted(File::Spec->file_name_is_absolute('/x')), + 'file_name_is_absolute() returns a clean boolean for a clean path'); +ok(!tainted(File::Spec->file_name_is_absolute($dirty)), + 'file_name_is_absolute() returns a clean boolean even for a tainted path'); +ok(!tainted((File::Spec->no_upwards('a', '..'))[0]), 'no_upwards() keeps clean names clean'); +ok(!tainted($_), 'splitpath() of a clean path is clean') for File::Spec->splitpath('/a/b/c'); +ok(!tainted($_), 'splitdir() of a clean path is clean') for File::Spec->splitdir('/a/b/c'); + +# tmpdir consults %ENV, but File::Spec::Unix::_tmpdir discards every tainted +# candidate under -T and falls back to the hard-coded directory, so the result +# is clean. Over-tainting it would break callers that open temporary files. +my $tmpdir = File::Spec->tmpdir; +ok(defined $tmpdir && length $tmpdir, 'tmpdir returns a path'); +ok(!tainted($tmpdir), 'tmpdir is clean under -T: tainted %ENV candidates are dropped'); + +# path() is the one method that hands back %ENV data verbatim. Win32 adds a +# clean literal "." ahead of the environment-derived entries, so check its +# first PATH entry rather than assuming index zero is from %ENV. +my @path = File::Spec->path(); +SKIP: { + if ($^O eq 'MSWin32') { + skip 'no PATH entry after Win32 curdir', 2 unless @path > 1; + ok(!tainted($path[0]), 'Win32 path() prepends a clean curdir'); + ok(tainted($path[1]), 'Win32 path() keeps PATH-derived entries tainted'); + } + else { + skip 'no PATH entries to check', 1 unless @path; + ok(tainted($path[0]), 'path() returns tainted entries: it splits $ENV{PATH}'); + } +} + +# --------------------------------------------------------------------------- +# Taint propagation from the caller's arguments. +# --------------------------------------------------------------------------- +ok(tainted(File::Spec->canonpath($dirty)), 'canonpath() propagates argument taint'); +ok(tainted(File::Spec->catfile($dirty, 'x')), 'catfile() propagates taint from a directory'); +ok(tainted(File::Spec->catfile('x', $dirty)), 'catfile() propagates taint from the file'); +ok(tainted(File::Spec->catdir($dirty, 'x')), 'catdir() propagates argument taint'); +ok(tainted(File::Spec->join($dirty, 'x')), 'join() propagates argument taint'); +ok(tainted(File::Spec->rel2abs($dirty, '/base')), 'rel2abs() propagates path taint'); +ok(tainted(File::Spec->rel2abs('x', $dirty)), 'rel2abs() propagates base taint'); +ok(tainted(File::Spec->abs2rel($dirty, '/base')), 'abs2rel() propagates path taint'); +ok(tainted(File::Spec->catpath('', $dirty, 'c')), 'catpath() propagates directory taint'); +ok(tainted((File::Spec->no_upwards($dirty))[0]), 'no_upwards() passes tainted names through'); +ok(tainted($_), 'splitdir() propagates argument taint') for File::Spec->splitdir($dirty); + +# splitpath() extracts its fields with a regexp match, and captures launder +# taint unless "use re 'taint'" is in effect, so the pieces come back clean. +ok(!tainted($_), 'splitpath() launders taint through its captures') + for File::Spec->splitpath($dirty); + +# With $no_file the directory field is the argument itself, not a capture. +{ + my ($volume, $directory, $file) = File::Spec->splitpath($dirty, 1); + ok(!tainted($volume), 'splitpath($path, 1) returns a clean volume'); + ok(tainted($directory), 'splitpath($path, 1) hands back the tainted path as the directory'); + ok(!tainted($file), 'splitpath($path, 1) returns a clean file'); +} + +SKIP: { + skip 'volume is significant outside Unix', 1 if $^O eq 'MSWin32'; + ok(!tainted(File::Spec->catpath($dirty, 'a', 'b')), + 'catpath() ignores the volume on Unix, so its taint does not reach the result'); +} + +# A getcwd()-derived path cannot reach an operation that touches the file +# system without being laundered first. +my $chdir_ok = eval { chdir File::Spec->rel2abs('.'); 1 }; +ok(!$chdir_ok, "chdir rejects the tainted rel2abs('.') value"); +like($@, qr/^Insecure dependency in chdir while running with -T switch/, + 'chdir reports the Perl security error for a tainted directory'); + +my ($laundered) = File::Spec->rel2abs('.') =~ /\A(.*)\z/s; +ok(!tainted($laundered), 'a laundered rel2abs() result is clean'); +ok(chdir($laundered), 'the laundered directory can be used with chdir'); + +done_testing;