#!/usr/bin/perl
# -*- perl -*-

=head1 NAME

apt-unstable - APT package handling utility -- wrapper script

=head1 SYNOPSIS

apt-unstable [options] [command] [package...]

=head1 DESCRIPTION

F<apt-unstable> is the wrapper script to use unstable packages on a
stable system.  When this script is called, it executes F<apt-get> or
F<apt-cache> with some additional appropriate options.

I<command> is one of:

=over 4

=item * update

=item * source

=item * check

=item * clean

=item * search

=item * show

=back

These commands are equivalent to commands of F<apt-get> and
F<apt-cache>.

=head1 OPTIONS

=over 4

=item -n

Prints real command.

=item -v, --version

Prints the version of this script.

=item --revision STRING

Sets C<STRING> as the local revision string.

=back

F<apt-unstable> accepts other options and passes them to F<apt-get> or
F<apt-cache> without the C<--config> option to specify a configuration
file.

=head1 ENVIRONMENT

=over 4

=item DEBEMAIL, EMAIL

It will be used as the maintainer/uploader's email address in any new
changelog sections created.  If both are set, DEBEMAIL will take
precedence.  If neither is set, F<apt-unstable> will do nothing to
update changelog.

=item DEBFULLNAME

The maintainer/uploader's full name to be used in new changelog
sections.  If unset, F<apt-unstable> will do nothing to update
changelog.

=back

=head1 FILES

=over 4

=item HOME/.apt-unstable/

The root of hierarchy of configuration files and working files.

=item HOME/.apt-unstable/etc/apt.conf

Alternative F</etc/apt/apt.conf>.

=item HOME/.apt-unstable/etc/sources.list

Alternative F</etc/apt/sources.list>.

=back

=head1 SEE ALSO

F<apt-get>(1), F<apt-cache>(1), F<apt.conf>(5), F<sources.list>(5)

=head1 TODO

=over 4

=item * install

Improvement to accept C<install> command is needed.  But, I have no
idea to decide which package have to be re-packaged in packages which
the requested package depends.

=item * upgrade

I think that C<upgrade> command to upgrade local packages which are
generated with F<apt-unstable> is also usefull.

=back

=head1 AUTHOR

TSUCHIYA Masatoshi <tsuchiya@namazu.org>

=head1 COPYRIGHT

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 GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING.  If not, write to the
Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=cut

use strict;
use File::Path qw/ mkpath /;
use File::Basename qw/ dirname basename /;
use File::Copy qw/ copy /;
use IO::Handle;
use IO::Pipe;


### Configuration Variables:
my $CONFDIR  = sprintf( "%s/.apt-unstable", $ENV{'HOME'} );
my $PROFILE  = "$CONFDIR/etc/apt.conf";

my $IDENT    = sprintf( 'local+%s', $ENV{'HOSTNAME'} );
my $BUILD    = 0;
my @BUILDOPT = ( '-us', '-uc', '-rfakeroot' );

my %COMMAND  = ( 'update' => [ 'apt-get', '-c', $PROFILE, ],
		 'source' => [ 'apt-get', '-c', $PROFILE, '--no-compile' ],
		 'check'  => [ 'apt-get', '-c', $PROFILE, ],
		 'clean'  => [ 'apt-get', '-c', $PROFILE, ],
		 'search' => [ 'apt-cache', '-c', $PROFILE, ],
		 'show'   => [ 'apt-cache', '-c', $PROFILE, ] );

my $VERSION  = sprintf( '0.%d.%d', q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/ );


### Code:
&main( @ARGV );


sub main {
    my( @argv ) = @_;

    my $scheme;
    my $debug;
    my $build = -1;
    my @option;
    while( $_ = shift @argv ){
	if( $_ eq '-n' ){
	    $debug = 1;
	} elsif( /^-(?:v|-version)$/ ){
	    printf( "%s %s\n", basename($0), $VERSION );
	    exit 1;
	} elsif( $_ eq '--revision' ){
	    $IDENT = shift @argv;
	} elsif( /^--revision=(.*)/ ){
	    $IDENT = $1;
	} elsif( /^-(?:b|-(?:compile|build))$/ ){
	    $build = 1;
	} elsif( /^-(?:-no-(?:b(?:uild)?|compile)|(?:b|-(?:compile|build))=no)/ ){
	    $build = 0;
	} elsif( /^-c(?:onfig-file)?$/ ){
	    die "Can't specify path of configuration file.\n";
	} else {
	    if( defined $COMMAND{$_} ){
		$scheme = $_;
		last;
	    }
	    push( @option, $_ );
	}
    }
    die "Can't detect scheme.\n" unless $scheme;

    push( @option, '-q' ) if $ENV{'TERM'} =~ /^(?:dumb|emacs)$/;

    my @command;
    push( @command, @{$COMMAND{$scheme}} );
    push( @command, @option );
    push( @command, $scheme );
    push( @command, @argv );

    if( $debug ){
	print join( " ", @command ), "\n";
    } else {
	&make_profile();
	&read_profile();
	$build >= 0 or $build = $BUILD;
	system @command;
	$scheme eq 'source' and grep( &update_changelog( $_, $build ), @argv );
    }
}


sub update_changelog {
    my( $package, $build ) = @_;

    my $tarball = &get_source_tarball( $package );
    my( $src_package, $src_version ) =
	( $tarball =~ /^([^_]+)_(.*?)\.(?:orig\.)?tar\.gz$/ );
    ( $src_package and $src_version )
	or die "Can't parse tarball's file name($tarball).\n";

    &add_changelog_entry( $src_package, $src_version );

    if( $build ){
	if( chdir sprintf( '%s-%s', $src_package, $src_version ) ){
	    system 'dpkg-buildpackage', @BUILDOPT;
	    chdir '..';
	}
    }
}


sub add_changelog_entry {
    my( $package, $upstream_version ) = @_;

    my $changelog = "$package-$upstream_version/debian/changelog";
    open( F, "< $changelog" ) or die "Can't open file($changelog) to read: $!\n";
    my( @buf ) = <F>;
    close F;

    unshift( @buf, &generate_changelog_entry( $changelog ) );

    open( F, "> $changelog" ) or die "Can't open file($changelog) to write: $!\n";
    print F @buf;
    close F;
}


sub generate_changelog_entry {
    my( $changelog ) = @_;

    my %changelog;
    for( &call_process( 'dpkg-parsechangelog', "-l$changelog" ) ){
	chomp;
	/^([^:]+):\s+(.*)/ and $changelog{lc($1)} = $2;
    }
    my $source = $changelog{source} || die "Can't detect package's source name.\n";
    my $version = $changelog{version} || die "Can't detect package's current version.\n";
    my $distribution = $changelog{distribution} || die "Can't detect package's distribution.\n";
    my $urgency = $changelog{urgency} ||  die "Can't detect package's urgency.\n";

    my $pat = sprintf( '%s', quotemeta $IDENT );
    my $local_version = ( $version =~ s/$pat(\d+)$// ) ? $1 : 0;

    my $num;
    if( $version =~ s/^([^-]+)-(.*)/$1/ ){
	$2 =~ /^(.*?)([1-9]+)[^1-9]*$/;
	$version = sprintf( "%s-%s", $version, $1 );
	$num = $2;
    } else {
	$version =~ s/^(.*?)([1-9]+)[^1-9]*$/$1/;
	$num = $2;
    }

    $version = sprintf( "%s%s%s%d",
			$version,
			( $local_version ? $num : sprintf( "%d.9", $num - 1 ) ),
			$IDENT,
			$local_version + 1 );

    defined( $ENV{'DEBFULLNAME'} )
	or die "Can't detect re-packager's name, set DEBFULLNAME environment.\n";
    my $packager = $ENV{'DEBFULLNAME'};

    defined( $ENV{'DEBEMAIL'} ) or defined( $ENV{'EMAIL'} )
	or die "Can't detect re-packager's mail address, set DEBEMAIL or EMAIL environment.\n";
    my $email = $ENV{'DEBEMAIL'} || $ENV{'EMAIL'};

    my $date = `822-date`;
    die "Can't get date." unless $date;

    my $s = sprintf( "%s (%s) %s; urgency=%s\n\n" .
		     "  * Re-packaging for local use.\n\n".
		     " -- %s <%s>  %s\n",
		     $source, $version, $distribution, $urgency,
		     $packager, $email, $date );
    print $s;
    $s;
}


# Function to get file name of source tarball of the specified package.
sub get_source_tarball {
    my( $package ) = @_;
    for my $s ( &call_process( 'apt-get', '-c', $PROFILE, '-q',
			       '--print-uris', 'source', $package ) ){
	if( $s =~ s/^'[^\']*'\s+// ){
	    $s =~ s/^(\S+)\s.*/$1/;
	    $s =~ /\.tar\.gz$/ and return $s;
	}
    }
    undef;
}


sub call_process {
    my( @argv ) = @_;

    my $read = new IO::Pipe;
  FORK: {
	if( my $pid = fork ){
	    # Parent process.
	    $read->reader;
	} elsif( defined $pid ){
	    # Child process.
	    $read->writer;
	    STDOUT->fdopen( $read, "w" );
	    STDERR->fdopen( $read, "w" );
	    STDIN->close();
	    exec @argv;
	    exit 0;
	} elsif( $! =~ /No more process/ ){
	    sleep 5;
	    redo FORK;
	} else {
	    die "Can't fork: $!\n";
	}
    }

    my( $s, $t );
    while( defined( $s = $read->getline() ) ){
	$t .= $s;
    }
    split( /\n/, $t );
}


sub read_profile {
    open( F, "< $PROFILE" ) or die "Can't open file($PROFILE) to read: $!\n";
    while( <F> ){
	/^\s*Apt::Get::Compile\s+"(false|true)";/
	    and $BUILD = ( $1 eq 'true' );
	/^\s*DPkg::Build-Options\s+"([^\"]*)";/
	    and @BUILDOPT = split( /\s+/, $1 );
    }
    close F;
}


sub make_profile {
    my $mode         = 0777 ^ umask;
    my $etc_dir      = dirname( $PROFILE );
    my $cache_dir    = "$CONFDIR/cache";
    my $state_dir    = "$CONFDIR/state";
    my $status_file  = "$CONFDIR/status";
    my $sources_file = "$etc_dir/sources.list";

    mkpath( $etc_dir, 0, $mode );
    mkpath( "$cache_dir/archives/partial", 0, $mode );
    mkpath( "$state_dir/lists/partial", 0, $mode );

    unless( -f $PROFILE ){
	my @buf;
	open( F, "apt-config dump 2>&1 |" ) or die;
	while( <F> ){
	    /^\s*Dir::(?:Etc|Cache|State(?:::status)?)\s/
		or push( @buf, $_ );
	}
	close F;

	push( @buf, "Dir::Etc \"$etc_dir/\";\n" );
	push( @buf, "Dir::Cache \"$cache_dir/\";\n" );
	push( @buf, "Dir::State \"$state_dir/\";\n" );
	push( @buf, "Dir::State::status \"$status_file\";\n" );

	open( F, "> $PROFILE" ) or die "Can't open file($PROFILE) to write: $!\n";
	print F @buf;
	close F;
    }

    unless( -f $sources_file ){
	my @buf;
	open( F, "< /etc/apt/sources.list" ) or die;
	while( <F> ){
	    my( $method, $path, $dist, $comp ) = split( /\s+/, $_, 4 );
	    unless( $path =~ m!^http://security.debian.org/$! ){
		$dist =~ s/^(?:(?:un)?stable|potato|woody|sarge)/unstable/
		    and push( @buf, "$method $path $dist $comp" );
	    }
	}
	close F;

	my %tag;
	open( F, "> $sources_file" ) or die "Can't open file($sources_file) to write: $!\n";
	for( @buf ){
	    unless( defined $tag{$_} ){
		print F $_;
		$tag{$_}++;
	    }
	}
	close F;

	print STDERR "$sources_file is generated automatically based on /etc/apt/sources.list.";
    }

    unless( -f $status_file ){
	my $file = '/var/lib/dpkg/status';
	open( F, "apt-config dump 2>&1 |" ) or die;
	while( <F> ){
	    /^\s*Dir::State::status\s+"(.*?)";/ and $file = $1, last;
	}
	close F;

	copy( $file, $status_file )
	    or die "Can't copy file($file -> $status_file): $!\n";
    }
}