diff --git a/collects/compiler/doc.txt b/collects/compiler/doc.txt index cfaed0f112..e2a55ac6a4 100644 --- a/collects/compiler/doc.txt +++ b/collects/compiler/doc.txt @@ -537,7 +537,11 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_. > (embedding-executable-is-directory? mred?) - Returns #t if Mzscheme/MrEd executables for the current platform correspond to - directories (as on Mac OS X). + directories from the user's perspective. + +> (embedding-executable-is-actually-directory? mred?) - Returns #t if + Mzscheme/MrEd executables for the current platform are implemented + as directories (as on Mac OS X). > (embedding-executable-put-file-extension+style+filters mred?) - @@ -546,7 +550,7 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_. MzScheme/MrEd launchers for this platform are directories, the `style' result is suitable for use with `get-directory', and the `extension' result may be a string indicating a required extension - for the directory name (e.g., ".app" for Mac OS X). + for the directory name (e.g., "app" for Mac OS X). > (embedding-executable-add-suffix path mred?) - Returns a path with a diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index d6fd69d078..fc628c7fb1 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -7,5 +7,6 @@ (make-embedding-executable write-module-bundle embedding-executable-is-directory? + embedding-executable-is-actually-directory? embedding-executable-put-file-extension+style+filters embedding-executable-add-suffix))) diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 0b1ae63d6b..b6e46b9567 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -19,12 +19,17 @@ (import) (define (embedding-executable-is-directory? mred?) - (eq? 'macosx (system-type))) + #f) + + (define (embedding-executable-is-actually-directory? mred?) + (and mred? (eq? 'macosx (system-type)))) (define (embedding-executable-put-file-extension+style+filters mred?) (case (system-type) - [(windows) (values ".exe" null '(("Executable" "*.exe")))] - [(macosx) (values ".app" '(enter-packages) #f)] + [(windows) (values "exe" null '(("Executable" "*.exe")))] + [(macosx) (if mred? + (values "app" '(enter-packages) '(("App" "*.app"))) + (values #f null null))] [else (values #f null null)])) (define (embedding-executable-add-suffix path mred?) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index dc555d83d6..d09d27f5fa 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1324,8 +1324,8 @@ (drscheme:language:put-executable parent program-filename - mred-launcher? #t + mred-launcher? (if mred-launcher? (string-constant save-a-mred-launcher) (string-constant save-a-mzscheme-launcher)))]) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 9bf546d2de..b1ebd60161 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -585,7 +585,7 @@ (define filename-text-field (instantiate text-field% () (label (string-constant filename)) (parent filename-panel) - (init-value (path->string (default-executable-filename program-filename #t))) + (init-value (path->string (default-executable-filename program-filename #f))) (min-width 400) (callback void))) (define filename-browse-button (instantiate button% () @@ -629,13 +629,9 @@ (gui-utils:ok/cancel-buttons button-panel (λ (x y) - (cond - [(filename-ok?) - (set! cancelled? #f) - (send dlg show #f)] - [else (message-box (string-constant drscheme) - (string-constant please-choose-an-executable-filename) - dlg)])) + (when (check-filename) + (set! cancelled? #f) + (send dlg show #f))) (λ (x y) (send dlg show #f)) (string-constant create) (string-constant cancel))) @@ -653,8 +649,8 @@ dlg base name - (not mzscheme?) launcher? + (not mzscheme?) (if launcher? (if mzscheme? (string-constant save-a-mzscheme-launcher) @@ -663,7 +659,7 @@ (string-constant save-a-mzscheme-stand-alone-executable) (string-constant save-a-mred-stand-alone-executable))))]) (when filename - (send filename-text-field set-value filename)))))) + (send filename-text-field set-value (path->string filename))))))) (define (currently-mzscheme-binary?) (cond @@ -677,20 +673,28 @@ (= 0 (send type-rb get-selection))] [else (eq? show-type 'launcher)])) - (define (filename-ok?) + (define (check-filename) (let ([filename-str (send filename-text-field get-value)] - [launcher-is-dir? - (cond - [(currently-mzscheme-binary?) - (mzscheme-launcher-is-directory?)] - [else - (mred-launcher-is-directory?)])]) - (cond - [(string=? "" filename-str) #f] - [(or (directory-exists? filename-str) - (file-exists? filename-str)) - (ask-user-can-clobber? filename-str)] - [else #t]))) + [mred? (not (currently-mzscheme-binary?))]) + (let-values ([(extension style filters) + (if (currently-launcher?) + (if mred? + (mred-launcher-put-file-extension+style+filters) + (mzscheme-launcher-put-file-extension+style+filters)) + (embedding-executable-put-file-extension+style+filters mred?))]) + + (cond + [(string=? "" filename-str) + (message-box (string-constant drscheme) + (string-constant please-choose-an-executable-filename) + dlg) + #f] + [(not (users-name-ok? extension dlg (string->path filename-str))) + #f] + [(or (directory-exists? filename-str) + (file-exists? filename-str)) + (ask-user-can-clobber? filename-str)] + [else #t])))) ;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean (define (ask-user-can-clobber? filename) @@ -758,7 +762,7 @@ style filters))]) (and users-name - (users-name-ok? dir? parent users-name) + (users-name-ok? extension parent users-name) (or (not dir?) (gui-utils:get-choice (format (string-constant warning-directory-will-be-replaced) @@ -770,32 +774,30 @@ parent)) users-name)))) - ;; users-name-ok? : boolean? (union #f frame% dialog%) string -> boolean + ;; users-name-ok? : string (union #f frame% dialog%) string -> boolean ;; returns #t if the string is an acceptable name for ;; a saved executable, and #f otherwise. - (define (users-name-ok? dir? parent name) - (case (system-type) - [(macosx) - (cond - [(not dir?) #t] ;; non dir executables are shell scripts and all names are okay - [(regexp-match #rx#".app$" (path->bytes name)) #t] - [else - (message-box (string-constant drscheme) - (format - (string-constant macosx-executables-must-end-with-app) - name) - parent) - #f])] - [(windows) - (cond - [(regexp-match #rx#".exe$" (path->bytes name)) #t] - [else - (message-box (string-constant drscheme) - (format (string-constant windows-executables-must-end-with-exe) - name) - parent) - #f])] - [else #t])) + (define (users-name-ok? extension parent name) + (or (not extension) + (let ([suffix-m (regexp-match #rx"[.][^.]*$" (path->string name))]) + (or (and suffix-m + (string=? (substring (car suffix-m) 1) extension)) + (begin + ;; FIXME: change the message to be platform-neutral and to + ;; use `extension' for the message + (case (system-type) + [(macosx) + (message-box (string-constant drscheme) + (format + (string-constant macosx-executables-must-end-with-app) + name) + parent)] + [(windows) + (message-box (string-constant drscheme) + (format (string-constant windows-executables-must-end-with-exe) + name) + parent)]) + #f))))) ;; default-executable-filename : path -> path (define (default-executable-filename program-filename mred?) diff --git a/collects/lang/plt-mred.ss b/collects/lang/plt-mred.ss index cb53850dcd..29fd48f2c8 100644 --- a/collects/lang/plt-mred.ss +++ b/collects/lang/plt-mred.ss @@ -1,9 +1,9 @@ (module plt-mred mzscheme (require (lib "mred.ss" "mred") (lib "class.ss")) - - (define argv #()) - (define program "mred") + + (define argv (current-command-line-arguments)) + (define program (find-system-path 'exec-file)) (provide argv program diff --git a/collects/lang/plt-mzscheme.ss b/collects/lang/plt-mzscheme.ss index afcd69f17a..c3f7c3bf87 100644 --- a/collects/lang/plt-mzscheme.ss +++ b/collects/lang/plt-mzscheme.ss @@ -1,6 +1,6 @@ (module plt-mzscheme mzscheme - (define argv #()) - (define program "mzscheme") + (define argv (current-command-line-arguments)) + (define program (find-system-path 'exec-file)) (provide argv program (all-from mzscheme))) diff --git a/collects/launcher/doc.txt b/collects/launcher/doc.txt index 4ff1e43741..dd60f48b9e 100644 --- a/collects/launcher/doc.txt +++ b/collects/launcher/doc.txt @@ -157,7 +157,7 @@ executables. platform are directories from the user perspective, the `style' result is suitable for use with `get-directory', and the `extension' result may be a string indicating a required extension for the - directory name (e.g., ".app" for Mac OS X). + directory name (e.g., "app" for Mac OS X). > (mzscheme-launcher-put-file-extension+style+filters) - Like `mred-launcher-get-file-extension+style+filters', but for MzScheme diff --git a/collects/launcher/launcher-unit.ss b/collects/launcher/launcher-unit.ss index 69d307d173..858253fc11 100644 --- a/collects/launcher/launcher-unit.ss +++ b/collects/launcher/launcher-unit.ss @@ -541,8 +541,8 @@ ;; Helper: (define (put-file-extension+style+filters type) (case type - [(windows) (values ".exe" null '(("Executable" "*.exe")))] - [(macosx) (values ".app" '(packages) '(("App" "*.app")))] + [(windows) (values "exe" null '(("Executable" "*.exe")))] + [(macosx) (values "app" '(packages) '(("App" "*.app")))] [else (values #f null null)])) (define (mred-launcher-add-suffix path)