Selkie.git | t/fixtures/ | error-log-roundtrip.raku

---

use NativeCall;

use Selkie::App::Internal::ErrorLog;
use Selkie::App::Internal::ErrorLogPlatform;

class ErrorLogProbe does Selkie::App::Internal::ErrorLog {
	method install(Str:D $path --> Nil) { self!install-error-log($path) }
	method uninstall(--> Nil) { self!uninstall-error-log }
	method replace-process-stderr(IO::Handle:D $handle --> Nil) {
		self!replace-process-stderr($handle)
	}
	method restore-process-stderr(--> Nil) { self!restore-process-stderr }
}

sub posix-write(int32, Str, size_t --> ssize_t)
	is native is symbol("write") { * }
sub windows-write-file(Pointer, Str, uint32, uint32 is rw, Pointer --> int32)
	is native("kernel32") is symbol("WriteFile") { * }

sub native-stderr(Str:D $message --> Nil) {
	my $written = $message.encode.bytes;
	if $*DISTRO.is-win {
		my uint32 $count = 0;
		my $ok = windows-write-file(
			windows-get-std-handle(WINDOWS-STD-ERROR-HANDLE),
			$message,
			$written,
			$count,
			Pointer,
		);
		die "native stderr write failed" unless $ok && $count == $written;
		return;
	}
	$written = posix-write(2, $message, $written);
	die "native stderr write failed" unless $written == $message.encode.bytes;
}

my $scratch = @*ARGS[0].IO;
my Str $stage = "setup";
my $stage-path = $scratch.add("fixture-stage.txt");
sub enter-stage(Str:D $next --> Nil) {
	$stage = $next;
	try $stage-path.spurt("$stage\n");
}
enter-stage($stage);
CATCH {
	default {
		my $message = "stage=$stage\n{.message}\n{.?backtrace.?full // ''}";
		try $scratch.add("fixture-failure.txt").spurt($message);
		exit 1;
	}
}

my $log-a = $scratch.add("nested path").add("first error.log");
my $log-b = $scratch.add("second error.log");
my $blocked = $scratch.add("not-a-file");
$blocked.mkdir;

my $probe = ErrorLogProbe.new;
my $original-windows-handle = IS-WINDOWS
	?? windows-get-std-handle(WINDOWS-STD-ERROR-HANDLE)
	!! Pointer;

# Exercise the PROCESS::<$ERR> swap on every host. The production error-log
# path uses it only on Windows, so a POSIX-only suite would otherwise miss
# container-aliasing regressions in restoration.
my $process-log = $scratch.add("process error.log");
my $process-handle = open $process-log, :w;
enter-stage("process stderr replacement");
$probe.replace-process-stderr($process-handle);
enter-stage("process stderr redirected say");
$*ERR.say("process-redirected-marker");
enter-stage("process stderr redirected flush");
$*ERR.flush;
enter-stage("process stderr restore");
$probe.restore-process-stderr;
enter-stage("process stderr replacement handle close");
$process-handle.close;
enter-stage("process stderr restored say");
$*ERR.say("process-restored-marker");
enter-stage("process stderr restored flush");
$*ERR.flush;

sub same-handle($left, $right --> Bool:D) {
	$left.defined && $right.defined && $left.Int == $right.Int;
}

enter-stage("first install");
$probe.install($log-a.Str);
if IS-WINDOWS {
	my $installed = windows-get-std-handle(WINDOWS-STD-ERROR-HANDLE);
	die "Win32 stderr handle was not replaced"
		if same-handle($installed, $original-windows-handle);
}
enter-stage("first redirected writes");
$*ERR.say("raku-marker-a");
$*ERR.flush;
native-stderr("native-marker-a\n");
enter-stage("first uninstall");
$probe.uninstall;
if IS-WINDOWS {
	die "Win32 stderr handle was not restored"
		unless same-handle(
			windows-get-std-handle(WINDOWS-STD-ERROR-HANDLE),
			$original-windows-handle,
		);
}

enter-stage("restored stderr write");
$*ERR.say("restored-marker");
$*ERR.flush;
native-stderr("native-restored-marker\n");

enter-stage("blank-path install");
$probe.install("   ");
$*ERR.say("blank-path-marker");
$*ERR.flush;
$probe.uninstall;

enter-stage("unopenable-path install");
$probe.install($blocked.Str);
$*ERR.say("unopenable-path-marker");
$*ERR.flush;
$probe.uninstall;

enter-stage("second install");
$probe.install($log-b.Str);
$*ERR.say("raku-marker-b");
$*ERR.flush;
native-stderr("native-marker-b\n");
enter-stage("second uninstall");
$probe.uninstall;
$probe.uninstall;

enter-stage("complete");
say "child-ok";