view release on metacpan or  search on metacpan

t/fugubench/worktree-verb.t  view on Meta::CPAN

		'the clone carries the origin URL of the source (WT-CLONE-2)'
	);

	ok( -f "$dest/Projects/one/deep/.env",
		'the .env file at depth arrives (WT-CLONE-3)' );
	is(
		( stat "$dest/Projects/one/deep/.env" )[2] & 07777,
		0600,
		'the copy keeps the mode of the source (WT-CLONE-3)'
	);
	ok( !-e "$dest/Projects/two/.env",
		'clone skips a .env symbolic link (WT-CLONE-3)' );
};

subtest 'clone keeps what exists and refuses a bad path' => sub {
	my ( $dir, $real ) = _repo();
	my $dest = tempdir( CLEANUP => 1 );

	_source( "$real/Wiki", 'https://example.com/wiki.git' );
	_write( "$real/.env", "KEY=value\n" );

	# A destination that exists stays as it is, so a second run
	# repairs a bootstrap that stopped early (WT-CLONE-4).
	make_path("$dest/Wiki");
	_write( "$dest/Wiki/local.txt", "mine\n" );

	# A project can leave a symbolic link at the destination of a
	# file copy. The copy replaces the link, and it writes no byte
	# through it (WT-CLONE-4).
	my $away = tempdir( CLEANUP => 1 );
	_write( "$away/target.txt", "outside\n" );
	symlink "$away/target.txt", "$dest/.env" or die "symlink: $!";

	my $result = _clone( $dir, $dest, 'Wiki', '.env', 'absent' );
	is( $result->{exit_code}, 0, 'clone exits 0' )
	    or diag $result->{stderr};
	ok( !-e "$dest/Wiki/.git",
		'clone keeps the destination that exists (WT-CLONE-4)' );
	is( Fugu::File->read("$dest/Wiki/local.txt"),
		"mine\n", 'the local change stays (WT-CLONE-4)' );
	like(
		$result->{stderr},
		qr{already exists, skipped: Wiki},
		'the message names the destination that clone skips'
	);

	ok( !-l "$dest/.env", 'clone replaces the destination link' );
	is( Fugu::File->read("$dest/.env"),
		"KEY=value\n", 'the copy holds the source (WT-CLONE-4)' );
	is( Fugu::File->read("$away/target.txt"),
		"outside\n", 'the file outside the tree keeps its content' );

	like(
		$result->{stderr},
		qr{missing in main checkout, skipped: absent},
		'clone skips an absent path with a message (WT-CLONE-5)'
	);

	# A path with a parent segment leaves the current directory,
	# so the shape check stops it before any work (WT-CLONE-5).
	$result = _clone( $dir, $dest, '../escape' );
	is( $result->{exit_code}, 1,
		'clone refuses a path with a parent segment (WT-CLONE-5)' );
	like( $result->{stderr}, qr/invalid path/,
		'the message names the cause' );

	# In the main checkout itself, clone changes nothing
	# (WT-CLONE-6).
	$result = _clone( $dir, $dir, 'Wiki' );
	is( $result->{exit_code}, 0, 'clone exits 0 in the main checkout' )
	    or diag $result->{stderr};
	like(
		$result->{stderr},
		qr/already the main checkout, nothing to do/,
		'the message names the cause (WT-CLONE-6)'
	);
	ok( -d "$real/Wiki/.git",
		'the main checkout keeps its repository (WT-CLONE-6)' );
};

subtest 'the base of the worktrees resolves against the root' => sub {

	# A clone under Projects/ inherits worktree.base from the
	# workspace above it, and its worktrees belong to the clone.
	# So the value resolves against the root, and not against the
	# home of the key (CLI-CONFIG-2).
	my $home = tempdir( CLEANUP => 1 );
	_write( "$home/.toolingrc", "worktree.base trees\n" );
	my ( $dir, $real ) = _repo( undef, "$home/Projects" );

	my $result = _run( $dir, 'create', 'one' );
	is( $result->{exit_code}, 0, 'create exits 0 with a configured base' )
	    or diag $result->{stderr};
	is( $result->{stdout}, "$real/trees/one\n",
		'the worktree sits under the configured base (CLI-CONFIG-2)' );

	$result = _run( $dir, 'list' );
	like(
		$result->{stdout},
		qr/^one\s+\d+ d\s+clean$/m,
		'list reads the configured base'
	);
};

subtest 'the nested worktree directory follows the configured base' => sub {

	# The skip of WT-REMOVE-3 and WT-CLONE-3 names the
	# worktree.base directory, and a checkout can configure
	# another one.
	my $home = tempdir( CLEANUP => 1 );
	_write( "$home/.toolingrc", "worktree.base trees\n" );
	my ( $dir, $real ) = _repo( undef, "$home/Projects" );

	my $result = _run( $dir, 'create', 'outer' );
	is( $result->{exit_code}, 0, 'create makes the worktree' )
	    or diag $result->{stderr};

	# A worktree of the worktree sits under the configured base.
	# The risk walk must skip it, so no state of it stops the
	# removal of the outer worktree.
	my $inner = "$real/trees/outer/trees/inner";

t/fugubench/worktree-verb.t  view on Meta::CPAN

	my $dest = tempdir( CLEANUP => 1 );
	_source( "$real/Projects/one", 'https://example.com/one.git' );
	make_path("$real/Projects/one/trees/inner");
	make_path("$real/Projects/one/deep");
	_write( "$real/Projects/one/trees/inner/.env", "KEY=nested\n" );
	_write( "$real/Projects/one/deep/.env",        "KEY=value\n" );

	$result = _clone( $dir, $dest, 'Projects' );
	is( $result->{exit_code}, 0, 'clone exits 0' )
	    or diag $result->{stderr};
	ok( -f "$dest/Projects/one/deep/.env",
		'the .env file outside the base arrives (WT-CLONE-3)' );
	ok( !-e "$dest/Projects/one/trees/inner/.env",
		'the .env walk skips the configured base (WT-CLONE-3)' );
};

subtest 'a base of the root stops each subcommand' => sub {

	# A worktree.base of . resolves to the root. The base then
	# holds every path of the checkout, and the containment guard
	# of remove admits each one. So the verb stops with the
	# configuration error (CLI-CONFIG-3).
	my ($dir) = _repo();
	make_path("$dir/lib");
	_write( "$dir/lib/Real.pm", "1;\n" );
	_write( "$dir/.toolingrc",  "worktree.base .\n" );
	_git( '-C', $dir, 'add', '-A' );
	_git( '-C', $dir, 'commit', '--quiet', '-m', 'Add a tracked tree' );

	for my $case ( [ 'create', 'one' ], [ 'remove', 'one' ], ['list'] ) {
		my $result = _run( $dir, @{$case} );
		is( $result->{exit_code}, 3,
			"$case->[0] stops with the configuration error" );
		like( $result->{stderr}, qr/worktree[.]base/,
			'the message names the key' );
	}

	my $dest   = tempdir( CLEANUP => 1 );
	my $result = _clone( $dir, $dest, 'lib' );
	is( $result->{exit_code}, 3,
		'clone stops with the configuration error' );
	ok( !-e "$dest/lib", 'clone copies nothing' );

	# The remove of a tracked directory of the checkout. No other
	# guard holds here: the risk walk finds no repository in a
	# plain directory, and _take then deletes the tree
	# (WT-SAFETY-1).
	$result = _run( $dir, 'remove', 'lib' );
	is( $result->{exit_code}, 3, 'remove refuses a tracked directory' );
	ok( -f "$dir/lib/Real.pm", 'the tracked tree stays' );
	is( _git( '-C', $dir, 'status', '--porcelain' ),
		q{}, 'the checkout holds no change' );
};

subtest 'a base of the wrong shape stops each subcommand' => sub {

	# The value leaves the tree, so the shape check of
	# CLI-CONFIG-3 refuses it. Every subcommand reads the base,
	# so each one stops with the configuration error.
	my ($dir) = _repo();
	_write( "$dir/.toolingrc", "worktree.base ../escape\n" );

	for my $case ( [ 'create', 'one' ], [ 'remove', 'one' ], ['list'] ) {
		my $result = _run( $dir, @{$case} );
		is( $result->{exit_code}, 3,
			"$case->[0] stops with the configuration error" );
		like( $result->{stderr}, qr/worktree[.]base: .*leaves the tree/,
			'the message names the key and the cause' );
	}

	my $dest   = tempdir( CLEANUP => 1 );
	my $result = _clone( $dir, $dest, 'Projects' );
	is( $result->{exit_code}, 3,
		'clone stops with the configuration error' );
	like( $result->{stderr}, qr/worktree[.]base: .*leaves the tree/,
		'the message names the key and the cause' );
};

subtest 'a linked worktree is no main checkout' => sub {
	my ( $dir, $real ) = _repo();

	my $result = _run( $dir, 'create', 'inner' );
	is( $result->{exit_code}, 0, 'create makes the worktree' )
	    or diag $result->{stderr};

	# The worktree holds the .toolingrc of the checkout, so the
	# walk stops in it. Its .git is a file, not a directory.
	$result = _run( "$real/.claude/worktrees/inner", 'list' );
	is( $result->{exit_code}, 1,   '-C on a linked worktree exits 1' );
	is( $result->{stdout},    q{}, 'the refusal writes no line' );
};

done_testing();