## 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 @_;
        }
    }

##### Copyright © 1997, Guy Geens
Published in Issue 18 of the Linux Gazette, June 1997