App-FuguBench

 view release on metacpan or  search on metacpan

lib/App/FuguBench/Wiki.pm  view on Meta::CPAN

#	grep reads the branch, because the library holds a page of
#	every session of every day. Of every call that this verb
#	parses, git colors the output of grep alone, so it carries
#	--no-color.
sub _origin_page_of_session ( $app, $dir, $branch, $session )
{
	return unless defined $branch;

	# The token holds letters, digits, a dot, a dash, and an
	# underscore (WIKI-OPEN-5). The dot is the one character that
	# the pattern of git reads, so the escape takes it alone.
	my $pattern = '^Session: ' . ( $session =~ s/[.]/\\./gr ) . '$';
	my $out     = _capture(
		$app,             $dir,
		'grep',           '--no-color',
		'--name-only',    '--extended-regexp',
		'-e',             $pattern,
		"origin/$branch", '--',
		'Session-*.md'
	);
	return unless defined $out && length $out;

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

# page, and -L, so it follows the redirect of the latest-release
# path. wget takes --tries=1, so no retry appends to standard output.
# Each tool writes the body to standard output.
my %COMMAND = (
	curl => "curl -fsSL $URL",
	wget => "wget -q --tries=1 -O - $URL",
	ftp  => "ftp -V -o - $URL",
);

# The value that the install script writes into the marker. It holds
# a backslash, because a transport that reads an escape changes it:
# the echo of a POSIX shell turns \t into a tab, and printf '%s'
# leaves the two bytes alone.
my $TOKEN = 'in\tstalled';

# The commands that the bin directory of a tree holds beside the
# stub. web/get runs sh, and a host whose sh holds no printf builtin
# needs printf. A stub prints its script with cat.
my @LINKED = qw(sh printf cat);

# _tree():

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

	# 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'
	);

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

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

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

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