view release on metacpan or  search on metacpan

lib/App/KGB/Client/Git.pm  view on Meta::CPAN

    }

    if ( scalar(@tags) > $self->tag_squash_threshold ) {
        # remove tags from the commit stream
        @{ $self->_commits } = grep {
            not eval { $_->isa('App::KGB::Commit::Tag') }
        } @{ $self->_commits };

        $self->init_painter;
        # add a synthetic tag summary
        push @{ $self->_commits },
            $self->format_message(
            $self->tag_squash_msg_template,
            log => sprintf(
                'Pushed %s, %s, %d other tags and %s',
                $self->colorize( branch => $tags[0]->tag_name ),
                $self->colorize( branch => $tags[1]->tag_name ),
                scalar(@tags) - 3,
                $self->colorize( branch => $tags[-1]->tag_name ),
            ),
            author_login => $ENV{USER},
            author_name  => $self->_get_full_user_name,
            );
    }
}

sub _exists {
    my ( $self, $obj ) = @_;

    # we resort to running 'git cat-file' ourselves as the Git wrapper doesn't
    # provide an easy way to do so without polluting STDERR in case the object
    # doesn't exist
    #
    # Sad but true
    my ( $in, $out, $err );
    # this will exit with status 128 if the object does not exist
    IPC::Run::run [ 'git', "--git-dir=" . $self->git_dir, 'cat-file', '-e',
        $obj ], \$in, \$out, \$err;

    # success means the object exists
    if ( $? == 0 ) {
        #warn "$obj exists";
        return 1;
    }

    my $res = $? >> 8;

    # exit code of 128 means the object doesn't exist
    if ( $res == 128 ) {
        #warn "$obj doesn't exist";
        return 0
    };

    die
        "Command 'git cat-file -e $obj' exited with code $res and said '$err'";
}

sub _describe_ref {
    my( $self, $new ) = @_;

    # raw commit looks like this:
    #commit cc746cf3f6b8937c059cf6311a8903dba9936749
    #tree 76bcae9bdbcfab304c8265d2c2cc245048c9f0f3
    #parent 7e99c8b051169e43189c822c8db77bcad5956734
    #author Damyan Ivanov <dmn@debian.org> 1257538837 +0200
    #committer Damyan Ivanov <dmn@debian.org> 1257538837 +0200
    #
    #    update README.debian with regard to repackaging
    #
    #:100644 100644 603d70d... b81e344... M  debian/README.debian
    #:100644 100644 f1511af... 573335e... M  debian/changelog

    my ( $fh, $ctx )
        = $self->_git->command_output_pipe( 'show', '--pretty=raw',
        '--no-abbrev', '--raw', $new );
    my @log;
    my @changes;
    my @parents;
    my $author_login;
    my $author_name;
    my $author_via;
    while (<$fh>) {
        if ( /^author (.+) <([^>]+)@[^>]+>/ ) {
            utf8::decode( $author_name  = $1 );
            utf8::decode( $author_login = $2 );
            next;
        }
        if ( /^committer (.+) <([^>]+)@[^>]+>/ ) {
            my $committer_name;
            utf8::decode( $committer_name  = $1 );
            if ($committer_name ne $author_name) {
                $author_via = $author_name . ' (via ' . $committer_name . ')';
            } else {
                $author_via = $author_name;
            }
            next;
        }
        push( @parents, substr( $1, 0, 7 ) ), next if /^parent\s+(\S+)/;
        push( @log, $1 ), next if /^    (.*)/;
        if (s/^::?//) {     # a merge commit
            chomp;
            my @old_modes;
            while ( s/^(\d{6,6})\s+// ) {
                push @old_modes, $1;
            }
            my $new_mode = pop @old_modes;

            my @old_shas;
            while (s/^([0-9a-f]{40,40})\s+//) {
                push @old_shas, $1;
            }
            my $new_sha = pop @old_shas;

            my $flag = '';
            s/^(\S+)\s+// and $flag = $1;

            my $file = $_;

            # maybe deleted?
            if ( $new_sha =~ /^0+$/ or $flag =~ /D/ ) {
                push @changes, App::KGB::Change->new("(D)$file");