diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/copy-file.tl | 105 | ||||
| -rw-r--r-- | stdlib/path-test.tl | 94 |
2 files changed, 94 insertions, 105 deletions
diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl index bc670743..412ac0d7 100644 --- a/stdlib/copy-file.tl +++ b/stdlib/copy-file.tl @@ -223,108 +223,3 @@ (let ((rst (stat ref-path))) (utimes s 0 nil rst.mtime rst.mtime-nsec)) (utimes s 0 nil 0 t)))) - -(defun path-simplify (comp) - (let ((abs (equal (car comp) "")) - out) - (each ((c comp)) - (casequal c - (".." (if (and (or out abs) (nequal (car out) "..")) - (pop out) - (push c out))) - (("." "")) - (t (push c out)))) - (nreverse out))) - -(eval-only - (defmacro if-windows (then : else) - (if (eql 2 (sizeof wchar)) - then - else)) - - (defmacro if-native-windows (then else) - (if-windows - ^(if (find #\\ path-sep-chars) ,then ,else) - else))) - -(defun path-split (str) - (let ((spl0 (sspl path-sep-chars str))) - (if-native-windows - (iflet ((head (car spl0)) - (p (pos #\: head))) - (list* [head 0..(succ p)] - [head (succ p)..:] - (cdr spl0)) - spl0) - spl0))) - -(defun path-volume (comp) - (let ((head (car comp))) - (if-native-windows - (let ((next (cadr comp)) - (more (cddr comp))) - (cond - ((and (equal head "") (equal next "") more) - (let ((vol (car more))) - (cond - ((nequal "" vol) - (set (car comp) "") - (set (cdr comp) (cdr more)) - vol) - (t :abs)))) - ((and (m^ #/[A-Za-z0-9]+:/ head) head) - (set (car comp) next) - (set (cdr comp) more) - (if (and (equal "" next) more) - ^(:abs . ,head) - ^(:rel . ,head))))) - (if (equal head "") :abs)))) - -(defun rel-path (from to) - (let* ((fspl (path-split from)) - (tspl (path-split to)) - (fvol (path-volume fspl)) - (tvol (path-volume tspl))) - (when (nequal fvol tvol) - (if (and (meq :abs fvol tvol) (meq nil fvol tvol)) - (error "~s: mixture of absolute and relative paths ~s ~s given" - 'rel-path from to)) - (if (meq :abs fvol tvol) - (error "~s: mixture of absolute and volume paths ~s ~s given" - 'rel-path from to)) - (if-windows - (progn - (when (and (consp fvol) (consp tvol)) - (if (neq (car fvol) (car tvol)) - (error "~s: mixture of volume absolute and relative paths \ - \ ~s ~s given" - 'rel-path from to))) - (when (neq (null fvol) (null tvol)) - (error "~s: mixture of volume and non-volume paths ~s ~s given" - 'rel-path from to)) - (error "~s: paths on different volumes ~s ~s given" - 'rel-path from to)))) - (let* ((fcomp (path-simplify fspl)) - (tcomp (path-simplify tspl)) - (ncommon (mismatch fcomp tcomp))) - (cond - ((null ncommon) ".") - ((find ".." (nthcdr ncommon fcomp)) - (error "~s: from path uses .. to escape 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]))))))) - -(defun path-equal (left right) - (if (and (stringp left) (equal left right)) - t - (let* ((lspl (path-split left)) - (rspl (path-split right)) - (lvol (path-volume lspl)) - (rvol (path-volume rspl))) - (if (nequal lvol rvol) - nil - (equal (path-simplify lspl) - (path-simplify rspl)))))) diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl index 5f28b352..9edbf5b3 100644 --- a/stdlib/path-test.tl +++ b/stdlib/path-test.tl @@ -152,6 +152,18 @@ (and (all g.mem (orf (op equal name) (op equal suname)))))))))) +(defun path-simplify (comp) + (let ((abs (equal (car comp) "")) + out) + (each ((c comp)) + (casequal c + (".." (if (and (or out abs) (nequal (car out) "..")) + (pop out) + (push c out))) + (("." "")) + (t (push c out)))) + (nreverse out))) + (eval-only (defmacro if-windows (then : else) (if (eql 2 (sizeof wchar)) @@ -240,3 +252,85 @@ (casequal ent (("." "..")) (t (return nil)))))))) + +(defun path-split (str) + (let ((spl0 (sspl path-sep-chars str))) + (if-native-windows + (iflet ((head (car spl0)) + (p (pos #\: head))) + (list* [head 0..(succ p)] + [head (succ p)..:] + (cdr spl0)) + spl0) + spl0))) + +(defun path-volume (comp) + (let ((head (car comp))) + (if-native-windows + (let ((next (cadr comp)) + (more (cddr comp))) + (cond + ((and (equal head "") (equal next "") more) + (let ((vol (car more))) + (cond + ((nequal "" vol) + (set (car comp) "") + (set (cdr comp) (cdr more)) + vol) + (t :abs)))) + ((and (m^ #/[A-Za-z0-9]+:/ head) head) + (set (car comp) next) + (set (cdr comp) more) + (if (and (equal "" next) more) + ^(:abs . ,head) + ^(:rel . ,head))))) + (if (equal head "") :abs)))) + +(defun rel-path (from to) + (let* ((fspl (path-split from)) + (tspl (path-split to)) + (fvol (path-volume fspl)) + (tvol (path-volume tspl))) + (when (nequal fvol tvol) + (if (and (meq :abs fvol tvol) (meq nil fvol tvol)) + (error "~s: mixture of absolute and relative paths ~s ~s given" + 'rel-path from to)) + (if (meq :abs fvol tvol) + (error "~s: mixture of absolute and volume paths ~s ~s given" + 'rel-path from to)) + (if-windows + (progn + (when (and (consp fvol) (consp tvol)) + (if (neq (car fvol) (car tvol)) + (error "~s: mixture of volume absolute and relative paths \ + \ ~s ~s given" + 'rel-path from to))) + (when (neq (null fvol) (null tvol)) + (error "~s: mixture of volume and non-volume paths ~s ~s given" + 'rel-path from to)) + (error "~s: paths on different volumes ~s ~s given" + 'rel-path from to)))) + (let* ((fcomp (path-simplify fspl)) + (tcomp (path-simplify tspl)) + (ncommon (mismatch fcomp tcomp))) + (cond + ((null ncommon) ".") + ((find ".." (nthcdr ncommon fcomp)) + (error "~s: from path uses .. to escape 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]))))))) + +(defun path-equal (left right) + (if (and (stringp left) (equal left right)) + t + (let* ((lspl (path-split left)) + (rspl (path-split right)) + (lvol (path-volume lspl)) + (rvol (path-volume rspl))) + (if (nequal lvol rvol) + nil + (equal (path-simplify lspl) + (path-simplify rspl)))))) |