Perl Script

By Guy Geens,

#! /usr/bin/perl -w
# cleantmp: Remove old files from /tmp partition
# Copyright (C) 1997 by Guy Geens 
# Snail Mail:
# Zwijnaardsesteenweg 183
# 9000 Gent
# Belgium

use File::Find;

# Security measure: chroot to /tmp
$tmpdir = '/tmp/';
chdir ($tmpdir) || die "$tmpdir not accessible: $!";
if (chroot($tmpdir)) {          # chroot() fails when not run by root
    ($prefix = $tmpdir) =~ s,/+$,,;
    $root = '/';
    $test = 0;
} else {
# Not run by root - test only
    $prefix = '';
    $root = $tmpdir;
    $test = 1;
}

@list = ();

&find(\&do_files, $root);
&find(\&do_dirs, $root);

if (@list) {
    print "Cleaned $tmpdir\n";
    print "Deleted files are:\n";
    for (sort @list) {
        print "$prefix$_\n";
    }
}

exit;

sub do_files {
    (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
        (-f _ || -l _ ) &&
            (int(-A _) > 3) &&
                ! /^\.X.*lock$/ &&
                    &removefile ($_) && push @list, $File::Find::name;
}

sub do_dirs {
    /^\..*-unix$/ && ($File::Find::prune = 1) ||
        (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
            -d _ && ($nlink == 2) &&
                ! /^lost\+found$/ &&
                    &removedir ($_) && push @list, "$File::Find::name/";
}

sub removedir {
    if ( $test ) {
        1;
    } else {
# Can't use @_: rmdir doesn't take a list argument
        rmdir $_[0];
    }
}

sub removefile {
    if ( $test ) {
        1;
    } else {
        unlink @_;
    }
}