#!/usr/local/bin/perl
#
# $Id: CleanTree.pl,v 1.4 2005/01/19 23:13:38 rdilley Exp $
#
# author: ron dilley
#
# desc: this perl script cleans up directories in a pretty
#       safe fashion.  Can be used to clean /tmp and /var/tmp
#
# Copyright (C) 2000  Ron A. Dilley
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; version 2
# of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
# ron.dilley@uberadmin.com
#
############################################################################

#
# modules
#
use Getopt::Std;
use DirHandle;

require "sys/stat.ph";
die "no &S_IFMT" unless defined &S_IFMT;

#
# pragmas
#
use strict;

#
# set environment
#
$ENV{PATH} = "/usr/bin:/bin:/usr/sbin:/sbin:/usr/ucb";

#
# turn on autoflush
#
select STDERR; $|;
select STDOUT; $|;

#
# defines
#
$::TRUE = 1;
$::FALSE = 0;
$::FAILED = -1;

$::VERSION = '$Revision: 1.4 $';
$::PROGNAME = "CleanTree.pl";

%::Config = ();
$::Config{'debug'} = $::FALSE;
$::Config{'max_dir_depth'} = 30;
$::Config{'max_path'} = 1024;
$::Config{'age_limit'} = '1w';
$::Config{'ignore_root'} = $::TRUE;
$::Config{'ignore_special'} = $::TRUE;
$::Config{'current_time'} = time();
$::Config{'real_uid'} = $::UID;
$::Config{'real_gid'} = $::GID;

@::dir_stack = ();

#
# main routine
#
if ( &main() != $::TRUE ) {
  exit( 1 );
}

exit( 0 );

############################################################################
#
# sub-routines
#

#
# main routine
#
sub main {
  my $arg;

  #
  # display script banner
  #
  &show_banner();

  #
  # parse command-line
  #
  &parse_command_line();

  #
  # calculate age limit (do it once for speed)
  #
  $::Config{'cutoff_time'} = $::Config{'current_time'} - &calc_age_limit( $::Config{'age_limit'} );
  if ( $::Config{'cutoff_time'} >= $::Config{'current_time'} ) {
    print "ERROR - Cutoff time [$::Config{'cutoff_time'}] should be less than [$::Config{'current_time'}]\n";
    return $::FAILED;
  } else {
    if ( $::Config{'debug'} >= 4 ) {
      print "DEBUG - Cutoff time: $::Config{'cutoff_time'}\n";
    }
  }

  #
  # scan each dir passed on the command line
  #
  while( $arg = shift( @::ARGV ) ) {
    &scan_dirs( $arg );
  }

  # done
  return $::TRUE;
}

#
# display banner info
#
sub show_banner {
  print "$::PROGNAME v$::VERSION\n";
  print "By: Ron Dilley\n";
  print "\n";
  print "$::PROGNAME comes with ABSOLUTELY NO WARRANTY.\n";
  print "This is free software, and you are welcome\n";
  print "to redistribute it under certain conditions;\n";
  print "See the GNU General Public License for details.\n";
  print "\n";

  return $::TRUE;
}

#
# display help info
#
sub show_help {
  print "Syntax:\n";
  print "\n";
  print "$::PROGNAME [options] {dir} [{dir} ...]\n";
  print "\n";
  print "-d {1-9}   Display debug information during program run\n";
  print "-l {1-99}  Override the default directory depth\n";
  print "           (default: 30)\n";
  print "-a {age}   Override the default age specification\n";
  print "           s,m,h,d,w - seconds, minutes, hours, ...\n";
  print "           (default: 1w)\n";
  print "-r         Remove files owned by root\n";
  print "           (default is to ignore)\n";
  print "-s         Remove special files (FIFO/DOOR/SOCK/BLK/CHR)\n";
  print "           (default is to ignore)\n";
  print "\n";

  return $::TRUE;
}

#
# parse command-line arguments
#
sub parse_command_line {
  no strict 'vars';

  if ( getopts( 'l:d:a:rs' ) == $::FALSE ) {
    &show_help();
    return $::FAILED;
  }
  if ( defined $opt_d ) {
    if ( $opt_d > 0 ) {
      # set debug mode
      $::Config{'debug'} = $opt_d;
    }
  }
  if ( defined $opt_l ) {
    if ( $opt_l > 0 ) {
      # set the max dir level
      $::Config{'max_dir_depth'} = $opt_l;
    }
  }
  if ( defined $opt_a ) {
    if ( $opt_a ne "" ) {
      # set the age limit
      $::Config{'age_limit'} = $opt_a;
    }
  }
  if ( defined $opt_r ) {
    if ( $opt_r > 0 ) {
      # toggle ignore_root
      $::Config{'ignore_root'} = $::FALSE;
    }
  }
  if ( defined $opt_s ) {
    if ( $opt_s > 0 ) {
      # toggle ignore_special
      $::Config{'ignore_special'} = $::FALSE;
    }
  }
  return $::TRUE;
}

# @(#)safe_system.pl	1.2 [02/01/00 - 12:02:55]
#
#  author: ron dilley
#    desc: this perl function does a system call with
#          extended error checks
#
#    type: function
#    args: $command
# returns: $::TRUE on no error, $::FAILED on error
#   notes: Requires $::Config{'debug'} to enable/disable verbose messages
#
############################################################################

sub safe_system {
  my( $command ) = @_;
  my( $ret );

  if ( ( $ret = ( 0xffff & system( $command ) ) ) != $::FALSE ) {
    if ( $ret == 0xff00 ) {
      if ( $::Config{'debug'} ) {
	print "DEBUG - Unable to execute command \[$!\]\n";
      }
    } elsif ( $ret > 0x80 ) {
      if ( $::Config{'debug'} ) {
	$ret >>= 8;
	print "DEBUG - Command returned non-zero exit status \[$ret\]\n";
      }
    } else {
      if ( $::Config{'debug'} ) {
	if ( $ret & 0x80 ) {
	  $ret &= ~0x80;
	  print "DEBUG - Command coredumped\n";
	}
	print "DEBUG - Command received signal \[$ret\]\n";
      }
    }
    return $::FAILED;
  }

  return $::TRUE;
}

#
# collect directory info
#
sub scan_dirs {
  my ( $starting_path ) = @_;
  if ( $::Config{'debug'} >= 2 ) {
    print "DEBUG - Target path is [$starting_path]\n";
  }

  if ( -d $starting_path ) {
    #
    # jump into dir (automounter)
    #
    &safe_system( "/bin/cd $starting_path" );

    #
    # scan the directory tree
    #
    &scan_dir( $starting_path );

    return $::TRUE;
  } elsif ( -e $starting_path ) {
    print "ERROR - [$starting_path] is not a directory\n";
  } else {
    print "ERROR - [$starting_path] does not exist\n";
  }

  return $::FAILED;
}

#
# scan dir (re-entrant)
#
sub scan_dir
{
  my( $current_dir ) = @_;
  my @entries;
  my $entry;
  my $del_count;
  my $entry_mode;
  my @first_stat;

  if ( $::Config{'debug'} >= 7 ) {
    print "DEBUG - Scanning [$current_dir]\n";
  }

  if ( @::dir_stack >= $::Config{'max_dir_depth'} ) {
    if ( $::Config{'debug'} >= 2 ) {
      print "DEBUG - Maximum directory depth reached\n";
    }
    return $::FAILED;
  }

  if ( $::Config{'max_path'} <= length( $current_dir ) ) {
    if ( $::Config{'debug'} >= 2 ) {
      print "DEBUG - [$current_dir] is too long\n";
    }
    return $::FAILED;
  }

  $_ = new DirHandle $current_dir;
  push( @::dir_stack, $_ );

  if ( $::Config{'debug'} >= 7 ) {
    print "DEBUG - dir_stack: $::dir_stack[0]\n";
  }

  opendir( $::dir_stack[0], $current_dir );
  @entries = grep( !/^\.\.?$/, readdir( $::dir_stack[0] ) );

  $del_count = @entries;

  if ( $del_count <= 0 ) {
    # empty directory
    if ( $::Config{'debug'} >= 2 ) {
      print "DEBUG - [$current_dir] is empty\n";
    }

    return $::TRUE;
  }

  foreach $entry ( @entries ) {
    if ( ( @first_stat = lstat( "$current_dir/$entry" ) ) <= 0 ) {
      print "ERROR - Unable to stat [$current_dir/$entry]\n";
    } else {   
      if ( ( $first_stat[2] & &S_IFMT() ) != &S_IFLNK() ) {
	if ( ( $first_stat[2] & &S_IFMT() ) == &S_IFDIR() ) {
	  if ( &scan_dir( "$current_dir/$entry" ) == $::TRUE ) {
	    # directory is empty
	    
	    # deal with it
	    if ( &process_entry( "$current_dir/$entry", @first_stat ) != $::TRUE ) {
	      # problem
	    } else {
	      $del_count--;
	    }
	  } else {
	    # cant remove directory
	    if ( $::Config{'debug'} >= 5 ) {
	      print "DEBUG - Can't remove [$current_dir/$entry]: It's not empty\n";
	    }
	  }
	} elsif ( ( $first_stat[2] & &S_IFMT() ) == &S_IFREG() ) {
	  # a file
	  
	  # deal with it
	  if ( &process_entry( "$current_dir/$entry", @first_stat ) != $::TRUE ) {
	    # problem
	  } else {
	    $del_count--;
	  }
	} else {
	  # a non-file/non-directory entry
	  if ( $::Config{'debug'} >= 6 ) {
	    print "DEBUG - [$entry] is a special file\n";
	  }
	  
	  if ( $::Config{'ignore_special'} ) {
	    # ignore the special files
	    if ( $::Config{'debug'} >= 4 ) {
	      print "DEBUG - Ignoring [$current_dir/$entry] it is a special file\n";
	    }
	  } else {
	    # deal with it
	    if ( &process_entry( "$current_dir/$entry", @first_stat ) != $::TRUE ) {
	      # problem
	    } else {
	      $del_count--;
	    }
	  }
	}
      } else {
	# a link entry
	if ( $::Config{'debug'} >= 6 ) {
	  print "DEBUG - [$entry] is a link\n";
	}
	
	# deal with it
	if ( &process_entry( "$current_dir/$entry", @first_stat ) != $::TRUE ) {
	  # problem
	} else {
	  $del_count--;
	}
      }
    }
  }

  closedir( $::dir_stack[0] );

  pop( @::dir_stack );

  if ( $del_count > 0 ) {
    # dir is not empty
    return $::FALSE;
  }

  # dir is empty
  return $::TRUE;
}

#
# process entry
#
sub process_entry {
  my ( $fqname, @first_stat ) = @_;
  my @second_stat;
  my $test_time;
  my $uid;
  my $gid;
  my $i;

  if ( $::Config{'debug'} >= 5 ) {
    print "DEBUG - Processing [$fqname]\n";
  }

  #
  # run tests to see if the file should be removed
  #

  # check for files owned by root
  if ( $::Config{'ignore_root'} ) {
    if ( $first_stat[4] == 0 ) {
      # ignore file, owned by root
      if ( $::Config{'debug'} >= 6 ) {
	print "DEBUG - Ignoring [$fqname] it is owned by root\n";
      }
      return $::FALSE;
    }
  }

  # check if older than age_limit
  if ( $first_stat[9] < $::Config{'cutoff_time'} ) {
    if ( $::Config{'debug'} >= 4 ) {
      print "DEBUG - [$fqname] should be removed\n";
    }

    #
    # change to uid/gid of the file to be unlinked
    #
    $::EUID = $first_stat[4];
    $::EGID = $first_stat[5];

    if ( ( @second_stat = lstat( "$fqname" ) ) <= 0 ) {
      print "ERROR - Unable to stat [$fqname]\n";
      return $::FAILED;
    }

    #
    # double check that the file has not changed (possible race condition)
    #
    if ( $first_stat[0] != $second_stat[0] |
	 $first_stat[1] != $second_stat[1] |
	 $first_stat[4] != $second_stat[4] |
	 $first_stat[5] != $second_stat[5] |
	 $first_stat[6] != $second_stat[6] ) {
      # file has changed, race?
      print "ERROR - [$fqname] has changed\n";
      return $::FAILED;
    }

    if ( $::Config{'debug'} >=8 ) {
      print "DEBUG - Unlinking [$fqname] as $::EUID/$::EGID\n";
    }

    # choose how to remove the file
    if ( ( $first_stat[2] & &S_IFMT() ) == &S_IFDIR() ) {
      # use rmdir instead of unlink
      if ( &safe_system( "rmdir \'$fqname\'" ) != $::TRUE ) {
	print "ERROR - Unable to rmdir [$fqname]\n";
	return $::FAILED;
      }
    } else {
      # use unlink
      if ( unlink( $fqname ) != $::TRUE ) {
	print "ERROR - Unable to unlink [$fqname]\n";
	return $::FAILED;
      }
    }

    #
    # change back
    #
    $::EUID = $::Config{'uid'};
    $::EGID = $::Config{'gid'};

    return $::TRUE;
  }

  if ( $::Config{'debug'} >= 5 ) {
    print "DEBUG - Ignoring [$fqname] file is not old enough\n";
  }

  #
  # did not do anything
  #
  return $::FALSE;
}

#
# calculate age limit using sendmail timespec
#
sub calc_age_limit {
  my( $limit ) = @_;
  my $delta;

  while ( $limit ne "" ) {
    if ( $limit =~ m/^([\d+])([s|m|h|d|w])(.*)/ ) {
      if ( $::Config{'debug'} >= 7 ) {
	print "DEBUG - Age Limit: $1 $2\n";
      }
      if ( $2 eq 's' ) {
	$delta += $1;
      } elsif ( $2 eq 'm' ) {
	$delta += ( $1 * &seconds_in_a_minute() );
      } elsif ( $2 eq 'h' ) {
	$delta += ( $1 * &seconds_in_an_hour() );
      } elsif ( $2 eq 'd' ) {
	$delta += ( $1 * &seconds_in_a_day() );
      } elsif ( $2 eq 'w' ) {
	$delta += ( $1 * &seconds_in_a_week() );
      } else {
	# something has gone really wrong
	print "ERROR - Invalid argument [$limit]\n";
	&show_help();
	return $::FAILED
      }
      $limit = $3;
    } else {
      print "ERROR - Invalid argument [$limit]\n";
      &show_help();
      return $::FAILED;
    }
  }

  return $delta;
}

#
# do some time calcs
#
sub seconds_in_a_minute { return 60; }
sub seconds_in_an_hour { return &seconds_in_a_minute * 60; }
sub seconds_in_a_day { return &seconds_in_an_hour * 24; }
sub seconds_in_a_week { return &seconds_in_a_day * 7; }
