251 lines
9.9 KiB
Scheme
Executable File
251 lines
9.9 KiB
Scheme
Executable File
#!/bin/sh
|
|
#| -*- scheme -*-
|
|
# PLT software installer
|
|
# ----------------------
|
|
# Normally it'll use MzScheme (will search for it at the same place this script
|
|
# is), but it can also be used with mred for graphic installations.
|
|
# Run with `-h' for more information.
|
|
|
|
# Try to find where mzscheme is, usually where this script is being run from
|
|
if [ -x install -a -d collects ]; then
|
|
pltdir="."
|
|
else
|
|
# Try finding the installation directory...
|
|
if [ -x "/bin/dirname" ]; then
|
|
pltdir="`/bin/dirname \"$0\"`"
|
|
elif [ -x "/usr/bin/dirname" ]; then
|
|
pltdir="`/usr/bin/dirname \"$0\"`"
|
|
else
|
|
dirname="`which dirname`"
|
|
if [ ! -z "$dirname" ]; then
|
|
pltdir="$dirname"
|
|
fi
|
|
fi
|
|
fi
|
|
|
|
if [ -x "$pltdir/bin/mzscheme" ]; then
|
|
mz="$pltdir/bin/mzscheme"
|
|
elif [ -e "$pltdir/MzScheme.exe" ]; then
|
|
# Note: with cygwin, `-x' doesn't work properly
|
|
mz="$pltdir/MzScheme.exe"
|
|
else
|
|
echo "install: cannot find the mzscheme executable"
|
|
echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
|
|
echo "!! Install incomplete! !!"
|
|
echo "!! !!"
|
|
echo "!! If you downloaded the source distribution, see !!"
|
|
echo "!! src/README for build instructions. !!"
|
|
echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
|
|
exit 1
|
|
fi
|
|
|
|
exec "$mz" -qC "$0" "$@"
|
|
exit 1
|
|
|#
|
|
|
|
(use-compiled-file-paths null)
|
|
|
|
(define plthome #f)
|
|
(define this-script #f)
|
|
(define install-mode? #f)
|
|
|
|
(when (or (getenv "OSX_PLT_INSTALL") (getenv "RPM_INSTALL_PREFIX"))
|
|
(set! install-mode? #t))
|
|
|
|
(define (set-plthome this)
|
|
(let-values ([(dir name dir?)
|
|
(split-path
|
|
(resolve-path
|
|
(path->complete-path (simplify-path (resolve-path this)))))])
|
|
(unless (path? dir) (error 'install "Bad pathname for install: ~s" this))
|
|
(current-directory dir)
|
|
(current-directory ".") ; avoid a "/" suffix
|
|
(set! plthome (current-directory))
|
|
(unless (and (directory-exists? "collects/mzlib") (file-exists? name))
|
|
(error 'install
|
|
"Can't find the PLT installation this script (~a) is part of"
|
|
this))
|
|
(set! this-script (path->string name))))
|
|
|
|
(define (setup-environment)
|
|
(putenv "PLTHOME" (path->string plthome))
|
|
(putenv "PLTCOLLECTS" "")
|
|
(current-library-collection-paths (list (build-path plthome "collects"))))
|
|
|
|
(require (lib "cmdline.ss"))
|
|
(define setup-flags (make-parameter '()))
|
|
(define (process-command-line args)
|
|
(define more-help
|
|
(lambda (help)
|
|
(display "This is the PLT installer.\nUsage: ")
|
|
(display help)
|
|
(exit 0)))
|
|
(command-line this-script (list->vector args)
|
|
(once-each
|
|
(("-i")
|
|
"Install mode.\n\
|
|
This is a `one-time option' that is intended to be used with\n\
|
|
installers or after retrieving a fresh plt tree. This will re-use\n\
|
|
existing zos (making only missing ones), and recreate the launchers.\n\
|
|
It should be again in this mode only if the PLT tree was moved."
|
|
(set! install-mode? #t)))
|
|
(help-labels
|
|
"Additional arguments (after a \"--\" are passed on to setup-plt")
|
|
(=> (lambda (f . _) (setup-flags _))
|
|
'("setup-flags")
|
|
more-help)))
|
|
|
|
;; Set up GUI if we're using MrEd
|
|
(when (namespace-variable-value 'make-eventspace #t (lambda () #f))
|
|
;; no console input
|
|
(current-input-port (open-input-string ""))
|
|
(let ([evt (make-eventspace)] [orig-exit (exit-handler)])
|
|
(parameterize ([current-eventspace evt])
|
|
(define (do-callback thunk)
|
|
(parameterize ([current-eventspace evt]) (queue-callback thunk #f)))
|
|
(define (quit)
|
|
(when (eq? 'ok (message-box "Stop Installation"
|
|
"Ok to stop the installation?"
|
|
f '(ok-cancel)))
|
|
(exit 1)))
|
|
(define (fail msg exit-code)
|
|
(do-callback
|
|
(lambda ()
|
|
(send e lock #f)
|
|
(let* ([p1 (send e last-position)]
|
|
[_ (send e insert msg p1)]
|
|
[p2 (send e last-position)])
|
|
(send e insert "\n(click button below to exit)" p2)
|
|
(send e change-style
|
|
(let ([d (make-object style-delta% 'change-bold)])
|
|
(send d set-delta-foreground "red")
|
|
d)
|
|
p1 p2))
|
|
(send e lock #t)
|
|
(send b set-label "Quit Installation")
|
|
(set! quit (lambda () (orig-exit exit-code)))))
|
|
(semaphore-wait (make-semaphore)))
|
|
(define f (make-object
|
|
(class frame% ()
|
|
(define/augment (can-close?) (quit) #f)
|
|
(super-instantiate ("PLT Installer" #f 600 480)))))
|
|
(define e (make-object text%))
|
|
(define c (make-object editor-canvas% f e '(no-hscroll)))
|
|
(define b (make-object button% "Stop Installation" f (lambda _ (quit))))
|
|
(send c allow-tab-exit #t)
|
|
(send e lock #t)
|
|
(send e auto-wrap #t)
|
|
(let ([out (make-output-port 'gui-output
|
|
always-evt
|
|
(lambda (bstring start end flush? breaks?)
|
|
(do-callback (lambda ()
|
|
(send e lock #f)
|
|
(send e insert
|
|
(bytes->string/utf-8
|
|
(subbytes bstring start end))
|
|
(send e last-position))
|
|
(send e lock #t)))
|
|
(- end start))
|
|
void)])
|
|
(current-output-port out)
|
|
(current-error-port out))
|
|
(send f center 'both)
|
|
(send f show #t)
|
|
(exit-handler
|
|
(lambda (v)
|
|
;; can use an explicit (exit 0) to show the output
|
|
(fail (if (zero? v) "Done" "INSTALLATION FAILED") v)))
|
|
(current-exception-handler
|
|
(lambda (e)
|
|
(if (exn:break? e)
|
|
(orig-exit 1) ; don't lock up if the process is killed
|
|
(fail (format "INSTALLATION FAILED: ~a"
|
|
(if (exn? e) (exn-message e) e))
|
|
1))))
|
|
(initial-exception-handler (current-exception-handler)))))
|
|
|
|
(define (create-zos)
|
|
(let/ec return
|
|
(parameterize
|
|
(;; Need a new namespace to ensure that all modules are compiled,
|
|
;; including ones we've already loaded. We also need to re-enable
|
|
;; compiled files, since cm.ss checks on that flag.
|
|
[current-namespace (make-namespace)]
|
|
[use-compiled-file-paths '("compiled")]
|
|
[current-command-line-arguments
|
|
(list->vector
|
|
(append (if install-mode? '("-n" "--trust-zos" "--no-install") '())
|
|
(setup-flags)))]
|
|
;; setup will use `exit' when done, so catch these, and stop if
|
|
;; non-zero
|
|
[exit-handler
|
|
(lambda (n)
|
|
(if (zero? n)
|
|
(return)
|
|
(error 'install "Errors in compilation process! (~a)" n)))]
|
|
;; also, protect `current-directory' since it will change
|
|
[current-directory (current-directory)])
|
|
(printf "Running setup...\n")
|
|
(dynamic-require '(lib "setup.ss" "setup") #f))))
|
|
|
|
(define oldrun-plthome #f)
|
|
;; This will change the `oldrun-plthome' definition in this file.
|
|
(define (remember-this-path!)
|
|
(let* ([in (open-input-file this-script)]
|
|
[lines (let loop ([r '()])
|
|
(let ([l (read-line in)])
|
|
(if (eof-object? l)
|
|
(reverse! r)
|
|
(loop (cons l r)))))])
|
|
(close-input-port in)
|
|
(let ([out (open-output-file this-script 'truncate)]
|
|
[oldrun-expr (format "~s" `(define oldrun-plthome
|
|
,(path->string plthome)))]
|
|
[oldrun-re "^ *\\(define oldrun-plthome .*\\) *$"])
|
|
(for-each (lambda (l)
|
|
(display (if (regexp-match oldrun-re l) oldrun-expr l) out)
|
|
(newline out))
|
|
lines))))
|
|
|
|
(define (main args)
|
|
(set-plthome (car args))
|
|
(when (regexp-match #rx"^[Ff]inish.[Ii]nstall($|\\.)" this-script)
|
|
(set! install-mode? #t))
|
|
(setup-environment)
|
|
(process-command-line (cdr args))
|
|
(when (and install-mode? (equal? (path->string plthome) oldrun-plthome))
|
|
(parameterize ([current-output-port (current-error-port)])
|
|
(for-each display
|
|
`("This program should be used again only when the PLT tree "
|
|
"was moved.\nYou should use "
|
|
,(if (eq? 'unix (system-type)) "bin/setup-plt" "Setup PLT")
|
|
" instead.\n"))
|
|
(exit 1)))
|
|
(create-zos)
|
|
(display "PLT installation done.\n")
|
|
(cond [(not install-mode?)
|
|
(when (file-exists? "bin/drscheme")
|
|
(for-each display '("\nRun DrScheme as bin/drscheme.\nFor Help, "
|
|
"select `Help Desk' from DrScheme's `Help' "
|
|
"menu,\nor run bin/help-desk.\n")))
|
|
;; if we're using GUI, and not in install mode, don't close the window
|
|
(exit 0)]
|
|
[this-script
|
|
#| Instead of deleting this, detect when running from the same place.
|
|
;; Delete this script when finished running in install-mode, it
|
|
;; doesn't make sense to do this twice. Experienced users should just
|
|
;; use setup-plt from now on.
|
|
(when (file-exists? this-script) (delete-file this-script))
|
|
;; Also remove Win/OSX stuff that just use this script.
|
|
(when (file-exists? "install.bat") (delete-file "install.bat"))
|
|
(when (file-exists? "Finish Install.exe")
|
|
;; this will fail if called from `Finish Install.exe' itself
|
|
(with-handlers ([void void]) (delete-file "Finish Install.exe")))
|
|
(when (directory-exists? "Finish Install.app")
|
|
((dynamic-require '(lib "file.ss") 'delete-directory/files)
|
|
"Finish Install.app"))
|
|
(when (file-exists? "finish install.command")
|
|
(delete-file "finish install.command"))
|
|
|#
|
|
(when (file-exists? this-script) (remember-this-path!))]))
|