/usr/share/racket/collects/setup/path-relativize.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | #lang racket/base
(require racket/promise)
(provide make-relativize)
(define (make-relativize find-root-dir tag to-rel-name from-rel-name)
;; Historical note: this module is based on the old "plthome.ss"
;; The `path->relative' and `relative->path' functions that this
;; generates are used to store paths that are relative to the root
;; directory (specified by `find-root-dir'), such as in .dep files.
;; This means that if the racket tree is moved, .dep files still
;; work. It is generally fine if `path->relative' misses some
;; usages, as long as it works when we prepare a distribution tree.
;; (If it misses, things will continue to work fine and .dep files
;; will contain absolute path names.)
;; We need to compare paths to find when something is in the racket
;; tree, so we explode the paths. This is slower than the old way
;; (by a factor of 2 or so), but it's simpler and more portable.
(define (explode-path* path)
(explode-path (simplify-path (path->complete-path path))))
(define exploded-root
(delay (cond [(find-root-dir) => explode-path*] [else #f])))
;; path->relative : path-or-bytes -> datum-containing-bytes-or-path
(define (path->relative path0)
(define path1
(cond [(bytes? path0) (bytes->path path0)]
[(path-string? path0) path0]
[else (raise-argument-error to-rel-name
"(or/c path-string? bytes?)"
path0)]))
(let loop ([path (explode-path* path1)] [root (force exploded-root)])
(cond [(not root) path0]
[(null? root) (cons tag (map (lambda (pe)
(datum-intern-literal
(path-element->bytes pe)))
path))]
;; Note: in some cases this returns the input path as is, which
;; could be a byte string -- it should be possible to return
;; `path1', but that messes up the xform compilation somehow, by
;; having #<path...> vaules written into dep files.
[(null? path) path0]
[(equal? (normal-case-path (car path)) (normal-case-path (car root)))
(loop (cdr path) (cdr root))]
[else path0])))
(define root-or-orig
(delay (or (find-root-dir)
;; No main "collects"/"doc"/whatever => use the
;; original working directory:
(find-system-path 'orig-dir))))
;; relative->path : datum-containing-bytes-or-path -> path
(define (relative->path path)
(cond [(and (pair? path) (eq? tag (car path))
(and (list? (cdr path)) (andmap bytes? (cdr path))))
(apply build-path (force root-or-orig)
(map bytes->path-element (cdr path)))]
[(path? path) path]
[(bytes? path) (bytes->path path)]
[(string? path) (string->path path)]
[else (raise-argument-error
from-rel-name
(format "(or/c path? bytes? (cons '~a (non-empty-listof bytes?)))" tag)
path)]))
(values path->relative relative->path))
|