~ruther/guix-local

ee8591990fd38ee2860f0ab659b05052b10f14c6 — Ludovic Courtès 11 years ago 07c0b6e
guix package: Fix 'readlink*' implementation.

* guix/scripts/package.scm (readlink*): Fix to handle symlinks with
  relative targets.  Taken from ld-wrapper2.in.
1 files changed, 25 insertions(+), 7 deletions(-)

M guix/scripts/package.scm
M guix/scripts/package.scm => guix/scripts/package.scm +25 -7
@@ 730,13 730,31 @@ doesn't need it."

(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (catch 'system-error
    (lambda ()
      (readlink* (readlink file)))
    (lambda args
      (if (= EINVAL (system-error-errno args))
          file
          (apply throw args)))))
  (define %max-symlink-depth 50)

  (let loop ((file  file)
             (depth 0))
    (define (absolute target)
      (if (absolute-file-name? target)
          target
          (string-append (dirname file) "/" target)))

    (if (>= depth %max-symlink-depth)
        file
        (call-with-values
            (lambda ()
              (catch 'system-error
                (lambda ()
                  (values #t (readlink file)))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (if (or (= errno EINVAL))
                        (values #f file)
                        (apply throw args))))))
          (lambda (success? target)
            (if success?
                (loop (absolute target) (+ depth 1))
                file))))))


;;;