view release on metacpan or  search on metacpan

t/187-foundation-result-json.t  view on Meta::CPAN

    git => App::karr::Git->new( dir => "$repo" ) );
  for my $spec ( @specs ) {
    my $id = $store->allocate_next_id;
    $store->save_task( App::karr::Task->new(
      id => $id, status => 'backlog', title => "task $id",
      ref $spec ? %$spec : ( title => $spec ) ) );
  }
}

sub tasks_of {
  my ( $repo ) = @_;
  return App::karr::BoardStore->new(
    git => App::karr::Git->new( dir => "$repo" ) )->load_tasks;
}

sub task_by_id {
  my ( $repo, $id ) = @_;
  return App::karr::BoardStore->new(
    git => App::karr::Git->new( dir => "$repo" ) )->find_task( $id );
}

sub state_data {
  my ( $repo ) = @_;
  my $file = path( $repo )->child('.karr.state');
  return {} unless $file->exists;
  return json_decode( $file->slurp_utf8 );
}

sub log_of {
  my ( $repo ) = @_;
  my $file = path( $repo )->child('.karr.log');
  return $file->exists ? $file->slurp_utf8 : '';
}

# A result object in the shape `claude -p --output-format json` really emits
# (2.1.233): the fields this classification reads, with the rest of the real
# payload's bulk left out. Written as one line, which is how it arrives.
sub result_json {
  my ( %over ) = @_;
  return json_encode( {
    type             => 'result',
    subtype          => 'success',
    is_error         => \0,
    num_turns        => 7,
    duration_ms      => 1490,
    total_cost_usd   => 0.04704,
    session_id       => '10efe29e-1fad-4dce-8026-b4086b5c37f5',
    stop_reason      => 'end_turn',
    terminal_reason  => 'completed',
    api_error_status => undef,
    result           => 'done',
    %over,
  } );
}

# What #160's corpus proves an ordinary agent prints: its own board, including
# a backlog title with a symptom word in it, and a genuine-looking API error
# line. Neither may reach the classifier once the run has reported for itself.
my $NOISE = <<'NOISE';
#3 backlog retry the network fetch on 503
#4 backlog invalid credentials in the auth path
API Error: 429 {"type":"error","error":{"type":"rate_limit_error"}}
NOISE

# A harmless fake agent: it prints what the mode tells it to, optionally moves
# one card through karr's own store, and exits. It never leaves the temp repo
# and it never calls anything real.
sub write_fake_agent {
  my ( $dir ) = @_;
  my $lib    = path('lib')->absolute->stringify;
  my $script = path($dir)->child('fake-agent.pl');
  $script->spew_utf8(<<'PERL');
use strict;
use warnings;
require App::karr::Git;
require App::karr::BoardStore;
require App::karr::ActivityLog;

my $repo   = $ENV{KARR_REPO} or die "no KARR_REPO\n";
my $noise  = $ENV{KARR_FAKE_NOISE}  // '';
my $result = $ENV{KARR_FAKE_RESULT} // '';
my $where  = $ENV{KARR_FAKE_WHERE}  // 'last';   # last | middle | none
my $move   = $ENV{KARR_FAKE_MOVE}   // '';
my $code   = $ENV{KARR_FAKE_EXIT}   // 0;

if ( $move ) {
  my $store = App::karr::BoardStore->new(
    git => App::karr::Git->new( dir => $repo ) );
  my ( $t ) = grep {
    $_ && !$_->has_blocked && $_->status ne 'done' && $_->status ne 'archived'
  } $store->load_tasks;
  if ( $t ) {
    $t->status('done');
    $store->save_task( $t );
    App::karr::ActivityLog->new( git => $store->git, role => 'agent' )
      ->log_entry( agent => 'fake-agent', action => 'move',
                   task_id => $t->id + 0, detail => 'done' );
  }
}

print "$result\n" if $result && $where eq 'middle';
print $noise if length $noise;
print "$result\n" if $result && $where eq 'last';
exit $code;
PERL
  return qq{$^X -I"$lib" "$script"};
}

# ---------------------------------------------------------------------------
# Unit: finding the report
# ---------------------------------------------------------------------------

subtest 'a result object is found at the tail of the output, and only there' => sub {
  my $f  = App::karr::Foundation->new( _config_data => {} );
  my $js = result_json();

  is $f->_run_result( undef ), undef, 'no output, no report';
  is $f->_run_result( '' ),    undef, 'empty output, no report';

  my $bare = $f->_run_result( "$js\n" );
  is ref $bare, 'HASH', 'the object on its own is read';