(This is relevant to most UNIXes, not only linux.) A few days ago I posted a perl script to use instead of rm in (cron or interactive) commands like find /tmp -type f -atime +2 -exec rm {} \; I now came up with an improved version. Use at your own peril. Paul Szabo - System Manager // School of Mathematics and Statistics psz@maths.usyd.edu.au // University of Sydney, NSW 2006, Australia ----- #! /usr/local/bin/perl -- # #V safe-rm V1.1 30 May 96 Paul Szabo <psz@maths.usyd.edu.au> # # Safe rm program to be used in root cron jobs like # find /tmp -type f -atime +2 -exec safe-rm {} \; # instead of rm. # # # There is a race between when find starts to descend into /tmp and when it # # calls rm. Suppose I make deeply nested trees like # # # # /tmp/a/b/c/d/passwd (all real dirs and file) and also # # /tmp/x/b/c/d -> /etc (all real dirs and the last symlink) # # # # then, after find starts up but before it reaches /tmp/a/.../passwd I do # # # # cd /tmp; mv a z; mv x a # # # # then find will exec 'rm /tmp/a/b/c/d/passwd' but this removes /etc/passwd. # # If the directories are deep enough then find will slow down a lot, and the # # race will be easy to win. # # We increase security in two ways: # 1) ensure that we get a current, full path without any symlinks # 2) change UID to owner of the file and refuse objects owned by root # # If using safe-rm then we can also remove empty directories and symlinks: # find /tmp -atime +2 -exec safe-rm {} \; $TOP = '/'; if ( -d '/usr/apollo' ) { $APOLLO = 1; $TOP = '//'; } ( $CMD = $0 ) =~ s!^/?([^/]*/)*!!; sub err { if ("$USAGE" ne '') { if ($#_ >= 0) { print "$CMD failed with error:\n\n"; } else { print "$CMD failed with some unknown error.\n"; } } foreach (@_) { print "$_\n"; } if ("$USAGE" ne '') { print "\nUsage:$USAGE"; } exit 1; } # Returns success or failure whether path given is acceptable sub goodpath { my ($path) = @_; if ( length($path) < 1 || length($path) > 999 ) { return 0; } if ( $path =~ m![^a-zA-Z0-9/.,:_-]! ) { return 0; } if ( $path =~ m!^[^a-zA-Z0-9/.]! ) { return 0; } if ( $APOLLO ) { if ( $path =~ m!/[^a-zA-Z0-9/.]! ) { return 0; }; if ( $path =~ m!.//! ) { return 0; } } else { if ( $path =~ m!/[^a-zA-Z0-9.]! ) { return 0; } } if ( $path =~ m![^/]/$! ) { return 0; } return 1; } # Returns full (absolute) path beginning with /, or error message. sub fullpath { # Whinge: Why is this not part of standard Perl? # Or at least why is getwd not implemented? my ($path) = @_; my ($obj, $dir, $nam, $name, $loop, @statp, @statt, @statd, @stato); goodpath($path) || return "Bad pathname $path ."; @statp = stat("$path"); $#statp = 1; if ( ! -e _ ) { return "Object $path does not exist"; } $obj = "$path"; if ( $obj =~ m![^/]/$! ) { $obj =~ s!/$!!; } ( $dir = "$obj" ) =~ s![^/]*$!!; ( $nam = "$obj" ) =~ s!^.*/!!; if ( "$obj" ne "$dir$nam" ) { return "Cannot decompose object name $obj: $dir and $nam ?"; } lstat("$obj"); $loop = 0; while ( -l _ ) { $loop++; if ( $loop > 20 ) { return "Symlink loop in $obj"; } $nam = readlink("$obj"); if ("$nam" eq '') { return "Cannot resolve link $obj: $!"; } if ("$nam" =~ m!^/!) { $obj = "$nam"; } else { $obj = "$dir$nam"; } goodpath($obj) || return "Bad object name $obj ."; ( $dir = "$obj" ) =~ s![^/]*$!!; ( $nam = "$obj" ) =~ s!^.*/!!; if ( "$obj" ne "$dir$nam" ) { return "Cannot decompose object name $obj: $dir and $nam ?"; } @stato = stat("$obj"); $#stato = 1; if ( "@statp" ne "@stato" ) { return "Cannot resolve $path: not same as $obj ?"; } lstat("$obj"); } if ( "$nam" eq '.' || "$nam" eq '..' ) { $dir = "$dir$nam"; $nam = ''; } @statt = stat("$TOP"); $#statt = 1; if ( ! -d _ ) { return "But $TOP is not a directory ?"; } if ("$dir" eq '') { $dir = '.'; } if ( $dir =~ m![^/]/$! ) { $dir =~ s!/$!!; } @statd = stat("$dir"); $#statd = 1; $loop = 0; while ( "@statd" ne "@statt" ) { if ( $loop > 100 ) { return "Directory loop in $obj"; } if ( ! -d _ ) { return "But $dir is not a directory ?"; } opendir (DH,"$dir/..") || return "Cannot read directory $dir/.. ?"; @stato = (); while ( "@statd" ne "@stato" ) { $name = readdir(DH) || last; if ( "$name" eq '.' || "$name" eq '..' ) { next; } if ( $name =~ m!/! ) { next; } goodpath("$name") || next; goodpath("$dir/../$name") || next; @stato = lstat("$dir/../$name"); $#stato = 1; } closedir (DH) || return "Cannot stop reading directory $dir/.. ?"; if ( "@statd" ne "@stato" ) { return "Cannot look up $dir (for $dir/$nam) in $dir/.. ?"; } $dir = "$dir/.."; if ( "$nam" eq '' ) { $nam = "$name"; } else { $nam = "$name/$nam"; } goodpath($nam) || return "Bad name $dir/$nam ."; @statd = stat("$dir"); $#statd = 1; if ( "@statd" eq "@stato" ) { last; } } $obj = "$TOP$nam"; goodpath($obj) || return "Bad final pathname $obj"; @stato = stat("$obj"); $#stato = 1; if ( "@statp" ne "@stato" ) { return "Cannot resolve $path: not same as $obj ?"; } return "$obj"; } # Returns error message or full (absolute) path beginning with / # for directory, keeping last leaf as is. Same as fullpath except # for symlinks: fullpath returns the object pointed to, or # whinges if it points nowhere. sub fulldir { my ($path) = @_; my ($obj, $dir, $nam, @statp, @stato); goodpath($path) || return "Bad pathname $path ."; @statp = lstat("$path"); $#statp = 1; if ( ! -l _ ) { return fullpath("$path"); } $obj = "$path"; if ( $obj =~ m![^/]/$! ) { $obj =~ s!/$!!; } ( $dir = "$obj" ) =~ s![^/]*$!!; ( $nam = "$obj" ) =~ s!^.*/!!; if ( "$obj" ne "$dir$nam" ) { return "Cannot decompose object name $obj: $dir and $nam ?"; } if ( "$nam" eq '' || "$nam" eq '.' || "$nam" eq '..' ) { return "Bad linkname $path"; } if ("$dir" eq '') { $dir = '.'; } if ( $dir =~ m![^/]/$! ) { $dir =~ s!/$!!; } $obj = fullpath("$dir"); if ( $obj !~ m!^/! ) { return "$obj"; } if ( $obj =~ m!/$! ) { $obj = "$obj$nam"; } else { $obj = "$obj/$nam"; } goodpath($obj) || return "Bad final pathname $obj"; @stato = lstat("$obj"); $#stato = 1; if ( "@statp" ne "@stato" ) { return "Cannot resolve $path: not same as $obj ?"; } return "$obj"; } # This routine DOES NOT RETURN !! # Removes object $file. # If $statted is 1, then lstat($file) must still be available as lstat(_). # (This allows an extra degree of checking that we remove the right object.) # This routine does not return, mainly because it sets UID, GID to 'owner' # of the file to remove, and can never set it back. (This protects somewhat # against being tricked and removing the wrong file.) # To remove multiple files, use saferm_fork instead. sub saferm { my ($file, $statted) = @_; my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks); my ($nam, $dir, $n, @statl, @statn); goodpath($file) || err ("Bad object name $file ."); if ( $statted == 1 ) { @statn = lstat(_); @statl = lstat("$file"); if ( "@statl" ne "@statn" ) { err ("Object $file seems to have changed"); } } else { @statl = lstat("$file"); } if ( ! -e _ ) { err ("Object $file does not exist."); } if ( ! ( -f _ || -d _ || -l _) ) { err ("Object $file is not a (plain) file, directory or symlink."); } ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = @statl; # Files created often inherit group from directory, and /tmp is often owned by root.wheel. Set some safe GID. if ( $gid == 0 ) { $gid = 999; } if ( $uid < 999 || $uid > 32000 ) { err ("Object $file is owned by UID $uid"); } if ( $gid < 999 || $gid > 32000 ) { err ("Object $file is owned by GID $gid"); } # Give up privileges $( = $gid; $) = $gid; $< = $uid; $> = $uid; if ( $< != $uid || $> != $uid || $( != $gid || $) != $gid ) { err ("Object $file: cannot set UID $uid, GID $gid"); } $n = fulldir("$file"); if ( $n !~ m!^/! ) { err ("Error resolving $file: $n"); } if ( "$n" ne "$file" ) { err ("Not full pathname $file: it really is $n"); } ( $dir = "$file" ) =~ s![^/]*$!!; ( $nam = "$file" ) =~ s!^.*/!!; if ( "$file" ne "$dir$nam" ) { err ("Cannot decompose object name $file: $dir and $nam ?"); } if ( "$nam" eq '' || "$nam" eq '.' || "$nam" eq '..' || "$dir" eq '' ) { err ("Bad object name $file"); } if ( $dir =~ m![^/]/$! ) { $dir =~ s!/$!!; } chdir("$TOP") || err ("Object $file: Cannot chdir($TOP)"); $n = fullpath('.'); if ( "$n" ne "$TOP" ) { err ("Object $file: chdir($TOP) got us to $n"); } chdir("$dir") || err ("Object $file: Cannot chdir($dir)"); $n = fullpath('.'); if ( "$n" ne "$dir" ) { err ("Object $file: chdir($dir) got us to $n"); } @statn = lstat("$nam"); if ( "@statl" ne "@statn" ) { err ("Object $file seems to have changed"); } if ( -d _ ) { # print "About to rmdir $file ...\n"; rmdir("$nam"); # || err ("Cannot remove dir $file"); # No error message: it may have been not empty } else { # print "About to unlink $file ...\n"; unlink("$nam") || err ("Cannot remove $file"); } exit 0; } # (This routine is not used.) # Uses saferm after forking. # Same arguments as saferm. sub saferm_fork { my ($file, $statted) = @_; my ($pid); if ( ! defined($pid = fork) ) { print "Cannot fork to remove $file\n"; } if ( $pid == 0 ) { saferm ($file, $statted); exit 0; } waitpid($pid,0); } if ( $#ARGV != 0 ) { err ("Specify one object (only) to remove."); } ($FILE) = @ARGV; saferm ($FILE, 0); #!#