#lang racket/base ;; copy of launcher/launcher since it has a bug in 5.1.1. ;; The bug's fixed in later versions of Racket, but my local machine still ;; has 5.1.1. As soon as I switch over, this module will lose ;; its meaning. (require scheme/path scheme/file scheme/list scheme/string compiler/embed setup/dirs setup/variant compiler/private/winutf16) (define current-launcher-variant (make-parameter (system-type 'gc) (lambda (v) (unless (memq v '(3m script-3m cgc script-cgc)) (raise-type-error 'current-launcher-variant "variant symbol" v)) v))) (define (variant-available? kind cased-kind-name variant) (cond [(or (eq? 'unix (system-type)) (and (eq? 'macosx (system-type)) (eq? kind 'mzscheme))) (let ([bin-dir (find-console-bin-dir)]) (and bin-dir (file-exists? (build-path bin-dir (format "~a~a" (case kind [(mzscheme) 'racket] [(mred) 'gracket]) (variant-suffix variant #f))))))] [(eq? 'macosx (system-type)) ;; kind must be mred, because mzscheme case is caught above (directory-exists? (build-path (find-gui-bin-dir) (format "~a~a.app" cased-kind-name (variant-suffix variant #f))))] [(eq? 'windows (system-type)) (file-exists? (build-path (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-gui-bin-dir)) (format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))] [else (error "unknown system type")])) (define (available-variants kind) (let* ([cased-kind-name (if (eq? kind 'mzscheme) "Racket" "GRacket")] [normal-kind (system-type 'gc)] [alt-kind (if (eq? '3m normal-kind) 'cgc '3m)] [normal (if (variant-available? kind cased-kind-name normal-kind) (list normal-kind) null)] [alt (if (variant-available? kind cased-kind-name alt-kind) (list alt-kind) null)] [script (if (and (eq? 'macosx (system-type)) (eq? kind 'mred) (pair? normal)) (if (eq? normal-kind '3m) '(script-3m) '(script-cgc)) null)] [script-alt (if (and (memq alt-kind alt) (pair? script)) (if (eq? alt-kind '3m) '(script-3m) '(script-cgc)) null)]) (append normal alt script script-alt))) (define (available-gracket-variants) (available-variants 'mred)) (define (available-mred-variants) (available-variants 'mred)) (define (available-racket-variants) (available-variants 'mzscheme)) (define (available-mzscheme-variants) (available-variants 'mzscheme)) (define (install-template dest kind mz mr) (define src (build-path (collection-path "launcher") (if (eq? kind 'mzscheme) mz mr))) (when (or (file-exists? dest) (directory-exists? dest) (link-exists? dest)) (delete-directory/files dest)) (copy-file src dest) ;; Make sure we can write. (file-or-directory-permissions dest (bitwise-ior (file-or-directory-permissions dest 'bits) user-write-bit))) (define (script-variant? v) (memq v '(script-3m script-cgc))) (define (add-file-suffix path variant mred?) (let ([s (variant-suffix variant (case (system-type) [(unix) #f] [(windows) #t] [(macosx) (and mred? (not (script-variant? variant)))]))]) (if (string=? "" s) path (path-replace-suffix path (string->bytes/utf-8 (if (and (eq? 'windows (system-type)) (regexp-match #rx#"[.]exe$" (path->bytes path))) (format "~a.exe" s) s)))))) (define (string-append/spaces f flags) (string-append* (append-map (lambda (x) (list (f x) " ")) flags))) (define (str-list->sh-str flags) (string-append/spaces (lambda (s) (string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'")) flags)) (define (str-list->dos-str flags) (define (trans s) (if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s)) s (list->string (let loop ([l (string->list s)] [slashes '()]) (cond [(null? l) '()] [(char-whitespace? (car l)) `(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))] [(eq? #\\ (car l)) `(#\\ ,@(loop (cdr l) (cons #\\ slashes)))] [(eq? #\" (car l)) `(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))] [else `(,(car l) ,@(loop (cdr l) '()))]))))) (string-append/spaces trans flags)) (define one-arg-x-flags '((xa "-display") (xb "-geometry") (xc "-bg" "-background") (xd "-fg" "-foregound") (xe "-font") (xf "-name") (xg "-selectionTimeout") (xh "-title") (xi "-xnllanguage") (xj "-xrm"))) (define no-arg-x-flags '((xk "-iconic") (xl "-rv" "-reverse") (xm "+rv") (xn "-synchronous") (xo "-singleInstance"))) (define (skip-x-flags flags) (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) (let loop ([f flags]) (cond [(null? f) null] [(ormap (xfmem (car f)) one-arg-x-flags) (if (null? (cdr f)) null (loop (cddr f)))] [(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))] [else f])))) (define (output-x-arg-getter exec args) (let ([or-flags (lambda (l) (string-append* (add-between l " | ")))]) (string-append* (append (list "# Find X flags and shift them to the front\n" "findxend() {\n" " oneargflag=''\n" " case \"$1\" in\n") (map (lambda (f) (format (string-append " ~a)\n" " oneargflag=\"$1\"\n" " ~a=\"$2\"\n" " ;;\n") (or-flags (cdr f)) (car f))) one-arg-x-flags) (map (lambda (f) (format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f))) no-arg-x-flags) (list (format (string-append " *)\n ~a~a ~a ;;\n" " esac\n" " shift\n" " if [ \"$oneargflag\" != '' ] ; then\n" " if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n" " shift\n" " fi\n" " findxend ${1+\"$@\"}\n" "}\nfindxend ${1+\"$@\"}\n") exec (string-append* (append (map (lambda (f) (format " ${~a+\"~a\"} ${~a+\"$~a\"}" (car f) (cadr f) (car f) (car f))) one-arg-x-flags) (map (lambda (f) (format " ${~a+\"~a\"}" (car f) (cadr f))) no-arg-x-flags))) args)))))) (define (protect-shell-string s) (regexp-replace* #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) (define (normalize+explode-path p) (explode-path (normal-case-path (simple-form-path p)))) (define (relativize bindir-explode dest-explode) (let loop ([b bindir-explode] [d dest-explode]) (if (and (pair? b) (equal? (car b) (car d))) (loop (cdr b) (cdr d)) (let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) (if (null? p) #f (apply build-path p)))))) (define (make-relative-path-header dest bindir) ;; rely only on binaries in /usr/bin:/bin (define (has-exe? exe) (or (file-exists? (build-path "/usr/bin" exe)) (file-exists? (build-path "/bin" exe)))) (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) (has-exe? "readlink"))] [dest-explode (normalize+explode-path dest)] [bindir-explode (normalize+explode-path bindir)]) (if (and (has-exe? "dirname") (has-exe? "basename") (or has-readlink? (and (has-exe? "ls") (has-exe? "sed"))) (equal? (car dest-explode) (car bindir-explode))) (string-append "# Make this PATH-independent\n" "saveP=\"$PATH\"\n" "PATH=\"/usr/bin:/bin\"\n" "\n" (if has-readlink? "" (string-append "# imitate possibly-missing readlink\n" "readlink() {\n" " ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n" "}\n" "\n")) "# Remember current directory\n" "saveD=`pwd`\n" "\n" "# Find absolute path to this script,\n" "# resolving symbolic references to the end\n" "# (changes the current directory):\n" "D=`dirname \"$0\"`\n" "F=`basename \"$0\"`\n" "cd \"$D\"\n" "while test " ;; On solaris, Edward Chrzanowski from Waterloo says that the man ;; page says that -L is not supported, but -h is; on other systems ;; (eg, freebsd) -h is listed as a compatibility feature (if (regexp-match #rx"solaris" (path->string (system-library-subpath))) "-h" "-L") " \"$F\"; do\n" " P=`readlink \"$F\"`\n" " D=`dirname \"$P\"`\n" " F=`basename \"$P\"`\n" " cd \"$D\"\n" "done\n" "D=`pwd`\n" "\n" "# Restore current directory\n" "cd \"$saveD\"\n" "\n" "bindir=\"$D" (let ([s (relativize bindir-explode dest-explode)]) (if s (string-append "/" (protect-shell-string s)) "")) "\"\n" "PATH=\"$saveP\"\n") ;; fallback to absolute path header (make-absolute-path-header bindir)))) (define (make-absolute-path-header bindir) (string-append "bindir=\""(protect-shell-string bindir)"\"\n")) (define (make-unix-launcher kind variant flags dest aux) (install-template dest kind "sh" "sh") ; just for something that's executable (let* ([alt-exe (let ([m (and (eq? kind 'mred) (script-variant? variant) (assq 'exe-name aux))]) (and m (format "~a~a.app/Contents/MacOS/~a~a" (cdr m) (variant-suffix variant #t) (cdr m) (variant-suffix variant #t))))] [x-flags? (and (eq? kind 'mred) (eq? (system-type) 'unix) (not (script-variant? variant)))] [post-flags (cond [x-flags? (skip-x-flags flags)] [alt-exe null] [else flags])] [pre-flags (cond [(not x-flags?) null] [else (let loop ([f flags]) (if (eq? f post-flags) null (cons (car f) (loop (cdr f)))))])] [pre-str (str-list->sh-str pre-flags)] [post-str (str-list->sh-str post-flags)] [header (string-append "#!/bin/sh\n" "# This script was created by make-" (symbol->string kind)"-launcher\n")] [dir-finder (let ([bindir (if alt-exe (find-gui-bin-dir) (find-console-bin-dir))]) (if (let ([a (assq 'relative? aux)]) (and a (cdr a))) (make-relative-path-header dest bindir) (make-absolute-path-header bindir)))] [exec (format "exec \"${bindir}/~a~a\" ~a" (or alt-exe (case kind [(mred) "gracket"] [(mzscheme) "racket"])) (if alt-exe "" (variant-suffix variant #f)) pre-str)] [args (format "~a~a ${1+\"$@\"}\n" (if alt-exe "" "-N \"$0\" ") post-str)] [assemble-exec (if (and (eq? kind 'mred) (not (script-variant? variant)) (not (null? post-flags))) output-x-arg-getter string-append)]) (unless (find-console-bin-dir) (error 'make-unix-launcher "unable to locate bin directory")) (with-output-to-file dest #:exists 'truncate (lambda () (display header) (newline) ;; comments needed to rehack launchers when paths change ;; (see setup/unixstyle-install.ss) (display "# {{{ bindir\n") (display dir-finder) (display "# }}} bindir\n") (newline) (display (assemble-exec exec args)))))) (define (utf-16-regexp b) (byte-regexp (bytes-append (bytes->utf-16-bytes b) #"[^>]*" (bytes->utf-16-bytes #">")))) (define (make-windows-launcher kind variant flags dest aux) (if (not (and (let ([m (assq 'independent? aux)]) (and m (cdr m))))) ;; Normal launcher: (make-embedding-executable dest (eq? kind 'mred) #f null null null flags aux #t variant) ;; Independent launcher (needed for Setup PLT): (begin (install-template dest kind "mzstart.exe" "mrstart.exe") (let ([bstr (bytes->utf-16-bytes (string->bytes/utf-8 (str-list->dos-str flags)))] [p (open-input-file dest)] [m (utf-16-regexp #"utf-16-bytes (bytes-append (path->bytes (let ([bin-dir (if (eq? kind 'mred) (find-gui-bin-dir) (find-console-bin-dir))]) (if (let ([m (assq 'relative? aux)]) (and m (cdr m))) (or (relativize (normalize+explode-path bin-dir) (normalize+explode-path dest)) (build-path 'same)) bin-dir))) ;; null wchar marks end of executable directory #"\0\0"))] [find-it ; Find the magic start (lambda (magic s) (file-position p 0) (let ([m (regexp-match-positions magic p)]) (if m (car m) (begin (close-input-port p) (when (file-exists? dest) (delete-file dest)) (error 'make-windows-launcher "Couldn't find ~a position in template" s)))))] [exedir-poslen (find-it x "executable path")] [command-poslen (find-it m "command-line")] [variant-poslen (find-it v "variant")] [pos-exedir (car exedir-poslen)] [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] [pos-command (car command-poslen)] [len-command (- (cdr command-poslen) (car command-poslen))] [pos-variant (car variant-poslen)] [space (char->integer #\space)] [write-magic (lambda (p s pos len) (file-position p pos) (display s p) (display (make-bytes (- len (bytes-length s)) space) p))] [check-len (lambda (len s es) (when (> (bytes-length s) len) (when (file-exists? dest) (delete-file dest)) (error (format "~a exceeds limit of ~a characters with ~a characters: ~a" es len (string-length s) s))))]) (close-input-port p) (check-len len-exedir exedir "executable home directory") (check-len len-command bstr "collection/file name") (let ([p (open-output-file dest #:exists 'update)]) (write-magic p exedir pos-exedir len-exedir) (write-magic p (bytes-append bstr #"\0\0") pos-command len-command) (let* ([suffix (variant-suffix (current-launcher-variant) #t)] [suffix-bytes (bytes-append (list->bytes (append-map (lambda (c) (list c 0)) (bytes->list (string->bytes/latin-1 suffix)))) #"\0\0")]) (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) (close-output-port p))))))) ;; OS X launcher code: ;; make-macosx-launcher : symbol (listof str) pathname -> (define (make-macosx-launcher kind variant flags dest aux) (if (or (eq? kind 'mzscheme) (script-variant? variant)) ;; Racket or script launcher is the same as for Unix (make-unix-launcher kind variant flags dest aux) ;; Gracket "launcher" is a stand-alone executable (make-embedding-executable dest (eq? kind 'mred) #f null null null flags aux #t variant))) (define (make-macos-launcher kind variant flags dest aux) (install-template dest kind "GoMr" "GoMr") (let* ([p (open-input-file dest)] [m (regexp-match-positions #rx#"" p)]) ;; fast-forward to the end: (let ([s (make-bytes 4096)]) (let loop () (if (eof-object? (read-bytes! s p)) (file-position p) (loop)))) (let ([data-fork-size (file-position p)]) (close-input-port p) (let ([p (open-output-file dest #:exists 'update)] [str (str-list->sh-str (append (if (eq? kind 'mred) null '("-Z")) flags))]) (file-position p (caar m)) (display (integer->integer-bytes (string-length str) 4 #t #t) p) (display (integer->integer-bytes data-fork-size 4 #t #t) p) (file-position p data-fork-size) (display str p) (close-output-port p))))) (define (get-maker) (case (system-type) [(unix) make-unix-launcher] [(windows) make-windows-launcher] [(macos) make-macos-launcher] [(macosx) make-macosx-launcher])) (define (make-gracket-launcher flags dest [aux null]) ((get-maker) 'mred (current-launcher-variant) flags dest aux)) (define (make-mred-launcher flags dest [aux null]) ((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux)) (define (make-racket-launcher flags dest [aux null]) ((get-maker) 'mzscheme (current-launcher-variant) flags dest aux)) (define (make-mzscheme-launcher flags dest [aux null]) ((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux)) (define (strip-suffix s) (path-replace-suffix s #"")) (define (build-aux-from-path aux-root) (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)]) (define (try key suffix) (let ([p (path-replace-suffix aux-root suffix)]) (if (file-exists? p) (list (cons key p)) null))) (append (try 'icns #".icns") (try 'ico #".ico") (try 'independent? #".lch") (let ([l (try 'creator #".creator")]) (if (null? l) l (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (with-input-from-file (cdar l) (lambda () (let ([s (read-string 4)]) (if s (list (cons (caar l) s)) null))))))) (let ([l (try 'file-types #".filetypes")]) (if (null? l) l (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (with-input-from-file (cdar l) (lambda () (let*-values ([(d) (read)] [(local-dir base dir?) (split-path aux-root)] [(icon-files) (append-map (lambda (spec) (let ([m (assoc "CFBundleTypeIconFile" spec)]) (if m (list (build-path (path->complete-path local-dir) (format "~a.icns" (cadr m)))) null))) d)]) (list (cons 'file-types d) (cons 'resource-files (remove-duplicates icon-files))))))))) (let ([l (try 'file-types #".utiexports")]) (if (null? l) l (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (with-input-from-file (cdar l) (lambda () (let ([d (read)]) (list (cons 'uti-exports d))))))))))) (define (make-gracket-program-launcher file collection dest) (make-mred-launcher (list "-l-" (string-append collection "/" file)) dest (build-aux-from-path (build-path (collection-path collection) (strip-suffix file))))) (define (make-mred-program-launcher file collection dest) (make-gracket-program-launcher file collection dest)) (define (make-racket-program-launcher file collection dest) (make-mzscheme-launcher (list "-l-" (string-append collection "/" file)) dest (build-aux-from-path (build-path (collection-path collection) (strip-suffix file))))) (define (make-mzscheme-program-launcher file collection dest) (make-racket-program-launcher file collection dest)) (define (unix-sfx file mred?) (string-downcase (regexp-replace* #px"\\s" file "-"))) (define (sfx file mred?) (case (system-type) [(unix) (unix-sfx file mred?)] [(windows) (string-append (if mred? file (unix-sfx file mred?)) ".exe")] [else file])) (define (program-launcher-path name mred?) (let* ([variant (current-launcher-variant)] [mac-script? (and (eq? (system-type) 'macosx) (script-variant? variant))]) (let ([p (add-file-suffix (build-path (if (or mac-script? (not mred?)) (find-console-bin-dir) (find-gui-bin-dir)) ((if mac-script? unix-sfx sfx) name mred?)) variant mred?)]) (if (and (eq? (system-type) 'macosx) (not (script-variant? variant))) (path-replace-suffix p #".app") p)))) (define (gracket-program-launcher-path name) (program-launcher-path name #t)) (define (mred-program-launcher-path name) (gracket-program-launcher-path name)) (define (racket-program-launcher-path name) (case (system-type) [(macosx) (add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f)) (current-launcher-variant) #f)] [else (program-launcher-path name #f)])) (define (mzscheme-program-launcher-path name) (racket-program-launcher-path name)) (define (gracket-launcher-is-directory?) #f) (define (racket-launcher-is-directory?) #f) (define (mred-launcher-is-directory?) #f) (define (mzscheme-launcher-is-directory?) #f) (define (gracket-launcher-is-actually-directory?) (and (eq? 'macosx (system-type)) (not (script-variant? (current-launcher-variant))))) (define (mred-launcher-is-actually-directory?) (gracket-launcher-is-actually-directory?)) (define (racket-launcher-is-actually-directory?) #f) (define (mzscheme-launcher-is-actually-directory?) #f) ;; Helper: (define (put-file-extension+style+filters type) (case type [(windows) (values "exe" null '(("Executable" "*.exe")))] [(macosx) (values "app" '(packages) '(("App" "*.app")))] [else (values #f null null)])) (define (gracket-launcher-add-suffix path) (embedding-executable-add-suffix path #t)) (define (mred-launcher-add-suffix path) (gracket-launcher-add-suffix path)) (define (racket-launcher-add-suffix path) (embedding-executable-add-suffix path #f)) (define (mzscheme-launcher-add-suffix path) (racket-launcher-add-suffix path)) (define (gracket-launcher-put-file-extension+style+filters) (put-file-extension+style+filters (if (and (eq? 'macosx (system-type)) (script-variant? (current-launcher-variant))) 'unix (system-type)))) (define (mred-launcher-put-file-extension+style+filters) (gracket-launcher-put-file-extension+style+filters)) (define (racket-launcher-put-file-extension+style+filters) (put-file-extension+style+filters (if (eq? 'macosx (system-type)) 'unix (system-type)))) (define (mzscheme-launcher-put-file-extension+style+filters) (racket-launcher-put-file-extension+style+filters)) (define (gracket-launcher-up-to-date? dest [aux null]) (racket-launcher-up-to-date? dest aux)) (define (mred-launcher-up-to-date? dest [aux null]) (racket-launcher-up-to-date? dest aux)) (define (mzscheme-launcher-up-to-date? dest [aux null]) (racket-launcher-up-to-date? dest aux)) (define (racket-launcher-up-to-date? dest [aux null]) (cond ;; When running Setup PLT under Windows, the ;; launcher process stays running until Racket ;; completes, which means that it cannot be ;; overwritten at that time. So we assume ;; that a Setup-PLT-style independent launcher ;; is always up-to-date. [(eq? 'windows (system-type)) (and (let ([m (assq 'independent? aux)]) (and m (cdr m))) (file-exists? dest))] ;; For any other setting, we could implement ;; a fancy check, but for now always re-create ;; launchers. [else #f])) (define (install-gracket-program-launcher file collection name) (make-gracket-program-launcher file collection (gracket-program-launcher-path name))) (define (install-racket-program-launcher file collection name) (make-racket-program-launcher file collection (racket-program-launcher-path name))) (define (install-mred-program-launcher file collection name) (make-mred-program-launcher file collection (mred-program-launcher-path name))) (define (install-mzscheme-program-launcher file collection name) (make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require racket/runtime-path) (define-runtime-path whalesong-path "whalesong.rkt") (make-racket-launcher (list (path->string whalesong-path)) "whalesong" '())