path: root/lib/DhMakeELPA/Command/Packaging.pm

package DhMakeELPA::Command::Packaging;

use strict;
use warnings;

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

use base 'DhMakePerl::Command::Packaging';

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

use constant debstdversion => '4.1.3';

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;
        }
    }
}

# from dh-make-perl
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 Emacs addons team <pkg-emacsen-addons\@lists.alioth.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 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 lookingg 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
# TODO support .markdown, .mdwn etc.
sub create_docs {
    my $self = shift;
    my @docs = glob($self->main_dir . "/*.md");

    if ( keys %{$self->bins} le 1 && scalar @docs gt 0 ) {
        my $fh = $self->_file_w( $self->debian_file('docs') );
        $fh->print( "*.md\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 detect_buttercup_tests {
    my $self = shift;

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

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

1;