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

O Operator
Diff

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

added on local at 2026-07-12 00:48:41

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