diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-05-03 06:51:19 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-05-03 06:51:19 -0700 |
| commit | 8be2ee867659dc8b6c47d4fb6694aceaf10bfd7c (patch) | |
| tree | 728eb3bfac974743a7fa428a447195cbf0fc54d2 /share | |
| parent | de3082638e204aae1fa63a390967cbef082304bb (diff) | |
| download | txr-8be2ee867659dc8b6c47d4fb6694aceaf10bfd7c.tar.gz txr-8be2ee867659dc8b6c47d4fb6694aceaf10bfd7c.tar.bz2 txr-8be2ee867659dc8b6c47d4fb6694aceaf10bfd7c.zip | |
New function: rel-path.
* lisplib.c (copy_file_set_entries): Add rel-path as autoload
trigger for copy-file module.
* share/txr/stdlib/copy-file.tl (rel-path): New function.
* tests/018/rel-path.tl: New file.
* txr.1: Documented.
* share/txr/stdlib/doc-syms.tl: Updated.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/copy-file.tl | 32 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 1 |
2 files changed, 33 insertions, 0 deletions
diff --git a/share/txr/stdlib/copy-file.tl b/share/txr/stdlib/copy-file.tl index aaff63f2..67c3493a 100644 --- a/share/txr/stdlib/copy-file.tl +++ b/share/txr/stdlib/copy-file.tl @@ -212,3 +212,35 @@ (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)) + (cond + ((and out (equal ".." c)) (pop out)) + ((equal "." c)) + (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))) + (if (null ncommon) + "." + (let ((nup (- (len fcomp) ncommon)) + (down [tcomp ncommon..:])) + (cat-str (append (repeat '("..") nup) down) + [path-sep-chars 0]))))))) diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl index cf061a69..de12a878 100644 --- a/share/txr/stdlib/doc-syms.tl +++ b/share/txr/stdlib/doc-syms.tl @@ -1611,6 +1611,7 @@ ("struct-type" "N-02C33D76") ("op" "N-0068EA9D") ("int-cptr" "N-01768FB9") + ("rel-path" "N-016892B4") ("window-mappend" "N-015AFD48") ("with-delete-expander" "N-02A6E020") ("f-getfl" "N-025E55E7") |