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
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

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

@ -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)))

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

@ -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?)

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

@ -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)))])

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

@ -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?)
(when (check-filename)
(set! cancelled? #f)
(send dlg show #f)]
[else (message-box (string-constant drscheme)
(string-constant please-choose-an-executable-filename)
dlg)]))
(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?
[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
[(currently-mzscheme-binary?)
(mzscheme-launcher-is-directory?)]
[else
(mred-launcher-is-directory?)])])
(cond
[(string=? "" filename-str) #f]
[(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])))
[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)
(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)
(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])]
parent)]
[(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]))
parent)])
#f)))))
;; default-executable-filename : path -> path
(define (default-executable-filename program-filename mred?)

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

@ -2,8 +2,8 @@
(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

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

@ -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)))

2
collects/launcher/doc.txt
View File

@ -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

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

@ -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)