chicken-setup.scm

Scheme跨平台编译器

	(let ((docpath (pathname-directory (doc-index #t))))
	  (print "\n* Installing documentation files in " docpath ":")
	  (for-each
	   (lambda (f)
	     (copy-file f (make-pathname docpath f) #f) )
	   (cdr docs))
	  (newline)
	  (set! *rebuild-doc-index* #t)) )
      (and-let* ((exs (assq 'examples info)))
	(let ((example-dest 
	       ((lambda (pre) (if pre (make-pathname pre (example-path)) (example-path)))
		(installation-prefix))))
	  (print "\n* Installing example files in " example-dest ":")
	  (for-each 
	   (lambda (f)
	     (let ((destf (make-pathname example-dest f)))
	       (copy-file f destf #f)
	       (unless *windows-shell*
	         (run (chmod a+rx ,(quotewrap destf))) ) ))
	   (cdr exs))
	  (newline) ))
      (write-info id dests info) ) ) )

(define (install-program id files #!optional (info '()))
  (define (exify f)
    (translate-extension
     f
     (if *windows-shell* "exe" #f) ) )
  (when (setup-install-flag)
    (let* ((files (check-filelist (if (list? files) files (list files))))
	   (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
		   (installation-prefix)))
	   (files (if *windows*
                      (map (lambda (f)
                             (if (list? f) 
                                 (list (exify (car f)) (exify (cadr f)))
                                 (exify f) ) )
                           files)
                      files) ) 
	   (dests (map (lambda (f)
			 (let ((from (if (pair? f) (car f) f))
			       (to (make-dest-pathname ppath f)) )
			   (copy-file from to) 
			   (unless *windows-shell*
				   (run (chmod a+r ,(quotewrap to))))
			   to) )
		       files) ) )
      (write-info id dests info) ) ) )

(define (install-script id files #!optional (info '()))
  (when (setup-install-flag)
    (let* ((files (check-filelist (if (list? files) files (list files))))
	   (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
		   (installation-prefix)))
	   (pfiles (map (lambda (f)
			  (let ((from (if (pair? f) (car f) f))
				(to (make-dest-pathname ppath f)) )
			    (copy-file from to) 
			    (unless *windows-shell*
				    (run (chmod a+r ,(quotewrap to))))
			    to) )
			files) ) )
      (unless *windows-shell*
	(run (chmod a+rx ,(string-intersperse pfiles " "))) )
      (write-info id pfiles info) ) ) )

(define (uninstall-extension ext)
  (let* ((info (extension-information ext))
	 (files (and info (assq 'files info))) )
    (if files
	(begin
	  (printf "deleting ~A ...~%" ext)
	  (for-each 
	   (lambda (f)
	     (let ((f (if (pair? f) (cadr f) f)))
	       (when (setup-verbose-flag) (printf "  deleting ~A~%" f))
	       (run (,*remove-command* ,(quotewrap f)) ) ) )
	   (cdr files) ) )
	(print "no files to uninstall") )
    (when (assq 'documentation info) (set! *rebuild-doc-index* #t))
    (delete-file* (make-setup-info-pathname (->string ext)))))


;;; More helper stuff

(define (repo-path #!optional ddir?)
  (let ((p (if (and ddir? (installation-prefix))
	       (make-pathname (installation-prefix) (repository-path))
	       (repository-path))) )
    (ensure-directory p)
    p) )

(define (ensure-directory path)
  (and-let* ((dir (pathname-directory path)))
    (if (file-exists? dir)
	(unless (directory? dir)
	  (error "can not create directory: a file with the same name already exists") )
	(begin
	  (create-directory dir)
	  (unless *windows-shell*
		  (run (chmod a+x ,(quotewrap dir))))))))

(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "") 
		     (verb (setup-verbose-flag)) (compile-only #f))
  (let* ((fname (create-temporary-file "c"))
	 (oname (pathname-replace-extension fname "o"))
	 (r (begin
	      (with-output-to-file fname (cut display code))
	      (system 
	       (let ((cmd (conc
			   cc " "
			   (if compile-only "-c" "") " "
			   cflags " " *target-cflags* " "
			   fname " "
			   (if compile-only
			       "" 
			       (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
			   " >/dev/null "
			   (if verb "" "2>&1") ) ) )
		 (when verb (print cmd " ..."))
		 cmd) ) ) ) )
    (when verb (print (if (zero? r) "succeeded." "failed.")))
    (system (sprintf "~A ~A" *remove-command* (quotewrap fname)))
    (zero? r) ) )

(define (required-chicken-version v)
  (when (string-ci<? (chicken-version) (->string v))
    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )

(define (upgrade-message ext msg)
  (error
   (sprintf
    "the required extension `~s' ~a - please run~%~%  chicken-setup ~a~%~%and repeat the current installation operation."
    ext msg ext) ) )

(define (required-extension-version . args)
  (let loop ((args args))
    (match args
      (() #f)
      ((ext version . more)
       (let ((info (extension-information ext))
	     (required-version (->string version)) )
	 (if info
	     (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
	       (cond ((not ver) (upgrade-message ext "has no associated version information"))
		     ((version-numbers>
		       (version-string->numbers required-version) 
		       (version-string->numbers (->string ver))) 
		      (upgrade-message 
		       ext
		       (sprintf "is older than ~a, which is what this extension requires"
				required-version) ) )
		     (else (loop more)) ) ) 
	     (upgrade-message ext "is not installed") ) ) )
      (_ (error 'required-extension-information "bad argument format" args)) ) ) )

(define test-compile try-compile)

(define (find-library name proc)
  (test-compile 
   (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
   ldflags: (conc "-l" name) ) )


;;; HTTP repository access

(define (find-header name)
  (test-compile
   (sprintf "#include <~a>\nint main() { return 0; }\n" name)
   compile-only: #t) )

(define (http-get-path-request path fname host)
  (sprintf "~A HTTP/1.0\r\nHost: ~A\r\nConnection: close\r\nContent-length: 0\r\n\r\n"
	   (let ((p (make-pathname path fname "" "/")))
	     (if (absolute-pathname? p)
		 p
		 (conc "/" p) ) )
	   host))

(define (http-get-request path fname host)
  (if *proxy-host*
      (sprintf "GET http://~A~A" host (http-get-path-request path fname host))
      (sprintf "GET ~A" (http-get-path-request path fname host))))

(define (setup-tcp-connect host port)
  (if *proxy-host*
      (tcp-connect *proxy-host* *proxy-port*)
      (tcp-connect host port)))

(define (download-repository-tree)
  (unless *repository-tree*
    (when (setup-verbose-flag) (print "downloading catalog ..."))
    (let loop ((hosts *repository-hosts*))
      (if (null? hosts)
	  (error "unable to connect")
	  (match hosts
	    (((host path port) . more)
	     (call/cc
	      (lambda (return)
		(or (handle-exceptions ex
		      (begin (printf "could not connect to ~A.~%" host) #f)
		      (when (setup-verbose-flag)
			(printf "downloading catalog from ~A ...~%" host) )
		      (let-values (((i o) (setup-tcp-connect host port)))
			(set! *last-decent-host* (car hosts))
			(let ((req (http-get-request path remote-repository-name host)))
			  (when (setup-verbose-flag) (display req))
			  (display req o) )
			(let ((ln (read-line i)))
			  (when (setup-verbose-flag) (print ln))
			  (when (string-match "HTTP.+ 404 .+" ln)
			    (print "no remote repository available") 
			    (return #f) ) )
			(let loop ()
			  (let ((ln (read-line i)))
			    (when (setup-verbose-flag) (print ln))
			    (if (string=? "" ln)
				(begin
				  (set! *repository-tree* (read i))
				  (when *debug*
				    (print "catalog:")
				    (pp *repository-tree*) )
				  (close-input-port i)
				  (close-output-port o)
				  #t)
				(loop) ) ) ) ) )
		    (loop more) ) ) ) )
	    ((x . _) (error "(internal) invalid host" x)) ) ) ) ) )

(define *progress-indicator*
  (thread-start!
   (rec (loop)
     (thread-sleep! 1)
     (print* ".")
     (loop) ) ) )

(thread-suspend! *progress-indicator*)

(define (with-progress-indicator thunk)
  (dynamic-wind
      (cut thread-resume! *progress-indicator*)
      thunk
      (lambda ()
	(newline)
	(thread-suspend! *progress-indicator*) ) ) )

(define (download-data hostdata item #!optional filename)
  (unless hostdata (set! hostdata (car *repository-hosts*)))
  (cond (*local-repository*
	 (when (setup-verbose-flag) (printf "fetching from local directory ~a ...~%" *local-repository*))
	 (let* ((p  (->string item))
	       (fpath  (make-pathname (setup-download-directory) p "egg-dir")))
	   (copy-file (make-pathname *local-repository* p) fpath #t #f)))

	((or *svn-trunk* *svn-repository* ) =>
	 (lambda (url)
	   (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" url))
	   (let* ((p (->string item))
		  (fpath (make-pathname (setup-download-directory) p "egg-dir")))
	     (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
		       ,(make-pathname url p) ,(quotewrap fpath)))
	     fpath)))

	(else
	 (match hostdata
	   ((host path port)
	    (let ((fname (or filename (third (assq item *repository-tree*)))))
	      (printf "downloading ~A from ~A ~!" fname hostdata)
	      (let-values (((i o) (setup-tcp-connect host port)))
		(let ((req (http-get-request 
			    (if filename (pathname-directory filename) path)
			    (if filename (pathname-strip-directory fname) fname)
			    host) ) )
		  (when *debug* (display req))
		  (display req o) )
		(let loop ()
		  (let ((ln (read-line i)))
		    ;; check for 404 here...
		    (if (string=? "" ln)
			(let ((data (with-progress-indicator (cut read-string #f i))))
			  (close-input-port i)
			  (close-output-port o)
			  (if (not (file-exists? (setup-download-directory)))
			      (create-directory (setup-download-directory)))
			  (let ((fpath (make-pathname (setup-download-directory) (pathname-strip-directory fname))))
			    (with-output-to-file fpath
			      (cut display data) 
			      binary:)
			    fpath))
			(loop) ) ) ) ) ) )
	   (x (error "(internal) invalid host" x)) ) ) ) )

(define (requirements reqs)
  (fold 
   (lambda (r reqs)
     (cond ((symbol? r)
	    (let ((node (assq r *repository-tree*)))
	      (cond (node (append (requirements (cdddr node)) (list (car node)) reqs))
		    ((memq r ##sys#core-library-modules) reqs)
		    (else (error "broken dependencies: extension does not exist" r) ) ) ) )
	   (else (error "invalid requirement spec" r))))
   '() 
   reqs) )

(define (fetch-file ext)
  (and (or *dont-ask*
	   (yes-or-no?
	    (sprintf "File ~A.egg or ~A.setup not found in the download directory. ~%Do you want to download .egg archive ?" ext ext)
	    "yes") )
       (cond ((pathname-directory ext)
	      (printf "Warning: no repository index available, trying direct download...~%" ext)
	      (set! *last-decent-host* (car *repository-hosts*))
	      (set! *dont-ask* #t)
	      (download-data
	       *last-decent-host*
	       (pathname-file ext)
	       (pathname-replace-extension ext "egg") ))

	     (else
	      (download-repository-tree)
	      (set! *dont-ask* #t)
	      (let ((a (and *repository-tree* (assq (string->symbol ext) *repository-tree*))))
		(when *debug* (printf "catalog entry: ~s~%" a))
		(cond (a (let ((reqs (remove extension-information (delete-duplicates (requirements (cdddr a)) eq?))))
			   (when (pair? reqs)
			     (print "downloading required extensions " reqs " ...")
			     (for-each (cut download-data *last-decent-host* <>) reqs)
			     (print "installing required extensions ...")
			     (for-each (cut install <>) (map ->string reqs)) )
			   (download-data *last-decent-host* (first a))) ) 
		      (else
		       (error "Extension does not exist in the repository" ext)) ) ) ) ) ) )


;;; Main entry point

(define (install filename)
  (let ((df (not *fetch-only*)))
    (let loop ((filename filename))
      (cond ((and df (with-ext filename "setup")) => run-setup-script)
	    ((or (with-ext filename "egg") (with-ext filename "egg-dir")) =>
	     (lambda (fpath)
	       (let ((f (pathname-strip-directory fpath)))
		 (when df
		   (unpack/enter fpath)
		   (let ((sfile (pathname-replace-extension f "setup")))
		     (when (not (file-exists? sfile))
		       (cond
			(*svn-trunk* 
			 (when (file-exists? "trunk") (chdir "trunk")))

			((and (not *svn-trunk*) (file-exists? "tags") )
			 (let ((ds (sort (map version-string->numbers (directory "tags")) version-numbers>)))
			   (when (pair? ds) 
			     (let ((d (make-pathname "tags" (car ds))))
			       (chdir d)))) )
			))
		     (loop sfile)
		     (clear-builddir) ) ) ) ))
	    ((fetch-file filename) =>
	     (lambda (fpath)
	       (set! *fetched-eggs* 
		     (append 
		      *fetched-eggs* 
		      (if fpath (list fpath) (list (make-pathname (current-directory) filename "egg")))))
	       (when df
		 (loop fpath))))))))


;;; Documentation index generation

(define (doc-index #!optional ddir?)
  (make-pathname (repo-path ddir?) "index.html"))

(define (doc-stylesheet #!optional ddir?)
  (make-pathname (repo-path ddir?) "style.css"))

(define (extension-documented? rpath fn)
  (let ([pn (make-setup-info-pathname fn rpath)])
    (and (file-exists? pn)
	 (with-input-from-file pn
	   (lambda ()