#!/usr/bin/perl -w

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

package MyPod;
use Pod::Parser;
use YAML;

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

my @pragmas = qw(attributes attrs autouse base bigint bignum
				 bigrat blib bytes charnames constant
				 diagnostics encoding fields filetest if 
				 integer less lib locale open ops overload
				 re sigtrap sort strict subs threads utf8
				 vars vmsish warnings warnings::register);

my @stdmodules = qw(AnyDBM_File Attribute::Handlers::demo::Demo
Attribute::Handlers::demo::Descriptions
Attribute::Handlers::demo::MyClass Attribute::Handlers attributes
AutoLoader AutoSplit autouse base Benchmark bigint bignum bigrat blib
bytes Carp::Heavy Carp CGI::Apache CGI::Carp CGI::Cookie CGI::Fast
CGI::Pretty CGI::Push CGI::Switch CGI::Util CGI charnames Class::ISA
Class::Struct constant CPAN::FirstTime CPAN::Nox CPAN Cwd DB
Devel::SelfStubber diagnostics Digest DirHandle Dumpvalue English Env
Exporter::Heavy Exporter ExtUtils::Command::MM ExtUtils::Command
ExtUtils::Constant ExtUtils::Embed ExtUtils::Installed ExtUtils::Install
ExtUtils::Liblist::Kid ExtUtils::Liblist ExtUtils::MakeMaker::bytes
ExtUtils::MakeMaker::vmsish ExtUtils::MakeMaker ExtUtils::Manifest
ExtUtils::Mkbootstrap ExtUtils::Mksymlists ExtUtils::MM_Any
ExtUtils::MM_BeOS ExtUtils::MM_Cygwin ExtUtils::MM_DOS
ExtUtils::MM_MacOS ExtUtils::MM_NW5 ExtUtils::MM_OS2 ExtUtils::MM
ExtUtils::MM_Unix ExtUtils::MM_UWIN ExtUtils::MM_VMS ExtUtils::MM_Win32
ExtUtils::MM_Win95 ExtUtils::MY ExtUtils::Packlist ExtUtils::testlib
Fatal fields File::Basename File::CheckTree File::Compare File::Copy
File::DosGlob File::Find File::Path File::Spec::Cygwin File::Spec::Epoc
File::Spec::Functions File::Spec::Mac File::Spec::OS2 File::Spec::Unix
File::Spec::VMS File::Spec::Win32 File::Spec File::stat File::Temp
FileCache FileHandle filetest Filter::Simple FindBin Getopt::Long
Getopt::Std Hash::Util I18N::Collate I18N::LangTags::List I18N::LangTags
if integer IPC::Open2 IPC::Open3 less Locale::Constants Locale::Country
Locale::Currency Locale::Language Locale::Maketext::GutsLoader
Locale::Maketext::Guts Locale::Maketext Locale::Script locale
Math::BigFloat Math::BigFloat::Trace Math::BigInt::Calc
Math::BigInt::Scalar Math::BigInt::Trace Math::BigInt Math::BigRat
Math::Complex Math::Trig Memoize::AnyDBM_File Memoize::ExpireFile
Memoize::Expire Memoize::ExpireTest Memoize::NDBM_File
Memoize::SDBM_File Memoize::Storable Memoize Net::Cmd Net::Config
Net::Domain Net::FTP::A Net::FTP::dataconn Net::FTP::E Net::FTP::I
Net::FTP::L Net::FTP Net::hostent Net::netent Net::Netrc Net::NNTP
Net::Ping Net::POP3 Net::protoent Net::servent Net::SMTP Net::Time NEXT
open overload PerlIO PerlIO::via::QuotedPrint Pod::Checker Pod::Find
Pod::Functions Pod::Html Pod::InputObjects Pod::LaTeX Pod::Man
Pod::ParseLink Pod::Parser Pod::ParseUtils Pod::Perldoc::BaseTo
Pod::Perldoc::GetOptsOO Pod::Perldoc::ToChecker Pod::Perldoc::ToMan
Pod::Perldoc::ToNroff Pod::Perldoc::ToPod Pod::Perldoc::ToRtf
Pod::Perldoc::ToText Pod::Perldoc::ToTk Pod::Perldoc::ToXml Pod::Perldoc
Pod::Plainer Pod::PlainText Pod::Select Pod::Text::Color
Pod::Text::Overstrike Pod::Text::Termcap Pod::Text Pod::Usage
Search::Dict SelectSaver SelfLoader Shell sigtrap sort strict subs
Switch Symbol Term::ANSIColor Term::Cap Term::Complete Term::ReadLine
Test::Builder Test::Harness::Assert Test::Harness::Iterator
Test::Harness::Straps Test::Harness Test::More Test::Simple Test
Text::Abbrev Text::Balanced Text::ParseWords Text::Soundex Text::Tabs
Text::Wrap Thread Thread::Queue Thread::Semaphore Tie::Array Tie::File
Tie::Handle Tie::Hash Tie::Memoize Tie::RefHash Tie::Scalar
Tie::SubstrHash Time::gmtime Time::Local Time::localtime Time::tm
Unicode::Collate Unicode::UCD UNIVERSAL User::grent User::pwent utf8
vars vmsish warnings warnings::register);

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 File::Copy qw(copy move);
use User::pwent;
use Getopt::Long;
use Cwd;
use Module::Depends::Intrusive;
use strict;

my $debstdversion = '3.6.1';
my $priority = 'optional';
#my $section = 'interpreters';
my $section = 'perl';
my $depends = '${perl:Depends}';
my $bdependsi = 'perl (>= 5.8.0-7)';
my $bdepends = 'debhelper (>= 4.0.2)';
my $maintainer = get_maintainer();
my $arch = 'all';
my $date = `822-date`;
my $debiandir;
my $startdir = getcwd();
my $dh_compat = 4;

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

my $mod_cpan_version;

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

GetOptions(
	"cpan=s" => \$cpanmodule,
#	"cpanplus=s" => \$cpanplusmodule,
	"cpan-mirror=s" => \$cpanmirror,
	"desc=s" => \$desc,
	"arch=s" => \$arch,
	"version=s" => \$version,
	"help" => sub {die "\n"},
	# disabled: see build_package()
	"dbflags=s" => \$dbflags,
	"exclude|i" => \$excludeRE,
	"build!" => \$build,
	"install!" => \$install,
	"notest" => \$notest,
	) || die <<"USAGE";
Usage:
$0 [ --build ] [ --install ] [ SOURCE_DIR | --cpan MODULE ]
Other options: [ --desc DESCRIPTION ] [ --arch all|any ] [ --version VERSION ]
               [ --cpan-mirror MIRROR ] [ --exclude|-i [REGEX] ] [ --notest ]
USAGE

$excludeRE = '(?:\/|^)(?:CVS|.svn)\/' if ($excludeRE && $excludeRE == 1);

load_overrides();
my $tarball = setup_dir();
   ($pkgname, $version) = extract_basic();
move ($tarball, dirname($tarball) . "/${pkgname}_${version}.orig.tar.gz") if ($tarball && $tarball =~ /(?:\.tar\.gz|\.tgz)$/);
my $module_build = (-f "$maindir/Build.PL") ? "Module-Build" : "MakeMaker";
$bdepends .= ', libmodule-build-perl' if ($module_build eq "Module-Build");
$depends .= ', ${shlibs:Depends}' if $arch eq 'any';
$depends .= ', ${misc:Depends}';
extract_changelog($maindir);
extract_docs($maindir);
$depends .= ", " . extract_depends($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_compat("$debiandir/compat");
create_watch("$debiandir/watch", $cpanmodule) if ($cpanmodule);
#create_readme("$debiandir/README.Debian");
create_copyright("$debiandir/copyright");
fix_rules("$debiandir/rules", (defined $changelog ? $changelog : ''), @docs);
apply_final_overrides();
build_package($maindir) if $build or $install;
install_package($debiandir) if $install;
print "Done\n";
exit(0);

sub setup_dir {
	my $tarball;
	$mod_cpan_version = '';
	if ($cpanmodule) {
        # Is the module a core module
        if ((grep(/$cpanmodule/, @pragmas)) ||
            (grep(/$cpanmodule/, @stdmodules))) {
            die "$cpanmodule is a standard module.\n";
        }	
	
		require CPAN;
		CPAN::Config->load;

		unshift @{$CPAN::Config->{'urllist'}}, $cpanmirror if $cpanmirror;

		$CPAN::Config->{'build_dir'} = $ENV{'HOME'} . "/.cpan/build";
		$CPAN::Config->{'cpan_home'} = $ENV{'HOME'} . "/.cpan/";
		$CPAN::Config->{'histfile'}  = $ENV{'HOME'} . "/.cpan/history";
		$CPAN::Config->{'keep_source_where'} = $ENV{'HOME'} . "/.cpan/source";
                
		my ($dist, $mod, $cpanversion);
		$mod = CPAN::Shell->expand('Module', '/^'.$cpanmodule.'$/') 
			|| die "Can't find '$cpanmodule' module on CPAN\n";
		$mod_cpan_version = $mod->cpan_version;
		$cpanversion = $CPAN::VERSION;
		$cpanversion =~ s/_.*//;

		$tarball = $CPAN::Config->{'keep_source_where'} . "/authors/id/";
                
		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";
                        $tarball .= $mod->{CPAN_FILE};
			$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";
                        $tarball .= $mod->cpan_file;
                        $maindir = $dist->dir;
		}

		copy ($tarball, $ENV{'PWD'});
		$tarball = $ENV{'PWD'} . "/" . basename($tarball);
		my $new_maindir = $ENV{PWD}."/".basename($maindir);
		`mv "$maindir" "$new_maindir"`;
		$maindir = $new_maindir;

	} elsif ($cpanplusmodule) {
        die "CPANPLUS support is b0rken at the moment.";
        
		eval "use CPANPLUS 0.045;";
		my $cb = CPANPLUS::Backend->new(conf => {debug => 1, verbose => 1});
		my $href = $cb->fetch( modules => [ $cpanplusmodule ], fetchdir => $ENV{'PWD'});
		die "Cannot get $cpanplusmodule\n" if keys(%$href) != 1;
		my $file = (values %$href)[0];
		print $file, "\n\n";
		$maindir = $cb->extract( files => [ $file ], extractdir => $ENV{'PWD'} )->{$file};
	} else {
		$maindir = shift(@ARGV) || '.';
		$maindir =~ s/\/$//;
	}
	return $tarball;
}

sub build_package {
	my $maindir = shift;
	# uhmf! dpkg-genchanges doesn't cope with the deb being in another dir..
	#system("dpkg-buildpackage -b -us -uc $dbflags") == 0
	system("fakeroot make -C $maindir -f debian/rules clean");
	system("fakeroot make -C $maindir -f 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 {
	($perlname, $version) = extract_name_ver();
	find(\&check_for_xs, $maindir);
	$pkgname = lc $perlname;
	$pkgname =~ s/::/-/;
	$pkgname = 'lib'.$pkgname unless $pkgname =~ /^lib/;
	$pkgname .= '-perl' unless ($pkgname =~ /-perl$/ and $cpanmodule !~ /::perl$/i);

	# 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 {
		(! $excludeRE || ! $File::Find::name =~ /$excludeRE/) && /\.(pm|pod)$/ && do { extract_desc($_) };
	}, $maindir);

        return ($pkgname, $version);
}

sub extract_name_ver {
	my $meta = "$maindir/META.yml";
	my $makefile = "$maindir/Makefile.PL";
	if(-f $meta) {
                return extract_name_ver_from_meta($meta);
	} else {
		return extract_name_ver_from_makefile($makefile);
	}
}

sub extract_name_ver_from_meta {
	my $meta = shift;
	my $data = YAML::LoadFile($meta);
	return ($data->{name}, $data->{version});
}

sub extract_name_ver_from_makefile {
	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 =~ /(['"]?)DISTNAME\1\s*(=>|,)\s*(['"]?)(\S+)\3/s;
    $name = $4 if ! $name && $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);
	$name = $cpanplusmodule if ($name eq '__PACKAGE__' && $cpanplusmodule);
	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
		if ( open(MF, "<$dir/$vfrom") ) {
			while (<MF>) {
				if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
					no strict;
					#warn "ver: $_";
					$ver = (eval $_)[0];
					last;
				}
			}
			close(MF);
		} else {
			if ( $mod_cpan_version ) {
				warn "Cannot open $dir/$vfrom to gather the ".
				     "version: using cpan_version\n";
				$ver = $mod_cpan_version;
			} else {
				die "Cannot open $dir/$vfrom to gather the ".
				    "version: use --cpan or --version\n";
			}
		}
	}
	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 DETAILS 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;
	}
	unless ($longdesc) {
		$longdesc = $parser->get('DESCRIPTION')
			|| $parser->get('DETAILS')
			|| $desc;
		$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;
		$longdesc =~ s/\r//g;
	}
	$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 && (! $excludeRE || ! $File::Find::name =~ /$excludeRE/));
	}, $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 && (! $excludeRE || ! $File::Find::name =~ /$excludeRE/)) ;
	}, $dir);
}

sub extract_depends {
	my ($dir) = shift;
	$dir .= '/' unless $dir =~ m/\/$/;

	my $mod_dep = Module::Depends::Intrusive->new();
	
	$mod_dep->dist_dir( $dir );
	$mod_dep->find_modules();

	my %dep_hash = %{$mod_dep->requires};
	
	my @uses;

	foreach my $module (keys( %dep_hash )) {
		next if (grep ( /^$module$/, @pragmas, @stdmodules));
		
		push @uses, $module;
	}

	my @deps;
	my @not_debs;

	if (`which apt-file`) {
		foreach my $module (@uses) {
			print "Searching for $module package using apt-file.\n";
			$module =~ s|::|/|g;

			my @search = `apt-file search $module.pm`;

			# Regex's to search the return of apt-file to find the right pkg
			my $ls  = '(?:lib|share)';
			my $ver = '\d+(\.\d+)+';
			my $re  = "usr/(?:$ls/perl/$ver|$ls/perl5)/$module\\.pm";
				
			for (@search) {
				# apt-file output
				# package-name: path/to/perl/module.pm
				chomp; 
				my ($p, $f) = split / /, $_;
				chop($p); #Get rid of the ":"
				if ($f =~ /$re/ && ! grep { $_ eq $p } @deps, "perl", "perl-base", "perl-modules") {
					push @deps, $p;
					last;
				}
			}
			
			unless (@search) {
			    $module =~ s|/|::|g;
				push @not_debs, $module;
		    }
		}
	}
	
	print "\n";
	print "Needs the following debian packages: " . join (", ", @deps) . "\n" if (@deps);
	print "Needs the following modules for which there are no debian packages available: "
		. join (", ", @not_debs) . "\n" if (@not_debs);
	
	return join (", ", @deps);
}

sub check_for_xs {
	(! $excludeRE || ! $File::Find::name =~ /$excludeRE/) && /\.(xs|c|cpp|cxx)$/i && do {
		$arch = 'any';
	};
}

sub fix_rules  {
	my ($rules_file, $changelog_file, @docs) = @_;

	my $test_line = ($module_build eq 'Module-Build') ? 
	    '$(PERL) Build test' : '$(MAKE) test';
	$test_line = "#$test_line" if $notest;

	open (FH, "+<$rules_file") || die "Can't open $rules_file: $!";
	my @content = <FH>;
	seek(FH, 0, 0) || die "Can't rewind $rules_file: $!";
	truncate(FH, 0)|| die "Can't truncate $rules_file: $!";
	for (@content) {
		s/#CHANGES#/$changelog_file/g;
		s/#DOCS#/join " ", @docs/eg;
		s/#TEST#/$test_line/g;
		print FH $_;
	}
	close FH;
}

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 "Build-Depends-Indep: $bdependsi\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 .\n This description was automagically extracted from the module by dh-make-perl.\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.$module_build.noxs":"rules.$module_build.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_compat {
	my $file = shift;
	open(COMPAT, ">$file") or die "Can't open $file: $!\n";
	print COMPAT "$dh_compat\n";
	close COMPAT;
}

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

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;
		# Fun with regexes
		if ( $copyright =~ /same terms as Perl itself/i ) {
		    print C "\n\n", <<END;
Perl is distributed under your choice of the GNU General Public License or
the Artistic License.  On Debian GNU/Linux systems, the complete text of the
GNU General Public License can be found in \`/usr/share/common-licenses/GPL\'
and the Artistic Licence in \`/usr/share/common-licenses/Artistic\'.
END
		} elsif ( $copyright =~ /GPL/ ) {
		    print C "\n\n", <<END;
The full text of the GPL is available on Debian systems in
/usr/share/common-licenses/GPL
END
		}
	}
	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 create_watch {
	my ($file, $perl_path_name) = @_;
	open(C, ">$file") || die "Cannot open $file: $!\n";
	
	$perl_path_name =~ s|::|-|g;
	$perl_path_name =~ s|(\w+)(-.*)|$1/$1$2|;
	$perl_path_name .= "-(.*)(\.tar\.gz|\.tar|\.tgz)";

	print C "\# format version number, currently 2; this line is compulsory!\n";
	print C "version=2\n";
	print C "http://www.cpan.org/modules/by-module/$perl_path_name\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;
	}

	$email =~ s/^(.*)\s+<(.*)>$/$2/;
	
	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')));
	$bdependsi = $val if (defined($val=get_override_val($data, $subkey, 'bdependsi')));	
	$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

B<dh-make-perl> - Create debian source packages from perl modules

=head1 SYNOPSIS

B<dh-make-perl> [B<SOURCE_DIR> | B<--cpan> I<MODULE>]

You can modify B<dh-make-perl>'s behaviour with some switches:

=over

=item B<--desc> I<SHORT DESCRIPTION>

Uses the argument to --desc as short description for the package.

=item B<--arch> I<any> | I<all>

This switches between arch-dependent and arch-independet packages. If B<--arch>
isn't used, B<dh-make-perl> uses a relatively good-working algorithms to
decide this alone.

=item B<--version> I<VERSION>

Specifies the version of the resulting package.

=item B<--cpan-mirror> I<MIRROR>

Specifies a CPAN site to use as mirror.

=item B<--exclude> | B<-i> [I<REGEX>]

This allows you to specify a PCRE to exclude some files from the search for
docs and stuff like that. If no argument is given, it uses a default to
exclude CVS and .svn directories.

=item B<--build>

Builds the package after setting it up

=item B<--install>

Installs the freshly built package. Specifying --install implies --build - The
package will not be installed unless it was built (obviously ;-) )

=item B<--notest>

Does not run the automatic testing of the module as part of the build script.
This is mostly useful when packaging buggy or incomplete software.

=back

=head1 DESCRIPTION

B<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 B<--cpan> switch
and B<dh-make-perl> will download the module for you from
a CPAN mirror, or you can specify the directory with the
already unpacked sources. If neither --cpan nor a directory
is given as argument, dh-make-perl tries to create a
perl package from the data in F<.>

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/share/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.MakeMaker.noxs

A debian/rules makefile for modules that use ExtUtils::MakeMaker, but don't
have C/XS code.

=item * rules.MakeMaker.xs

A debian/rules makefile for modules that use ExtUtils::MakerMaker and
C/XS code.

=item * rules.Module-Build.noxs

A debian/rules makefile for modules that use Module::Build, but don't have 
C/XS code.

=item * rules.Module-Build.xs

A debian/rules makefile for modules that use Module::Build and 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> (MIA)

Maintained for a time by Ivan Kohler E<lt>ivan-debian@420.amE<gt>.

Maintained for a time by Marc Brockschmdit E<lt>marc@dch-faq.deE<gt>.

Now maintained by Gunnar Wolf E<lt>gwolf@gwolf.orgE<gt>.

Patches from:
  Gergely Nagy E<lt>algernon@bonehunter.rulez.orgE<gt>
  Adrian Phillips E<lt>adrianp@powertech.noE<gt>
  Ton Nijkes E<lt>tonn@wau.mis.ah.nlE<gt>
  Matt Hope E<lt>dopey@debian.orgE<gt>
  Juerd E<lt>juerd@ouranos.juerd.netE<gt>
  Christian Kurz E<lt>shorty@debian.orgE<gt>
  David Pashley E<lt>david@davidpashley.comE<gt>
  Edward Betts E<lt>edward@debian.orgE<gt>

=cut

