0001: (define-module scmxref.path-util
0002:   (use file.util)
0003:   (use srfi-11) ; let-values
0004:   (export canonical-path
0005:           relative-path
0006:           path-to-top
0007:           ))
0008: (select-module scmxref.path-util)
0009: ;;
0010: ;; ---  not really belongs to scmxref
0011: ;;
0012: 
0013: ;;;
0014: ;;;  Pathname utilities: canonical-path, relative-path, path-to-top.
0015: ;;;
0016: 
0017: ;;
0018: ;;  Function: <code>canonical-path path</code>
0019: ;;
0020: ;;    Calculate canonical path of <code>path</code>.
0021: ;;
0022: (define (canonical-path path)
0023:   (simplify-path
0024:    (sys-normalize-pathname
0025:     path :absolute #t :canonicalize #t)))
0026: 
0027: ;;
0028: ;; Function: <code>path-to-top path</code>
0029: ;;
0030: ;;   Calculate path to top directory from dirname of <code>path</code>.
0031: ;;   An error is raised if <code>path</code> goes beyond top.
0032: ;;
0033: ;;   Example:
0034: ;;
0035: ;;     (path-to-top "")            => ""
0036: ;;     (path-to-top "foo")         => ""
0037: ;;     (path-to-top "foo/")        => "../"
0038: ;;     (path-to-top "foo/bar")     => "../"
0039: ;;     (path-to-top "foo/bar/")    => "../../"
0040: ;;     (path-to-top "foo/../bar")  => ""
0041: ;;     (path-to-top "foo/../bar/") => "../"
0042: ;;     (path-to-top "foo/../../")  => ERROR
0043: ;;     (path-to-top "../")         => ERROR
0044: ;;
0045: (define (path-to-top pathname)
0046:   (let ((path (simplify-path
0047:                (if (absolute-path? pathname)
0048:                  (string-copy pathname 1 (string-length pathname))
0049:                  pathname))))
0050:     (let lp ((path path)
0051:              (lis  '()))
0052:       (if (eq? (string-scan path "../") 0)
0053:         (error "Invalid path " pathname)
0054:         (cond ((string=? path "/")
0055:                (apply string-append lis))
0056:               ((string-scan path #\/ 'after)
0057:                => (lambda (path)
0058:                     (lp path (cons "../" lis))))
0059:               (else
0060:                (apply string-append lis)))))))
0061: 
0062: ;;
0063: ;; Function: <code>relative-path from to</code>
0064: ;;
0065: ;;   Calculate relative path from <code>from</code> to <code>to</code>.
0066: ;;
0067: ;;   Example: in case (current-directory) => "/home/smith"
0068: ;;
0069: ;;     (relative-path "" "")                => ""
0070: ;;     (relative-path "foo" "")             => ""
0071: ;;     (relative-path "foo/" "")            => "../"
0072: ;;     (relative-path "foo/" "foo/bar")     => "bar"
0073: ;;     (relative-path "foo/" "foo/bar/")    => "bar/"
0074: ;;     (relative-path "../foo/" "foo/bar/") => "../smith/foo/bar/"
0075: ;;     (relative-path "" "../..")           => "../../"
0076: ;;     (relative-path "" "../../..")        => "../../"  ; parent of root is itself.
0077: ;;
0078: ;;   BUG: the last case does not work as expected.
0079: ;;
0080: (define (relative-path from to)
0081:   (let lp ((f0 (canonical-path from))
0082:            (t0 (canonical-path to)))
0083:     (let-values (((f1 f2) (string-scan f0 #\/ 'both))
0084:                  ((t1 t2) (string-scan t0 #\/ 'both)))
0085:       (cond ((and f1 t1 (string=? f1 t1))
0086:              (lp f2 t2))
0087:             (else
0088:              (string-append (path-to-top f0) t0))))))
0089: 
0090: (provide "scmxref/path-util")
0091: