58 lines
1.7 KiB
Racket
58 lines
1.7 KiB
Racket
|
|
(module collects-path mzscheme
|
|
|
|
(provide collects-path->bytes
|
|
check-collects-path
|
|
set-collects-path)
|
|
|
|
(define (collects-path->bytes collects-path)
|
|
(and collects-path
|
|
(cond
|
|
[(path? collects-path) (path->bytes collects-path)]
|
|
[(string? collects-path) (string->bytes/locale collects-path)]
|
|
[(and (list? collects-path)
|
|
(pair? collects-path))
|
|
(let ([l (map (lambda (p)
|
|
(cond
|
|
[(path? p) (path->bytes p)]
|
|
[(string? p) (string->bytes/locale p)]
|
|
[else #""]))
|
|
collects-path)])
|
|
(let loop ([l l])
|
|
(if (null? (cdr l))
|
|
(car l)
|
|
(bytes-append (car l) #"\0" (loop (cdr l))))))]
|
|
[else #""])))
|
|
|
|
(define (check-collects-path who collects-path collects-path-bytes)
|
|
(when collects-path
|
|
(unless (or (path-string? collects-path)
|
|
(and (list? collects-path)
|
|
(andmap path-string? collects-path)))
|
|
(raise-type-error who "path, string, list of paths and strings, or #f"
|
|
collects-path))
|
|
(unless ((bytes-length collects-path-bytes) . <= . 1024)
|
|
(error who "collects path list is too long"))))
|
|
|
|
(define (find-cmdline rx)
|
|
(let ([m (regexp-match-positions rx (current-input-port))])
|
|
(if m
|
|
(caar m)
|
|
(error
|
|
'create-embedding-executable
|
|
"can't find collection-path position in executable"))))
|
|
|
|
(define (set-collects-path dest-exe collects-path-bytes)
|
|
(when collects-path-bytes
|
|
(let ([libpos (let ([tag #"coLLECTs dIRECTORy:"])
|
|
(+ (with-input-from-file dest-exe
|
|
(lambda () (find-cmdline tag)))
|
|
(bytes-length tag)))])
|
|
(with-output-to-file dest-exe
|
|
(lambda ()
|
|
(let ([out (current-output-port)])
|
|
(file-position out libpos)
|
|
(write-bytes collects-path-bytes out)
|
|
(write-bytes #"\0\0" out)))
|
|
'update)))))
|