view release on metacpan or  search on metacpan

t/fugubench/hook.t  view on Meta::CPAN

};

subtest 'a session in a worktree reads the worktree' => sub {
	my ( $tree, $origin ) = _tree();
	my $co = _checkout( $tree, 'Workspace',
		"wiki.origin\tfile://$origin\n" . "wiki.project\tWorkspace\n" );

	# A worktree holds its own .toolingrc and its own library
	# clone, so it is a checkout of its own. The walk must not cut
	# the cwd at the marker (CLI-CHECKOUT-4, HOOK-EVENTS-5).
	my $wt = "$co/.claude/worktrees/wt-1";
	_write( "$wt/.toolingrc",
		"wiki.origin\tfile://$origin\n" . "wiki.project\tTree\n" );
	_git( $tree, 'clone', '--quiet', "$tree/origin.git", "$wt/Wiki" );

	my $page = "Session-Tree-$today-1.md";
	my $r    = _hook( $tree, 'SessionStart',
		_json( session_id => 's1', cwd => $wt ) );
	is( $r->{stdout}, "$page\n", 'the page takes the project of the worktree' )
	    or diag $r->{stderr};
	ok( -e "$wt/Wiki/$page", 'the page lands in the library of the worktree' );
	is( scalar( glob "$co/Wiki/Session-*" ),
		undef, 'the library above the worktree holds no page' );

	# SessionEnd reads the same checkout, and it closes that page.
	$r = _hook( $tree, 'SessionEnd',
		_json( session_id => 's1', cwd => $wt ) );
	is( $r->{exit_code}, 0, 'SessionEnd exits zero' ) or diag $r->{stderr};
	like( Fugu::File->read("$wt/Wiki/$page"),
		qr/^Closed: /m, 'the page of the worktree holds the closed line' );
};

subtest 'WorktreeCreate writes the path, and a second run repeats it' => sub {
	my ($tree) = _tree();
	my ( $repo, $real ) = _repo( $tree, 'repo', q{} );
	my $wt = "$real/.claude/worktrees/wt-1";

	my $r = _hook( $tree, 'WorktreeCreate',
		_json( cwd => $repo, name => 'wt-1' ) );
	is( $r->{exit_code}, 0, 'the event exits zero' ) or diag $r->{stderr};
	is( $r->{stdout}, "$wt\n", 'the path is the only line of the output' );
	ok( -e "$wt/.git", 'the worktree exists' );

	# Claude Code runs the create hook again when a session
	# reconnects (HOOK-WORKTREE-3, WT-CREATE-7).
	$r = _hook( $tree, 'WorktreeCreate',
		_json( cwd => $repo, name => 'wt-1' ) );
	is( $r->{exit_code}, 0, 'a second create of one name exits zero' )
	    or diag $r->{stderr};
	is( $r->{stdout}, "$wt\n", 'the second create writes the path again' );

	# The harness needs the path, so this event reports a failure
	# (HOOK-EVENTS-3).
	$r = _hook( $tree, 'WorktreeCreate', _json( cwd => $repo ) );
	is( $r->{exit_code}, 1,   'a payload with no name exits 1' );
	is( $r->{stdout},    q{}, 'a payload with no name writes no path' );

	# The event returns the code of the subcommand, and the
	# subcommand refuses a name that leaves the base (WT-CREATE-2).
	$r = _hook( $tree, 'WorktreeCreate',
		_json( cwd => $repo, name => '../escape' ) );
	is( $r->{exit_code}, 1, 'a name that the subcommand refuses exits 1' );
	like( $r->{stderr}, qr/invalid worktree name/,
		'the subcommand names the reason' );

	is(
		_hook( $tree, 'WorktreeCreate', _json( name => 'wt-2' ) )
		    ->{exit_code},
		1,
		'a payload with no cwd exits 1'
	);

	my $outside = "$tree/outside";
	make_path($outside);
	is(
		_hook(
			$tree, 'WorktreeCreate',
			_json( cwd => $outside, name => 'wt-3' ) )->{exit_code},
		1,
		'a cwd with no checkout exits 1'
	);

	# A sub-agent payload changes nothing (HOOK-EVENTS-4).
	$r = _hook( $tree, 'WorktreeCreate',
		_json( cwd => $repo, name => 'wt-4', agent_id => 'a1' ) );
	is( $r->{exit_code}, 0, 'a sub-agent payload exits zero' );
	ok( !-e "$real/.claude/worktrees/wt-4",
		'a sub-agent makes no worktree' );
};

subtest 'WorktreeRemove keeps the worktree and prints the command' => sub {
	my ($tree) = _tree();
	my ($repo) = _repo( $tree, 'repo', q{} );
	my $wt = "$repo/.claude/worktrees/team/wt-1";
	make_path($wt);

	my $r = _hook( $tree, 'WorktreeRemove',
		_json( cwd => $repo, worktree_path => $wt ) );
	is( $r->{exit_code}, 0,   'the event exits zero' );
	is( $r->{stdout},    q{}, 'the event writes no result line' );
	ok( -d $wt, 'the event removes nothing' );
	like( $r->{stderr}, qr/\Qworktree kept: $wt\E/,
		'the hint names the path' );
	like(
		$r->{stderr},
		qr{\Qto remove it: make -C $repo worktree-remove NAME=team/wt-1\E},
		'the hint names the root and the name'
	);

	# The split takes the worktree.base value of the checkout.
	my ($other) = _repo( $tree, 'other', "worktree.base\ttrees\n" );
	$r = _hook( $tree, 'WorktreeRemove',
		_json( cwd => $other, worktree_path => "$other/trees/wt-2" ) );
	like( $r->{stderr}, qr{\Qmake -C $other worktree-remove NAME=wt-2\E},
		'the split takes the configured base' );

	# Without a checkout the verb prints the path alone.
	$r = _hook( $tree, 'WorktreeRemove', _json( worktree_path => $wt ) );
	is( $r->{exit_code}, 0, 'a payload with no cwd exits zero' );
	like( $r->{stderr}, qr/\Qworktree kept: $wt\E/,
		'the hint names the path' );