#!/usr/bin/perl -w

# Copyright 1999 by Martin Bialasinski
# Copyright 2006 by Peter Samuelson
# This programm is subject to the GNU General Public License Version 2

# doc-base Copyright (C) 1997,1998 Christian Schwarz,
# Also licensed under the GPL2

use strict;
use Cwd;
use Getopt::Long;
use File::Copy;
use File::Basename;
use File::Temp ('tempdir');

my $builddir = tempdir('equivs.XXXXXX', DIR => cwd, CLEANUP => 1) or
  die "Cannot create temporary build dir: $!\n";
my %control;

sub usage {
  print STDERR <<EOU;
Usage: equivs-build [--full|-f] [--arch=foo|-a=foo] controlfile
controlfile is the name of an equivs controlfile.
You can use "equivs-control filename" to create one.

--full   Full build including signing, etc., suitable for upload to Debian
--arch   Build package for a different architecture.
         Used e.g. for building Hurd packages under Linux.
EOU
  exit 1;
}

my ($full_package, $arch);
GetOptions(full => \$full_package, 'arch=s' => \$arch) or usage();

my $debug = 0;

umask(022);

my $controlfile = $ARGV[0];
if (! $controlfile) {
  print STDERR "No control file was specified\n";
  usage();
}

system("cp -R /usr/share/equivs/template/* $builddir") == 0 or
  die "Error on copy of the template files: exit status " . ($?>>8) . "\n";

# Parse the equivs control file

read_control_file($builddir, \%control, $arch, $controlfile);

if ($debug) {
  my ($k, $v);
  while (($k, $v) = each %control ) {
    print "$k -> $v\n";
  }
}

# Copy any additional files

my @extra_files = split ",", $control{'Extra-Files'} || "";

mkdir "$builddir/docs", 0755;
open DOCS, '>', "$builddir/debian/docs" or
  die "Cannot open $builddir/debian/docs for writing: $!\n";

foreach my $file (@extra_files){
  $file =~ s/ +//g;
  my $destination = basename($file);
  copy $file, "$builddir/docs/$destination" or
    die "Cannot copy $file to $builddir/docs/$destination: $!\n";
  print DOCS "docs/$destination\n";
}
close DOCS;

foreach my $script (qw(Preinst Postinst Prerm Postrm)) {
    next unless defined $control{$script};
    my $destination = lc($script);
    copy $control{$script}, "$builddir/debian/$destination" or
      die "Cannot copy $script to $builddir/debian/$destination: $!\n";
}


write_control_file($builddir, \%control);

if ($control{'Changelog'}) {
  copy $control{'Changelog'}, "$builddir/debian/changelog" or
    die "Cannot copy changelog file $control{'Changelog'}: $!\n";
} else {
  make_changelog($builddir, \%control);
}


if ($control{'Readme'}) {
  copy $control{'Readme'}, "$builddir/debian/README.Debian.in" or
    die "Cannot copy README file $control{'Readme'}: $!\n";
}

# Make substitutions in the Readme
make_readme($builddir, \%control);

# Copy a copyright file, otherwise use GPL2
if ($control{'Copyright'}) {
  copy $control{'Copyright'}, "$builddir/debian/copyright" or
    die "Cannot copy copyright file $control{'Copyright'}: $!\n";
}

chdir $builddir;
unlink glob "debian/*.in";

my @build_cmd = ();
# Set architecture for crosscompiling, if requested
if ($arch) {
  @build_cmd = ("dpkg-architecture", "-a$arch", "-c");
}

if ($full_package) {
  push @build_cmd, 'debuild', '-rfakeroot';
} else {
  push @build_cmd, 'fakeroot', 'debian/rules', 'binary';
}
system(@build_cmd) == 0 or
  die "Error in the build process: exit status " . ($?>>8) . "\n";

chdir '..';
print "\nThe package has been created.\n";
print "Attention, the package has been created in the current directory,\n";
print "not in \"..\" as indicated by the message above!\n";
exit 0;

sub read_control_file {
  my ($builddir, $control, $specific_arch, $file) = @_;
  my $in;

  open($in, "$builddir/debian/control.in") or
    die "Cannot open control file: $!\n";
  read_control_file_section($in, $control) or
    die "error: empty control file\n";
  close $in;

  # Set some field defaults: Maintainer, Architecture
  my (@user) =  getpwuid $>;
  my $gecos;
  my ($username, $systemname, $fullname);

  ($username, $gecos) = @user[0,6];
  $fullname = (split ",", $gecos)[0];

  chomp($systemname = qx(hostname --fqdn));

  $control->{'Maintainer'} = "$fullname <$username\@$systemname>";

  $control->{'Architecture'} = $specific_arch ? 'any' : 'all';

  open($in, $file) or
    die "Cannot open control file $file: $!\n";

  read_control_file_section($in, $control) or
    die "error: empty control file\n";
  close $in;

  # Fix Source: entry
  $control->{'Source'} = $control->{'Package'};

  # remove trailing whitespace
#  foreach my $key (keys %$control) {
#    $control->{$key} =~ s/\s$//;
#  }

}

sub read_control_file_section {
  my ($fh, $pfields) = @_;

  my ($cf,$v);
  while (<$fh>) {
    chomp;
    next if (m/^\s*$/ or m/^\s*#/);

    # new field?
    if (/^(\S+)\s*:\s*(.*?)\s*$/) {
      ($cf,$v) = (ucfirst lc $1, $2);
      $cf =~ s/(?<=-)([a-z])/uc $1/eg;
      $pfields->{$cf} = $v;
    } elsif (/^(\s+\S.*)$/) {
      $v = $1;
      defined($cf) or die "syntax error in control file: no field specified\n";
      $pfields->{$cf} .= "\n$v";
    } else {
      die "syntax error in control file: $_\n";
    }
  }

  return 1;
}


# Write control fields
sub control_fields {
  my $retval;
  my ($control, @fields) = @_;

  foreach my $str (@fields) {
    my $t = $control->{$str};
    if ($t) {
      $retval .= "$str: $t\n";
    }
  }

  return $retval;
}


sub write_control_file {
  my ($builddir, $control) = @_;
  open OUT, '>', "$builddir/debian/control" or
    die "Cannot open $builddir/debian/control for writing: $!\n";

  print OUT control_fields($control,
			   "Source",
			   "Section",
			   "Priority",
			   "Maintainer",
			   "Build-Depends",
			   "Standards-Version");
  print OUT "\n";
  print OUT control_fields($control,
			   "Package",
			   "Architecture",
			   "Pre-Depends",
			   "Depends",
			   "Recommends",
			   "Suggests",
			   "Conflicts",
			   "Provides",
			   "Replaces",
			   "Description");
  close OUT;
}


sub make_changelog {
  my ($builddir, $control) = @_;
  my ($version, $date);

  $version = $control->{'Version'} || "1.0";
  chomp ($date = qx(822-date));

  open OUT, '>', "$builddir/debian/changelog" or
    die "Couldn't write changelog: $!\n";
  print OUT <<EOINPUT;
$control->{Package} ($version) unstable; urgency=low

  * First version

 -- $control->{'Maintainer'}  $date
EOINPUT
  close OUT;
}


# Create the README.Debian file
sub make_readme {
  my ($builddir, $control) = @_;
  my ($content, $deps);

  open IN, "$builddir/debian/README.Debian.in" or
    die "Cannot open the README file: $!\n";
  $content = join '', <IN>;
  close IN;

  $content =~ s/\@packagename\@/$control->{'Package'}/g;

  $deps = control_fields($control,
			 "Pre-Depends",
			 "Depends",
			 "Recommends",
			 "Suggests",
			 "Conflicts",
			 "Provides",
			 "Replaces");
  $deps ||= " ";
  $content =~ s/\@depends\@/$deps/g;
  open OUT, '>', "$builddir/debian/README.Debian" or
    die "Cannot open $builddir/debian/README.Debian for writing: $!\n";
  print OUT $content;
  close OUT;
}
