Replace our RELATIVE-PATHNAME with PATHNAME-UTIL’s
This commit is contained in:
parent
e2f2f38f01
commit
74acf3fa2d
|
@ -4,7 +4,7 @@
|
||||||
:version "0.1"
|
:version "0.1"
|
||||||
:license "GPLv3"
|
:license "GPLv3"
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:depends-on (:dexador :lquery :split-sequence)
|
:depends-on (:dexador :lquery :pathname-utils :split-sequence)
|
||||||
:components ((:file "src/mirror-img"))
|
:components ((:file "src/mirror-img"))
|
||||||
:in-order-to ((test-op (test-op "mirror-img/tests"))
|
:in-order-to ((test-op (test-op "mirror-img/tests"))
|
||||||
(build-op (build-op "mirror-img/unix"))))
|
(build-op (build-op "mirror-img/unix"))))
|
||||||
|
|
|
@ -108,7 +108,7 @@ to mirror it."
|
||||||
DOWNLOAD-DIR, and URL-DIR."
|
DOWNLOAD-DIR, and URL-DIR."
|
||||||
(format nil "~A~A"
|
(format nil "~A~A"
|
||||||
url-dir
|
url-dir
|
||||||
(relative-pathname download-dir pathname)))
|
(pathname-utils:relative-pathname download-dir pathname)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -204,58 +204,3 @@ That is, 443 is implied by HTTPS, so nil is returned; but 998 wouldn’t be impl
|
||||||
"Given a pathname, return the entirety of the file leaf.
|
"Given a pathname, return the entirety of the file leaf.
|
||||||
That is, everything following the last directory name."
|
That is, everything following the last directory name."
|
||||||
(car (last (split-sequence:split-sequence #\/ (namestring pathname)))))
|
(car (last (split-sequence:split-sequence #\/ (namestring pathname)))))
|
||||||
|
|
||||||
;; pathname pathname → pathname
|
|
||||||
(defun relative-pathname (from pathname)
|
|
||||||
"Create a relative pathname leading from the pathname FROM to PATHNAME.
|
|
||||||
By default, FROM is the current working directory."
|
|
||||||
(let* ((dir-str
|
|
||||||
(reduce (lambda (a b)
|
|
||||||
(format nil "~A/~A" a b))
|
|
||||||
(cdr (relative-pathname-directory pathname from))))
|
|
||||||
(dir-pathname
|
|
||||||
(pathname (format nil "~A/" dir-str))))
|
|
||||||
(merge-pathnames dir-pathname
|
|
||||||
(pathname (pathname-leaf pathname)))))
|
|
||||||
|
|
||||||
;; pathname pathname → list
|
|
||||||
(defun relative-pathname-directory (pathname &optional (from (uiop/os:getcwd)))
|
|
||||||
"Given a PATHNAME, create a relative PATHNAME-DIRECTORY-style list from the
|
|
||||||
perspective of the FROM pathname (the current working directory, by default).
|
|
||||||
Returns something along the lines of '(:RELATIVE “..” “DAD”)"
|
|
||||||
(let* ((from (cdr (pathname-directory from)))
|
|
||||||
(to (cdr (pathname-directory pathname)))
|
|
||||||
(from+to (list-lengths nil from to))
|
|
||||||
(to-append (list)))
|
|
||||||
(append
|
|
||||||
(list :relative)
|
|
||||||
(remove-if
|
|
||||||
#'not
|
|
||||||
(loop for from-dir in (car from+to)
|
|
||||||
for to-dir in (cadr from+to)
|
|
||||||
collect
|
|
||||||
(cond ((equal from-dir to-dir)
|
|
||||||
nil)
|
|
||||||
((not from-dir)
|
|
||||||
to-dir)
|
|
||||||
(to-dir
|
|
||||||
(setq to-append (append to-append (list to-dir)))
|
|
||||||
"..")
|
|
||||||
('T
|
|
||||||
".."))))
|
|
||||||
to-append)))
|
|
||||||
|
|
||||||
;; object list … list → list(-of-lists)
|
|
||||||
(defun list-lengths (padding &rest lists)
|
|
||||||
"Equalize the lengths of LISTS, by padding the tail-end of smaller lists with
|
|
||||||
the PADDING object."
|
|
||||||
(let ((target-length
|
|
||||||
(apply #'max (mapcar #'length lists))))
|
|
||||||
(mapcar
|
|
||||||
(lambda (lst)
|
|
||||||
(append
|
|
||||||
lst
|
|
||||||
(loop for i
|
|
||||||
upto (- target-length (length lst) 1)
|
|
||||||
collect padding)))
|
|
||||||
lists)))
|
|
||||||
|
|
Ŝarĝante…
Reference in New Issue