view release on metacpan or  search on metacpan

bin/gitc-submit  view on Meta::CPAN

    # adjust the cover-letter subject line
    my @patches = glob("$tmpdir/*.patch");
    if ( @patches > 2 and $its ) {
        fill_in_subject_line($tmpdir, $changeset);
        return ( $tmpdir, "$tmpdir/0000-cover-letter.patch" );
    }

    # there's only one real patch, so send it
    unlink "$tmpdir/0000-cover-letter.patch";
    my ($patch) = glob("$tmpdir/*.patch");
    if ($its) {
        my $uri = $its->issue_changeset_uri( $its->get_issue($changeset) );
        if ($uri) {
            my $content = do {
                open my $fh, '<', $patch or die "Couldn't open $patch: $!";
                local $/;
                <$fh>;
            };
            $content =~ s{\n\n}{\n\n$uri\n\n};
            open my $fh, '>', $patch or die "Couldn't write to $patch: $!";
            print $fh $content;
        }
    }
    return ( $tmpdir, $patch );
}

sub fill_in_subject_line {
    my ($tmpdir, $changeset) = @_;
    my $file = "$tmpdir/0000-cover-letter.patch";

    # read in the current cover letter
    open my $fh, '<', $file or die "Couldn't read cover letter : $?";
    my $content = do { local $/; <$fh> };
    close $fh;

    # replace the default subject line
    my $its_name = $its->label_service;
    my $its_label = $its->label_issue;
    my $issue = $its->get_issue($changeset);
    my $subject = eval {
        print STDERR "Looking for $its_name $its_label...";
        my $summary = $its->issue_summary($issue);
        print STDERR "done\n";
        return $summary;
    } || "Submitted for Review";
    warn "Problem obtaining the $its_label summary: $@" if $issue and $@;
    $content =~ s/\Q*** SUBJECT HERE ***\E/$subject/;

    # remove the default blurb line
    my $uri = $its->issue_changeset_uri($issue);
    $content =~ s/\Q*** BLURB HERE ***\E/$uri/;

    # save the new version
    open $fh, '>', $file or die "Couldn't write cover letter : $?";
    print $fh $content;
    close $fh;

    return;
}

sub update_email_headers {
    my ( $tmpdir, $cover_letter ) = @_;
    return if $cover_letter !~ m/0000-cover-letter/;
    require Email::Simple;

    # find headers we want to set
    my @blacklist = qw(
        date
        from
        in-reply-to
        message-id
        references
        subject
    );
    my $cover = Email::Simple->new( slurp($cover_letter) );
    my %extra_headers;
    for my $header ( $cover->header_names ) {
        next if $header =~ m/^from /i;
        $extra_headers{ lc $header } = $cover->header($header);
    }
    delete @extra_headers{@blacklist};

    # process each patch email
    for my $file ( glob "$tmpdir/*.patch" ) {
        next if $file =~ m/0000-cover-letter/;
        my $email = Email::Simple->new( slurp($file) );
        while ( my ( $name, $value ) = each %extra_headers ) {
            $email->header_set( $name, $value );
        }

        open my $fh, '>', $file or die "Unable to write to $file: $!";
        print $fh $email->as_string;
    }

    return;
}

# this might be worth factoring out to App::Gitc::Util at some point
sub author_email {
    my $name       = get_user_name();
    my $email      = get_user_email();
    return "$name <$email>";
}

# Returns a list of environments that will have merge conflicts if
# this changeset is promoted.
sub find_merge_conflicts {
    my ($changeset) = @_;

    warn "Looking for merge conflicts...\n";
    git "checkout -q --no-track -b test-merges origin/master";
    my @conflicts;
    for my $environment (qw( master )) {
        git "reset -q --hard origin/$environment";
        my $output = git "merge --quiet --no-stat --no-ff $changeset";
        push @conflicts, $environment if $output =~ m/Automatic merge failed/;
    }

    git "reset --hard";  # clean up after any failed merges
    git "checkout -q -f $changeset";
    my $output = git "branch -D test-merges"; # there is no --quiet option