Diff

/var/www/vhosts/3dshawn.com/site1/MODS/CompileCheck.pm

modified on local at 2026-07-12 00:51:20

Added

lines

Removed

-1

lines

Context

131

unchanged

Blobs

from 6616dcca750f
to f24af278b0c0

Restore this content →

Unified diff

Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.

1	1	package MODS::CompileCheck;
2	2	#======================================================================
3	3	# DriftSense -- syntax check for captured blob content.
4	4	#
5	5	# Test-compiles content using system-native tools (no CPAN, no libs):
6	6	# Perl (.pl .pm .cgi) -> perl -c
7	7	# JavaScript (.js .mjs) -> node --check (skipped gracefully if no node)
8	8	# Shell (.sh .bash) -> bash -n
9	9	# Python (.py) -> python3 -m py_compile (skipped if no python)
10	10	#
11	11	# All checks run under a short timeout with content written to a
12	12	# mode-0600 tempfile that's unlinked immediately after.
13	13	#
14	14	# my $r = MODS::CompileCheck::check($content, $file_name);
15	15	# # $r = { status => 'ok' \| 'error' \| 'unchecked',
16	16	# # language => 'perl',
17	17	# # message => 'perl -c output on error' }
18	18	#======================================================================
19	19	use strict;
20	20	use warnings;
21	21	use IPC::Open3;
22	22	use Symbol 'gensym';
23	23	use Fcntl ();
24	24
25	25	my $TIMEOUT_S = 8;
26	26
27	27	sub check {
28	28	my ($content, $file_name) = @_;
29	29	$file_name //= '';
30	30	return { status => 'unchecked', language => 'unknown', message => 'no content' }
31	31	unless defined $content && length $content;
32	32
33	33	my $ext = lc(($file_name =~ /\.([a-zA-Z0-9]+)$/)[0] // '');
34	34	my $lang;
35	35	my @argv;
36	36	if ($ext =~ /^(pl\|pm\|cgi\|t)$/) { $lang = 'perl'; @argv = (_which('perl'), '-c'); }
37	37	elsif ($ext =~ /^(js\|mjs)$/) { $lang = 'javascript'; @argv = (_which('node'), '--check'); }
38	38	elsif ($ext =~ /^(sh\|bash)$/) { $lang = 'shell'; @argv = (_which('bash'), '-n'); }
39	39	elsif ($ext =~ /^py$/) { $lang = 'python'; @argv = (_which('python3'), '-m', 'py_compile'); }
40	40	elsif ($ext =~ /^(json)$/) { $lang = 'json'; @argv = (_which('python3'), '-c', 'import sys,json; json.load(sys.stdin)'); }
41	41	else {
42	42	return { status => 'unchecked', language => 'unsupported', message => "no compiler wired for .$ext" };
43	43	}
44	44
45	45	return { status => 'unchecked', language => $lang, message => "$argv[0] not installed" }
46	46	unless $argv[0] && -x $argv[0];
47	47
48	48	# Write content to a temp file and pass its path to the compiler.
49	49	# Except for JSON where we pipe via stdin.
50	50	my $tmp;
51	51	if ($lang ne 'json') {
52	52	$tmp = _write_tmp($content, $ext);
53	53	return { status => 'unchecked', language => $lang, message => "tempfile failed" }
54	54	unless $tmp;
55	55	push @argv, $tmp;
56	56	}
57	57
58	58	my ($wtr, $rdr, $err_fh);
59	59	$err_fh = gensym;
60	60	my $pid = eval { open3($wtr, $rdr, $err_fh, @argv) };
61	61	if ($@ \|\| !$pid) {
62	62	unlink $tmp if $tmp;
63	63	return { status => 'unchecked', language => $lang, message => "spawn failed: $@" };
64	64	}
65	65	if ($lang eq 'json') {
66	66	binmode $wtr; print {$wtr} $content;
67	67	}
68	68	close $wtr;
69	69
70	70	# Read with timeout via alarm
71	71	my $out = '';
72	72	my $err = '';
73	73	eval {
74	74	local $SIG{ALRM} = sub { die "timeout\n" };
75	75	alarm($TIMEOUT_S);
76	76	local $/;
77	77	$out = <$rdr> // '';
78	78	$err = <$err_fh> // '';
79	79	alarm(0);
80	80	};
81	81	my $timed_out = $@ =~ /timeout/ ? 1 : 0;
82	82	close $rdr; close $err_fh;
83	83	kill 'TERM', $pid if $timed_out;
84	84	waitpid $pid, 0;
85	85	my $rc = $? >> 8;
86	86	unlink $tmp if $tmp;
87	87
88	88	if ($timed_out) {
89	89	return { status => 'unchecked', language => $lang, message => "timed out after ${TIMEOUT_S}s" };
90	90	}
91	91
92	92	my $status = $rc == 0 ? 'ok' : 'error';
93	93	my $msg = _pretty_message($out, $err, $status, $lang);
94	94	return { status => $status, language => $lang, message => $msg };
95	95	}
96	96
97	97	#---------------------------------------------------------------------
98	98	sub _which {
99	99	my ($bin) = @_;
100	100	return "/usr/bin/$bin" if -x "/usr/bin/$bin";
101	101	return "/usr/local/bin/$bin" if -x "/usr/local/bin/$bin";
102	102	return "/bin/$bin" if -x "/bin/$bin";
103	103	return '';
104	104	}
105	105
106	106	sub _write_tmp {
107	107	my ($content, $ext) = @_;
108	108	my $t = time();
109		my $path = "/tmp/.ds_check_${t}_$$_" . int(rand(1_000_000)) . ".$ext";
	109	my $rand = int(rand(1_000_000));
	110	my $path = '/tmp/.ds_check_' . $t . '_' . $$ . '_' . $rand . '.' . $ext;
110	111	sysopen(my $fh, $path, Fcntl::O_WRONLY() \| Fcntl::O_CREAT() \| Fcntl::O_EXCL(), 0600)
111	112	or return undef;
112	113	binmode $fh;
113	114	print $fh $content;
114	115	close $fh;
115	116	return $path;
116	117	}
117	118
118	119	sub _pretty_message {
119	120	my ($out, $err, $status, $lang) = @_;
120	121	my $m = length($err) ? $err : $out;
121	122	$m //= '';
122	123	# Strip our temp path noise
123	124	$m =~ s{/tmp/\.ds_check_\d+_\d+_\d+\.\w+}{<tempfile>}g;
124	125	# Cap length
125	126	$m = substr($m, 0, 2000) if length($m) > 2000;
126	127	if ($status eq 'ok' && !length $m) {
127	128	return "$lang compiles cleanly";
128	129	}
129	130	return $m;
130	131	}
131	132
132	133	1;