view release on metacpan or  search on metacpan

lib/LCFG/Build/VCS.pm  view on Meta::CPAN

    my @cmd = $self->build_cmd(@args);

    my @out;
    if ( $self->dryrun ) {
        my $cmd = join q( ), @cmd;
        print "Dry-run: $cmd\n";
    }
    else {
        my ( $in, $out, $err );

        my $success = run \@cmd, \$in, \$out, \$err;
        if ( !$success ) {
            die "Error whilst running @cmd: $err\n";
        }
        if ($err) {
            warn "$err\n";
        }

        @out = split /[\r\n]+/, $out;
    }

    return @out;
}

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

    return File::Spec->catfile( $self->workdir, $self->logname );
}

sub gen_tag {
    my ( $self, $version ) = @_;

    # Build a tag from the name and version (if specified) and then
    # replace any period or hyphen characters.
    #
    # name: lcfg-foo, version: 1.0.1, gives: lcfg_foo_1_0_1

    my $tag;
    if ( !defined $version ) {
        $tag = $self->module;
    }
    else {

        if ( $version eq 'latest' ) {
            $tag = 'latest';
        }
        else {
            $tag = join q{_}, $self->module, $version;
        }

    }

    $tag =~ s/\./_/g;
    $tag =~ s/\-/_/g;

    return $tag;
}

sub update_changelog {
    my ( $self, $version, $options ) = @_;
    $options //= {};

    $options->{dryrun}  = $self->dryrun;
    $options->{id}      = $self->id;
    $options->{version} = $version;
    $options->{style} ||= 'default';

    my $dir = $self->workdir;

    my ( $logfile, $needs_add );
    if ( $options->{style} eq 'debian' ) {
        $logfile = File::Spec->catfile( $dir, 'debian', 'changelog' );
        $needs_add = !-e $logfile;

        if ( !$options->{pkgname} ) {

            # Cook up something sensible which looks like a Debian package
            # name

            $options->{pkgname} = lc $self->module;

            # underscores are not permitted, helpfully replace with dashes
            $options->{pkgname} =~ s/_/-/g;

            # For safety remove any other invalid characters
            $options->{pkgname} =~ s/[^a-z0-9-]//;
        }

        update_debian_changelog( $logfile, $options );
    } else {
        $logfile = $self->logfile;
        $needs_add = !-e $logfile;

        update_lcfg_changelog( $logfile, $options );
    }

    if ( !$self->dryrun ) {
        if ($needs_add) {
            $self->run_cmd( 'add', $logfile );
        }
    }

    return;
}

sub update_lcfg_changelog {
    my ( $logfile, $options ) = @_;
    $options //= {};

    $options->{date} ||= DateTime->now->ymd;

    my $dir = (File::Spec->splitpath($logfile))[1];

    my $tmplog = File::Temp->new(
        TEMPLATE => 'lcfgXXXXXX',
        UNLINK   => 1,
        DIR      => $dir,
    );

    my $tmpname = $tmplog->filename;

    $tmplog->print(<<"EOT");
$options->{date}  $options->{id}: new release

\t* Release: $options->{version}

EOT

    if ( -f $logfile ) {
        my $log = IO::File->new( $logfile, 'r' )
            or die "Could not open $logfile: $!\n";

        while ( defined( my $line = <$log> ) ) {
            $tmplog->print($line);
        }

        $log->close;
    }

    $tmplog->close
        or die "Could not close temporary file, $tmpname: $!\n";

    if ( !$options->{dryrun} ) {
        rename $tmpname, $logfile
          or die "Could not rename $tmpname as $logfile: $!\n";
    }

    return;
}

# These update_*_changelog subroutines are also used externally from
# places which do not have access to the VCS object so they are not
# class methods.

sub update_debian_changelog {
    my ( $logfile, $options ) = @_;
    $options //= {};

    $options->{urgency}      ||= 'low';
    $options->{distribution} ||= 'unstable';
    $options->{release}      //= 1;
    $options->{message}      ||= 'New upstream release';

    # RFC822 date
    $options->{date} = DateTime->now->strftime('%a, %d %b %Y %H:%M:%S %z');

    if ( !$options->{email} ) {
        my $user_name = (getpwuid($<))[0];

        my $email_addr = $ENV{DEBEMAIL} || $ENV{EMAIL};

        if ( !$email_addr ) {
            require Net::Domain;

            my $domain = Net::Domain::hostdomain();
            
            $email_addr = join '@', $user_name, $domain;
        }

        # trim any leading or trailing whitespace
        $email_addr =~ s/^\s+//; $email_addr =~ s/\s+$//;

        if ( $email_addr !~ m/<.+>/ ) {
            my $email_name = $ENV{DEBFULLNAME} || $ENV{NAME}  || $user_name;
            $email_name =~ s/^\s+//; $email_name =~ s/\s+$//;

            $email_addr = "$email_name <$email_addr>";
        }

        $options->{email} = $email_addr;
    }

    my ( $dir, $basename ) = (File::Spec->splitpath($logfile))[1,2];

    my $tmplog = File::Temp->new(
        TEMPLATE => 'lcfgXXXXXX',
        UNLINK   => 1,
        DIR      => $dir,
    );
    my $tmpname = $tmplog->filename;

    my $tt = Template->new(
        {
            INCLUDE_PATH => $dir,
        }
    ) or die $Template::ERROR . "\n";

    my $template = q{
[%- FOREACH entry IN entries -%]
[% entry.item('pkgname') %] ([% entry.item('version') %]-[% entry.item('release') %]) [% entry.item('distribution') %]; urgency=[% entry.item('urgency') %]

  * [% entry.item('message') %]

 -- [% entry.item('email') %]  [% entry.item('date') %]