--- /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 <http://www.gnu.org/licenses/>.
+#
+#    Matthias Förste <foerste@schlittermann.de>
+
+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 = <FILE>;
+  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.

--- /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;
+
+}