diff options
| author | Kaz Kyheku <kaz@kylheku.com> | 2020-03-10 22:33:24 -0700 |
|---|---|---|
| committer | Kaz Kyheku <kaz@kylheku.com> | 2020-03-10 22:33:24 -0700 |
| commit | bbb650af0c211ef35580daecd975a096e71b0b3a (patch) | |
| tree | 3744d8661a5b964fb8e6a5c96056b827ac960754 /share | |
| parent | b0f3da66f6a9f0e911e167cb8e61eeaa1f75234c (diff) | |
| download | txr-bbb650af0c211ef35580daecd975a096e71b0b3a.tar.gz txr-bbb650af0c211ef35580daecd975a096e71b0b3a.tar.bz2 txr-bbb650af0c211ef35580daecd975a096e71b0b3a.zip | |
compile-file: propagate permissions for hash bang programs.
* share/txr/stdlib/compiler.tl (propagate-perms): New
function.
(compile-file-conditionally): If the source file is a hash
bang script, then call propagate-perms just before closing
the streams.
* txr.1: Documented the permission propagation.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 21 |
1 files changed, 20 insertions, 1 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index e7cc10b9..953a4129 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1711,11 +1711,29 @@ [mapdo (op prinl @1 out-stream) out-forms] (delete-package *package*))) +(defun propagate-perms (in-stream out-stream) + (let ((sti (stat in-stream))) + (when (plusp (logand sti.mode s-ixusr)) + (let ((mode "+x") + (suid (if (plusp (logand sti.mode s-isuid)) ",u+s")) + (sgid (if (and (plusp (logand sti.mode s-isgid)) + (plusp (logand sti.mode s-ixgrp))) ",g+s"))) + (when (or suid sgid) + (let ((sto (stat out-stream))) + (set mode (append mode + (if (eql sti.uid sto.uid) suid) + (if (eql sti.gid sto.gid) sgid))))) + (chmod out-stream mode))))) + (defun compile-file-conditionally (in-path out-path test-fn) (whenlet ((success nil) + (perms nil) (streams (open-compile-streams in-path out-path test-fn))) (with-resources ((in-stream (car streams) (close-stream in-stream)) (out-stream (cadr streams) (progn + (when perms + (propagate-perms in-stream + out-stream)) (close-stream out-stream) (unless success (remove-path (caddr streams)))))) @@ -1732,7 +1750,8 @@ (progn (set line `@line `) (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) - (put-line (butlast line) out-stream)) + (put-line (butlast line) out-stream) + (set perms t)) (seek-stream in-stream 0 :from-start)) (labels ((compile-form (unex-form) (let* ((form (macroexpand unex-form)) |