#!/bin/sh
#|
# PLT software installer
# Configures PLTHOME path within scripts
# For certain platforms and installations, adds extra
#  directory links (to reach non-standard binaries
#  through the platform's standard path)
# Creates .zo files if the user assents

if [ ! \( \( -x install \) -a \( -d collects \) \) ] ; then
  echo "install: must be run from its own directory"
  exit 1
fi

if [ ! \( -x bin/mzscheme \) ] ; then
  echo "install: cannot execute bin/mzscheme"
  echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
  echo "!!               Install incomplete!               !!"
  echo "!!                                                 !!"
  echo "!! If you downloaded the source distribution, see  !!"
  echo "!!        src/README for build instructions.       !!"
  echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
  exit 1
fi

exec ./bin/mzscheme -qr "$0" ${1+"$@"}
exit 1

|#

(use-compiled-file-kinds 'none)

(unless (equal? #() argv)
  (error './install "no arguments allowed on the command line")
  (exit 1))

(define release-date "May 2003")

(define didnothing " (nothing to do)")

(define plthome (current-directory))
(putenv "PLTHOME" plthome)
(putenv "PLTCOLLECTS" "")
(current-library-collection-paths (list (build-path plthome "collects")))

(define plthome (regexp-replace* "\"" plthome "\\\\\""))

(define in-osx-install? (getenv "OSX_PLT_INSTALL"))

(when in-osx-install?
  (namespace-require '(lib "mred.ss" "mred"))
  (namespace-require '(lib "class.ss")))

;; Set up GUI
(when in-osx-install?
  (let ([evt (make-eventspace)]
	[there-was-an-error? #f])
    (parameterize ([current-eventspace evt])
      (define f (make-object frame% "PLT Installer" #f 600 480))
      (define e (make-object text%))
      (define c (make-object editor-canvas% f e))
      (define b (make-object button% "Stop Installation" f
			     (lambda (b e)
			       (when (or there-was-an-error?
					 (eq? 'ok (message-box
						   "Stop Installation"
						   "Ok to stop the installation?"
						   f
						   '(ok-cancel))))
				 (exit 1)))))
      (send e lock #t)
      (send e auto-wrap #t)
      (let ([out (make-custom-output-port
		  #f
		  (lambda (string start end flush?)
		    (parameterize ([current-eventspace evt])
		      (queue-callback
		       (lambda ()
			 (send e lock #f)
			 (send e insert (substring string start end)
			       (send e last-position))
			 (send e lock #t))
		       #f))
		    (- end start))
		  void
		  void)])
	(current-output-port out)
	(current-error-port out))
      (send f show #t)
      (let ([old-exit (exit-handler)])
	(exit-handler (lambda (v)
			(unless (zero? v)
			  (parameterize ([current-eventspace evt])
			    (queue-callback
			     (lambda ()
			       (send e lock #f)
			       (let ([s (send e last-position)])
				 (send e insert "INSTALLATION FAILED" s)
				 (let ([ss (send e last-position)])
				   (send e insert "\n(click button below to continue)" ss)
				   (send e change-style 
					 (let ([d (make-object style-delta% 'change-bold)])
					   (send d set-delta-foreground "red")
					   d)
					 s ss))
				 (send e lock #t))
			       (send b set-label "Quit Installation")
			       (set! there-was-an-error? #t))
			     #f))
			  (semaphore-wait (make-semaphore)))
			(old-exit v)))))))

(printf "setting PLTHOME to \"~a\" in scripts:~n" plthome)

(require (lib "check-text.ss" "version"))

(define re:plthome #rx"^(.*)PLTHOME=(.*)$")

(for-each
 (lambda (f)
    (let ([p (build-path "bin" f)])
      (cond
       [(and (file-exists? p)
	     (> (file-size p) 4096))
	(printf " skipping ~a~n" p)]
       [else
	(when (file-exists? p)
	  (set! didnothing "")
	  (printf " checking ~a~n" p)
	  (let ([lines (with-input-from-file p
			 (lambda ()
			   (let loop ()
			     (let ([l (read-line)])
			       (if (eof-object? l)
				   null
				   (cons l (loop)))))))])
	    (when (ormap (lambda (i) (regexp-match re:plthome i)) lines)
	      (printf " updating ~a~n" p)
	      (with-output-to-file p
		(lambda ()
		  (for-each
		   (lambda (l)
		     (let ([m (regexp-match re:plthome l)])
		       (if m
			   (printf "~aPLTHOME=\"~a\"~n"
				   (cadr m) plthome)
			   (printf "~a~n" l))))
		   lines))
		'truncate))))])))
 (directory-list "bin"))

(define (get-y-n)
  (flush-output)
  (let ([r (read-line)])
    (not (regexp-match "^[nN]" r))))

(define in-rpm-install? (getenv "RPM_INSTALL_PREFIX"))
(define in-rpm-build? (and (getenv "RPM_OPT_FLAGS") (not in-rpm-install?)))
(define in-freebsd-port-build? #t)

(define check-version?
  (if in-osx-install?
      #f ;; until the version checker can work better with the GUI...
      (if (or in-freebsd-port-build? in-rpm-install? in-rpm-build?)
	  #f
	  (begin
	    (printf "This distribution was created in ~a.~n" release-date)
	    (printf "  Check for updates of PLT software over the Internet (y/n)? [y] ")
	    (get-y-n)))))

(when check-version?
  (check-version))

(define zo?
  (or in-freebsd-port-build? 
      in-rpm-install?
      in-osx-install?
      (and (not in-rpm-build?)
	   (begin
	    (printf "PLT software starts up much faster with .zo files, but creating .zo~n")
	    (printf "files now takes a few minutes and requires several MB of additional~n")
	    (printf "disk space.~n")
	    (printf "  Create .zo files now (y/n)? [y] ")
	    (get-y-n)))))

(unless zo?
  (printf "Skipping .zo-file creation; create .zo files later by running~n")
  (printf "  ~a/bin/setup-plt~n" plthome))

(when zo?
  ;; 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.
  (parameterize ([current-namespace (make-namespace)]
		 [use-compiled-file-kinds 'all])
    (dynamic-require '(lib "setup.ss" "setup") #f)))

(printf "PLT installation done~a.~n" didnothing)
(when (file-exists? "bin/drscheme")
  (printf "Run DrScheme as bin/drscheme.~n")
  (printf "For Help, select `Help Desk' from DrScheme's `Help' menu, or run bin/help-desk.~n"))

