#!/usr/bin/perl

=head1 NAME

    debosh

=head1 DESCRIPTION

    Instant debian packaging
    
    черновая сборка, от текущей рабочей копии: 
    debosh --dirty

    сборка старой версии проекта
    debosh --rev 567 

    сборка, с указанием "debian_revision" (часть в версии, после -)
    по-умолчанию 1
    debosh --deb-rev 2

    не запускать тесты
    debosh --no-tests

    готовые пакеты складывать в указанный каталог
    debosh --debdir ../debian

    строгая проверка, что все зависимости явно указаны в meta.yaml:
    debosh --dirty -s
    debosh --strict

    $Id:$

=cut

=head1 METHODS

=cut

use strict;
use warnings;
use open ':std' => ':utf8';
use utf8;

use Cwd qw/getcwd/;
use File::Find qw/find/;
use File::Type;
use File::Slurp;
use File::Temp qw/tempdir/;
use Getopt::Long;
use List::MoreUtils qw/none uniq/;
use Module::Info;
use YAML;

umask 022;

my %DIR_MAP = (
    bin  => 'usr/local/bin',
    etc  => 'etc',
    lib  => 'usr/share/perl5',
    opt  => 'opt',
    usr  => 'usr',
    sbin => 'usr/local/sbin',
    share => 'usr/local/share',
    var  => 'var',
    home => 'home',
);

my @dpkg_actions = qw/preinst postinst prerm postrm/;

$ENV{LC_ALL} = "C";

# исключительно местный костыль, в апстрим не нужен
$ENV{TMPDIR} = '/tmp/temp-ttl/ttl_1d' if (-d '/tmp/temp-ttl/ttl_1d');

my $CLEANUP = 1;
my $DEBDIR  = undef;
my $DIRTY   = 0;
my $REVISION = 'HEAD';
my $DEBIAN_REVISION = '1';
my $RUN_TESTS = 1;
my $STRICT = 0;
GetOptions(
    'cleanup!' => \$CLEANUP,
    'debdir=s' => \$DEBDIR,
    'dirty'    => \$DIRTY,
    'rev=s'    => \$REVISION,
    'deb-rev=s'=> \$DEBIAN_REVISION,
    'tests!'   => \$RUN_TESTS,
    's|strict' => \$STRICT,
    'h|help'   => \&usage,
);

if ($DEBIAN_REVISION !~ /^[a-z0-9\+\.\~]+$/) {
    die "Incorrect value for --deb-rev option";
}

my $start_dir = getcwd();
my $work_dir  = tempdir(CLEANUP => $CLEANUP);
print "Created working directory $work_dir\n";

my $source_dir   = $DIRTY ? $start_dir : obtain_source($work_dir, rev => $REVISION);
my $package_info = get_package_info($source_dir, dirty => $DIRTY);

my $package_dir = "$work_dir/package";
mkdir $package_dir or die "Can't mkdir '$package_dir'";
create_debian_files($package_info, $package_dir, $source_dir);
chdir $package_dir;
my $error = system('dpkg-buildpackage -rfakeroot');
die "packaging failed: $?" if $error;

opendir(my $dh, $work_dir);
my @files = readdir($dh);
my @deb_files = grep {-f "$work_dir/$_"} @files;
closedir($dh);
die "No deb files in '$work_dir'" unless @deb_files;

chdir $start_dir;
my $debian_dir = $DEBDIR || "$start_dir/debian";
unless (-d $debian_dir) {
    mkdir $debian_dir or die "Can't mkdir '$debian_dir'";
}
for my $deb_file (@deb_files) {
    system('cp', "$work_dir/$deb_file", "$debian_dir");
}

exit(0);


=head2 obtain_source

    Получаем чистую копию из репозитория

=cut

sub obtain_source
{
    my ($work_dir, %O) = @_;

    my ($svn_url) = grep {/^URL: /} `svn info`;
    chomp $svn_url;
    $svn_url =~ s/URL: //;
    
    my $source_dir = "$work_dir/source";
    my $error = system("svn co $svn_url\@$O{rev} $source_dir");
    die "failed to obtain source: $?" if $error;

    # в changes должны быть так или иначе отражены все внесенные изменения
    # ==> модификация changes не должна быть старше всей рабочей копии
    my ($last_changed_rev) = grep {/^Last Changed Rev: /} `svn info $source_dir`;
    chomp $last_changed_rev;
    $last_changed_rev =~ s/Last Changed Rev: //;
    my ($last_changed_rev_changes) = grep {/^Last Changed Rev: /} `svn info $source_dir/changes`;
    chomp $last_changed_rev_changes;
    $last_changed_rev_changes =~ s/Last Changed Rev: //;
    die "too old 'changes' file: r$last_changed_rev_changes (project itself has r$last_changed_rev)" if $last_changed_rev_changes < $last_changed_rev;

    return $source_dir;
}


=head2 get_package_info

    Получаем данные пакета из содержимого директории
    Возможные опции
      dirty => undef | 1

=cut

sub get_package_info
{
    my ($source_dir, %O) = @_;

    opendir(my $dh, $source_dir);
    my @dir_content = readdir($dh);
    closedir($dh);

    my $dir_layout = {};
    # find dirs
    $dir_layout->{$_} = 1 for grep {-d "$source_dir/$_"} keys %DIR_MAP;
    # find files
    $dir_layout->{$_} = 1 for grep {-f "$source_dir/$_"} qw/changes meta.yaml/;
    # dpkg scripts: postinst, prerm, etc.
    $dir_layout->{dpkg_actions}->{$_} = 1 for grep {-f "$source_dir/actions/$_"} @dpkg_actions;

    die 'no changes file'   unless $dir_layout->{changes};
    die 'no meta.yaml file' unless $dir_layout->{'meta.yaml'};
    my @main_dirs = grep {$DIR_MAP{$_}} keys %DIR_MAP;
    die "none of dirs @main_dirs is present" if none {$dir_layout->{$_}} @main_dirs;

    my $meta = YAML::Load(scalar read_file("$source_dir/meta.yaml"));
    die "package is not specified" unless $meta->{package};
    my $version = get_version(scalar read_file("$source_dir/changes"));
    if ($O{dirty}) {
        $version .= '~dirty';
    }

    $meta->{dir_layout} = $dir_layout;
    $meta->{version}    = $version;
    $meta->{requires} ||= {};
    die "bad format of field 'requires'" unless ref($meta->{requires}) eq 'HASH';
    $meta->{build_requires} ||= {};
    die "bad format of field 'build_requires'" unless ref($meta->{build_requires}) eq 'HASH';
    $meta->{conflicts} ||= {};
    die "bad format of field 'conflicts'" unless ref($meta->{conflicts}) eq 'HASH';
    $meta->{provides} ||= {};
    die "bad format of field 'provides'" unless ref($meta->{provides}) eq 'HASH';
    $meta->{replaces} ||= {};
    die "bad format of field 'replaces'" unless ref($meta->{replaces}) eq 'HASH';
    $meta->{perl_ignore} ||= [];
    die "bad format of field 'perl_ignore'" unless ref($meta->{perl_ignore}) eq 'ARRAY';

    my $missing_dependencies_found;
    for my $package (sort(get_perl_deps($source_dir, $dir_layout, $meta->{perl_ignore}))) {
        unless(defined $meta->{requires}->{$package}) {
            $meta->{requires}->{$package} = 0;
            warn "Package $package is required but not specified in meta.yaml!";
            $missing_dependencies_found = 1;
        }
    }
    die if $STRICT && $missing_dependencies_found;

    return $meta;
}


=head2 get_version

    Разбираем изменения, чтобы получить текущую версию

=cut

sub get_version
{
    my $changes = shift;

    my ($version) = split /\n/, $changes, 2;
    $version =~ s/\s+$//;
    die "bad version string '$version'" unless $version =~ /\d+(?:\.\d+)*/;
    return $version;
}


=head2 get_perl_deps

    Достаем зависимости от perl-пакетов
    Проверяем модули и скрипты
    Возвращаем список debian-пакетов

=cut

sub get_perl_deps
{
    my $source_dir = shift;
    my $dir_layout = shift;
    my $ignore_arr = shift;

    my $current_dir = getcwd();
    my $lib_dir;
    if ($dir_layout->{lib}) {
        $lib_dir = "$source_dir/lib";
        chdir $lib_dir;
        unshift @INC, $lib_dir;
    }

    my @perl_sources = ();
    my $is_file = sub {-f $_[0] && $_[0] !~ /\.svn/};
    my %find_rules = (
        bin => sub { 
            $is_file->($File::Find::name) && 
            File::Type->new()->mime_type($File::Find::name) eq 'application/x-perl' && 
            push @perl_sources, $File::Find::name 
        }, # TODO be smarter
        lib => sub { $is_file->($File::Find::name) && /\.pm$/ && push @perl_sources, $File::Find::name },
    );
    for my $dir (grep {$dir_layout->{$_}} keys %find_rules) {
        find($find_rules{$dir}, "$source_dir/$dir");
    }
    my %ignore = map { $_ => 1 } @$ignore_arr; 
    my @modules = grep {!$ignore{$_}} uniq map {Module::Info->new_from_file($_)->modules_used()} @perl_sources;
    my @deps = ();
    foreach my $module (@modules) {
        my @mods = Module::Info->all_installed($module) or die "Can't get info for module '$module'";
        next if grep {$_->is_core} @mods;
        my $info = $mods[0];
        # если модуль находится в том пакете, который собираем -- ok, нигде больше не ищем
        next if $dir_layout->{lib} && $info->inc_dir eq $lib_dir;
        my $file = $info->file;
        my ($result) = `dpkg -S $file`;
        die 'dpkg returned nothing' unless $result;
        die "Can't resolve package name for module '$module', file '$file'" if $result =~ /not found/;
        if ($result =~ /^([^:]+):/) {
            push @deps, $1;
        }
    }
    if ($dir_layout->{lib}) {
        chdir $current_dir;
        shift @INC;
    }
    return uniq @deps;
}


=head2 create_debian_files

    Создаем директорию debian и файлы changelog, compat, control, rules

=cut

sub create_debian_files
{
    my $package_info = shift;
    my $package_dir  = shift;
    my $source_dir   = shift;

    my $debian_dir = "$package_dir/debian";
    mkdir $debian_dir or die "Can't mkdir '$debian_dir'";

    my $version = "$package_info->{version}-".$DEBIAN_REVISION;
    my ($date) = `date -R`;

    my $changelog = <<CHANGELOG;
$package_info->{package} ($version) unstable; urgency=low

  * next auto build

 -- $ENV{DEBFULLNAME} <$ENV{DEBEMAIL}>  $date


CHANGELOG
    write_file("$debian_dir/changelog", {atomic => 1}, $changelog);

    my $depends = format_depends($package_info->{requires}, ());
    my $build_depends = format_depends($package_info->{build_requires}, 'debhelper (>= 5)');
    my $conflicts = format_depends($package_info->{conflicts});
    my $provides = format_depends($package_info->{provides});
    my $replaces = format_depends($package_info->{replaces});
    my $control = <<CONTROL;
Source: $package_info->{package}
Section: unknown
Priority: extra
Maintainer: $ENV{DEBFULLNAME} <$ENV{DEBEMAIL}>
Build-Depends: $build_depends
Standards-Version: 3.7.2

Package: $package_info->{package}
Architecture: all
Depends: $depends
Conflicts: $conflicts
Provides: $provides
Replaces: $replaces
Description: $package_info->{description}
 $package_info->{description}
CONTROL
    write_file("$debian_dir/control", {atomic => 1}, $control);

    my $rules = <<RULES;
#!/usr/bin/make -f
# -*- makefile -*-

# Uncomment this to turn on verbose mode.
#export DH_VERBOSE=1

# This has to be exported to make some magic below work.
export DH_OPTIONS

SOURCE = $source_dir
DEST = debian
DEST_MAIN = debian/$package_info->{package}

build:
%BUILD%

binary: install
	echo nop

clean:
	dh_testdir
	dh_testroot
	dh_clean
	rm -f build-arch-stamp build-indep-stamp #CONFIGURE-STAMP#

	# Add here commands to clean up after the build process.
	-\$(MAKE) clean

	dh_clean

install:
	dh_testdir
	dh_testroot
	dh_clean -k -i
	dh_installdirs

	# main
%MAIN%
	dh_perl
	dh_link
	dh_fixperms
	#dh_makeshlibs
	dh_installdeb
	#dh_shlibdeps
	dh_gencontrol -- -v$version
	dh_md5sums
	dh_builddeb -- -Zgzip

.PHONY: build clean install
RULES

    my $main = '';
    for my $dir (grep {$package_info->{dir_layout}->{$_}} keys %DIR_MAP) {
        $main .= qq[\tinstall -d \${DEST_MAIN}/$DIR_MAP{$dir}\n];
        $main .= qq[\trsync -a --exclude=".svn" \${SOURCE}/$dir/ \${DEST_MAIN}/$DIR_MAP{$dir}/\n];
    }
    # ubuntu 12.04: /etc/crontab and the files in /etc/cron.d must be owned by root, and must not be group- or other-writable.
    $main .= qq[\tchmod 0644 \${DEST_MAIN}/etc/cron.d/* || true\n];
    $rules =~ s/%MAIN%/$main/;

    my $build = "\techo nop";
    if (-d "$source_dir/t" && $RUN_TESTS) {
        $build = "\tprove -I\${SOURCE}/lib -r \${SOURCE}/t";
    }
    if (-d "$source_dir/t.py" && $RUN_TESTS) {
        $build = $build . "\n\tpython -m unittest discover -s \${SOURCE}/t.py -v";
        $build = $build . "\n\trm \${SOURCE}/bin/*.pyc || true";
    }
    $rules =~ s/%BUILD%/$build/;

    write_file("$debian_dir/rules", {atomic => 1}, $rules);
    write_file("$debian_dir/compat", {atomic => 1}, '5');
    chmod 0755, "$debian_dir/rules";

    for my $action (keys %{$package_info->{dir_layout}->{dpkg_actions}} ){
        write_file("$debian_dir/$package_info->{package}.$action", {atomic => 1}, scalar read_file("$source_dir/actions/$action"));
        chmod 0755, "$debian_dir/$package_info->{package}.$action";
    }

    # create symlink file
    if (my $sl = $package_info->{symlink}) {
        my $mapped_dir_re = join q{|}, map {quotemeta $_} grep {$_ ne $DIR_MAP{$_}} keys %DIR_MAP;
        my $adjust_re = qr# ^ ($mapped_dir_re) (?=/) #xms;
        my %asl = map { my $p = $_; $p =~ s/$adjust_re/$DIR_MAP{$1}/xms; $p } %$sl;

        my $link_data = join q{}, map {"$asl{$_} $_\n"} keys %asl;
        write_file("$debian_dir/$package_info->{package}.links", {atomic => 1}, $link_data);
        chmod 0755, "$debian_dir/$package_info->{package}.links";
    }
}

=head2 format_depends($depends_hash, @additional_depends)

    Из хэша с зависимостями делаем отформатированную строку для control

=cut
sub format_depends {
    my ($depends_hash, @add_depends) = @_;
    return join ",\n         ", 
            @add_depends,
            map {$_ . ($depends_hash->{$_} ? " ($depends_hash->{$_})" : '')} keys %$depends_hash;
}


=head2 usage

    usage-сообщение

=cut 
sub usage {
    system("podselect -section SYNOPSIS -section DESCRIPTION $0 | pod2text-utf8 >&2");
    exit(1);
}

