フルパスから相対パスを求める

Scheme

こんどは Scheme で。

(use srfi-13)

(define (init lst)
  (cond ((null? lst) (error "init: empty list"))
        ((null? (cdr lst)) '())
        (else
         (cons (car lst) (init (cdr lst))))))

(define (relative-path-list target base)
  (cond ((null? base) target)
        ((null? target) (map (lambda (x) "..") base))
        ((equal? (car base) (car target)) (relative-path-list (cdr target) (cdr base)))
        (else
         (append
          (map (lambda (x) "..") base)
          target))))

(define (valid-path? path)
  (and (> (string-length path) 0)
       (equal? (string-ref path 0) #\/)
       (not (string-index path #[\\?*:|"<>]))))

(define (relative-path target base)
  (if (and (valid-path? target) (valid-path? base))
      (let ((relative-path-components
             (relative-path-list
              (cdr (string-split target #/\/+/))
              (init (cdr (string-split base #/\/+/))))))
        (string-join
         (if (and (not (null? relative-path-components))
                  (equal? (car relative-path-components) ".."))
             relative-path-components
             (cons "." relative-path-components))
         "/"))
      (error "invalid path")))

(use gauche.test)
(test-start "relative-path")

(test* "a file in the same directory"
       "./to.txt"
       (relative-path "/aaa/bbb/to.txt" "/aaa/bbb/from.txt"))

(test* "a file in the parent directory"
       "../to.txt"
       (relative-path "/aaa/to.txt" "/aaa/bbb/from.txt"))

(test* "a file in the child directory"
       "./ccc/to.txt"
       (relative-path "/aaa/bbb/ccc/to.txt" "/aaa/bbb/from.txt"))

(test* "a file through the grandparent directory"
       "../ccc/ddd/to.txt"
       (relative-path "/aaa/ccc/ddd/to.txt" "/aaa/bbb/from.txt"))

(test* "a file through the root directory"
       "../../ddd/ccc/to.txt"
       (relative-path "/ddd/ccc/to.txt" "/aaa/bbb/from.txt"))

(test* "a file from the directory"
       "../ddd/to.txt"
       (relative-path "/aaa/ddd/to.txt" "/aaa/bbb/"))

(test* "a directory from the directory"
       "../ccc/"
       (relative-path "/aaa/ccc/" "/aaa/bbb/"))

(test* "the same path"
       "./ccc.txt"
       (relative-path "/aaa/bbb/ccc.txt" "/aaa/bbb/ccc.txt"))

(test* "passing empty path"
       *test-error*
       (relative-path "/bbb/to.txt" ""))

(test* "invalid character for filename"
       *test-error*
       (relative-path "/bbb/to.txt" "/aaa/g*"))

(test* "path does not start with slash"
       *test-error*
       (relative-path "./bbb/to.txt" "aaa/bbb/from.txt"))

(test* "consecutive slash"
       "./to.txt"
       (relative-path "/////aaa//////bbb///////to.txt"
                      "//aaa///bbb////from.txt"))

(test-end)