#!/usr/bin/perl -w

# TODO: 
# * get more info from the package (maybe using CPAN methods)

package MyPod;
use Pod::Parser;

@MyPod::ISA = qw(Pod::Parser);

sub set_names {
	my ($parser, @names) = @_;
	foreach my $n (@names) {
		$parser->{_deb_}->{$n} = undef;
	}
}

sub get {
	my ($parser, $name) = @_;
	$parser->{_deb_}->{$name};
}

sub cleanup {
	my $parser = shift;
	delete $parser->{_current_};
	foreach my $k ( keys %{$parser->{_deb_}}) {
		$parser->{_deb_}->{$k} = undef;
	}
}

sub command {
	my ($parser, $command, $paragraph, $line_num) = @_;
	$paragraph =~ s/\s+$//s;
	if ($command =~ /head/ && exists($parser->{_deb_}->{$paragraph})) {
		$parser->{_current_} = $paragraph;
		$parser->{_lineno_} = $line_num;
	} else {
		delete $parser->{_current_};
	}
	#print "GOT: $command -> $paragraph\n";
}

sub add_text {
	my ($parser, $paragraph, $line_num) = @_;
	return unless exists $parser->{_current_};
	return if ($line_num - $parser->{_lineno_} > 15);
	$paragraph =~ s/^\s+//s;
	$paragraph =~ s/\s+$//s;
	$paragraph = $parser->interpolate($paragraph, $line_num);
	$parser->{_deb_}->{$parser->{_current_}} .= "\n\n".$paragraph;
	#print "GOTT: $paragraph'\n";
}

sub verbatim { shift->add_text(@_)}

sub textblock { shift->add_text(@_)}

sub interior_sequence {
	my ($parser, $seq_command, $seq_argument) = @_;
	if ($seq_command eq 'E') {
		my %map = ('gt' => '>', 'lt' => '<', 'sol' => '/', 'verbar' => '|');
		return $map{$seq_argument} if exists $map{$seq_argument};
		return chr($seq_argument) if ($seq_argument =~ /^\d+$/);
		# html names...
	}
	return $seq_argument;
}

package main;

use File::Basename;
use File::Find;
use User::pwent;
use CPAN;
use Getopt::Long;
use Cwd;
use strict;

my $debstdversion = '3.5.1';
my $priority = 'optional';
my $section = 'interpreters';
my $depends = '${perl:Depends}';
my $bdepends = 'debhelper (>= 3.0.5), perl (>= 5.6.0-17)';
my $maintainer = get_maintainer();
my $arch = 'all';
my $date = `822-date`;
my $debiandir;
my $startdir = getcwd();

my %overrides;
my $datadir = '/usr/share/dh-make-perl';
my $homedir = "$ENV{HOME}/.dh-make-perl";
my ($perlname, $makefile, $maindir, $modulepm);
my ($pkgname, $srcname, $version, $desc, $longdesc, $copyright, $author);
my ($extrasfields, $extrapfields);
my (@docs, $changelog, @args);
my ($cpanmodule, $build, $install, $dbflags);

$dbflags = $>==0?"":"-rfakeroot";
chomp($date);

GetOptions(
	"cpan=s" => \$cpanmodule,
	"desc=s" => \$desc,
	"arch=s" => \$arch,
	"version=s" => \$version,
	"help" => sub {die "\n"},
	# disabled: see build_package()
	"dbflags=s" => \$dbflags,
	"build!" => \$build,
	"install!" => \$install,
	) || die <<"USAGE";
Usage:
$0 [--build] [--install] [module_source_dir|--cpan modulename]
Other options: [--desc description] [--arch arch] [--version pkg_version]
USAGE

load_overrides();
setup_dir();
extract_basic();
$depends .= ', ${shlibs:Depends}' if $arch eq 'any';
extract_changelog($maindir);
extract_docs($maindir);
apply_overrides();

die "Cannot find a description for the package: use the --desc switch\n" unless $desc;
print "Using maintainer: $maintainer\n";
print "Found changelog: $changelog\n" if defined $changelog;
print "Found docs: @docs\n";
-d $debiandir && die "The directory $debiandir is already present and I won't overwrite it: remove it yourself.\n";
# start writing out the data
mkdir ($debiandir, 0755) || die "Cannot create $debiandir dir: $!\n";
create_control("$debiandir/control");
create_changelog("$debiandir/changelog");
create_rules("$debiandir/rules");
create_readme("$debiandir/README.Debian");
create_copyright("$debiandir/copyright");
# FIXME: it's quite ugly to do it this way
$changelog ||= "";
@args = ("perl", "-pi", "-e", "s(#CHANGES#)($changelog);s(#DOCS#)(@docs);", "debian/rules" );
#print "Running: ", join(" ", @args), "\n";
system(@args) == 0
	|| die "Cannot apply substitutions: $?\n";
apply_final_overrides();
build_package() if $build;
install_package() if $install;
print "Done\n";
exit(0);

sub setup_dir {
	if ($cpanmodule) {
		my ($dist, $mod, $cpanversion);
		$mod = CPAN::Shell->expand('Module', '/^'.$cpanmodule.'$/') 
			|| die "Can't find '$cpanmodule' module on CPAN\n";
		$cpanversion = $CPAN::VERSION;
		$cpanversion =~ s/_.*//;
		if ($cpanversion < 1.59) { # wild guess on the version number
			$dist = $CPAN::META->instance('CPAN::Distribution', $mod->{CPAN_FILE});
			$dist->get || die "Cannot get $mod->{CPAN_FILE}\n";
			$maindir = $dist->{'build_dir'};
		} else {
			# CPAN internals changed
			$dist = $CPAN::META->instance('CPAN::Distribution', $mod->cpan_file);
			$dist->get || die "Cannot get ", $mod->cpan_file, "\n";
			$maindir = $dist->dir;
		}
	} else {
		$maindir = shift(@ARGV) || '.';
	}
	chdir($maindir) || die "Cannot chdir to $maindir\n";
}

sub build_package {
	$ENV{DESTDIR} = $startdir;
	# uhmf! dpkg-genchanges doesn't cope with the deb being in another dir..
	#system("dpkg-buildpackage -b -us -uc $dbflags") == 0
	system("fakeroot debian/rules clean");
	system("fakeroot debian/rules binary") == 0
		|| die "Cannot create deb package\n";
}

sub install_package {
	my $archspec = $arch;
	my $debname;
	if ($arch eq 'any') {
		$archspec = `dpkg --print-architecture`;
		chomp($archspec);
	}
	$debname = "${pkgname}_$version-1_$archspec.deb";
	system("dpkg -i $startdir/$debname") == 0
		|| die "Cannot install package $startdir/$debname\n";
}

sub extract_basic_copyright {
	for my $f (qw(LICENSE LICENCE COPYING)) {
		if (-f $f) {
			return `cat $f`;
		}
	}
	return undef;
}

sub extract_basic {
	$makefile = "$maindir/Makefile.PL";
	find(\&check_for_xs, $maindir);
	($perlname, $version) = extract_name_ver($makefile);
	$pkgname = lc $perlname;
	$pkgname =~ s/::/-/;
	$pkgname = 'lib'.$pkgname unless $pkgname =~ /^lib/;
	$pkgname = $pkgname.'-perl' unless $pkgname =~ /-perl$/;

	# ensure policy compliant names and versions (from Joeyh)...
	$pkgname =~ s/[^-.+a-zA-Z0-9]+/-/g;
	$srcname = $pkgname;
	$version =~ s/[^-.+a-zA-Z0-9]+/-/g;
	$version = "0$version" unless $version =~ /^\d/;
	
	print "Found: $perlname $version ($pkgname arch=$arch)\n";
	$debiandir = "$maindir/debian";

	$copyright = extract_basic_copyright();
	if ($modulepm) {
		extract_desc($modulepm);
	}

	find(sub {
		/\.(pm|pod)$/ && do { extract_desc($_) };
	}, $maindir);
}

sub extract_name_ver {
	my ($makefile) = shift;
	my ($file, $name, $ver, $vfrom, $dir);
	local $/ = undef;
	open (MF, "<$makefile") || die "Cannot open $makefile\n";
	$file = <MF>;
	close(MF);
	$name = $4 if $file =~ /(['"]?)NAME\1\s*(=>|,)\s*(['"]?)(\S+)\3/s;
	$ver = $4 if $file =~ /(['"]?)VERSION\1\s*(=>|,)\s*(['"]?)(\S+)\3/s;
	$vfrom = $4 if $file =~ /(['"]?)VERSION_FROM\1\s*(=>|,)\s*(['"]?)(\S+)\3/s;
	$dir = dirname($makefile) || './';
	$name =~ s/,.*$//;
	# band aid: need to find a solution also for build in directories
	# warn "name is $name (cpan name: $cpanmodule)\n";
	$name = $cpanmodule if ($name eq '__PACKAGE__' && $cpanmodule);
	for (($name, $ver)) {
		next unless defined;
		next unless /^\$/;
		# decode simple vars
		s/(\$\w+).*/$1/;
		if ($file =~ /\Q$_\E\s*=\s*(['"]?)(\S+)\1\s*;/) {
			$_ = $2;
		}
	}
	$ver = $version if defined $version;
	$modulepm = "$dir/$vfrom" if defined $vfrom;
	unless (defined $ver) {
		local $/ = "\n";
		# apply the method used by makemaker
		open(MF, "<$dir/$vfrom") || die "Cannot open $dir/$vfrom to gather the version: use the --version option\n";
		while (<MF>) {
			if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
				no strict;
				#warn "ver: $_";
				$ver = eval $_;
				last;
			}
		}
		close(MF);
	}
	return ($name, $ver);
}

sub extract_desc {
	my ($file) = shift;
	my $line;
	my $parser = new MyPod;
	return unless -f $file;
	$parser->set_names(qw(NAME DESCRIPTION COPYRIGHT AUTHOR AUTHORS));
	$parser->parse_from_file($file);
	if ((!$desc) && ($desc = $parser->get('NAME'))) {
		$desc =~ s/^\s*\S+\s+-\s+//s;
		$desc =~ s/^\s+//s;
		$desc =~ s/\s+$//s;
		$desc =~ s/^([^\s])/ $1/mg;
		$desc =~ s/\n.*$//s;
	}
	if ((!$longdesc) && ($longdesc = $parser->get('DESCRIPTION'))) {
		$longdesc = $desc unless $longdesc;
		$longdesc =~ s/^\s+//s;
		$longdesc =~ s/\s+$//s;
		$longdesc =~ s/^\t/ /mg;
		$longdesc =~ s/^\s*$/ ./mg;
		$longdesc =~ s/^\s*/ /mg;
		$longdesc =~ s/^([^\s])/ $1/mg;
	}
	$copyright = $parser->get('COPYRIGHT') unless $copyright;
	$author = $parser->get('AUTHOR') unless $author;
	$author = $parser->get('AUTHORS') unless $author;
	$parser->cleanup;
}

sub extract_changelog {
	my ($dir) = shift;
	$dir .= '/' unless $dir =~ m(/$);
	find(sub {
		$changelog = substr($File::Find::name, length($dir))
			if (!defined($changelog) && /^change(s|log)$/i);
	}, $dir);
}

sub extract_docs {
	my ($dir) = shift;
	$dir .= '/' unless $dir =~ m(/$);
	find(sub {
		push (@docs, substr($File::Find::name, length($dir))) 
			if /^(README|TODO|BUGS|NEWS|ANNOUNCE)/i;
	}, $dir);
}

sub check_for_xs {
	/\.(xs|c|cpp|cxx)$/i && do {
		$arch = 'any';
	};
}

sub create_control {
	my ($file) = shift;
	open(C, ">$file") || die "Cannot open $file\n";
	print C "Source: $srcname\n";
	print C "Section: $section\n";
	print C "Priority: $priority\n";
	print C "Build-Depends: $bdepends\n";
	print C $extrasfields if defined $extrasfields;
	print C "Maintainer: $maintainer\n";
	print C "Standards-Version: $debstdversion\n";
	print C "\n";
	print C "Package: $pkgname\n";
	print C "Architecture: $arch\n";
	print C "Depends: $depends\n";
	print C $extrapfields if defined $extrapfields;
	print C "Description: $desc\n$longdesc\n";
	close(C);
}

sub create_changelog {
	my ($file) = shift;
	open(C, ">$file") || die "Cannot open $file\n";
	print C "$srcname ($version-1) unstable; urgency=low\n";
	print C "\n  * Initial Release.\n\n";
	print C " -- $maintainer  $date\n\n";
	print C "Local variables:\nmode: debian-changelog\nEnd:\n";
	close(C);
}

sub create_rules {
	use File::Copy;
	my ($file) = shift;
	my $rulesname = $arch eq 'all'?"rules.noxs":"rules.xs";
	my $error;
	
	for my $source (("$homedir/$rulesname", "$datadir/$rulesname")) {
		copy($source, $file) && do {
			print "Using rules: $source\n";
			last;
		};
		$error = $!;
	}
	die "Cannot copy rules file ($rulesname): $error\n" unless -e $file;
	chmod(0755, $file);
}

sub create_copyright {
	my ($file) = shift;
	open(C, ">$file") || die "Cannot open $file\n";
	print C <<"EOF";
This copyright info was automatically extracted from the perl module.
It may not be accurate, so you better check the module sources
if don't want to get into legal troubles.

EOF
	if (defined $author) {
		print C "The upstream author is: $author.\n";
	}
	if (defined($copyright)) {
		print C $copyright;
	}
	close(C);
}

sub create_readme {
	my ($file) = shift;
	open(C, ">$file") || die "Cannot open $file\n";
	print C "This is the debian package for the $perlname module.\n";
	print C "It was created by $maintainer using dh-make-perl.\n";
	close(C);
}

sub get_maintainer {
	my $user = $ENV{LOGNAME} || $ENV{USER};
	my $pwnam = getpwuid($<);
	my ($email, $name, $mailh);
	die "Cannot determine current user\n" unless $pwnam;
	if (defined $ENV{DEBFULLNAME}) {
		$name = $ENV{DEBFULLNAME};
	} else {
		$name = $pwnam->gecos;
		$name =~ s/,.*//;
	}
	$user ||= $pwnam->name;
	$name ||= $user;
	$email = $ENV{DEBEMAIL} || $ENV{EMAIL};
	unless ($email) {
		chomp($mailh = `cat /etc/mailname`);
		$email = $user.'@'.$mailh;
	}
	return "$name <$email>";
}

sub load_overrides {
	# FIXME: check for errors
	do "$datadir/overrides";
	do "$homedir/overrides";
}

sub apply_overrides {
	my ($data, $val, $subkey);

	($data, $subkey) = get_override_data();
	return unless defined $data;
	$pkgname = $val if (defined($val=get_override_val($data, $subkey, 'pkgname')));
	$srcname = $val if (defined($val=get_override_val($data, $subkey, 'srcname')));
	$section = $val if (defined($val=get_override_val($data, $subkey, 'section')));
	$priority = $val if (defined($val=get_override_val($data, $subkey, 'priority')));
	$depends = $val if (defined($val=get_override_val($data, $subkey, 'depends')));
	$bdepends = $val if (defined($val=get_override_val($data, $subkey, 'bdepends')));
	$desc = $val if (defined($val=get_override_val($data, $subkey, 'desc')));
	$longdesc = $val if (defined($val=get_override_val($data, $subkey, 'longdesc')));
	$version = $val if (defined($val=get_override_val($data, $subkey, 'version')));
	$arch = $val if (defined($val=get_override_val($data, $subkey, 'arch')));
	$changelog = $val if (defined($val=get_override_val($data, $subkey, 'changelog')));
	@docs = split(/\s+/, $val) if (defined($val=get_override_val($data, $subkey, 'docs')));

	$extrasfields = $val if (defined($val=get_override_val($data, $subkey, 'sfields')));
	$extrapfields = $val if (defined($val=get_override_val($data, $subkey, 'pfields')));
	# fix longdesc if needed
	$longdesc =~ s/^\s*/ /mg;
}

sub apply_final_overrides {
	my ($data, $val, $subkey);

	($data, $subkey) = get_override_data();
	return unless defined $data;
	get_override_val($data, $subkey, 'finish');
}

sub get_override_data {
	my ($data, $checkver, $subkey);
	$data = $overrides{$perlname};

	return unless defined $data;
	die "Value of '$perlname' in overrides not a hashref\n" unless ref($data) eq 'HASH';
	if (defined($checkver = $data->{checkver})) {
		die "checkver not a function\n" unless (ref($checkver) eq 'CODE');
		$subkey = &$checkver($maindir);
	} else {
		$subkey = $version;
	}
	return ($data, $subkey);
}

sub get_override_val {
	my ($data, $subkey, $key) = @_;
	my $val;
	$val = defined($data->{$subkey.$key})?$data->{$subkey.$key}:$data->{$key};
	return &$val() if (defined($val) && ref($val) eq 'CODE');
	return $val;
}

=head1 NAME

dh-make-perl - Create debian source packages from perl modules

=head1 SYNOPSIS

dh-make-perl [module_source_dir|--cpan module]

Additional options include:

	[--build] [--install] [--desc description] [--arch architecture]

=head1 DESCRIPTION

dh-make-perl will create the files required to build
a debian source package out of a perl package.
This works for most simple packages and is also useful
for getting started with packaging perl modules.

You can specify a module name with the --cpan switch
and dh-make-perl will download the module for you from
a CPAN mirror, or you can specify the directory with the
already unpacked sources as the first argument.

There is an override mechanism in place to handle most of
the little changes that may be needed for some modules
(this hasn't been tested much, though, and the override
database needs to be filled in).

You can build and install the debian package using the --build
and --install command line switches.

Using this program is no excuse for not reading the
debian developer documentation, including the Debian policy,
the perl policy, the packaging manual and so on.

=head1 FILES

The following directories will be searched to find additional files
required by dh-make-perl:

	/usr/shared/dh-make-perl/
	$HOME/.dh-make-perl/

=over 4

=item * overrides

File that overrides information retreived (or guessed) about the package.
All the files in the library directories are loaded: entries in the home
take precedence. See the distributed overrides file for usage information.

=item * rules.noxs

A debian/rules makefile for use with modules without C/XS code.

=item * rules.xs

A debian/rules makefile for use with modules with C/XS code.

=back

=head1 ENVIRONMENT

HOME - get user's home directory

DEBFULLNAME - get the real name of the maintainer

LOGNAME or USER - get the username

DEBEMAIL or EMAIL - get the email address of the user

=head1 BUGS

Several, let me know when you find them.

=head1 AUTHOR

Paolo Molaro E<lt>lupus@debian.orgE<gt>

=cut
