view release on metacpan or  search on metacpan

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

#!/usr/bin/env perl
# ex:ts=8 sw=4:
# The stub of the install address, web/get (DIST-INSTALL-3 to
# DIST-INSTALL-6).
#
# Each case runs web/get as a child of /bin/sh. The whole PATH of the
# child is the bin directory of a temporary tree, and that directory
# holds the stub downloader of the case, or no downloader at all. So
# no case reaches the network, and each case reads and writes inside
# its own tree.
#
# A stub prints the install script of its case, and that script
# writes the marker file of the tree. The marker is the proof that sh
# ran the fetched text.

use v5.34;
use warnings;
use experimental 'signatures';
no feature qw(indirect multidimensional bareword_filehandles);

use Test::More;
use File::Basename qw(basename);
use File::Temp     qw(tempdir);
use FindBin        qw($RealBin);
use lib "$RealBin/../../lib";

use Fugu::File;
use Fugu::Process;

my $root = "$RealBin/../..";
my $get  = "$root/web/get";

# The release tarball holds t/fugubench and no web directory.
plan skip_all => 'no web/get' unless -f $get;

# The URL that the stub fetches. GitHub resolves the latest release
# at the moment of the fetch, so no release changes the website.
my $URL =
    'https://github.com/FuguBSD/FuguBench/releases/latest/download/install.sh';

# The line bound of the stub (DIST-INSTALL-5). A visitor reads the
# file before the visitor runs it, and one screen holds it.
my $MAX_LINES = 30;

# The argument list that the stub builds for each downloader
# (DIST-INSTALL-4). curl takes -f, so an HTTP error writes no error
# 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():
#	One temporary tree, with a bin directory as the whole PATH of
#	a child. A command of @LINKED that this host lacks stays out,
#	and the case that needs it then fails on its own.
sub _tree ()
{
	my $tree = tempdir( CLEANUP => 1 );
	mkdir "$tree/bin" or die "mkdir $tree/bin";

	for my $name (@LINKED) {
		my $path = Fugu::Process->find_command($name) or next;
		symlink $path, "$tree/bin/" . basename($path)
		    or die "symlink $path";
	}

	return $tree;
}

# _stub($tree, $name, @body):
#	One stub downloader in the bin directory of the tree. The stub
#	records its own command line in the log, and it then runs the
#	body lines of its case.
sub _stub ( $tree, $name, @body )
{
	my $path = "$tree/bin/$name";
	my $text = join "\n", '#!/bin/sh',
	    qq{echo "$name \$*" >> '$tree/log'}, @body, q{};
	Fugu::File->write( $path, $text, mode => 0755 ) or die "write $path";

	return;
}

# _install($tree):
#	One install script of two lines. The lines set a variable that
#	holds a backslash, and write it to the marker with printf. A
#	marker with the exact bytes proves that every byte of the
#	script reached sh.
sub _install ($tree)
{
	return "token='$TOKEN'\n"
	    . "printf '%s\\n' \"\$token\" > '$tree/marker'\n";
}

# _print($tree, $text):
#	The body line of a stub that prints one install script. The
#	test writes the text into the tree, so no quoting of a stub
#	reaches the text.
sub _print ( $tree, $text )
{
	Fugu::File->write( "$tree/script", $text )
	    or die "write $tree/script";