#!/usr/bin/perl -w

=head1 NAME

debian-builder - Rebuild a Debian package from its source code.

=head1 SYNOPSIS

  debian-builder [options]

  Help Options:
   --debug    Show useful debugging information.
   --help     Show this scripts help information.
   --manual   Read this scripts manual.
   --version  Show the version number and exit.
   --verbose  Show verbose output.

  Building options:

   --sign         Force package signing, disabled by default.
   --debuild foo  Pass arguments 'foo' onto debuild when building
   --suffix  foo  Give the built package versions the suffix 'foo'.

=cut



=head1 OPTIONS

=over 8

=item B<--debug>
Show the commands this script executes as an aid to debugging.

=item B<--help>
Show the brief help information.

=item B<--verbose>
Show verbose information useful to debugging.

=back

=cut

=head1 DESCRIPTION

  debian-builder is a simple script which is designed to facilitate the
 rebuilding of a Debian GNU/Linux package from its source code.  It will
 correctly handle the installation of any required build-dependencies,
 and remove them once building is complete.

=cut

=head1 AUTHOR


 Steve
 --
 http://www.steve.org.uk/

 $Id: debian-builder,v 1.14 2006/06/04 18:24:04 steve Exp $

=cut


=head1 LICENSE

Copyright (c) 2005 by Steve Kemp.  All rights reserved.

This module is free software;
you can redistribute it and/or modify it under
the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut


use strict;
use diagnostics;
use File::Copy;
use File::Temp qw/ tempdir /;
use Getopt::Long;
use Pod::Usage;


use strict;
use File::Copy;
use Getopt::Long;

#
#  Version number
#
my $RELEASE = "1.5";



#
# Configuration files from the config file, or the command line.
#
our %CONFIG;

#
# The list of packages installed upon the system
#
our %INSTALLED;



#
#  Parse the global and per-user configuration files, if they exist.
#
parseOptions();


#
#  Allow command line to override configuration file(s)
#
parseCommandLineArguments();



#
#  Unless the user is specifying their own arguments then
# we will add '-us' '-uc' to the debuild command line to
# disable package signing.
#
#  Rationale: If the user wishes to do this they are capable
# of adding these two flags themselves.
#
if (! defined( $CONFIG{'debuild_args'} ) )
{
   $CONFIG{'debuild_args'} = "-uc -us";
}


#
# Remove from  the debuild arguments if the '--sign' flag was used.
#
if ( $CONFIG{'sign_deb'} )
{
    # Remove the '-uc' and '-us' arguments.
    $CONFIG{'debuild_args'} =~ s/-uc//g;
    $CONFIG{'debuild_args'} =~ s/-us//g;

    # Remove any leading and trailing space.
    $CONFIG{'debuild_args'} =~ s/^\s+//;
    $CONFIG{'debuild_args'} =~ s/\s+$//;

}


#
# Show the debuild arguments
#
if ($CONFIG{'verbose'})
{
    print "Arguments for debuild are '$CONFIG{'debuild_args'}'\n";
}


#
#  We assume that we are given the name of package(s) to build
#
my $package = undef;

#
#  Build each package specified on the command line.
#
while( $package = shift )
{
    buildPackage( $package );
}


#
#  All done.
#
exit;





=head2 buildPackage

   Do all the work of building the given package.

   Return '>0' on success, '0' on failure of any kind.  (The result is the
 number of binary files moved into the results directory.)

=cut

sub buildPackage
{
    my ($package) = ( @_ );

    $CONFIG{'verbose'} && print "Starting build of $package\n";


    #
    #  See if we need a to build a different source package
    # than that which we were given.
    #
    my $source = getSourcePackageName( $package );
    $package   = $source;


    #
    #  Get the package source, and clean it a little.
    #
    my $directory = getPackageSource( $package, $CONFIG{'build_dir'} );
    $CONFIG{'verbose'} && print "Source directory is $directory\n";


    #
    #  See which packages are already installed upon our host.
    #
    %INSTALLED = getInstalledPackages();


    #
    #  Install the build-dependencies for the package.
    #
    installBuildDependencies( $package );


    #
    # Patch up the changelog file to include the required suffix.
    #
    if ( defined( $CONFIG{'package_suffix'} ) && 
	 length( $CONFIG{'package_suffix'} ) )
    {
	updateChangeLog( $directory, $CONFIG{'package_suffix'} );
    }




    #
    # Build the .deb
    #
    my $log_dir = $CONFIG{'log_dir'};
    system( "cd $directory; \
             debuild $CONFIG{'debuild_args'} | tee $log_dir/$package.log" );


    #
    # Move the deb, then nuke the build directory.
    #
    # here is where we tell that something produced a .deb or
    # not.
    #
    my $result = 0;


    #
    # Directory where we move built packages to
    #
    my $bin_dir = $CONFIG{'binary_dir'};

    #
    # Clean the temporary directory where the build took blace.
    #
    system( "rm -rf $directory" );

    #
    # Move the built packages from the build directory to the
    # binary directory.
    #
    $result += saveDebianPackage( $CONFIG{'build_dir'}, $bin_dir );

    #
    #  Uninstall all added packages, returning the system to the
    # state it was in initially.
    #
    tidySystem();


    #
    #  All done.
    #
    return( $result );
}



#
#  Read the global configuration file, then override with the users
# file if present
#
sub parseOptions
{
    my $global = "/etc/debian-builder/debian-builder.conf";

    if ( -e $global )
    {
	$CONFIG{'verbose'} && print "Reading $global\n";
	&parseConfigurationFile( $global );
    }

    if ( -e $ENV{"HOME"} . "/.debian-builderrc" )
    {
	$CONFIG{'verbose'} && print "Reading ~/.debian-builderrc\n";
	&parseConfigurationFile( $ENV{"HOME"} . "/.debian-builderrc" ) ;
    }
}


#
#  Parse the named configuration file.
#
#  Set the global '%CONFIG' hash with the values we read.
#
sub parseConfigurationFile
{
  my ($FILE) = ( @_ );


  if ( ( ! -e $FILE )  && ( $CONFIG{'verbose'} ) )
  {
    print "Configuration file '$FILE' missing.\n";
    return;
  }

  open( FILY, "<$FILE" ) or die "Cannot open file: $FILE - $!";

  my $line       = "";
  my $fieldCount = -1;
  my $lineCount  = 0;

  while (defined($line = <FILY>) )
  {
    chomp $line;
    if ($line =~ s/\\$//)
    {
      $line .= <FILY>;
      redo unless eof(FILY);
    }

    # Skip lines beginning with comments
    next if ( $line =~ /^([ \t]*)\#/ );

    # Skip blank lines
    next if ( length( $line ) < 1 );

    # Strip trailing comments.
    if ( $line =~ /(.*)\#(.*)/ )
    {
      $line = $1;
    }

    # Find variable settings
    if ( $line =~ /([^=]+)=(.+)/ )
    {
      my $key = $1;
      my $val = $2;

      # Strip leading and trailing whitespace.
      $key =~ s/^\s+//;
      $key =~ s/\s+$//;
      $val =~ s/^\s+//;
      $val =~ s/\s+$//;

      # Store value.
      $CONFIG{ $key } = $val;

      if ( $CONFIG{'verbose'} )
      {
	  print "Set: '$key' -> '$val'\n";
      }
    }
  }

  close( FILY );
}



=head2 parseCommandLineArguments

  Parse any command line arguments, and set the appropriate values
 in the global CONFIG hash.

=cut

sub parseCommandLineArguments
{
    my $HELP	= 0;
    my $MANUAL	= 0;
    my $VERSION	= 0;

    GetOptions(
	        "verbose",    \$CONFIG{'verbose'},
		"debuild=s",  \$CONFIG{'debuild_args'},
	        "suffix=s",   \$CONFIG{'package_suffix'},
		"sign",       \$CONFIG{'sign_deb'},
	        "help",       \$HELP,
	        "manual",     \$MANUAL,
	        "version",    \$VERSION
	      );

    pod2usage(1) if $HELP;
    pod2usage(-verbose => 2 ) if $MANUAL;

    if ( $VERSION )
    {
	my $REVISION      = '$Revision: 1.14 $';

	if ( $REVISION =~ /1.([0-9.]+) / )
	{
	    $REVISION = $1;
	}

	print "debian-builder release $RELEASE - CVS: $REVISION\n";
	exit;
    }
}



=head2 getSourcePackageName

  Return the name of the source package required to build package 'foo'

=cut

sub getSourcePackageName
{
    my ($package) = ( @_ );

    $CONFIG{'verbose'} && print "Finding source package for '$package'\n";

    my $available = "/var/lib/dpkg/available";

    my $found  = 0;
    my $source = $package;

    open( AVAIL, "<" . $available );
    while( my $line = <AVAIL> )
    {
	if ( $line =~ /^Package: (.*)/ )
	{
	    my $pkg = $1;
	    if ( $pkg eq $package )
	    {
		$found =1;
	    }
	}

	if ( $line =~ /Source: (.*)/ )
	{
	    if ( $found  )
	    {
		$source = $1;
	    }
	}
	if ( length( $line  ) < 2)
	{
	    $found = 0;
	}

    }
    close( AVAIL );

    if ( $source =~ /(.*) (.*)/ )
    {
	$source = $1;
    }

    $CONFIG{'verbose'} && print "Found: $source\n";

    return( $source );
}



=head2 getPackageSource

  Download the source of the package to the specified directory
 and return the name of the unpacked directory.

=cut

sub getPackageSource
{
    my( $package, $directory ) = ( @_ );

    die "The directory '$directory' doesn't exist!" unless ( -d $directory );

    #
    # Get the source, and remove the .dsc + .diff.gz files.
    #
    system( "cd $directory ; \
             apt-get source $package && \
             rm $package*.dsc &&
             rm $package*.diff.gz" );

    #
    #  Change to the directory which contains the unpacked code.
    #
    opendir( DIR, $directory );
    my $work = "";
    foreach my $ent ( readdir( DIR ) )
    {
	# Skip dotfiles.
	next if ( $ent =~ /^\./ );

	#
	# If we find a directory with the name of our package
	# that is the right one.
	#
	if ( ( -d $directory . "/" . $ent ) &&  ( $ent =~ /$package/ ) )
	{
	    $work = $directory . "/" . $ent;
	}
    }
    closedir( DIR );

    return( $work );
}



=head2 updateChangeLog

  If the Debian changelog file doesn't already refer to the specified
 version then add it.

=cut

sub updateChangeLog
{
    my ( $directory, $suffix ) = ( @_ );

    die "No Debian changelog in $directory" unless ( -e $directory . "/debian/changelog" );

    #
    #  Read the changelog
    #
    open( CHANGE, "<", $directory . "/debian/changelog" ) or die "Failed to read changelog : $!";
    my @LINES = <CHANGE>;
    close( CHANGE );

    #
    # Look for the current version.
    #
    if ($LINES[0] =~ /$package \(([^\)]+)\) (.*)/ )
    {
	my $ver = $1;
	if ( $ver =~ /$suffix/ )
	{
	    # Contains the 'ssp' marker already...
	    $CONFIG{'verbose'} && print "Package already has the suffix '$suffix': " . $LINES[0] . "\n";
	}
	else
	{
	    $LINES[ 0 ] = $package . " (" . $1 . $suffix . ") " . $2;
	    $CONFIG{'verbose'} && print "Package has new version: " . $LINES[0] . "\n";
	}
    }

    #
    # Store the update changelog.
    #
    open( CHANGE, ">", $directory . "/debian/changelog" ) or die "Unable to open the Debian changelog for writing - $!";
    foreach my $line ( @LINES )
    {
        print CHANGE $line;
    }
    close(CHANGE);
}



=head2 saveDebianPackage

  Move the build Debian package, associated .diff.gz file, .changes file,
 etc.  From the build directory into the binary directory.

  Return the number of files moved into the binary directory.

=cut

sub saveDebianPackage
{
    my ( $source, $dest ) = ( @_ );

    my $result = 0;


    opendir( DIR, $source );
    foreach my $entry ( readdir( DIR ) )
    {
	#
	#  Skip dotfiles.
	#
	next if ( $entry =~ /^\./ );

	#
	# Complete path to the file we're moving.
	#
	my $file = $source . "/" . $entry;

	if ( ( $file =~ /\.deb$/ )  ||
	     ( $file =~ /\.changes$/ )  ||
	     ( $file =~ /\.asc$/ ) ||
	     ( $file =~ /\.dsc$/ ) ||
	     ( $file =~ /\.diff.gz$/ ) ||
	     ( $file =~ /\.build$/ ) ||
	     ( $file =~ /\.tar.gz$/ ) )
	{
	    $CONFIG{'verbose'} && print "Moving file : $file - $dest\n";
	    File::Copy::move( $file, $dest );
	    $result ++;
	}
	else
	{
	    $CONFIG{'verbose'} && print "Removing file .. $file\n";
	    unlink( $file );
	}
    }
    closedir( DIR );

    return( $result );
}



=head2 tidySystem

  Uninstall all the build dependency packages we installed.

  We do this by finding the list of all packages which are currently
 installed and removing those that were not present when we started.

=cut

sub tidySystem
{
	if( not scalar(%INSTALLED) ) {
		return;
	}
	my %NEW = getInstalledPackages();
	my @removals;
	foreach my $package ( sort keys %NEW )
	{
		if ( ! $INSTALLED{ $package } )
		{
			push @removals, $package;

			$CONFIG{'verbose'} && print "Need to remove package : $package\n";
		}
	}
	removePackages( @removals );
}




=head2 getInstalledPackages

  Return a hash of all the currently installed packages.

=cut

sub getInstalledPackages
{
    #
    #  This command will display all the packages installed upon 
    # the current host.
    #
    my $command = "COLUMNS=200 dpkg --list | grep ^ii | awk '{print \$2}' | sort -u";

    #
    #  Run the command and store each package name.
    #
    open( STATUS, $command . " |" ) or die "Cannot run package query command '$command' - $!";

    my %INSTALLED;
    foreach my $line ( <STATUS> )
    {
	chomp( $line );
	$INSTALLED{$line} = 1;
    }
    close( STATUS );

    return( %INSTALLED );
}



=head2 installBuildDependencies

  Install the build-dependencies required to build the given package.

=cut

sub installBuildDependencies
{
    my ($package) = ( @_ );

    my $apt_install = qq(/usr/bin/apt-get -y -q -q build-dep -o "DPkg::Options::=--force-confold");

    system( $apt_install . " " . $package );
}



=head2 removePackages

  Remove the given array of packages from the system.

=cut

sub removePackages
{
    my ( @packages ) = ( @_ );

    if ( scalar( @packages) > 0 )
    {
	my $command = join(" ", "dpkg --purge", @packages, "2>/dev/null");

	$CONFIG{'verbose'} && print "Running: $command \n";

	system( $command );
    }
    else
    {
	$CONFIG{'verbose'} && print "No packages to remove.\n";
    }
}



=head2 END

  Desperately try to reset the host system to the same starting point
 as it initially had.

  This should be taken care of in situations where the script doesn't
 abort on an error condition.

=cut

sub END
{
    $CONFIG{'verbose'} && print "Running END\n";
    $CONFIG{'verbose'} = 1;
    tidySystem();
}
