file layout: moving share/txr/stdlib to stdlib.

This affects run-time also. Txr installations where the
executable is not in directory ending in ${bindir}
will look for stdlib rather than share/txr/stdlib,
relative to the determined installation directory.

* txr.c (sysroot_init): If we detect relative to the short
name, or fall back on the program directory, use stdlib
rather than share/txr/stdlib as the stdlib_path.

* INSTALL: Update some installation notes not to refer to
share/txr/stdlib but stdlib.

* Makefile (STDLIB_SRCS): Refer to stdlib, not
share/txr/stdlib.
(clean): In unconfigured mode, remove the old share/txr/stdlib
entirely.  Remove .tlo files from stdlib.
(install): Install lib materials from stdlib.

* txr.1: Updated documentation under Deployment Directory Structure.

* share/txr/stdlib/{asm,awk,build,cadr}.tl:
Renamed to stdlib/{asm,awk,build,cadr}.tl.

* share/txr/stdlib/{compiler,conv,copy-file,debugger}.tl:
Renamed to stdlib/{compiler,conv,copy-file,debugger}.tl.

* share/txr/stdlib/{defset,doc-lookup,doc-syms,doloop}.tl:
Renamed to stdlib/{defset,doc-lookup,doc-syms,doloop}.tl.

* share/txr/stdlib/{each-prod,error,except,ffi}.tl:
Renamed to stdlib/{each-prod,error,except,ffi}.tl.

* share/txr/stdlib/{getopts,getput,hash,ifa}.tl:
Renamed to stdlib/{getopts,getput,hash,ifa}.tl.

* share/txr/stdlib/{keyparams,match,op,optimize}.tl:
Renamed to stdlib/{keyparams,match,op,optimize}.tl.

* share/txr/stdlib/{package,param,path-test,pic}.tl:
Renamed to stdlib/{package,param,path-test,pic}.tl.

* share/txr/stdlib/{place,pmac,quips,save-exe}.tl:
Renamed to stdlib/{place,pmac,quips,save-exe}.tl.

* share/txr/stdlib/{socket,stream-wrap,struct,tagbody}.tl:
Renamed to stdlib/{socket,stream-wrap,struct,tagbody}.tl.

* share/txr/stdlib/{termios,trace,txr-case,type}.tl:
Renamed to stdlib/{termios,trace,txr-case,type}.tl.

* share/txr/stdlib/{ver,vm-param,with-resources,with-stream}.tl:
Renamed to stdlib/{ver,vm-param,with-resources,with-stream}.tl.

* share/txr/stdlib/yield.tl: Renamed to stdlib/yield.tl.

* share/txr/stdlib/{txr-case,ver}.txr:
Renamed to stdlib/{txr-case,ver}.txr.

* gencadr.txr: Update to stdlib/place.tl.

* genman.txr: Update to stdlib/cadr.tl.

1 files changed, 251 insertions, 0 deletions

diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl
new file mode 100644
index 00000000..28460b72
--- /dev/null
+++ b/stdlib/copy-file.tl
@@ -0,0 +1,251 @@
+;; Copyright 2018-2021
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(eval-only
+  (defsymacro copy-size 65536))
+
+(defstruct copy-path-opts ()
+  perms times owner symlinks (euid (geteuid)))
+
+(defstruct copy-path-stack-node ()
+  path stat new-p)
+
+(defun make-copy-path-opts (opt-list)
+  (if opt-list
+    (let (opts)
+      (each ((opt opt-list))
+        (if (structp opt)
+          (set opts opt)
+          (progn
+            (unless opts
+              (set opts (new copy-path-opts)))
+            (caseql opt
+              (:perms (set opts.perms t))
+              (:times (set opts.times t))
+              (:owner (set opts.owner t))
+              (:symlinks (set opts.symlinks t))
+              (:all (set opts.perms t
+                         opts.times t
+                         opts.owner t
+                         opts.symlinks t))
+              (t (error "~s: unrecognized option ~s" 'copy-path opt))))))
+      opts)
+    (load-time (new copy-path-opts))))
+
+(defun copy-file (from-path to-path : preserve-perms preserve-times)
+  (with-resources ((buf (make-buf copy-size)
+                        (buf-set-length buf 0) (buf-trim buf))
+                   (ist (open-file from-path "b") (close-stream ist))
+                   (ista (fstat ist))
+                   (ost (if (path-dir-p ista)
+                          (throwf 'path-permission `~s: ~a is a directory`
+                                  'copy-file from-path)
+                          (open-file to-path "wb"))
+                        (close-stream ost)))
+    (while (eql (len buf) copy-size)
+      (fill-buf-adjust buf 0 ist)
+      (put-buf buf 0 ost))
+    (when preserve-perms
+      (chmod ost ista.mode))
+    (when preserve-times
+      (flush-stream ost)
+      (utimes ost
+              ista.atime (or ista.atime-nsec 0)
+              ista.mtime (or ista.mtime-nsec 0)))
+    nil))
+
+(defun copy-files (paths dest-dir : preserve-perms preserve-times)
+  (each ((path paths))
+    (while t
+      (catch**
+        (return (copy-file path (path-cat dest-dir (base-name path))
+                           preserve-perms preserve-times))
+        (skip `skip copying @path` (exc . args) (return))
+        (retry `retry copying @path` (exc . args))))))
+
+(defun do-tweak-obj (to-path st opts link-p)
+  (when (and opts.perms (not link-p))
+    (chmod to-path st.mode))
+  (when opts.times
+    (lutimes to-path
+             st.atime (or st.atime-nsec 0)
+             st.mtime (or st.mtime-nsec 0)))
+  (when (and opts.owner
+             (or (zerop opts.euid)
+                 (and (path-mine-p st)
+                      (path-my-group-p st))))
+    (lchown to-path st.uid st.gid)))
+
+(defun do-copy-obj (from-path to-path st opts)
+  (let ((type (logand st.mode s-ifmt))
+        (initial-perms (if opts.perms #o700 #o777))
+        (tweak t))
+    (caseql* type
+      (s-ifreg
+        (copy-file from-path to-path opts.perms opts.times))
+      (s-ifsock
+        (mknod to-path (logior type initial-perms)))
+      (s-ififo
+        (mkfifo to-path initial-perms))
+      (s-iflnk
+        (if opts.symlinks
+          (symlink (readlink from-path) to-path)
+          (progn
+            (do-copy-obj from-path to-path (stat from-path) opts)
+            (set tweak nil))))
+      ((s-ifblk s-ifchr)
+       (mknod to-path (logior type initial-perms) st.rdev))
+      (s-ifdir
+        (ensure-dir to-path)))
+    (when tweak
+      (do-tweak-obj to-path st opts (eq type s-iflnk)))))
+
+(defun copy-path-rec (from-dir to-dir . opt-list)
+  (let* ((opts (make-copy-path-opts opt-list))
+         (dir-stack nil))
+    (unwind-protect
+      (ftw from-dir
+           (lambda (path type stat . rest)
+             (while t
+               (catch**
+                 (let* ((rel-path (let ((p [path (len from-dir)..:]))
+                                    (if (pure-rel-path-p p) p [p 1..:])))
+                        (tgt-path (path-cat to-dir rel-path)))
+                   (unless (starts-with from-dir path)
+                     (error "~s: problem with directory traversal" 'copy-path))
+                   (caseql* type
+                     ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
+                                              'copy-path path))
+                     (ftw-d (let ((new-p (ensure-dir tgt-path)))
+                              (whilet ((top (car dir-stack))
+                                       ((and top
+                                             (not (starts-with tgt-path
+                                                               top.path)))))
+                                (do-tweak-obj top.path top.stat opts nil)
+                                (pop dir-stack))
+                              (push (new copy-path-stack-node
+                                         path tgt-path
+                                         stat stat
+                                         new-p new-p)
+                                    dir-stack)))
+                     (t (iflet ((cur (car dir-stack)))
+                          (unless cur.new-p
+                            (remove-path tgt-path)))
+                        (do-copy-obj path tgt-path stat opts)))
+                   (return))
+                 (skip `skip copying @path` (exc . args) (return))
+                 (retry `retry copying @path` (exc . args)))))
+           ftw-phys)
+      (whilet ((top (pop dir-stack)))
+        (do-tweak-obj top.path top.stat opts nil)))))
+
+(defun remove-path-rec (path)
+  (ftw path
+       (lambda (path type stat . rest)
+         (while t
+           (catch**
+             (return
+               (caseql* type
+                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
+                                          'remove-rec path))
+                 (ftw-dp (rmdir path))
+                 (t (remove-path path))))
+             (skip `skip removing @path` (exc . args) (return))
+             (retry `retry copying @path` (exc . args)))))
+       (logior ftw-phys ftw-depth)))
+
+(defun chmod-rec (path perm)
+  (ftw path
+       (lambda (path type stat . rest)
+         (while t
+           (catch**
+             (return
+               (caseql* type
+                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
+                                          'remove-rec path))
+                 (ftw-sl)
+                 (t (chmod path perm))))
+             (skip `skip chmod @path` (exc . args) (return))
+             (retry `retry chmod @path` (exc . args)))))
+       (logior ftw-phys)))
+
+(defun chown-rec (path uid gid)
+  (ftw path
+       (lambda (path type stat . rest)
+         (while t
+           (catch**
+             (return
+               (caseql* type
+                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
+                                          'remove-rec path))
+                 (t (lchown path uid gid))))
+             (skip `skip chown @path` (exc . args) (return))
+             (retry `retry chown @path` (exc . args)))))
+       (logior ftw-phys)))
+
+(defun touch (path : ref-path)
+  (with-stream (s (or (ignerr (open-file path "mn")) (open-file path "n")))
+    (if ref-path
+      (let ((rst (stat ref-path)))
+        (utimes s 0 nil rst.mtime rst.mtime-nsec))
+      (utimes s 0 nil 0 t))))
+
+(defun rel-path (from to)
+  (unless (eq (abs-path-p from) (abs-path-p to))
+    (error "~s: mixture of absolute and relative paths ~s ~s given"
+           'rel-path from to))
+
+  (macrolet ((if-windows (then : else)
+               (if (find #\\ path-sep-chars) then else)))
+    (if-windows
+      (when-match `@{fdrv #/[A-Za-z0-9]+:/}@nil` from
+        (when-match `@{tdrv #/[A-Za-z0-9]+:/}@nil` to
+          (unless (equal fdrv tdrv)
+            (error "~s: paths on different drives ~s ~s given"
+                   'rel-path from to)))))
+
+    (flet ((canon (comp)
+             (let (out)
+               (each ((c comp))
+                 (casequal c
+                   (".." (if (and out (nequal (car out) ".."))
+                           (pop out)
+                           (push c out)))
+                   (("." ""))
+                   (t (push c out))))
+               (nreverse out))))
+      (let* ((fcomp (canon (spl path-sep-chars from)))
+             (tcomp (canon (spl path-sep-chars to)))
+             (ncommon (mismatch fcomp tcomp)))
+        (cond
+          ((null ncommon) ".")
+          ((find ".." (nthcdr ncommon fcomp))
+           (error "~s: from path uses ... to escapes common prefix: ~s ~s"
+                  'rel-path from to))
+          (t (let ((nup (- (len fcomp) ncommon))
+                   (down [tcomp ncommon..:]))
+               (cat-str (append (repeat '("..") nup) down)
+                        [path-sep-chars 0]))))))))