Dir-Purge-1.02/0000755000076500007650000000000010503763563011074 5ustar jvjvDir-Purge-1.02/CHANGES0000644000076500007650000000063210503763525012066 0ustar jvjvRevision history for Perl extension Dir::Purge. 1.02 Tue Sep 19 14:24:54 2006 - fix problem with purgedir_by_age. 1.01 Tue Feb 21 22:37:35 2005 - Add "include" with subroutine or regex to preselect candidates. - Add "reverse" option to reverse the strategy. - Add verbosity levels. - Thread safe (use a local hash to keep state). 1.00 Sun May 21 15:36:15 2000 - First CPAN release. Dir-Purge-1.02/MANIFEST0000644000076500007650000000021710503763563012225 0ustar jvjvREADME CHANGES MANIFEST Makefile.PL lib/Dir/Purge.pm t/basic.t META.yml Module meta-data (added by MakeMaker) Dir-Purge-1.02/t/0000755000076500007650000000000010503763563011337 5ustar jvjvDir-Purge-1.02/t/basic.t0000444000076500007650000000372207113415175012603 0ustar jvjv# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' use File::Path; BEGIN { $| = 1; print "1..9\n"; } END {print "not ok 1\n" unless $loaded;} use Dir::Purge; $loaded = 1; print "ok 1\n"; # Cleanup the test directory and re-create it. rmtree (['t1'], 1, 0); mkdir ('t1', 0777); # Put in the test files. my $now = time - 1000; for ( qw(f1 f6 f3 f2 f5 f4) ) { my $f = "t1/$_"; open (F, ">$f") or warn ("$f: $!\n"); print F ("$f\n"); close (F); $now += 60; utime ($now, $now, $f) or warn ("$f: $!\n"); warn ("$f: ", (stat($f))[9], " ", $now, " ", "Oops!\n") unless abs((stat($f))[9] - $now) < 30; } # Check existence of directory and files. opendir (D, "t1") or print "not "; print "ok 2\n"; my @files = grep {!/^\./} readdir(D); closedir (D); print "not " unless @files == 6; print "ok 3\n"; print "not " unless join(" ",sort @files) eq "f1 f2 f3 f4 f5 f6"; print "ok 4\n"; # Test purgedir. Nothing should be changed. my $msgs; eval { local $SIG{__WARN__} = sub { $msgs .= shift }; purgedir ({verbose => 0, test => 1, keep => 4}, "t1"); }; print "$@\nnot " if $@; print "ok 5\n"; print "$msgs\nnot " unless $msgs eq < 0, keep => 4}, "t1"); }; print "$@\nnot " if $@; print "ok 8\n"; # Check that only the 4 most recent files are kept. opendir (D, "t1"); @files = grep {!/^\./} readdir(D); closedir (D); unless ( join(" ",sort @files) eq "f2 f3 f4 f5" ) { print "@files\n"; print "not "; } print "ok 9\n"; # Remove the test directory again. rmtree (['t1']); # Local Variables: # mode: cperl # End: Dir-Purge-1.02/lib/0000755000076500007650000000000010503763563011642 5ustar jvjvDir-Purge-1.02/lib/Dir/0000755000076500007650000000000010503763563012360 5ustar jvjvDir-Purge-1.02/lib/Dir/Purge.pm0000444000076500007650000002475610503760541014005 0ustar jvjv# Dir::Purge.pm -- Purge directories # RCS Info : $Id: Purge.pm,v 1.6 2006/09/19 12:24:01 jv Exp $ # Author : Johan Vromans # Created On : Wed May 17 12:58:02 2000 # Last Modified By: Johan Vromans # Last Modified On: Tue Sep 19 14:23:56 2006 # Update Count : 161 # Status : Unknown, Use with caution! # Purge directories by strategy. # # This is also an exercise in weird programming techniques. package Dir::Purge; use strict; use Carp; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); $VERSION = "1.02"; @ISA = qw(Exporter); @EXPORT = qw(&purgedir); @EXPORT_OK = qw(&purgedir_by_age); my $purge_by_age; # strategy sub purgedir_by_age { my @dirs = @_; my $opts; if ( UNIVERSAL::isa ($dirs[0], 'HASH') ) { $opts = shift (@dirs); my $strat = delete $opts->{strategy}; if ( defined $strat && $strat ne "by_age" ) { croak ("Invalid option: 'strategy'"); } $opts->{strategy} = "by_age"; } else { $opts = { keep => shift(@dirs), strategy => "by_age" }; } purgedir ($opts, @dirs); } # Common processing code. It verifies the arguments, directories and # calls $code->(...) to do the actual purging. # Nothing is done if any of the verifications fail. sub purgedir { my (@dirs) = @_; my $error = 0; my $code = $purge_by_age; # default: by age my $ctl = { tag => "purgedir" }; my @opts = qw(keep strategy reverse include verbose test debug); # Get the parameters. Only the 'keep' value is mandatory. if ( UNIVERSAL::isa ($dirs[0], 'HASH') ) { my $opts = shift (@dirs); @{$ctl}{@opts} = delete @{$opts}{@opts}; if ( $ctl->{strategy} ) { if ( $ctl->{strategy} eq "by_age" ) { $code = $purge_by_age; } else { carp ("Unsupported purge strategy: '$ctl->{strategy}'"); $error++; } } foreach (sort keys %$opts) { carp ("Unhandled option \"$_\""); $error++; } } elsif ( $dirs[0] =~ /^-?\d+$/ ) { $ctl->{keep} = shift (@dirs); } unless ( $ctl->{keep} ) { croak ("Missing 'keep' value"); } elsif ( $ctl->{keep} < 0 ) { # Hmm. I would like to deprecate this, but on the other hand, # a negative 'subscript' fits well in Perl. #carp ("Negative 'keep' value is deprecated, ". # "use 'reverse => 1' instead"); $ctl->{keep} = -$ctl->{keep}; $ctl->{reverse} = !$ctl->{reverse}; } $ctl->{verbose} = 1 unless defined ($ctl->{verbose}); $ctl->{verbose} = 9 if $ctl->{debug}; if ( $ctl->{include} ) { if ( !ref($ctl->{include}) ) { croak("Invalid value for 'include': " . $ctl->{include}); } elsif ( UNIVERSAL::isa($ctl->{include}, 'CODE') ) { # OK } elsif ( UNIVERSAL::isa($ctl->{include}, 'Regexp') ) { my $pat = $ctl->{include}; $ctl->{include} = sub { $_[0] =~ $pat }; } else { croak("Invalid value for 'include': " . $ctl->{include}); } } # Thouroughly check the directories, and refuse to do anything # in case of problems. warn ("$ctl->{tag}: checking directories\n") if $ctl->{verbose} > 1; foreach my $dir ( @dirs ) { # Must be a directory. unless ( -d $dir ) { carp (-e _ ? "$dir: not a directory" : "$dir: not existing"); $error++; next; } # We need write access since we are going to delete files. unless ( -w _ ) { carp ("$dir: no write access"); $error++; } # We need read access since we are going to get the file list. unless ( -r _ ) { carp ("$dir: no read access"); $error++; } # Probably need this as well, don't know. unless ( -x _ ) { carp ("$dir: no access"); $error++; } } # If errors, bail out unless testing. if ( $error ) { if ( $ctl->{test} ) { carp ("$ctl->{tag}: errors detected, continuing"); } else { croak ("$ctl->{tag}: errors detected, nothing done"); } } # Process the directories. foreach my $dir ( @dirs ) { $code->($ctl, $dir); } }; # Everything else is assumed to be small building-block routines to # implement a plethora of purge strategies. # Actually, I cannot think of any right now. # Gather file names and additional info. my $gather = sub { my ($ctl, $dir, $what) = @_; local (*DIR); opendir (DIR, $dir) or croak ("dir: $!"); # shouldn't happen -- we've checked! my @files; foreach ( readdir (DIR) ) { next if $ctl->{include} && !$ctl->{include}->($_, $dir); next if /^\./; next unless -f "$dir/$_"; push (@files, [ "$dir/$_", $what->("$dir/$_") ]); } closedir (DIR); warn ("$ctl->{tag}: $dir: ", scalar(@files), " files\n") if $ctl->{verbose} > 1; warn ("$ctl->{tag}: $dir: @{[map { $_->[0] } @files]}\n") if $ctl->{debug}; \@files; }; # Sort the list on the supplied info. my $sort = sub { my ($ctl, $files) = @_; my @sorted = map { $_->[0] } sort { $a->[1] <=> $b->[1] } @$files; warn ("$ctl->{tag}: sorted: @sorted\n") if $ctl->{debug}; \@sorted; }; # Remove the files to keep from the list. my $reduce = sub { my ($ctl, $files) = @_; if ( $ctl->{reverse} ) { # Keep the newest files (tail of the list). splice (@$files, @$files-$ctl->{keep}, $ctl->{keep}); } else { # Keep the oldest files (head of the list). splice (@$files, 0, $ctl->{keep}); } $files; }; # Remove the files in the list. my $purge = sub { my ($ctl, $files) = @_; # Remove the selected files. foreach ( @$files ) { if ( $ctl->{test} ) { warn ("$ctl->{tag}: candidate: $_\n"); } else { warn ("$ctl->{tag}: removing $_\n") if $ctl->{verbose}; unlink ($_) or carp ("$_: $!"); } } }; # Processing routine: purge by file age. $purge_by_age = sub { my ($ctl, $dir) = @_; warn ("$ctl->{tag}: purging directory $dir (by age, keep $ctl->{keep})\n") if $ctl->{verbose} > 1; # Gather, with age info. my $files = $gather->($ctl, $dir, sub { -M _ }); # Is there anything to do? if ( @$files <= $ctl->{keep} ) { warn ("$ctl->{tag}: $dir: below limit\n") if $ctl->{verbose} > 1; return; } # Sort, reduce and purge. $purge->($ctl, $reduce->($ctl, $sort->($ctl, $files))); }; 1; __END__ =head1 NAME Dir::Purge - Purge directories to a given number of files. =head1 SYNOPSIS perl -MDir::Purge -e 'purgedir (5, @ARGV)' /spare/backups use Dir::Purge; purgedir ({keep => 5, strategy => "by_age", verbose => 1}, "/spare/backups"); use Dir::Purge qw(purgedir_by_age); purgedir_by_age (5, "/spare/backups"); =head1 DESCRIPTION Dir::Purge implements functions to reduce the number of files in a directory according to a strategy. It currently provides one strategy: removal of files by age. By default, the module exports one user subroutine: C. The first argument of C should either be an integer, indicating the number of files to keep in each of the directories, or a reference to a hash with options. In either case, a value for the number of files to keep is mandatory. The other arguments are the names of the directories that must be purged. Note that this process is not recursive. Also, hidden files (name starts with a C<.>) and non-plain files (e.g., directories, symbolic links) are not taken into account. All directory arguments and options are checked before anything else is done. In particular, all arguments should point to existing directories and the program must have read, write, and search (execute) access to the directories. One additional function, C, can be exported on demand, or called by its fully qualified name. C calls C with the "by age" purge strategy preselected. Since this happens to be the default strategy for C, calling C is roughly equivalent to calling C. =head1 WARNING Removing files is a quite destructive operation. Supply the C option, described below, to dry-run before production. =head1 OPTIONS Options are suppled by providing a hash reference as the first argument. The following calls are equivalent: purgedir ({keep => 3, test => 1}, "/spare/backups"); purgedir_by_age ({keep => 3, test => 1}, "/spare/backups"); purgedir ({strategy => "by_age", keep => 3, test => 1}, "/spare/backups"); All subroutines take the same arguments. =over 4 =item keep The number of files to keep. A negative number will reverse the strategy. See option C below. =item strategy Specifies the purge strategy. Default (and only allowed) value is "by_age". This option is for C only. The other subroutines should not be provided with a C option. =item include If this is a reference to a subroutine, this subroutine is called with arguments ($file,$dir) and must return true for the file to be included in the list of candidates, If this is a regular expression, the file file will be included only if the expression matches the file name. =item reverse If true, the strategy will be reversed. For example, if the strategy is "by_age", the oldest files will be kept instead of the newest files. Another way to reverse the strategy is using a negative C value. This is not unlike Perl's array subscripts, which count from the end if negative. A negative C value can be combined with C to reverse the reversed strategy again. =item verbose Verbosity of messages. Default value is 1, which will report the names of the files being removed. A value greater than 1 will produce more messages about what's going on. A value of 0 (zero) will suppress messages. =item debug For internal debugging only. =item test If true, no files will be removed. For testing. =back =head1 EXPORT Subroutine C is exported by default. Subroutine C may be exported on demand. Calling purgedir_by_age() is roughly equivalent to calling purgedir() with an options hash that includes C "by_age">. The variable $Dir::Purge::VERSION may be used to inspect the version of the module. =head1 AUTHOR Johan Vromans (jvromans@squirrel.nl) wrote this module. =head1 COPYRIGHT AND DISCLAIMER This program is Copyright 2000 by Squirrel Consultancy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with Perl. 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 either the GNU General Public License or the Artistic License for more details. =cut Dir-Purge-1.02/Makefile.PL0000444000076500007650000000051710206452450013035 0ustar jvjv#!/usr/bin/perl -w use ExtUtils::MakeMaker; use strict; WriteMakefile ( NAME => 'Dir::Purge', VERSION_FROM => 'lib/Dir/Purge.pm', ($] >= 5.005) ? ( AUTHOR => "Johan Vromans ", ABSTRACT => "Selective purging of directories and files." ) : (), PREREQ_PM => { 'Test::More' => 0 }, ); Dir-Purge-1.02/README0000444000076500007650000000257310206441722011747 0ustar jvjvDir::Purge implements functions to reduce the number of files in a directory according to a strategy. It currently provides one strategy: removal of files by age. EXAMPLES ======== From the command-line: perl -MDir::Purge -e 'purgedir (5, @ARGV)' /spare/backups From your Perl program: use Dir::Purge; purgedir ({keep => 5, strategy => "by_age", verbose => 1}, "/spare/backups"); use Dir::Purge qw(purgedir_by_age); purgedir_by_age (5, "/spare/backups"); AVAILIBILITY ============ The Comprehensive Perl Archive Network (CPAN), see "http://www.perl.com/CPAN/authors/Johan_Vromans". The kit is named Dir-Purge-x.yy.tar.gz, where x.yy is the version number. COPYRIGHT AND DISCLAIMER ======================== Module Dir::Purge is Copyright 2000,2005 by Squirrel Consultancy. This program is free software; you can redistribute it and/or modify it under the terms of the Perl Artistic License or the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. ------------------------------------------------------------------- Johan Vromans jvromans@squirrel.nl Squirrel Consultancy Haarlem, the Netherlands http://www.squirrel.nl http://www.squirrel.nl/people/jvromans ------------------ "Arms are made for hugging" -------------------- Dir-Purge-1.02/META.yml0000644000076500007650000000052310503763563012345 0ustar jvjv# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Dir-Purge version: 1.02 version_from: lib/Dir/Purge.pm installdirs: site requires: Test::More: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30