package DPKG::Make;

# Scott Harrison

# In order to view the documentation internal to this module,
# please type    "perldoc ./Make.pm"

use vars qw(
	    $VERSION
	    );

$VERSION='0.1';

# ----------------------------------------------------- Plain Old Documentation

=pod

=head1 NAME

DPKG::Make - cleanly generate an Debian package (.dpkg)

=head1 SYNOPSIS

    use DPKG::Make;

    # The "Manifest": list of files that will comprise the software package.
    my @filelist=('tmproot/file1.txt',
		  'tmproot/file2.txt',
		  'tmproot/file3.txt',
		  'tmproot/file4.txt');

    my %doc; my %conf; my %metadata;

    # Define special handling of files.
    $doc{'tmproot/file1.txt'}=1;
    $conf{'tmproot/file2.txt'}=1;

    # Bare minimum metadata (descriptive data of the software package).
    my $pathprefix='tmproot';
    my $tag='test'; # cannot use uppercase characters
    my $version='0.1';
    my $release='1';

    # Highly descriptive metadata.
    %metadata=(
	       'vendor'=>'Excellence in Perl Laboratory',
	       'summary'=>'a Test Software Package',
	       'name'=>$tag,
	       'copyrightname'=>'...',
	       'group'=>'base',
	       'AutoReqProv'=>'no',
	       'requires=>[()],
	       'email'=>'joe@somewhere.com',
	       'description'=>'This package is generated by DPKG::Make. '.
                      'This implements the '.$tag.' software package',
        'pre'=>'echo "You are installing a package built by DPKG::Make; '.
                      'DPKG::Make is available at http://www.cpan.org/."',
 	       );

    # Temporary "sandbox" (this should not be /tmp because this is deleted!).
    my $buildloc='TempBuildLoc';

    # The "execute" subroutine coordinates all of the DPKG building steps.
    DPKG::Make::execute($tag,$version,$release,$arch,$buildloc,$pathprefix,
		       \@filelist,\%doc,\%conf,
		       \%metadata);

    # You can also build a DPKG in more atomic steps; these three smaller
    # steps are equivalent to the execute command.

    # Step 1: Generate the rpm source location.
    DPKG::Make::dpkgsrc($tag,$version,$release,$arch,$buildloc,$pathprefix,
 	              \@filelist,\%doc,\%conf,
		      \%metadata);

    # Step 2: Build the rpm and copy into the invoking directory.
    DPKG::Make::compiledpkg($buildloc,$metadata{'name'},$version,
			  $release,$arch,
			  $currentdir,$invokingdir);

    # Step 3: clean the location used to gather and build the rpm.
    DPKG::Make::cleanbuildloc($buildloc);

=cut

=pod

=head1 SUBROUTINES

=cut

use strict;

###############################################################################

=pod

=head2 DPKG::Make::testsystem()

Check to see if DPKG builder application is available

=over 4

=item INPUT

n/a

=item OUTPUT

n/a

=item ERROR

if necessary commands do not exist (dpkg, debuild, etc), print error and exit

=item NOTE

To date, this testing action has been fully adequate, though imperfect.

=cut

sub testsystem {
    # ----------- If needed software does not exist, then print error and exit.
    unless (qx{dpkg --version} and qx{debuild --version}) { # needed software
	print(<<END);
**** ERROR **** This module only works with a properly installed Debian package
builder application.  Cannot find dpkg or debuild commands.  Script aborting.
END
        exit(1);
    }
}

###############################################################################

=pod

=head2 DPKG::Make::execute($tag,$version,$release,$arch,$buildloc,$pathprefix,\@filelist,\%doc,\%conf,\%metadata);

Build the DPKG in one clean sweep.

=over 4

=item INPUT

6 scalar strings, 1 array reference, and 3 hash references

=item OUTPUT

n/a

=item ERROR

Errors are monitored by the other subroutines that are called.

=item NOTE

First calls &dpkgsrc, then &compiledpkg, then &cleanbuildloc.

=cut

sub execute {
    my ($tag,$version,$release,$arch,$buildloc,$pathprefix,
	$filelistref,$docref,$confref,$metadataref)=@_;

    # --------------------------- Is there rpm building software on the system?
    &testsystem();

    # ---------------- Generate a properly named and prepared source directory.
    my $name=dpkgsrc($tag,$version,$release,$arch,$buildloc,$pathprefix,
	   $filelistref,$docref,$confref,$metadataref);

    # --------------------------------------------- Compile the Debian package.
    my $currentdir=`pwd`; chomp($currentdir); my $invokingdir=$currentdir;
    $currentdir.='/'.$buildloc;
    compiledpkg($buildloc,$name,$version,$release,$arch,
	       $currentdir,$invokingdir);

    # ----------------------------------- Remove the prepared source directory.
    cleanbuildloc($buildloc);
}

###############################################################################

=pod

=head2 DPKG::Make::dpkgsrc($tag,$version,$release,$arch,$buildloc,$pathprefix,\@filelist,\%doc,\%conf,\%metadata);

Properly assemble the DPKG source location (prior to building).

=over 4

=item INPUT

6 scalar strings, 1 array reference, and 3 hash references

=item OUTPUT

n/a

=item ERROR

$version, $release, and $buildloc variables need to have a string length
greater than zero, else the module causes an exit(1).

$tag must only consist of alphanumeric characters, else the module
causes an exit(1).  $tag cannot include the underscore '_' character
and must be all lowercase.

=item NOTE

Should be called before &compiledpkg and &cleanbuildloc.

=cut

sub dpkgsrc {
    my ($tag,$version,$release,$arch,$buildloc,$pathprefix,
	$filelistref,$docref,$confref,$metadataref)=@_;

    # --------------------------- Is there rpm building software on the system?
    &testsystem();

    # ------------------------ Are all the input arguments syntactically valid?
    if (!$version or !$release) { # defined and string length greater than zero
	print "**** ERROR **** Invalid version or release argument.\n";
	exit(1);
    }
    if ($tag=~/\W/ or $tag=~/\_/) { # non-alphanum characters cause problems
	print(<<END);
**** ERROR **** Invalid tag name "$tag"
END
        exit(1);
    }
    if ($tag=~/[A-Z]/) { # must be lower-case
	print(<<END);
**** ERROR **** Invalid tag name "$tag" (must be lower-case)
END
        exit(1);
    }
    if (-e "$buildloc") {
	print(<<END);
**** ERROR **** buildloc "$buildloc" already exists; remove it before running!
END
        exit(1);
    }
    if (!length($buildloc)) {
	print(<<END);
**** ERROR **** buildloc "$buildloc" needs to be defined
END
        exit(1);
    }

# ------------------------------------------------------- Initialize variables.
    my $file;
    my ($type,$size,$octalmode,$user,$group);
    
    my $currentdir=`pwd`; chomp($currentdir); my $invokingdir=$currentdir;
    $currentdir.='/'.$buildloc;

# ---------------------------------------- Determine $name and other variables.
    my $name;
    if ($$metadataref{'name'} && $$metadataref{'name'}!~/\W/) {
	$name=$$metadataref{'name'};
    }
    else {
	$name=$tag;
    }
    my $summary=$$metadataref{'summary'};
    my $vendor=$$metadataref{'vendor'};
    my $copyright=$$metadataref{'copyrightname'};
    $copyright='not specified here' unless $copyright;
    my $autoreqprov=$$metadataref{'AutoReqProv'};
    my $requires=join("\n",@{$$metadataref{'requires'}});
    my $description=$$metadataref{'description'};
    my $pre=$$metadataref{'pre'};
    my $rpmgroup=$$metadataref{'group'};
    my $email=$$metadataref{'email'};

# ----------------------------------------- Set the EMAIL environment variable.
    $ENV{'EMAIL'}=$email;

# ---------------------------------------------- Generate temporary directories
    print('Generating temporary directory ./'.$buildloc."\n");
    mkdir($buildloc,0755) or
	die("**** ERROR **** cannot generate $buildloc directory\n");
    my $binaryroot=$buildloc.'/'.$name.'-'.$version;
    mkdir($binaryroot,0755);

# ----------------------------------- Process file list and gather information.
    my %BinaryRootMakefile;
    my %Makefile;
    my %conffiles;
    my %dirlist;
#    my %dotspecfile;

    my @filelist=@{$filelistref}; # do not overwrite $filelistref contents
    foreach my $file (@filelist) {
	chomp($file);
	my $comment="";
#	if ($$confref{$file}) {
#	    $file.=" # conf";
#	}
#	if ($$docref{$file}) {
#	    $file.=" # doc";
#	}
#	if ($file=~/\s+\#(.*)$/) {
#	    $file=~s/\s+\#(.*)$//;
#	    $comment=$1;
#	}
#	my $directive="";
#	if ($comment=~/config\(noreplace\)/) {
#	    $directive="\%config(noreplace) ";
#	}
#	elsif ($comment=~/config/) {
#	    $directive="\%config ";
#	}
#	elsif ($comment=~/doc/) {
#	    $directive="\%doc";
#	}
	if (($type,$size,$octalmode,$user,$group)=find_info($file)) {
	    $octalmode="0" . $octalmode if length($octalmode)<4;
	    if ($pathprefix) {
		$file=~s/^$pathprefix//;
	    }
	    if ($type eq "files") {
	push(@{$BinaryRootMakefile{$type}},"\tinstall -D -m $octalmode ".
		     "$pathprefix$file $binaryroot$file\n");
		push(@{$Makefile{$type}},"\tinstall -D -m $octalmode ".
		     "\$(SOURCE)$file \$(ROOT)$file\n");
	$conffiles{$file}=1;
#	push(@{$dotspecfile{$type}},"$directive\%attr($octalmode,$user,".
#		     "$group) $file\n");
	    }
	    elsif ($type eq "directories") {
	push(@{$BinaryRootMakefile{$type}},"\tinstall -m $octalmode -d ".
		     "$binaryroot$file\n");
		push(@{$Makefile{$type}},"\tinstall -m $octalmode -d ".
		     "\$(SOURCE)$file \$(ROOT)$file\n");
	$dirlist{$file}=1;
#		push(@{$dotspecfile{$type}},"\%dir \%attr($octalmode,$user,".
#		     "$group) $file\n");
	    }
	    elsif ($type eq "links") {
	my $link=$size; # I use the size variable to pass the link value
		# from the subroutine find_info
		$link=~s/^$pathprefix//;
		push(@{$BinaryRootMakefile{$type}},
		     "\tln -s $link $binaryroot$file\n");
		push(@{$Makefile{$type}},"\tln -s $link \$(ROOT)$file\n");
#		push(@{$dotspecfile{$type}},"\%attr(-,$user,$group) $file\n");
	    }
	}
    }
    
# - Generate software package Makefile and the BinaryRootMakefile (mirror copy)
    open(OUTS,">$binaryroot/Makefile");
    print(OUTS <<END);
ROOT=\$(DESTDIR)
SOURCE=`pwd`

END
    open(OUTB, ">$buildloc/BinaryRootMakefile");
    foreach $type ("directories","files","links") {
	print(OUTS "$type\:\n");
	print(OUTS join("",@{$Makefile{$type}})) if $Makefile{$type};
	print(OUTS "\n");
	print(OUTB "$type\:\n");
	print(OUTB join("",@{$BinaryRootMakefile{$type}}))
	    if $BinaryRootMakefile{$type};
	print(OUTB "\n");
    }
    close(OUTB);
    print(OUTS <<END);
install: directories files links

END
    print(OUTS "clean:\n\techo \"clean not yet implemented\"\n\n");
    close(OUTS);
    
# ---------------- Mirror copy (BinaryRoot) files to the a temporary directory.
    `make -f $buildloc/BinaryRootMakefile directories`;
    `make -f $buildloc/BinaryRootMakefile files`;
    `make -f $buildloc/BinaryRootMakefile links`;

# ------------------------------------ Generate debian directory with deb-make.
    print `cd $binaryroot; echo 's' | deb-make native`;
    if ($?) {
	die("Failed on running deb-make");
    }
    print ".\n";
    print ".\n";
    print ".\n";
    print "Automated editing of the $binaryroot/debian directory...\n";

# -------------------------------------- Print information for debian/dirs file
    print "Altering the debian/dirs file...\n";
    open(DIRSFILE,">$binaryroot/debian/dirs");
    foreach (keys %dirlist) {
	print(DIRSFILE "$_\n");
    }
    print(DIRSFILE "tmp\n"); # need at least one entry for debuild working
    close(DIRSFILE);

# --------------------------------- Print information for debian/conffiles file
    print "Altering the debian/conffiles file...\n";
    open(CONFFILES,">$binaryroot/debian/conffiles");
    foreach (keys %dirlist) {
	print(CONFFILES "$_\n");
    }
    close(CONFFILES);

# ----------------------------------- Print information for debian/control file
    print "Altering the debian/control file...\n";
    my %orig_control_hash;
    open(CONTROL,"<$binaryroot/debian/control");
    while(<CONTROL>) {
	chomp;
	if (/\:\s/) {
	    my ($key,$value)=split(/\:\s/);
	    $orig_control_hash{$key}=$value;
	}
    }
    close(CONTROL);
    my $policy=$orig_control_hash{'Standards-Version'};
    open(CONTROL,">$binaryroot/debian/control");
    print(CONTROL <<END);
Source: $name
Section: $rpmgroup
Priority: optional
Maintainer: $vendor <$email>
Standards-Version: $policy

Package: $name
Architecture: $arch
Depends: \${shlibs:Depends}
Description: $summary
 $description
END
    close(CONTROL);
    
    return $name;
}

###############################################################################

=pod

=head2 DPKG::Make::compiledpkg($buildloc,$name,$version,$release,$arch,$currentdir,$invokingdir);

Properly assemble the DPKG source location.

=over 4

=item INPUT

7 scalar strings

=item OUTPUT

n/a

=item ERROR

None captured.  debuild warning and exit status is ignored for now...
(debuild is stringent about pgp-signing which I do not think is totally
necessary).

=item NOTE

Should be called after &rpmsrc and before &cleanbuildloc.

=cut

sub compiledpkg {
    my ($buildloc,$name,$version,$release,$arch,$currentdir,$invokingdir)=@_;

    # --------------------------- Is there rpm building software on the system?
    &testsystem();

    # ------------------------------------------ Execute the 'debuild' command.
    my $binaryroot=$buildloc.'/'.$name.'-'.$version;
    unless (-d "$binaryroot/debian") {
	die("Cannot find $binaryroot/debian directory");
    }
    print "cd $binaryroot/debian; debuild\n";
    print `cd $binaryroot/debian; debuild 2>\&1`;

    # ----------------------------------- Copy files to the invoking directory.
    print `cp -v $buildloc/*.tar.gz .`;
    print `cp -v $buildloc/*.dsc .`;
    print `cp -v $buildloc/*.deb .`;
    print `cp -v $buildloc/*.changes .`;
    return;
}

###############################################################################

=pod

=head2 DPKG::Make::cleanbuildloc($buildloc);

Clean build location - usually F<TempBuildLoc>.

=over 4

=item INPUT

1 scalar string

=item OUTPUT

n/a

=item ERROR

If the input argument is empty, then abort.  Also should abort if cannot
remove the location specified by the input argument.

=item NOTE

Should be called after &dpkgsrc and after &compiledpkg.

=cut

sub cleanbuildloc {
    my ($buildloc)=@_;
    # ----------------------------- Make sure that the input argument is valid.
    if (!length($buildloc)) {
	print(<<END);
**** ERROR **** buildloc "$buildloc" already exists
END
        exit(1);
    }
    # ----------------------------- Try to remove the build location directory.
    else {
	print (`rm -Rf $buildloc`);
	if ($?!=0) {
	    print(<<END);
**** ERROR **** removal of $buildloc failed
END
            exit(1);
	}
    }
    return;
}

###############################################################################

=pod

=head2 DPKG::Make::find_info($file_system_location);

Recursively gather information from a directory

=over 4

=item INPUT

1 scalar string

=item OUTPUT

n/a

=item ERROR

If $file_system_location is neither a directory, or softlink, or regular file,
then abort.

=item NOTE

Called by &rpmsrc.

=cut

sub find_info {
    my ($file)=@_;
    my $line='';
    if (($line=`find $file -type f -prune`)=~/^$file\n/) {
	$line=`find $file -type f -prune -printf "\%s\t\%m\t\%u\t\%g"`;
	return("files",split(/\t/,$line));
    }
    elsif (($line=`find $file -type d -prune`)=~/^$file\n/) {
	$line=`find $file -type d -prune -printf "\%s\t\%m\t\%u\t\%g"`;
	return("directories",split(/\t/,$line));
    }
    elsif (($line=`find $file -type l -prune`)=~/^$file\n/) {
	$line=`find $file -type l -prune -printf "\%l\t\%m\t\%u\t\%g"`;
	return("links",split(/\t/,$line));
    }
    die("**** ERROR **** $file is neither a directory, soft link, or file.\n");
}

1;

# ------------------------------------------------ More Plain Old Documentation

=pod

=head1 DESCRIPTION

Automatically generate an dpkg software package from a list of files.

B<DPKG::Make> builds the RPM in a very clean and configurable fashion.
(Finally!  Making RPMs outside of F</usr/src/redhat> without a zillion
file intermediates left over!)

B<DPKG::Make> generates and then deletes temporary
files needed to build an RPM with.
It works cleanly and independently from pre-existing
directory trees such as F</usr/src/redhat/*>.

B<DPKG::Make> accepts five kinds of
information, three of which are significant:

=over 4

=item *

(significant) a list of files that are to be part of the software package;

=item *

(significant) the filesystem location of these files;

=item *

(significant) a descriptive tag and a version tag for the naming of the
DPKG software package;

=item *

documentation and configuration files;

=item *

and additional metadata
associated with the Debian software package.

=back

When using DPKG::Make::execute, a temporary directory named $buildloc is

=over 4

=item *

generated under the directory from which you run your script,

=item *

and then deleted after the *.deb file and 3 other files are generated.

=back

The DPKG will typically be named
"$metadata{'name'}-$version.deb".
If $metadata{'name'} is not specified, then $tag is used.

Here are some of the items are generated inside
the $buildloc directory during the construction of an Debian package (DPKG):

=over 4

=item *

Debian control file (F<./$buildloc/$name-$version/debian/control>)

=item *

package Makefile (F<./$buildloc/$name-$version/Makefile>)

This is the Makefile that is called by the debuild
command in building the .deb file from source and contents of
the debian/ directory.
The following directories are generated and/or used:

=over 4

=item *

SOURCE directory: F<./$buildloc/$name-$version/>

=item *

TARGET directory: F<./$buildloc/$name-$version/tmp/>

=back

=item *

BinaryRootMakefile (F<./$buildloc/BinaryRootMakefile>)

This is the Makefile that this script creates and calls
to build the F<$buildloc/BinaryRoot/> directory from the existing
filesystem.
The following directories are generated and/or used:

=over 4

=item *

SOURCE directory: / (your entire filesystem)

=item *

TARGET directory: F<./$buildloc/$name-$version/>

=back

=back

The final output of B<DPKG::Make::execute> is a binary F<.deb> file
(as well as F<.dsc>, F<.tar.gz>, and F<.changes> files).
The F<./buildloc> directory is deleted (along with the F<./buildloc/*/debian>
directory).  The typical file name generated by B<DPKG::Make> is
F<$tag-$version.deb>.

=head1 README

Automatically generate a DPKG software package from a list of files.

B<DPKG::Make> builds the Debian package in a very clean and configurable
fashion without requiring knowledge of Debian package building internals.

B<DPKG::Make> generates and then deletes temporary
files (and binary root directory tree) to build an Debian package with.

So far, this module has been tested on Debian v2.2.  It still is not
as mature as B<RPM::Make> (see RPM-Tools at www.cpan.org), but is in
a basic working condition right now.  I need to do more to streamline
everything associated with generating a debian package according
to the many debian "policies".

=head1 PREREQUISITES

This script requires the C<strict> module.

=head1 AUTHOR

 Scott Harrison
 sharrison@users.sourceforge.net

Please let me know how/if you are finding this module useful and
any/all suggestions.  -Scott

=head1 LICENSE

Written by Scott Harrison, sharrison@users.sourceforge.net

Copyright Michigan State University Board of Trustees

This file is part of the LearningOnline Network with CAPA (LON-CAPA).

This 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 of the License, or
(at your option) any later version.

This file 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.

The GNU Public License is available for review at
http://www.gnu.org/copyleft/gpl.html.

For information on the LON-CAPA project, please visit
http://www.lon-capa.org/.

=head1 STATUS

This module is new.  Its API is similar to B<RPM::Make> which comes
from RPM-Tools.

=head1 OSNAMES

Linux

=cut