suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

many repairs to Create Executable...

Browse Source 
svn: r1558
This commit is contained in:
Matthew Flatt 2005-12-07 14:27:12 +00:00
parent 027eb72aaa
commit d9bad21ca2
9 changed files with 74 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/compiler/doc.txt
View File

@ -537,7 +537,11 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
> (embedding-executable-is-directory? mred?) - Returns #t if > (embedding-executable-is-directory? mred?) - Returns #t if
Mzscheme/MrEd executables for the current platform correspond to 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?) - > (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 MzScheme/MrEd launchers for this platform are directories, the
`style' result is suitable for use with `get-directory', and the `style' result is suitable for use with `get-directory', and the
`extension' result may be a string indicating a required extension `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 > (embedding-executable-add-suffix path mred?) - Returns a path with a

1
collects/compiler/embed-sig.ss
View File

@ -7,5 +7,6 @@
(make-embedding-executable (make-embedding-executable
write-module-bundle write-module-bundle
embedding-executable-is-directory? embedding-executable-is-directory?
embedding-executable-is-actually-directory?
embedding-executable-put-file-extension+style+filters embedding-executable-put-file-extension+style+filters
embedding-executable-add-suffix))) embedding-executable-add-suffix)))

11
collects/compiler/embed-unit.ss
View File

@ -19,12 +19,17 @@
(import) (import)
(define (embedding-executable-is-directory? mred?) (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?) (define (embedding-executable-put-file-extension+style+filters mred?)
(case (system-type) (case (system-type)
[(windows) (values ".exe" null '(("Executable" "*.exe")))] [(windows) (values "exe" null '(("Executable" "*.exe")))]
[(macosx) (values ".app" '(enter-packages) #f)] [(macosx) (if mred?
(values "app" '(enter-packages) '(("App" "*.app")))
(values #f null null))]
[else (values #f null null)])) [else (values #f null null)]))
(define (embedding-executable-add-suffix path mred?) (define (embedding-executable-add-suffix path mred?)

2
collects/drscheme/private/language-configuration.ss
View File

@ -1324,8 +1324,8 @@
(drscheme:language:put-executable (drscheme:language:put-executable
parent parent
program-filename program-filename
mred-launcher?
#t #t
mred-launcher?
(if mred-launcher? (if mred-launcher?
(string-constant save-a-mred-launcher) (string-constant save-a-mred-launcher)
(string-constant save-a-mzscheme-launcher)))]) (string-constant save-a-mzscheme-launcher)))])

68
collects/drscheme/private/language.ss
View File

@ -585,7 +585,7 @@
(define filename-text-field (instantiate text-field% () (define filename-text-field (instantiate text-field% ()
(label (string-constant filename)) (label (string-constant filename))
(parent filename-panel) (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) (min-width 400)
(callback void))) (callback void)))
(define filename-browse-button (instantiate button% () (define filename-browse-button (instantiate button% ()
@ -629,13 +629,9 @@
(gui-utils:ok/cancel-buttons (gui-utils:ok/cancel-buttons
button-panel button-panel
(λ (x y) (λ (x y)
(cond (when (check-filename)
[(filename-ok?)
(set! cancelled? #f) (set! cancelled? #f)
(send dlg show #f)] (send dlg show #f)))
[else (message-box (string-constant drscheme)
(string-constant please-choose-an-executable-filename)
dlg)]))
(λ (x y) (send dlg show #f)) (λ (x y) (send dlg show #f))
(string-constant create) (string-constant create)
(string-constant cancel))) (string-constant cancel)))
@ -653,8 +649,8 @@
dlg dlg
base base
name name
(not mzscheme?)
launcher? launcher?
(not mzscheme?)
(if launcher? (if launcher?
(if mzscheme? (if mzscheme?
(string-constant save-a-mzscheme-launcher) (string-constant save-a-mzscheme-launcher)
@ -663,7 +659,7 @@
(string-constant save-a-mzscheme-stand-alone-executable) (string-constant save-a-mzscheme-stand-alone-executable)
(string-constant save-a-mred-stand-alone-executable))))]) (string-constant save-a-mred-stand-alone-executable))))])
(when filename (when filename
(send filename-text-field set-value filename)))))) (send filename-text-field set-value (path->string filename)))))))
(define (currently-mzscheme-binary?) (define (currently-mzscheme-binary?)
(cond (cond
@ -677,20 +673,28 @@
(= 0 (send type-rb get-selection))] (= 0 (send type-rb get-selection))]
[else (eq? show-type 'launcher)])) [else (eq? show-type 'launcher)]))
(define (filename-ok?) (define (check-filename)
(let ([filename-str (send filename-text-field get-value)] (let ([filename-str (send filename-text-field get-value)]
[launcher-is-dir? [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 (cond
[(currently-mzscheme-binary?) [(string=? "" filename-str)
(mzscheme-launcher-is-directory?)] (message-box (string-constant drscheme)
[else (string-constant please-choose-an-executable-filename)
(mred-launcher-is-directory?)])]) dlg)
(cond #f]
[(string=? "" filename-str) #f] [(not (users-name-ok? extension dlg (string->path filename-str)))
#f]
[(or (directory-exists? filename-str) [(or (directory-exists? filename-str)
(file-exists? filename-str)) (file-exists? filename-str))
(ask-user-can-clobber? filename-str)] (ask-user-can-clobber? filename-str)]
[else #t]))) [else #t]))))
;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean ;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean
(define (ask-user-can-clobber? filename) (define (ask-user-can-clobber? filename)
@ -758,7 +762,7 @@
style style
filters))]) filters))])
(and users-name (and users-name
(users-name-ok? dir? parent users-name) (users-name-ok? extension parent users-name)
(or (not dir?) (or (not dir?)
(gui-utils:get-choice (gui-utils:get-choice
(format (string-constant warning-directory-will-be-replaced) (format (string-constant warning-directory-will-be-replaced)
@ -770,32 +774,30 @@
parent)) parent))
users-name)))) 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 ;; returns #t if the string is an acceptable name for
;; a saved executable, and #f otherwise. ;; a saved executable, and #f otherwise.
(define (users-name-ok? dir? parent name) (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) (case (system-type)
[(macosx) [(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) (message-box (string-constant drscheme)
(format (format
(string-constant macosx-executables-must-end-with-app) (string-constant macosx-executables-must-end-with-app)
name) name)
parent) parent)]
#f])]
[(windows) [(windows)
(cond
[(regexp-match #rx#".exe$" (path->bytes name)) #t]
[else
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(format (string-constant windows-executables-must-end-with-exe) (format (string-constant windows-executables-must-end-with-exe)
name) name)
parent) parent)])
#f])] #f)))))
[else #t]))
;; default-executable-filename : path -> path ;; default-executable-filename : path -> path
(define (default-executable-filename program-filename mred?) (define (default-executable-filename program-filename mred?)

4
collects/lang/plt-mred.ss
View File

@ -2,8 +2,8 @@
(require (lib "mred.ss" "mred") (require (lib "mred.ss" "mred")
(lib "class.ss")) (lib "class.ss"))
(define argv #()) (define argv (current-command-line-arguments))
(define program "mred") (define program (find-system-path 'exec-file))
(provide argv (provide argv
program program

4
collects/lang/plt-mzscheme.ss
View File

@ -1,6 +1,6 @@
(module plt-mzscheme mzscheme (module plt-mzscheme mzscheme
(define argv #()) (define argv (current-command-line-arguments))
(define program "mzscheme") (define program (find-system-path 'exec-file))
(provide argv (provide argv
program program
(all-from mzscheme))) (all-from mzscheme)))

2
collects/launcher/doc.txt
View File

@ -157,7 +157,7 @@ executables.
platform are directories from the user perspective, the `style' platform are directories from the user perspective, the `style'
result is suitable for use with `get-directory', and the `extension' result is suitable for use with `get-directory', and the `extension'
result may be a string indicating a required extension for the 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 > (mzscheme-launcher-put-file-extension+style+filters) - Like
`mred-launcher-get-file-extension+style+filters', but for MzScheme `mred-launcher-get-file-extension+style+filters', but for MzScheme

4
collects/launcher/launcher-unit.ss
View File

@ -541,8 +541,8 @@
;; Helper: ;; Helper:
(define (put-file-extension+style+filters type) (define (put-file-extension+style+filters type)
(case type (case type
[(windows) (values ".exe" null '(("Executable" "*.exe")))] [(windows) (values "exe" null '(("Executable" "*.exe")))]
[(macosx) (values ".app" '(packages) '(("App" "*.app")))] [(macosx) (values "app" '(packages) '(("App" "*.app")))]
[else (values #f null null)])) [else (values #f null null)]))
(define (mred-launcher-add-suffix path) (define (mred-launcher-add-suffix path)