File Coverage

blib/lib/Git/FastExport/Stitch.pm

Criterion	Covered	Total	%
statement	151	164	92.0
branch	58	72	80.5
condition	7	12	58.3
subroutine	14	14	100.0
pod	3	3	100.0
total	233	265	87.9

package Git::FastExport::Stitch;
$Git::FastExport::Stitch::VERSION = '0.108';
use strict;
use warnings;
use Cwd qw( cwd );
use Carp;
use Scalar::Util qw( blessed );
use List::Util qw( first );
use File::Basename qw( basename );
use Git::FastExport;

sub new {
    my ( $class, $options, @args ) = @_;

    # create the object
    my $self = bless {

        # internal structures
        mark     => 1_000_000,    # mark counter in the new repo
        mark_map => {},
        commits  => {},
        repo     => {},
        name     => {},
        cache    => {},

        # default options
        select => 'last',

    }, $class;

    # set the options
    for my $key (qw( select )) {
        $self->{$key} = $options->{$key} if exists $options->{$key};
    }
    croak "Invalid value for 'select' option: '$self->{select}'"
        if $self->{select} !~ /^(?:first|last|random)$/;

    # process the remaining args
    $self->stitch( splice @args, 0, 2 ) while @args;

    return $self;
}

# add a new repo to stich in
sub stitch {
    my ( $self, $repo, $dir ) = @_;

    # $repo is either a Git::Repository object or a valid path
    my $export = blessed($repo) && $repo->isa('Git::Repository')
      ? $repo     # a Git::Repository object
      : eval {    # assume a path
        my $r;
        my $orig = cwd;

        # chdir and create a Git::Repository object there
        if ( defined $repo ) {
            chdir $repo or croak "Can't chdir to $repo: $!";
            $r = Git::Repository->new();
            chdir $orig or croak "Can't chdir back to $orig: $!";
        }
        else { die "Undefined repository path" }
        $r;
      };
    $@ =~ s/ at .*\z//s, croak $@ if !$export;

    # do not stich a repo with itself
    $repo = $export->git_dir;
    croak "Already stitching repository $repo" if exists $self->{repo}{$repo};

    # pick the refs suffix:
    # use base directory without the .git extension or non ASCII characters
    my @parts = File::Spec->splitdir( ( File::Spec->splitpath( $repo, 1 ) )[1] );
    my $name = pop @parts;
    $name = pop @parts if $name eq '.git';
    $name =~ s/\.git$//;
    $dir = $name if not defined $dir;
    $name =~ y/-A-Za-z0-9_/-/cs;
    $name =~ s/^-|-$//g;

    # check if the name is not used already and pick a replacement if it is
    if ( exists $self->{name}{$name} ) {
        my $suffix = "A";
        $suffix++ while ( exists $self->{name}{"$name-$suffix"} );
        $name .= "-$suffix";
    }

    # git fast-export appeared in git 1.5.4
    croak "stitch() requires a git version greater or equal to 1.5.4, this is only version ${\$export->version}"
      if $export->version_lt('1.5.4');

    # initiate the Git::FastExport stream
    my $stream =
      $export->command(qw( fast-export --progress=1 --all --date-order ))
      ->stdout;

    # set up the internal structures
    $self->{repo}{$repo}{repo}   = $repo;
    $self->{repo}{$repo}{dir}    = $dir;
    $self->{repo}{$repo}{git}    = $export;
    $self->{repo}{$repo}{parser} = Git::FastExport->new($stream);
    $self->{repo}{$repo}{name}   = $name;
    $self->{repo}{$repo}{block}  = $self->{repo}{$repo}{parser}->next_block();
    $self->_translate_block($repo);

    return $self;
}

# return the next block in the stitched stream
sub next_block {
    my ($self) = @_;
    my $repo = $self->{repo};

    # keep a list of next blocks (per repo)
    # any undef block means the stream is finished
    delete $repo->{$_} for grep { !defined $repo->{$_}{block} } keys %$repo;

    # no repo left, we're done
    return if ! keys %$repo;

    # return any non-commit block directly
    if ( my $next
        = first { $repo->{$_}{block}{type} ne 'commit' } keys %$repo )
    {
        my $block = $repo->{$next}{block};
        $repo->{$next}{block} = $repo->{$next}{parser}->next_block();
        $self->_translate_block( $next );
        return $block;
    }

    # select the oldest available commit
    my ($next) = keys %$repo;
    $next
        = $repo->{$next}{block}{committer_date} < $repo->{$_}{block}{committer_date} ? $next : $_
        for keys %$repo;
    my $commit = $repo->{$next}{block};

    # fetch the next block
    $repo->{$next}{block} = $repo->{$next}{parser}->next_block();
    $self->_translate_block( $next );

    # prepare the attachement algorithm
    $repo = $repo->{$next};
    my $commits  = $self->{commits};

    # first commit in the old repo linked to latest commit in new repo
    if ( $self->{last} && !$commit->{from} ) {
        $commit->{from} = ["from :$self->{last}"];
    }

    # update historical information
    my ($id) = $commit->{mark}[0] =~ /:(\d+)/g;
    $self->{last} = $id;    # last commit applied
    my $ref = ( split / /, $commit->{header} )[1];
    my $node = $commits->{$id} = {
        name     => $id,
        repo     => $repo->{repo},
        ref      => $ref,
        children => [],
        parents  => {},
        merge    => exists $commit->{merge},
    };

    # mark our original source
    $commit->{header} =~ s/$/-$repo->{name}/;

    # this commit's parents
    my @parents = map {/:(\d+)/g} @{ $commit->{from} || [] },
        @{ $commit->{merge} || [] };

    # get the reference parent list used by _last_alien_child()
    my $parents = {};
    for my $parent (@parents) {
        if ( $commits->{$parent}{repo} eq $node->{repo} ) {
            push @{ $parents->{ $node->{repo} } }, $parent;
        }
        else {    # record the parents from the other repositories
            for my $repo ( grep $_ ne $node->{repo},
                keys %{ $commits->{$parent}{parents} } )
            {
                push @{ $parents->{$repo} },
                    @{ $commits->{$parent}{parents}{$repo} || [] };
            }
        }
    }

    # map each parent to its last "alien" commit
    my %parent_map = map {
        $_ => $self->_last_alien_child( $commits->{$_}, $ref, $parents )->{name}
    } @parents;

    # map parent marks
    for ( @{ $commit->{from} || [] }, @{ $commit->{merge} || [] } ) {
        s/:(\d+)/:$parent_map{$1}/g;
    }

    # update the parents information
    for my $parent ( map { $commits->{ $parent_map{$_} } } @parents ) {
        push @{ $parent->{children} }, $node->{name};
        push @{ $node->{parents}{ $parent->{repo} } }, $parent->{name};
    }

    # dump the commit
    return $commit;
}

sub _translate_block {
    my ( $self, $repo ) = @_;
    my $mark_map = $self->{mark_map};
    my $block    = $self->{repo}{$repo}{block};

    # nothing to do
    return if !defined $block;

    # mark our original source
    $block->{header} =~ s/$/-$self->{repo}{$repo}{name}/
        if $block->{type} =~ /^(?:reset|tag)$/;

    # map to the new mark
    for ( @{ $block->{mark} || [] } ) {
        s/:(\d+)/:$self->{mark}/;
        $mark_map->{$repo}{$1} = $self->{mark}++;
    }

    # update marks in from & merge
    for ( @{ $block->{from} || [] }, @{ $block->{merge} || [] } ) {
        s/:(\d+)/:$mark_map->{$repo}{$1}/g;
    }

    # update marks & dir in files
    for ( @{ $block->{files} } ) {
        s/^M (\d+) :(\d+)/M $1 :$mark_map->{$repo}{$2}/;
        my $dir = $self->{repo}{$repo}{dir};
        if ( defined $dir && $dir ne '' ) {
            s!^(M \d+ :\d+) (\"?)(.*)!$1 $2$dir/$3!;    # filemodify
            s!^D (\"?)(.*)!D $1$dir/$2!;                # filedelete

            # /!\ quotes may happen - die and fix if needed
            die "Choked on quoted paths in $repo! Culprit:\n$_\n"
                if /^[CR] \S+ \S+ /;

            # filecopy | filerename
            s!^([CR]) (\"?)(\S+) (\"?)(\S+)!$1 $2$dir/$3 $4$dir/$5!;
        }
    }
}

# find the last child of this node
# that has either no child
# or a child in our repo
# or an alien child that has the same parent list
sub _last_alien_child {
    my ( $self, $node, $ref, $parents ) = @_;
    my $commits = $self->{commits};

    my $from = $node->{name};
    my $repo = $node->{repo};

    while (1) {

        # no children nodes
        return $node if ( !@{ $node->{children} } );

        # some children nodes are local
        return $node
            if grep { $commits->{$_}{repo} eq $repo } @{ $node->{children} };

        # all children are alien to us
        my @valid;
        for my $id ( @{ $node->{children} } ) {

            my $peer = $commits->{$id};

            # parents of $peer in $peer's repo contains
            # all parents from $parent in $peer's repo
            my %pparents;
            @{pparents}{ @{ $peer->{parents}{ $peer->{repo} } || [] } } = ();
            next
                if grep !exists $pparents{$_},
                @{ $parents->{ $peer->{repo} } };

            # this child node has a valid parent list
            push @valid, $id;
        }

        # compute the commit to attach to, using the requested algorithm
        if (@valid) {
            my $node_id = $self->{cache}{"$from $node->{name}"} ||=
                  $self->{select} eq 'last'  ? $valid[-1]
                : $self->{select} eq 'first' ? $valid[0]
                :                              $valid[ rand @valid ];
            $node = $commits->{$node_id};
        }
    }

    # return last valid child
    return $node;
}

'progress 1 objects';

__END__