view release on metacpan or  search on metacpan

lib/App/karr/Git.pm  view on Meta::CPAN

sub is_repo {
    my ($self) = @_;
    my $ok = try {
        # open_ext walks up to find a .git; throws on miss.
        Git::Native->open_ext( $self->dir->stringify );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
    return $ok;
}

sub repo_root {
    my ($self) = @_;
    my $repo = $self->_repo or return undef;
    # workdir is undef for bare repos; in that case fall back to gitdir.
    my $root = $repo->workdir // $repo->gitdir;
    $root =~ s{/+\z}{};
    return path($root);
}

# ----- User identity (read via native config, not via CLI) -----

sub _config_string {
    my ( $self, $key ) = @_;
    my $repo = $self->_repo or return '';
    my $val = try { $repo->config_string($key) } catch { undef };
    return defined $val ? $val : '';
}

sub git_user_email {
    my ($self) = @_;
    return $self->_config_string('user.email');
}

sub git_user_name {
    my ($self) = @_;
    return $self->_config_string('user.name');
}

sub git_user_identity {
    my ($self) = @_;
    my $name = $self->git_user_name;
    my $email = $self->git_user_email;
    return "$name <$email>" if $name && $email;
    return $email || $name || '';
}

# ----- Ref name validation -----

sub normalize_ref_name {
    my ( $self, $ref ) = @_;
    defined $ref or die "Ref name is required\n";
    $ref =~ s{^/+}{};
    return $ref =~ m{^refs/} ? $ref : "refs/$ref";
}

sub validate_helper_ref {
    my ( $self, $ref ) = @_;
    my $full_ref = $self->normalize_ref_name($ref);

    my @blocked = (
        'refs/heads/',
        'refs/tags/',
        'refs/remotes/',
        'refs/bisect/',
        'refs/replace/',
        'refs/karr/',
    );

    for my $prefix (@blocked) {
        die "Ref '$full_ref' is in a protected namespace\n"
            if index( $full_ref, $prefix ) == 0;
    }
    die "Ref '$full_ref' is in a protected namespace\n"
        if $full_ref eq 'refs/stash' || index( $full_ref, 'refs/stash/' ) == 0;

    # Native validity check via Git::Native.
    die "Ref '$full_ref' is not a valid git ref name\n"
        unless Git::Native->reference_name_is_valid($full_ref);

    return $full_ref;
}

# ----- Ref CRUD (the hotspot — was 4 fork/exec per write_ref) -----

sub write_ref {
    my ( $self, $ref, $content ) = @_;
    my $repo = $self->_repo or return;

    my $blob_oid = $repo->blob_create_frombuffer($content);
    my $tb       = $repo->tree_builder;
    $tb->insert(name => 'data', oid => $blob_oid, mode => 0100644);
    my $tree_oid = $tb->write;

    my $sig = $self->_signature;
    my $commit_oid = $repo->commit_create(
        tree       => $tree_oid,
        parents    => [],
        message    => 'karr ref update',
        author     => $sig,
        committer  => $sig,
    );

    $repo->reference_create( $ref, $commit_oid, force => 1 );
    return 1;
}

sub read_ref {
    my ( $self, $ref ) = @_;
    my $repo = $self->_repo or return '';
    my $content = try {
        return '' unless $repo->reference_exists($ref);
        my $r      = $repo->reference($ref);
        my $oid    = $r->target;
        return '' unless $oid;
        my $commit = $repo->commit($oid);
        my $tree   = $commit->tree;
        my $entry  = $tree->entry_by_name('data');
        return '' unless $entry;
        return $repo->blob( $entry->{oid} )->content;
    } catch { '' };
    # Match historical CLI behaviour: cat-file's trailing newline was chomped.
    chomp $content if defined $content;
    return $content;
}

sub ref_exists {
    my ( $self, $ref ) = @_;
    my $repo = $self->_repo or return 0;
    return $repo->reference_exists($ref) ? 1 : 0;