code snippet of DSSAFE.pm

DSSAFE.pm

# ...
@EXPORT = qw(open popen ppopen close system psystem exec backtick pbacktick
             maketemp untaint is_tainted);
# ...
sub __parsecmd {
    my $cmd = shift;
    my @args = quotewords('\s+', 1, $cmd);

    my @env = (); # currently not used. pending review.
    my @xargs = (); # arguments of the command
    my ($xcmd, $fout, $fin, $ferr, $mout, $min, $merr, $rd2);

    while (@args) {
        my $arg = shift @args;
        next if (length($arg) == 0);
        unless (defined $xcmd) {
            if ($arg =~ /^(\w+)=(.+)$/) {
                push @env, {$1 => $2};
                next;
            } elsif ($arg =~ /^[^\/a-zA-Z]/) {
                __log("Invalid command: $cmd"); # must be / or letter
                return undef;
            }
            $xcmd = untaint($arg);
            next;
        }
        if ($arg =~ /^(2|1)>&(2|1)$/) {
            $rd2 = $2;
        } elsif ($arg =~ /^(1|2)?(>>?)([^>].*)?$/) {
            if ($1 and $1 == 2) {
                ($merr, $ferr) = ($2, $3 || untaint(shift @args));
            } else {
                ($mout, $fout) = ($2, $3 || untaint(shift @args));
            }
        } elsif ($arg =~ /^(<)(.+)?$/) {
            ($min, $fin) = ($1, $2 || untaint(shift @args));
        } elsif ($arg =~ /^(>&)(.+)?$/) {
            $fout = $ferr = $2 || untaint(shift @args);
            $mout = $merr = ">";
        } elsif ($arg =~ /^(\'|\")(.*)(\'|\")$/) {
            push @xargs, $2; # skip checking meta between quotes
#               } elsif ($arg =~ /[\$\&\*\(\)\{\}\[\]\`\;\|\?\n~<>]/) {
        } elsif ($arg =~ /[\&\*\(\)\{\}\[\]\`\;\|\?\n~<>]/) {
            __log("Meta characters not allowed: ($arg) $cmd");
            return undef;
        } elsif ($arg =~ /\W\$/) {
            __log("Meta characters not allowed: ($arg) $cmd");
        } else {
            push @xargs, untaint($arg);
        }
    }
    if ($rd2) {
        # redirect both 2 and 1 to the same place
        if (defined $fout) {
            ($ferr, $merr) = ($fout, $mout);
        } elsif (defined $ferr) {
            ($fout, $mout) = ($ferr, $merr);
        } elsif ($rd2 == 1) {
            open STDERR, ">&STDOUT" or die "cannot dup STDERR to STDOUT:$!\n";
            select STDERR; $|=1;
            select STDOUT; $|=1;
        } elsif ($rd2 == 2) {
            open STDOUT, ">&STDERR" or die "cannot dup STDOUT to STDERR:$!\n";
            select STDOUT; $|=1;
            select STDERR; $|=1;
        }
    }
    unless ($xcmd) {
        __log("Command parsing error: $cmd");
        return undef;
    }

    # need to untaint $cmd. otherwise the whole hash will be tainted.
    # but $cmd will never be used for exec anyway, only for debug.
    my $params = { cmd => untaint($cmd), xcmd => $xcmd, xargs => \@xargs };
    $params->{fstdout} = $fout if $fout;
    $params->{mstdout} = $mout if $mout;                                
    $params->{fstderr} = $ferr if $ferr;
    $params->{mstderr} = $merr if $merr;
    $params->{fstdin} = $fin if $fin;
    $params->{mstdin} = $min if $min;
    
    return $params;
}

# ...
sub system {
    return CORE::system(@_) if (@_ > 1);
    my $params = __parsecmd(join(' ', @_));
    return -1 unless ($params);

    # We want SIGINT and SIGQUIT to be ignored in the parent
    # while the child is running.  However, we want the child
    # to get these signals -- so we declare a block around
    # the code that ignores SIGINT such that the child will
    # exec with the signals turned on.
    {
        local $SIG{INT} = 'IGNORE';
        local $SIG{QUIT} = 'IGNORE';
        flush STDOUT; flush STDERR; flush STDIN;
      
        my $pid = fork;
        unless (defined $pid) {
            __log("system: cannot fork $!");
            return -1;
        }
        if ($pid) {
            waitpid $pid, 0;
            return $?;
        }
    }
    return __execo $params;
}