#! /usr/bin/perl -w
# deb-moveold - clean a local Debian mirror of obsolete packages
# Copyright (C) 1999 Michael Weber <michael.weber@post.rwth-aachen.de>

use strict;
use Getopt::Long;
use File::Path;
use File::Copy;
use File::Spec;
use File::Basename;

my $rcs_id = '$Id: deb-moveold.pl,v 1.8 1999/08/27 11:38:52 michaelw Exp $';
my $program_version = "1.0";

=head1 NAME

deb-moveold - clean a local Debian mirror of obsolete packages

=cut

=head1 SYNOPSIS

=over 4

=item
B<deb-moveold> 
[S<B<-a>|B<--attic> F<directory>>]
[S<B<-p>|B<--prune> {B<a>|I<depth>}>]
[B<-s>|B<--dry-run>]
[B<-v>] [B<--verbose>=I<N>]
[B<-l>|B<--loggable>]
[B<-f>|B<--printZ<>-failed>]

=item
B<deb-moveold> 
[B<-d>|B<--delete>]
[B<-s>|B<--dry-run>] 
[B<-v>] [B<--verbose>=I<N>]
[B<-l>|B<--loggable>]
[B<-f>|B<--print-failed>]

=item
B<deb-moveold> B<-V>|B<--version>

=item
B<deb-moveold> B<-h>|B<--help>

=back

=cut

=head1 DESCRIPTION

B<dpkg-moveold> checks Debian packages in a directory tree. If there are
several package files, just differing in version numbers, only the latest
package is left there. All outdated package files are moved (or, by request,
deleted).

This is especially useful, if you occasionally download packages, but also
want to install them via I<apt(8)>. You have to create a F<Packages.gz>
database with I<dpkg-scanpackages(1)> and the latter would bail out, if
there are duplicate packages.

B<deb-moveold> itself does not depend on a F<Packages> file or an internet
connection to work properly.

I<dpkg(1)> is utilized for comparing the version numbers of two packages.

=cut

=head1 OPTIONS

=over 4

=item B<-h, --help>

Print a brief option summary, then exit successfully.

=item B<-V, --version>

Print version number, then exit successfully.

=item B<-s, --dry-run> 

Make this run a dry-run. Don't really delete/move/create files or
directories.

=item B<-v, --verbose I<N>>

Be verbose. Adding B<-v> option several times will increase verbosity.
Default is verbosity I<N>=1.

=item B<-l, --loggable>

Generate loggable output. No progress messages.

=item B<-f, --print-failed>

Print list of packages, that for some reason couldn't be deleted/moved.

=item B<-d, --delete>

Delete obsolete files instead of moving them. NOTE: options B<-a> and B<-p>
are ignored, if this option is given.

=item B<-p, --prune> {B<a>|I<depth>}

Prunes I<depth> (or all with B<a>) sections of the path, just as I<patch(1)>
does. Default is I<depth>=1.

=item B<-a, --attic> F<directory>

Specify attic directory (default is F<Attic/>). Here the old files are moved
to.

=back

=cut

## Defaults ###################################################################
my $attic           = "Attic";
my $prune           = 1;
my $no_act          = 0;
my $verbose         = 1;
my $verbose_incr    = 0;
my $progress        = 1;
my $remove          = 0;
my $print_failed    = 0;
my $print_help      = 0;
my $usage_info      = '';
my $version_info    = '';
my $print_version   = 0;

$version_info = <<END_OF_VERSIONINFO;
deb-moveold $program_version - clean a local Debian mirror of obsolete packages
Copyright (C) 1999 Michael Weber <michael.weber\@post.rwth-aachen.de>

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 2, 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 file /usr/doc/copyright/GPL for
more details.
$rcs_id 
END_OF_VERSIONINFO

$usage_info = <<END_OF_USAGE;
Usage: deb-moveold [OPTION] ...
where options are:
    -h, --help              Print this help.
    -V, --version           Print version, then exit.
    -v                      Increase verbosity.
        --verbose=N         Set verbosity.
	                    [N=1]
    -l, --loggable          Produce loggable output (no progress meter).
    -f, --[no]print-failed  Print list of failed packages.
    -s, --dry-run           Pretend to create/delete/move files and dirs.
    -d, --delete            Delete files instead of moving them.
    -p, --prune=N           Prune parts of the directory name.
                            [N=1]
    -a, --attic=DIR         Location, where new files are moved to.
                            [DIR=$attic/]
END_OF_USAGE

## Options processing ########################################################

Getopt::Long::Configure ("no_ignore_case","no_auto_abbrev","bundling");
my $options_ok = GetOptions( 
        "version|V"       => \$print_version,
	"help|h"          => \$print_help,
	"verbose=i"       => \$verbose,
	"v+"              => \$verbose_incr,
	"loggable|l"      => \$progress,
	"print-failed|f"  => \$print_failed,
	"dry-run|s"       => \$no_act,
	"delete|d"        => \$remove,
	"prune|p=s"       => \$prune,
	"attic|a=s"       => \$attic
   );

if ( $print_help ) {
	print $version_info;
	print "\n",$usage_info;
	exit 0;
}
if ( $print_version ) {
	print $version_info;
	exit 0;
}

$prune = do {
	if    ( $prune eq 'a' )     { -1 }
	elsif ( $prune =~ /^\d+$/ ) { $prune }
        else  { print "option `-p|--prune' requires numeric argument or `a'\n"; 
	        $options_ok = 0; 
        }
};

$verbose += $verbose_incr;

die $usage_info unless $options_ok;

## Get file from STDIN #######################################################
my @scanpkg = sort { $a->{filename} cmp $b->{filename} } 
                   map { chomp; { dirname=>dirname($_), filename=>basename($_) } } <STDIN>;
my $num_packages  = scalar @scanpkg;

##############################################################################
## Main ######################################################################

my $pkg_count     = 0;
my $nopkg_count   = 0;
my $pkg_moved     = 0;
my @pkg_failed    = ();
## here the newest version of a package is stored ############################
my $newest= { dir => '', filename => '', package => '', version => '', arch => undef };

print STDERR "[ deb-moveold in DRY-RUN mode ]\n" if $no_act;

for (@scanpkg) {
	## get info about current package ####################################
	my $current = do {
		my $dir  = $_->{dirname};
		my $file = $_->{filename};
		my ($package, $version, $maybe_arch);
	
		## Check package name and derive version number from it ######
		my $tmpfile = $file;
		unless ( $tmpfile =~ s@\.deb$@@
		       && ( ($package, $version, $maybe_arch) = split( /_/, $tmpfile ) )
		       && defined $package
		       && defined $version
		       ) {
			       $nopkg_count++;
			       next;
		}

		{ dir      => $dir,
		  filename => $file,
		  package  => $package,
		  version  => $version,
		  arch     => $maybe_arch
		}
	};
		      
	## Progress meter ####################################################
	$pkg_count++;
	my $perc = 100 * ($pkg_count + $nopkg_count)/$num_packages;
	printf STDERR "[ Processing package %4d (%3d%% ready) ]\r", $pkg_count, $perc if $progress;

	## Only compare packages, that are of the same program ###############
	if ( $current->{package} eq $newest->{package} ) {
		## Utilize dpkg(1) to compare versions #######################
		system ("dpkg","--compare-versions", $newest->{version}, "lt", $current->{version});
		my ($rec) = do {
			if ( $? == 0 ) {
				## Current package is newer ##################
				my $tmp = $newest;
				$newest = $current;
				$tmp;
			} else {
				my $exitval    = $? >> 8;
				my $signal     = $? & 127;
				my $coredumped = $? & 128;
			
				if ( $signal ) {
					die "\ndeb-moveold: aborted with signal " . $signal . "\n";
				} elsif ( $coredumped ) {
					die "\ndeb-moveold: Huh? dpkg dumped core?\n";
				} elsif ( $exitval == 1 ) {
				        ## Current package is older ##########
					$current;
				} else {
					die "\ndeb-moveold: dpkg failed with exitcode " . $exitval . "\n";
				}
			}
		};
		$pkg_moved++;
		&do_move( $rec, $newest->{version}, \@pkg_failed );
	} else {
		$newest = $current;
	}
}

## Print statistics ##########################################################
# printf STDERR "                                        \n" if $verbose;
if ( $verbose ) {
	printf STDERR "Total:     %4d                          \n", $num_packages;
	printf STDERR "Processed: %4d\n", $pkg_count;
	printf STDERR "  %-8s %4d\n", $remove ? "Deleted:" : "Moved:", $pkg_moved if $pkg_moved;
	printf STDERR "  failed:  %4d\n", scalar @pkg_failed if scalar @pkg_failed;
	if ( $print_failed && scalar @pkg_failed ) {
		print STDERR "\nA list of failed packages follows:\n";
		for( @pkg_failed ) {
			print STDERR $_,"\n";
		}
	}
}

=head1 RETURN VALUES

B<deb-moveold> returns 0 on success and 1, if there are failed packages. On
fatal errors, the program dies with an error message and an exit
code greater than 1.

=cut

## Exit program ##############################################################
exit 1 if scalar @pkg_failed;
exit 0;


##############################################################################
## Subroutine to really delete/move files ####################################
sub do_move ()
{
	my ($p, $kept_version, $failed) = @_;
	$p->{dir}  = File::Spec->canonpath( $p->{dir} );
	my $source = File::Spec->catfile( $p->{dir}, $p->{filename} );
	
	if ($remove) {
		## Delete files instead of moving them #######################
		print "removing $source (keeping $kept_version)... " if $verbose > 1;
		if ( $no_act || unlink $source ) {
			print "done.\n" if $verbose > 1;
		} else {
			die "\ndeb-moveold: failed removing `$source': $!\n";
	       	}
	} else {
		## Move file to new location in Attic ########################
	        my @dir = split ( /\//, $p->{dir} );
		
		## Prune directories if wished ###############################
		my ($dir) = do { 
			if ( $prune < 0 ) {
				$attic; 
			} else {
				splice( @dir, 0, $prune );
				File::Spec->canonpath( File::Spec->catdir( $attic, @dir ) );
			}
		};
		my $dest =  File::Spec->catfile( $dir, $p->{filename} );

		## create dir, if necessary ##################################
		unless ( -d $dir ) {
			print "dir `$dir' does not exist. attempt to create it... " if $verbose  > 2;
			mkpath( $dir, 0 ) unless ( $no_act );
			print "done.\n" if $verbose > 2;
		}
	
		print "moving ".$p->{package}."(".$p->{version}.") to $dest (keeping $kept_version)... " if $verbose > 1;
		if ( $no_act || move( $source, $dest ) ) {
			print "done.\n" if $verbose > 1;
		} else {
			push @$failed, $source;
			print "failed: $!\n" if $verbose > 1;
	       	}
	}
}

__END__

=head1 EXAMPLES

=head2 C<find debian/ -type f | dpkg-moveold>

All files (with correct Debian package names) in the directory F<debian/>
and its subdirectories are checked; packages, for which there is a newer
version available, are moved to F<Attic/>. The directory structure is
mirrored, i.e. if there is an obsolete package
F<debian/unstable/binary-all/foo_0.9-1.deb>

it would be moved to

F<Attic/unstable/binary-all/foo_0.9-1.deb>

=head2 C<find debian/ -name \*.deb | dpkg-moveold -pa --verbose=0>

Same as above, but obsolete files are moved to F<Attic/>, not preserving the
directory structure (i.e. flat). Statistics at the end of the run are NOT
printed.

=head2 C<find /opt/mirrors/debian/unstable/ -name \*.deb | dpkg-moveold -f -p4 -a debian-OLD>

Obsolete packages are moved to F<debian-OLD/unstable/...> and the filenames
of failed packages are printed at the end of the run.

Note, that you have to use B<-p4> to prune 
F</opt/mirrors/debian/unstable/> to 
F<unstable/>, because of the absolute path (exactly like I<patch(1)> does).
You almost always want to use the B<-p> option with absolute paths.

=head2 C<find /opt/mirrors/debian/ -name \*.deb | dpkg-moveold -sdvvf>

Do a dry-run, delete packages instead of moving, be verbose and print the
filenames of packages that failed.

=head2 C<find debian/ -name \*.deb | dpkg-moveold -f && find Attic/ -name \*.deb | dpkg-moveold -dvf>

Move old packages of the F<debian/> tree to F<Attic/> (preserving the
directory structure of F<debian/>), then clean the F<Attic/> of
duplicate (modulo version) packages. You end up with only the latest
packages in F<debian/> and fallback packages (second-to-latest versions) in
F<Attic/>.

After that, running I<dpkg-scanpackages(1)> at F<debian/> might be a good
idea, to make your local mirror usable by I<apt(8)>.

=head2 C<ls /var/cache/apt/archives/*.deb | dpkg-moveold -dvvf>

Clean I<apt(8)>'s cache directory.

=head2 C<debuild && (cd .. ; ls *.deb | dpkg-moveold -aOLD -pa )>

Clean up old packages after a completed build, keep them in F<OLD/>.

=cut

=head1 CAVEATS

=over 4

=item * When using absolute paths you have to increase the argument of prune
by one: B<-p1> prunes
F</opt/mirrors/debian/> to 
F<opt/mirrors/debian/>

because of the absolute path. On the other hand, B<-p1> with
F<opt/mirrors/debian/> would lead to
F<mirrors/debian/>.

=item * Don't let B<deb-moveold> traverse through different architecture's
subdirs. It will happily count these files as duplicates, which is obviously
the Wrong Thing(tm).

=item * Directories are created without asking.

=item * Files may be overwritten without asking.

=back

=cut

=head1 RESTRICTIONS

=over 4

=item * Currently, only Debian binary packages (suffix F<.deb>) are handled
(for example, with filenames produced by B<dpkg-name>).

=item * A package's architecture is ignored. See B<CAVEATS>.

=back

=cut

=head1 SEE ALSO

L<dpkg(1)>, L<dpkg-name(1)>, L<dpkg-scanpackages(1)>, L<apt(8)>, L<patch(1)>

=cut

=head1 COPYRIGHT

Copyright (C) 1999 Michael Weber <michael.weber@post.rwth-aachen.de>

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 2, 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 file /usr/doc/copyright/GPL for
more details.

=cut