view release on metacpan or  search on metacpan

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

    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;
}

sub delete_ref {
    my ( $self, $ref ) = @_;
    my $repo = $self->_repo or return 0;
    try { $repo->reference_delete($ref) };
    return 1;
}

# ----- Remote / network ops: native via Git::Native::Remote -----

sub has_remote {
    my ( $self, $remote ) = @_;
    $remote //= 'origin';
    my $repo = $self->_repo or return 0;
    return $repo->has_remote($remote);
}

# Default credentials callback: SSH-agent → ~/.ssh/id_ed25519 → ~/.ssh/id_rsa
# → default → fail. Matches CLI `git`'s implicit auth chain.
sub _default_credentials_cb {
    my @tried;
    return sub {
        my (%args) = @_;
        my $user  = $args{username_from_url} || 'git';
        my $types = $args{allowed_types}    || 0;

        # GIT_CREDENTIAL_SSH_KEY = 1<<1 = 2
        if ( $types & 2 ) {
            return Git::Native::Credential->ssh_agent( username => $user )
                unless $tried[0]++;
            for my $k (qw( id_ed25519 id_rsa )) {
                my $priv = "$ENV{HOME}/.ssh/$k";
                next unless -r $priv;
                next if $tried[1]{$k}++;
                return Git::Native::Credential->ssh_key(
                    username    => $user,
                    private_key => $priv,
                    public_key  => "$priv.pub",
                    passphrase  => '',
                );
            }
        }
        # GIT_CREDENTIAL_DEFAULT = 1<<3 = 8
        if ( ( $types & 8 ) && !$tried[2]++ ) {
            return Git::Native::Credential->default;
        }
        return undef;   # PASSTHROUGH — give up
    };
}

sub fetch {
    my ( $self, $remote ) = @_;
    $remote //= 'origin';
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    return try {
        my $r = $repo->remote($remote);
        $r->fetch(
            refspecs    => [],   # use configured refspecs
            credentials => _default_credentials_cb(),
        );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
}

sub push {
    my ( $self, $remote, $refspec ) = @_;
    $remote //= 'origin';
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    $refspec //= '+refs/karr/*:refs/karr/*';
    return try {
        my $r = $repo->remote($remote);
        $r->push(
            refspecs    => [$refspec],
            credentials => _default_credentials_cb(),
            prune       => 1,
        );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
}

sub pull {
    my ( $self, $remote ) = @_;
    $remote //= 'origin';
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    return try {
        my $r = $repo->remote($remote);
        $r->fetch(
            refspecs    => ['refs/karr/*:refs/karr/*'],
            credentials => _default_credentials_cb(),
        );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
}

sub push_ref {
    my ( $self, $ref, $remote ) = @_;
    $remote //= 'origin';
    $ref = $self->validate_helper_ref($ref);
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    return try {
        my $r = $repo->remote($remote);
        $r->push(
            refspecs    => ["+$ref:$ref"],
            credentials => _default_credentials_cb(),
        );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
}

sub pull_ref {
    my ( $self, $ref, $remote ) = @_;
    $remote //= 'origin';
    $ref = $self->validate_helper_ref($ref);
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    return try {
        my $r = $repo->remote($remote);
        $r->fetch(
            refspecs    => ["$ref:$ref"],
            credentials => _default_credentials_cb(),
        );
        1;
    } catch { $self->{_last_error} = "$_"; 0 };
}

# ----- Task / config refs (sit on top of write_ref/read_ref) -----

sub save_task_ref {
  my ($self, $task) = @_;
  my $ref = "refs/karr/tasks/" . $task->id . "/data";
  $self->write_ref($ref, $task->to_markdown);
}

sub load_task_ref {
  my ($self, $id) = @_;
  my $ref = "refs/karr/tasks/$id/data";
  my $content = $self->read_ref($ref);
  return undef unless $content;
  require App::karr::Task;
  return App::karr::Task->from_string($content);
}

sub list_task_refs {
  my ($self) = @_;
  my %ids;
  for my $ref ( $self->list_refs('refs/karr/tasks/') ) {
    $ids{$1} = 1 if $ref =~ m{refs/karr/tasks/(\d+)/};
  }
  return sort { $a <=> $b } keys %ids;
}

sub list_refs {
    my ( $self, $prefix ) = @_;
    $prefix //= 'refs/karr/';
    my $repo = $self->_repo or return ();
    # Glob to scope the iterator server-side.
    my $names = $repo->reference_names( glob => "$prefix*" );
    return @$names;
}

sub ref_oids {
    my ( $self, $prefix ) = @_;
    $prefix //= 'refs/karr/';
    my $repo = $self->_repo or return undef;
    my %oids;
    for my $ref ( $self->list_refs($prefix) ) {
        my $oid = try {
            my $t = $repo->reference($ref)->target;
            $t ? $t->hex : undef;
        } catch { undef };
        $oids{$ref} = $oid if defined $oid;
    }
    return \%oids;
}

sub read_config_ref {
    my ($self) = @_;
    my $content = $self->read_ref('refs/karr/config');
    return {} unless $content;
    return Load($content);
}

sub write_config_ref {
    my ( $self, $data ) = @_;
    return $self->write_ref( 'refs/karr/config', Dump($data) );
}

sub read_next_id_ref {
    my ($self) = @_;
    my $content = $self->read_ref('refs/karr/meta/next-id');
    return 1 unless length $content;
    $content =~ s/\s+\z//;
    return $content =~ /^\d+$/ ? int($content) : 1;
}

sub write_next_id_ref {
    my ( $self, $next_id ) = @_;
    return $self->write_ref( 'refs/karr/meta/next-id', "$next_id\n" );
}

sub delete_refs {
    my ( $self, $prefix ) = @_;
    for my $ref ( $self->list_refs($prefix) ) {
        $self->delete_ref($ref);
    }
    return 1;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::karr::Git - Git operations for karr sync (all-native via Git::Native + libgit2)

=head1 VERSION

version 0.301

=head1 SYNOPSIS

    my $git = App::karr::Git->new(dir => '.');

    $git->pull;
    my @ids = $git->list_task_refs;
    my $task = $git->load_task_ref($ids[0]);

=head1 DESCRIPTION

L<App::karr::Git> provides the low-level Git interface used by C<karr> for
syncing board state through C<refs/karr/*>. Everything — local object/ref
ops and network fetch/push — runs natively via L<Git::Native> (FFI to
libgit2). No fork/exec per op. SSH-agent and HTTPS-token credentials are
supplied through the libgit2 credential-acquire callback.

=head1 SEE ALSO

L<karr>, L<App::karr>, L<App::karr::BoardStore>, L<App::karr::Task>,
L<App::karr::Config>, L<Git::Native>

=head1 SUPPORT

=head2 Issues

Please report bugs and feature requests on GitHub at
L<https://github.com/Getty/karr/issues>.

=head2 IRC

Join C<#langertha> on C<irc.perl.org> or message Getty directly.

=head1 CONTRIBUTING

Contributions are welcome! Please fork the repository and submit a pull request.

=head1 AUTHOR

Torsten Raudssus <getty@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2026 by Torsten Raudssus <torsten@raudssus.de> L<https://raudssus.de/>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut