package DhMakeELPA::Command::Packaging;

use strict;
use warnings;

our $VERSION = '0.19.1';

=head1 NAME

DhMakeELPA::Command::Packaging - routines for 'make' dh-make-elpa command

=cut

use base 'DhMakeELPA';

__PACKAGE__->mk_accessors(
    qw( main_dir debian_dir
        bins control pkgname
        homepage elpa_version
        copyright gpl_version
        rules
      )
);

use Array::Unique;
use Array::Utils qw{array_minus};
use Cwd;
use Debian::Control;
use Debian::Rules;
use DhMakeELPA::MELPA;
use File::Basename qw{basename};
use File::Copy;
use File::Find::Rule;
use File::Grep qw{fgrep};
use File::Path ();
use File::Spec::Functions qw(catfile catpath splitpath);
use Git::Repository;
use TryCatch;

use constant debstdversion => '4.5.1';

our %DEFAULTS = (
);

sub new {
    my $class = shift;
    $class = ref($class) if ref($class);

    my $self = $class->SUPER::new(@_);

    while( my( $k, $v ) = each %DEFAULTS ) {
        $self->$k($v) unless defined $self->$k;
    }

    $self->cfg or die "cfg is mandatory";

    my @docs;
    tie @docs, 'Array::Unique';

    $self->docs( \@docs );

    $self->control( Debian::Control->new )
        unless $self->control;

    return $self;
}

=head1 METHODS

=over

=item main_file(file_name)

Constructs a file name relative to the main source directory, L</main_dir>

=cut

sub main_file {
    my( $self, $file ) = @_;

    catfile( $self->main_dir, $file );
}

=item debian_file(file_name)

Constructs a file name relative to the debian/ sub-directory of the main source
directory.

=cut

sub debian_file {
    my( $self, $file ) = @_;

    catfile( $self->main_file('debian'), $file );
}

sub get_user {
    return $ENV{LOGNAME} || $ENV{USER};
}

sub get_email {
    my $self = shift;
    my $email = $self->cfg->email;

    $email ||= ( $ENV{DEBEMAIL} || $ENV{EMAIL} );
    unless ($email) {
	my $mailh;
        chomp( $mailh = `cat /etc/mailname` );
        $email = $self->get_user . '@' . $mailh;
    }

    $email =~ s/^(.*)\s+<(.*)>$/$2/;
    return $email;
}

sub get_name {
    my $self = shift;

    my $name;
    my $user = $self->get_user;
    my $pwnam = getpwuid($<);
    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;
    return $name;
}

sub get_developer {
    my $self = shift;
    return $self->get_name . " <" . $self->get_email . ">";
}

sub fill_maintainer {
    my $self = shift;

    my $src = $self->control->source;
    my $maint = $self->get_developer;

    if ( $self->cfg->pkg_emacsen ) {
        my $pkg_emacsen_maint
            = "Debian Emacsen team <debian-emacsen\@lists.debian.org>";
        unless ( ( $src->Maintainer // '' ) eq $pkg_emacsen_maint ) {
            my $old_maint = $src->Maintainer;
            $src->Maintainer($pkg_emacsen_maint);
            $src->Uploaders->add($old_maint) if $old_maint;
        }

        $src->Uploaders->add($maint);
    }
    else {
        $src->Maintainer($maint);
    }
}

sub get_wnpp {
    my ( $self, $package ) = @_;

    return undef unless $self->cfg->network;

    my $wnpp = Debian::WNPP::Query->new(
        { cache_file => catfile( $self->cfg->home_dir, 'wnpp.cache' ) } );
    my @bugs = $wnpp->bugs_for_package($package);
    return $bugs[0];
}

sub extract_basic {
    my $self = shift;

    $self->debian_dir( $self->main_file('debian') );
    $self->find_bins();
    # TODO filter out other characters invalid in source package names
    # TODO better way than just looking at dir name?
    $self->pkgname( basename(cwd()) =~ s/\./-/r );
    if ( $self->cfg->version ) {
        $self->elpa_version($self->cfg->version);
    } else {
        $self->elpa_version($self->extract_version());
    }

    # Find the homepage, license and copyright by looking at the root
    # .el file, if it exists, of the binary package with the shortest
    # name, then the second shortest etc.  This might leave any of
    # these three undefined
    foreach my $bin (sort {length($a) <=> length($b)} keys %{$self->bins}) {
        my $fh = $self->_file_r( $self->main_file("$bin.el") );
        while (my $line = $fh->getline()) {
            if ($line =~ /^;; (X-)*URL: /) {
                chomp(my $homepage = $');
                $self->homepage($homepage);
            } elsif ($line =~ /^;; Copyright /) {
                chomp(my $copyright = $');
                $copyright =~ s/  / /g;
                $self->copyright($copyright);
            } elsif ($line =~ /either version 2/) {
                $self->gpl_version("2");
            } elsif ($line =~ /either version 3/) {
                $self->gpl_version("3");
            }
        }
        $fh->close;
        if (defined $self->homepage) {
            last;
        }
    }
}

sub find_bins {
    my $self = shift;

    my @el_files = glob($self->main_dir . "/*.el");
    unless ( @el_files ) {
        print "no *.el files in the current directory -- are you running\n";
        print "dh-make-elpa in the right place?\n";
        exit 1;
    }

    my @pkg_files = glob($self->main_dir . "/*-pkg.el");
    @el_files = array_minus( @el_files, @pkg_files );
    # try to ensure that the 'root' .el file is at the front of the list
    @el_files = sort { length $a cmp length $b } @el_files;
    my $single_bin = sub {
        my $bin = basename($el_files[0]) =~ s/\.el$//r;
        $self->bins({ "$bin" => ["*.el"] });
    };

    if (@el_files == 1) {
        &$single_bin();
    } else {
        $self->bins({});
        # there could be -pkg.el files that don't have an associated .el
        # file (e.g. helm-core-pkg.el) so add those back in to the list
        # we're going to check
        @el_files = (@el_files, grep { $_ =~ s/-pkg//; ! -f $_} @pkg_files);
        foreach my $el (@el_files) {
            my $pkg = $el =~ s/\.el$/-pkg.el/r;
            my $name = basename($el) =~ s/\.el$//r;
            # see if this package is a root package file: either it has an
            # accompanying -pkg.el, or it contains a Package-Version: line
            if (-f "$pkg" || fgrep { /^;; Package-Version:/ } $el) {
                my @files;
                try {
                    @files = package_files_list($name);
                } catch {
                    print "W: Could not download recipe for $name from MELPA\n";
                    print "W: Falling back to a single binary package\n";
                    &$single_bin();
                    last;
                }
                $self->bins->{$name} = \@files;
            }
        }
        # fallback: if we failed to figure out the bins, just use a
        # single one
        if ( scalar %{$self->bins} eq 0) {
            print "W: Failed to determine binary packages\n";
            print "W: Falling back to a single binary package\n";
            &$single_bin();
        }
    }
}

sub create_elpa {
    my $self = shift;
    if (keys %{$self->bins} le 1) {
        my $fh = $self->_file_w( $self->debian_file('elpa') );
        $fh->print( "*.el\n" );
        $fh->close;
    } else {
        foreach my $bin ( keys %{$self->bins} ) {
            my @files = @{$self->bins->{$bin}};
            my $fh = $self->_file_w( $self->debian_file("elpa-$bin.elpa") );
            foreach my $file (@files) {
                $fh->print("$file\n");
            }
            $fh->close;
        }
    }
}

sub fill_vcs {
    my $self = shift;
    my $src = $self->control->source;

    if ( $self->cfg->pkg_emacsen ) {
        $src->Vcs_Git(
                      sprintf( "https://salsa.debian.org/emacsen-team/%s.git",
                               $self->pkgname )
                     );
        $src->Vcs_Browser(
                          sprintf( "https://salsa.debian.org/emacsen-team/%s",
                                   $self->pkgname )
                         );
    }
}

# TODO Emacs might be able to extract this information better than we
# can: it can generate -pkg.el files from .el files
sub extract_description {
    my ($self, $el_file) = @_;
    my ($short_desc, $long_desc);
    my $package = $el_file =~ s/\.el//r;
    my $pkg_file = $package."-pkg.el";

    if ( -e $pkg_file ) {
        my $fh = $self->_file_r($pkg_file);
        my $lines = join("", $fh->getlines);
        $lines =~ s/\n//g;
        $short_desc = $lines =~ s/.*\(define-package\s+"[^"]+"\s+"[^"]+"\s+"([^"]+)".*/$1/rg;
        $fh->close;
    }

    if ( -e $el_file ) { # helm-core.el doesn't exist, though helm-core-pkg.el does
        my $fh = $self->_file_r($el_file);
        unless (defined $short_desc) {
            my $line = $fh->getline;
            $short_desc = $line =~ s/^.*--- (.*)$/$1/r =~ s/-\*- .* -\*-//r;
        }
        my $lines = join("", $fh->getlines);
        if ( $lines =~ /;;; Commentary:/ ) {
            $lines =~ /.*Commentary:\n\n(.*?)\n\n;;; Code:.*/s;
            if ( defined $1 ) {
                $long_desc = $1 =~ s/;;[ ]*//rsg;
            }
        }
        $fh->close;
    }

    unless (defined $short_desc) {
        print "I: couldn't determine short description for $package\n";
        $short_desc = "couldn't determine short description";
    }
    unless (defined $long_desc) {
        print "I: couldn't determine long description for $package\n";
        $long_desc = "couldn't determine long description";
    }
    return ($short_desc, $long_desc);
}

# TODO we might fall back to looking at the git tags
sub extract_version {
    my $self = shift;
    my $version;
    foreach my $bin ( keys %{$self->bins} ) {
        if ( -f $self->main_file("$bin-pkg.el") ) {
            my $fh = $self->_file_r("$bin-pkg.el");
            while (my $line = $fh->getline) {
                if ( $line =~ /.*\(define-package\s+"[^"]+"\s+"([0-9.a-zA-Z~+-]*)"/ ) {
                    $version = "$1";
                    last;
                }
            }
            $fh->close;
            last;
        } elsif ( -f $self->main_file("$bin.el") ) {
            my $fh = $self->_file_r("$bin.el");
            while (my $line = $fh->getline) {
                if ( $line =~ /^;; (Package-)*Version\s*:\s+([0-9.a-zA-Z~+-]*)$/ ) {
                    $version = "$2";
                    last;
                }
            }
            $fh->close;
            last;
        }
    }
    if (defined $version) {
        return $version;
    } else {
        die "Could not determine package version by examining *.el files.\nPlease specify --version.";
    }
}

sub create_gbp_conf {
    my $self = shift;

    my ( $content, $repo );
    my $file = $self->debian_file('gbp.conf');

    my $gbpname = "gbp.conf";
    for my $source (
        catfile( $self->cfg->home_dir, $gbpname ),
        catfile( $self->cfg->data_dir, $gbpname )
    ) {
        if ( -e $source ) {
            print "Using gbp-conf: $source\n" if $self->cfg->verbose;
            my $fh = $self->_file_r($source);
            $content = join "", $fh->getlines();
            last;
        };
    }

    # Now we update upstream tag format if necessary: strip the
    # leading 'v' if there are no tags that match /^v[0-9]/
    try {
        $repo = Git::Repository->new( git_dir => $self->main_file('.git') );
    } catch {
        my $fh = $self->_file_w($file);
        $fh->write($content);
        return;
    };
    my @tags = split "\n", $repo->run(("tag"));
    unless ( grep { /^v[0-9]/ } @tags ) {
        $content =~ s/upstream-tag\s*=\s*v/upstream-tag = /;
    }
    my $fh = $self->_file_w($file);
    $fh->write($content);
}

# TODO more complex case with more than one binary package
sub create_docs {
    my $self = shift;

    my $doc_regexp = qr/\.md$|\.markdown$|\.mdwn$|\.org$/i;
    opendir my $dh, $self->main_dir or die "$0: Unable to open directory: $!";
    my @docs = grep { /$doc_regexp/ && -f "$self->{main_dir}/$_" } readdir($dh);
    closedir $dh;

    if ( keys %{$self->bins} le 1 && scalar @docs gt 0 ) {
        my $fh = $self->_file_w( $self->debian_file('docs') );
        for (@docs) {
            $fh->print( "$_\n" );
        }
        $fh->close;
    } else {
        print "I: couldn't generate d/docs: not fully implemented\n";
    }
}

# TODO again, assumes tags are of the form v1.0.0
sub create_watch {
    my $self = shift;
    my ( $repo, $upstream_url, $watch_file_content );

    try {
        $repo = Git::Repository->new( git_dir => $self->main_file('.git') );
        $upstream_url = $repo->run(( "remote", "get-url", "upstream" ));
    } catch {
        print "I: couldn't generate d/watch -- no git remote named 'upstream'\n";
        return;
    };

    # try to take advantage of GitHub's release page, since mode=git
    # is much more taxing for QA team's servers
    if ( $upstream_url =~ /github\.com\/([^\/]+)\/([^\/]+)/ ) {
        my $user = $1;
        my $project = $2;
        $watch_file_content = <<EOT;
version=4
opts="filenamemangle=s/(?:.*?)?v?(\\d[\\d.]*)\\.tar\\.gz/$project-\$1.tar.gz/" \\
    https://github.com/$user/$project/tags \\
    (?:.*?/)?v?(\\d[\\d.]*)\\.tar\\.gz debian uupdate
EOT
    } else {
        $watch_file_content = "version=4\nopts=\"mode=git\" "
          . $upstream_url
          . " refs/tags/v([\\d\\.\\d\\.]+) debian\n";
    }

    my $fh = $self->_file_w( $self->debian_file("watch") );
    $fh->printf($watch_file_content);
    $fh->close;
}

sub create_rules {
    my ( $self ) = @_;

    my $file = $self->debian_file('rules');

    $self->rules( Debian::Rules->new($file) );

    if ( $self->rules->is_dhtiny ) {
        print "$file already uses dh tiny rules\n"
            if $self->cfg->verbose;
        return;
    }

    $self->backup_file($file);

    my $rulesname = 'rules.dh.tiny';

    for my $source (
        catfile( $self->cfg->{home_dir}, $rulesname ),
        catfile( $self->cfg->{data_dir}, $rulesname )
    ) {
        if ( -e $source ) {
            print "Using rules: $source\n" if $self->cfg->{verbose};
            $self->rules->read($source);
            last;
        };
    }
    $self->rules->write;
    chmod( 0755, $file ) or die "chmod($file): $!";
}

sub detect_buttercup_tests {
    my $self = shift;

    my @files = File::Find::Rule
      ->file()
      ->grep( "\\(describe " )
      ->in('.');

    if ( scalar @files ) {
        return 1;
    } else {
        return 0;
    }
}

sub write_source_format {
    my ( $self, $path ) = @_;

    my ( $vol, $dir, $file ) = splitpath($path);
    $dir = catpath( $vol, $dir );

    if ( $self->cfg->source_format eq '1.0' ) {
        # this is the default, remove debian/source
        File::Path::rmtree($dir);
    }
    else {
        # make sure the directory exists
        File::Path::mkpath($dir) unless -d $dir;

        my $fh = $self->_file_w($path);
        $fh->print( $self->cfg->source_format, "\n" );
        $fh->close;
    }
}

=item backup_file(file_name)

Creates a backup copy of the specified file by adding C<.bak> to its name. If
the backup already exists, it is overwritten.

Does nothing unless the C<backups> option is set.

=cut

sub backup_file {
    my( $self, $file ) = @_;

    if ( $self->cfg->backups ) {
        warn "W: overwriting $file.bak\n"
            if -e "$file.bak" and $self->cfg->verbose;
        rename( $file, "$file.bak" );
    }
}

sub _file_r {
    my ( $self, $filename ) = @_;

    my $fh = IO::File->new( $filename, 'r' )
        or die "Cannot open $filename: $!\n";
    return $fh;
}

sub _file_w {
    my ( $self, $filename ) = @_;

    my $fh = IO::File->new( $filename, 'w' )
        or die "Cannot open $filename: $!\n";
    return $fh;
}

=head1 COPYRIGHT & LICENSE

=over

=item Copyright (C) 2016-2018 Sean Whitton <spwhitton@spwhitton.name>

=item Copyright (C) 2020-2021 Lev Lamberov <dogsleg@debian.org>

=back

It is slightly based on the corresponding part of dh-make-perl, which
is originally copyrighted as follows:

=over 4

=item Copyright (C) 2000, 2001 Paolo Molaro <lupus@debian.org>

=item Copyright (C) 2002, 2003, 2008 Ivan Kohler <ivan-debian@420.am>

=item Copyright (C) 2003, 2004 Marc 'HE' Brockschmidt <he@debian.org>

=item Copyright (C) 2005-2007 Gunnar Wolf <gwolf@debian.org>

=item Copyright (C) 2006 Frank Lichtenheld <djpig@debian.org>

=item Copyright (C) 2007-2018 gregor herrmann <gregoa@debian.org>

=item Copyright (C) 2007-2013 Damyan Ivanov <dmn@debian.org>

=item Copyright (C) 2008, Roberto C. Sanchez <roberto@connexer.com>

=item Copyright (C) 2009-2011, Salvatore Bonaccorso <carnil@debian.org>

=item Copyright (C) 2011, Nicholas Bamber <nicholas@periapt.co.uk>

=item Copyright (c) 2016, Nick Morrott <knowledgejunkie@gmail.com>

=item Copyright (c) 2017, David Miguel Susano Pinto <carandraug+dev@gmail.com>

=back

This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License version 2 as published by the Free
Software Foundation.

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

You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
Street, Fifth Floor, Boston, MA 02110-1301 USA.

=cut

1;
