my ($owner) = grep s%^.*/(.*)$%$1%,
  $ct->argv(qw(des -fmt "%[owner]p"), "vob:$vob")->qx;

# snip

system('/usr/bin/ssh', '-l', $owner, $host, $binct, @op, @lbtype);
[download]

You're passing user input ($owner) directly into system() which is bad. See perldoc perlsec about Laundering-and-Detecting-Tainted-Data. You may also need to clean up %ENV as well.

Update: Sorry, I thought the culprit was $owner but your regex should clean that one. In any case, I suspect that you've got an arg that's tainted. You can easily test a variable for taintedness with tainted EXPR in Scalar::Util

Thanks for the links.
I get the point... Yes the @op may contain spaces and parentheses... I'll read in detail what to do to retain them. I have cleaned up only $ENV{PATH}... Anything else there that must be looked at?

Marc

Anything which gets its data from outside the program, whether it's in the environment, on the command line, or through system calls needs to be cleaned before it's used to make a system call.

As many people have pointed out already, one of your arguments to system is tainted. Unfortunately, Perl doesn't tell you which one. You could walk though your code to try and figure it out, but since we're programming in Perl, laziness is a virtue, and there are modules to check this for you automatically.

If you have a recent version of IPC::System::Simple then if called it tainted arguments it will tell you which ones are tainted. That means your code changes to:

use IPC::System::Simple qw(system);

system('/usr/bin/ssh', '-l', $owner, $host, $binct, @op, @lbtype);
[download]

IPC::System::Simple will also throw a detailed exception if your ssh command doesn't run, is killed by a signal, or returns a non-zero exit value (although you can change that if you wish, see the docs).

If you're using autodie and have IPC::System::Simple installed, then you can do the same thing with lexical scope (ie, just for that block):

{
    use autodie qw(system);
    system('/usr/bin/ssh', '-l', $owner, $host, $binct, @op, @lbtype);
}
[download]

IPC::System::Simple is pure Perl with no dependencies and works on 5.6.0 and above. autodie is pure Perl, has IPC::System::Simple as an optional dependency, and works on 5.8.0 or above.

Disclaimer: I wrote all the modules mentioned in this post, so I obviously think they're great. ;)

Best regards,

Hi,

Warm thanks to all who replied...

1. I was not expecting to reach ClearCase users, so that I showed the whole code merely in an attempt to show that I had a real context, and a good reason for not providing a reproducible case.
2. Under the debugger, and using Scalar::Util::tainted, I could indeed find that the culprit is $owner... (despite my regexp processing, and some further more drastic, which failed so far).
3. I did install and start to use IPC::System::Simple and autodie, but so far without success. I add below the updated code, and the transcript.
4. Take this as an intermediate report until I get out of my mess (I of course take any help you might want to give me, but I ought to be able to find my way alone now--I still hope so anyway)
5. I use $me in the usage function.
6. The Name "main::LOG" used only once error goes away if I remove use autodie
7. Actually, use IPC::System::Simple doesn't seem to make any differnce either...
8. Now, I untainted everything and still get the error... See the diffs and the last bit of transcript below...
9. Added back use IPC::System::Simple; and use autodie qw(:system); (i.e. now, explicitly with system), and got something different (and useful). See below, Sep 11 17:43 update.
10. Breakthrough: this worked! The tainted function of Scalar::Util doesn't work well with strings...

Thanks again, especially to Paul for his useful modules!
Marc

#!/vobs/cello/cade_struct/bin/perl -w

use strict;
use Sys::Hostname;
use File::Basename;
use Getopt::Long;
use ClearCase::Argv;
use IPC::System::Simple;
use autodie;
use vars qw($help $unlock $vob @op @nusers @lbtype);

my $me = basename($0);
my $host = hostname;
my $ssh = '/usr/bin/ssh';
my $binct = '/opt/rational/clearcase/bin/cleartool';
my $account = getlogin || getpwuid($<) or die "Couldn't get the uid: $
+!\n";
my $eaccount = getpwuid($>) or die "Couldn't get the euid: $!\n";
my $log = "/home/$eaccount/RANOS_autobuild/builds/logs/lbunlock.log";
$ENV{PATH} = '';
ClearCase::Argv->ipc(1);
my $ct = ClearCase::Argv->new({autochomp=>1});
sub usage() {
  print "Usage: ${me} [[--unlock [| --nusers accounts]] --vob <vob>\n"
    . "  --lbtype <lbtypes> | [--help]]\n"
    . "       By default, lock; use --unlock explicitely.\n"
    . "       Only one vob is accepted, and it is mandatory.\n"
    . "       Multiple label types are possible, either with separate 
+options"
    . "\n        or as one comma separated list.\n"
    . "       All the types must exist in the vob.\n";
  exit 1;
}
my $res = GetOptions("help" => \$help, "unlock" => \$unlock, "vob=s" =
+> \$vob,
             "nusers=s" => \@nusers, "lbtype=s" => \@lbtype);
usage if $help or !($res and $vob and @lbtype) or ($unlock and @nusers
+);
@lbtype = split(/,/, join(',', @lbtype));
my $vob = $ct->argv(qw(des -s), "vob:$vob")->qx;
die "Couldn't find the vob $vob\n" unless $vob;
my $pwnam = (getpwuid($<))[6];
$pwnam =~ s/^ *(.*[^ ]) *$/$1/;
if ($unlock) {
  my @t = localtime;
  my $t = sprintf"%4d%02d%02d.%02d:%02d:%02d",
    (1900+$t[5]),1+$t[4],$t[3],$t[2],$t[1],$t[0];
  open LOG, ">>", "$log" or die "Failed to open the $log log: $!\n";
  print LOG "$t $account $vob @lbtype\n";
  close LOG;
  @op = ('unlock');
} else {
  @op = ('lock', '-c', "'Actual lock author: $account \($pwnam\)'");
  push(@op, '-nusers', join(',', @nusers)) if @nusers;
}
my ($owner) = grep s%^.*/(.*)$%$1%,
  $ct->argv(qw(des -fmt "%[owner]p"), "vob:$vob")->qx;
map { $_ = "lbtype:$_\@$vob" } @lbtype;
foreach my $t (@lbtype) {
  $ct->argv(qw(des -s), $t)->stdout(0)->system
    and die "Label type $t not found in $vob\n";
}
$< = $>;
$owner =~ s/[^-\@\w.]//g;
system($ssh, '-l', $owner, $host, $binct, @op, @lbtype);
map{print"$_\n"}($ssh, '-l', $owner, $host, $binct, @op, @lbtype);
[download]

$ ~eeivob05/bin/locklbtype -vob /vobs/atcctest -l MG -u
Name "main::LOG" used only once: possible typo at /dev/fd/4 line 45.
Insecure dependency in system while running with -T switch at /dev/fd/
+4 line 61, <GEN1> line 5.
[download]

15:21:32 BST update

$ ~eeivob05/bin/locklbtype -vob /vobs/atcctest -l MG -u
Tainted(eaccount): 0, eeivob05
Tainted(log): 0, /home/eeivob05/RANOS_autobuild/builds/logs/lbunlock.l
+og
Tainted(owner): 1, vobadm13
Tainted(uowner): 0, vobadm13
Tainted(op): 0, unlock
Tainted(lbtype): 0, lbtype:MG@/vobs/atcctest
Tainted(ssh): 0, /usr/bin/ssh
Tainted(host): 0, eieatx008
Tainted(binct): 0, /opt/rational/clearcase/bin/cleartool
Insecure dependency in system while running with -T switch at /dev/fd/
+4 line 78, <GEN1> line 5.
$ ct diff -diff -pred locklbtype
8,9c8,9
< use IPC::System::Simple;
< use autodie;
---
> # use IPC::System::Simple;
> use Scalar::Util qw(tainted);
60,62c60,78
< $owner =~ s/[^-\@\w.]//g;
< system($ssh, '-l', $owner, $host, $binct, @op, @lbtype);
< map{print"$_\n"}($ssh, '-l', $owner, $host, $binct, @op, @lbtype);
---
> my @untaintedbits;
> foreach (split //, $owner) {
>   if (/([-\@\w.])/) {
>     push @untaintedbits, $1;
>   }
> }
> my $uowner = join '', @untaintedbits;
> 
> print "Tainted(eaccount): ", tainted($eaccount), ", $eaccount\n";
> print "Tainted(log): ", tainted($log), ", $log\n";
> print "Tainted(owner): ", tainted($owner), ", $owner\n";
> print "Tainted(uowner): ", tainted($uowner), ", $uowner\n";
> print "Tainted(op): ", tainted(@op), ", @op\n";
> print "Tainted(lbtype): ", tainted(@lbtype), ", @lbtype\n";
> print "Tainted(ssh): ", tainted($ssh), ", $ssh\n";
> print "Tainted(host): ", tainted($host), ", $host\n";
> print "Tainted(binct): ", tainted($binct), ", $binct\n";
> # map{print"$_\n"}($ssh, '-l', $owner, $uowner, $host, $binct, @op, 
+@lbtype);
> system($ssh, '-l', $uowner, $host, $binct, @op, @lbtype);
[download]

Sep 11 17:43 update

$ ~eeivob05/bin/locklbtype -vob /vobs/atcctest -l MG -u
Tainted(eaccount): 0, eeivob05
Tainted(log): 0, /home/eeivob05/RANOS_autobuild/builds/logs/lbunlock.l
+og
Tainted(owner): 1, vobadm13
Tainted(uowner): 0, vobadm13
Tainted(op): 0, unlock
Tainted(lbtype): 0, lbtype:MG@/vobs/atcctest
Tainted(ssh): 0, /usr/bin/ssh
Tainted(host): 0, eieatx008
Tainted(binct): 0, /opt/rational/clearcase/bin/cleartool
IPC::System::Simple::run called with tainted argument "lbtype:MG@/vobs
+/atcctest" at (eval 10) line 13
 at /dev/fd/4 line 79
[download]

Sep 11 17:54:59 update

$ ct diff -diff -pred locklbtype
61,64c61,67
< my @untaintedbits;
< foreach (split //, $owner) {
<   if (/([-\@\w.])/) {
<     push @untaintedbits, $1;
---
> sub untaint($) {
>   my $tainted = shift;
>   my @untaintedbits;
>   foreach (split //, $tainted) {
>     if (m%([-\@\w.:/])%) {
>       push @untaintedbits, $1;
>     }
65a69
>   return join '', @untaintedbits;
67c71,72
< my $uowner = join '', @untaintedbits;
---
> my $uowner = untaint($owner);
> map { $_ = untaint($_) } @lbtype;
$ ~eeivob05/bin/locklbtype -vob /vobs/atcctest -l MG -u
Tainted(eaccount): 0, eeivob05
Tainted(log): 0, /home/eeivob05/RANOS_autobuild/builds/logs/lbunlock.l
+og
Tainted(owner): 1, vobadm13
Tainted(uowner): 0, vobadm13
Tainted(op): 0, unlock
Tainted(lbtype): 0, lbtype:MG@/vobs/atcctest
Tainted(ssh): 0, /usr/bin/ssh
Tainted(host): 0, eieatx008
Tainted(binct): 0, /opt/rational/clearcase/bin/cleartool
Unlocked label type "MG".
[download]

You should read the docs on taint mode more carefully.

The part you need is this:

# allow alphanumerics, period, hyphen, ampersand
if ($data =~ /^([-\@\w.]+)$/) { # $data is tainted
    $data = $1;                 # $data now untainted
} else {
  die "Bad data in '$data'";    # log this somewhere
}
[download]

The regex alone will NOT untaint the data - you must copy it through a capture variable, like $1, to untaint it.

Hi,

I did use the basename of $0 in my usage function. This worked fine as long as I was running the script normally.
But as soon as I installed it as suid, the $0 turned to contain something like /dev/fd/4 (i.e. the file descriptor under which perl had opened the script, and which was passed to a child process, running under the new id, I assume).

So, how is a script supposed to know under what name it was invoked, if suid'd?

Is this a specific problem on Solaris?

there is caller and __FILE__

C:\>more temp.pl
#!/usr/bin/perl --
use strict;
use warnings;

my ($package, $filename, $line) = eval { caller };

print "\$0 $0\n";
print "filename $filename\n";
print "__FILE__ ", __FILE__,"\n";

__END__


C:\>perl temp.pl
$0 temp.pl
filename temp.pl
__FILE__ temp.pl

C:\>
[download]