# HG changeset patch # User Matthias Förste # Date 1274096867 -7200 # Node ID fcdba28f4b068283280c8963d99cdd861bfe9642 import diff -r 000000000000 -r fcdba28f4b06 purge-proe --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/purge-proe Mon May 17 13:47:47 2010 +0200 @@ -0,0 +1,137 @@ +#!/usr/bin/perl + +# Delete old Pro/Engineer files +# Copyright (C) 2010 Matthias Förste +# +# 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, either version 3 of the License, or +# (at your option) any later version. +# +# 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, see . +# +# Matthias Förste + +use strict; +use warnings; + +use Getopt::Long; +use Pod::Usage; +use File::Find; + +my $files; +my $opt = { + + dirs => [], # dont set default dir here because arguments to --directory will + # not overwrite it, but added to it + keep => 3, + recursive => 1 + +}; + +my $proe_first_line = "#UGC:"; + +die "Failed to read options" unless GetOptions( + 'directory=s' => $opt->{dirs}, + 'help' => sub { pod2usage(-verbose => 1, -exitval => 0) }, + 'man' => sub { pod2usage(-verbose => 2, -exitval => 0) }, + 'keep=i' => \$opt->{keep}, + 'recursive' => \$opt->{recursive} +); + +sub doit { + + return if -d; + + my $f = $File::Find::name; + return unless $f =~ /^(.+)\.([0-9]+)$/; + + my ($stem, $suffix) = ($1, $2); + + unless (-s $_) { + warn "Ignoring '$f': is empty"; + return; + } + + unless (open FILE, '<', $_) { + warn "Ignoring '$f': failed to open: $!"; + return; + } + + my $line = ; + unless ($line =~ /^$proe_first_line/) { + warn "Ignoring '$f': not an Pro/Engineerfile?"; + return; + } + + $files->{$stem} = exists $files->{$stem} ? [ $suffix, @{$files->{$stem}} ] : [ $suffix ]; + +} + +$opt->{dirs} = ['.'] unless @{$opt->{dirs}}; +#print join "\n", @{$opt->{dirs}}; +#exit; + +find(\&doit, @{$opt->{dirs}}); +my @sufs; +for my $stem (keys %{$files}) { + +#print "$stem $files->{$stem}\n"; + @sufs = sort { $a <=> $b } @{$files->{$stem}}; + +#for (@sufs) { print "$stem.$_\n"; } + + my $to = $#sufs - $opt->{keep}; + my $from; + if ($to < 0) { $from = 0; } else { $from = $to + 1; } + +#print "$from $#sufs\n"; + + for (@sufs[0 .. $to]) { + print "Going to delete $stem.$_\n"; + warn "Couldn't unlink: $stem.$_: $!" unless unlink "$stem.$_"; + } + + for (@sufs[$from .. $#sufs]) { + print "Going to keep $stem.$_\n"; + } + +} + +=head1 NAME + +purge-proe - delete old Pro/Engineer files + +=head1 SYNOPSIS + +purge-proe [-d|--directory directory1] [-d|--directory directory2] ... + [-k|--keep n] + +purge-proe [-h|--help] + +purge-proe [-m|--man] + +=head1 OPTIONS + +=over + +=item B<-d>|B<--directory> directory + +A directory to clean. This option can be given multiple times. (default: +current directory) + +=item B<-k>|B<--keep n> + +Number of old files to keep. (default: 3) + +=back + +=head1 BUGS + +Probably. diff -r 000000000000 -r fcdba28f4b06 test --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test Mon May 17 13:47:47 2010 +0200 @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +my $purge_cmd = "./purge-proe"; + +my $stem = "a"; +my $subdir = "x"; +my $proe_first_line = "#UGC:"; +my $num_empty = 69; +my $num_non_proe = 101; +my @nums_before = (0, 1, 2, 7, 13, 17, 23, 42, '0815', 4711); + +use Test::Simple tests => 23; +#use Test::More tests => 23; + +my $files = { + + in_workdir => [ map "$stem.$_", @nums_before ], + in_subdir => [ map "$subdir/$stem.$_", @nums_before ], + empty => "$subdir/$stem.$num_empty", + non_proe => "$subdir/$stem.$num_non_proe" + +}; + +sub prepare; + +prepare({ dirs => [$subdir], files => $files, proe_first_line => $proe_first_line }); +ok(qx/$purge_cmd/, "Running '$purge_cmd'"); +my @iw = @{$files->{in_workdir}}; +my @is = @{$files->{in_subdir}}; + +for (@iw[$#iw-2 .. $#iw], @is[$#is-2 .. $#is], $files->{empty}, $files->{non_proe}) { ok(-f $_, "Checking for presence of file '$_'"); } +for (@iw[0 .. $#iw-3], @is[0 .. $#iw-3]) { ok(! -e $_, "Checking for absence of '$_'"); } + +for (@iw[$#iw-2 .. $#iw], @is[$#is-2 .. $#is], $files->{empty}, $files->{non_proe}, "y/abc") { unlink || warn "Can't unlink '$_': $!" if -f; } +rmdir $subdir or warn "Can't rmdir '$subdir': $!"; + +# $opts = { +# dirs => ['dir1', 'dir2', ..], +# files => { +# in_workdir => ['file1', 'file2', ..], +# in_subdir => ['path1', 'path2', ..], +# empty => 'path_to_an_empty_file', +# non_proe => 'path_to_a_nonempty_nonproe_file' +# }, +# proe_first_line => 'something that should appear in the first line of a file to match' +# } +sub prepare { + + my ($opts) = @_; + + for (@{$opts->{dirs}}) { mkdir $_ or warn "Can't mkdir '$_': $!"; } + + for (@{$opts->{files}->{in_workdir}}, @{$opts->{files}->{in_subdir}}) { + + open F, '>', $_ or warn "Can't open F, '>', '$_': $!"; + print F $proe_first_line; + close F; + + } + + my $empty = $opts->{files}->{empty}; + open F, '>', $empty or warn "Can't open F, '>', '$empty': $!"; + close F; + + my $non_proe = $opts->{files}->{non_proe}; + open F, '>', $non_proe or warn "Can't open F, '>', '$non_proe': $!"; + print F "foo"; + close F; + +}