chicken-setup.scm

Scheme跨平台编译器

		     (make:line-error "second part of line is not a list" (cadr line) name)
		     (every (lambda (dep)
			       (or (string? dep)
				   (make:form-error "dependency item is not a string" dep)))
			     (cadr line)))
		 (or (null? (cddr line))
		     (procedure? (caddr line))
		     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
	spec)))

(define (make:check-argv argv)
  (or (string? argv)
      (every string? argv)
      (error "argument is not a string or string list" argv)))

(define (make:make/proc/helper spec argv)
  (when (vector? argv) (set! argv (vector->list argv)))
  (make:check-spec spec)
  (make:check-argv argv)
  (letrec ((made '())
	   (exn? (condition-predicate 'exn))
	   (exn-message (condition-property-accessor 'exn 'message))
	   (make-file
	    (lambda (s indent)
	      (let* ((line (make:find-matching-line s spec))
		     (s2 (fixmaketarget s)) 
		     (date (and (file-exists? s2)
				(file-modification-time s2))))
		(when (setup-verbose-flag)
		  (printf "make: ~achecking ~a~%" indent s2))
		(if line
		    (let ((deps (cadr line)))
		      (for-each (let ((new-indent (string-append " " indent)))
				  (lambda (d) (make-file d new-indent)))
				deps)
		      (let ((reason
			     (or (not date)
				 (any (lambda (dep)
					  (let ((dep2 (fixmaketarget dep)))
					    (unless (file-exists? dep2)
					      (error (sprintf "dependency ~a was not made~%" dep2)))
					    (and (> (file-modification-time dep2) date)
						 dep2)) )
					deps))))
			(when reason
			  (let ((l (cddr line)))
			    (unless (null? l)
			      (set! made (cons s made))
			      (when (setup-verbose-flag)
				(printf "make: ~amaking ~a~a~%"
					indent
					s2
					(cond
					 ((not date)
					  (string-append " because " s2 " does not exist"))
					 ((string? reason)
					  (string-append " because " reason " changed"))
					 (else
					  (string-append (sprintf " just because (reason: ~a date: ~a)" 
								  reason date)))) ) )
			      (handle-exceptions exn
				  (begin
				    (printf "make: Failed to make ~a: ~a~%"
					    (car line)
					    (if (exn? exn)
						(exn-message exn)
						exn))
				    (signal exn) )
				((car l))))))))
		    (unless date
		      (error (sprintf "don't know how to make ~a" s2))))))))
    (cond
     ((string? argv) (make-file argv ""))
     ((null? argv) (make-file (caar spec) ""))
     (else (for-each (lambda (f) (make-file f "")) argv)))
    (when (setup-verbose-flag)
      (for-each (lambda (item)
		  (printf "make: made ~a~%" item))
	(reverse made)))) )

(define make/proc
  (case-lambda
   ((spec) (make:make/proc/helper spec '()))
   ((spec argv)
    (make:make/proc/helper
     spec
     (if (vector? argv)
	 (vector->list argv)
	 argv) ) ) ) )

(define-macro (make spec #!optional (argv ''()))
  (let ((form-error (lambda (s . p) (apply error s spec p))))
    (and (or (list? spec) (form-error "illegal specification (not a sequence)"))
	 (or (pair? spec) (form-error "empty specification"))
	 (every
	  (lambda (line)
	    (and (or (and (list? line) (>= (length line) 2))
		     (form-error "clause does not have at least 2 parts" line))
		 (let ((name (car line)))
		   (or (list? (cadr line))
		       (make:line-error "second part of clause is not a sequence" (cadr line) name)))))
	  spec))
    `(make/proc (list ,@(map (lambda (line)
			       `(list ,(car line)
				      (list ,@(cadr line))
				      ,@(let ((l (cddr line)))
					  (if (null? l)
					      '()
					      `((lambda ()
						  ,@l))))))
			     spec))
		,argv)))


;;; Create new repository file

(define (create-repository-file eggdir)
  (let ((eggs 
	 (filter-map
	  (lambda (d)
	    (and-let* ((mf (or (file-exists? (make-pathname (list eggdir d) d "meta"))
			       (file-exists? (make-pathname (list eggdir d "trunk") d "meta")))))
	      (display mf (current-error-port))
	      (newline (current-error-port))
	      (cons d (with-input-from-file mf read)) ) )
	  (directory eggdir))) )
    (write-char #\()
    (for-each
     (lambda (e)
       (let ((needs (assq 'needs (cdr e))))
	 (pp `(,(string->symbol (car e))
	       ()
	       ,(conc e ".egg")
	       ,@(if needs (cdr needs) '())))))
     eggs) 
    (write-char #\))))


;;; Show usage information

(define (usage)
  (display #<<EOF
usage: chicken-setup [OPTION ...] FILENAME

  -h  -help                      shows this text and exits
  -V  -version                   shows version of this program and exits
      -release                   shows release number and exits
  -R  -repository [PATH]         if PATH is not given, prints the location of the extension repository
                                 if PATH is given, specifies the location for the extension repository 
  -u  -uninstall                 removes the following extension from repository
  -H  -host HOSTNAME[:PORT]      specifies alternative host for downloading
  -p  -proxy HOSTNAME[:PORT]     connects via proxy
  -l  -list [NAME ...]           lists installed extensions or shows extension information
  -r  -run FILENAME              loads and executes given file
  -P  -program-path [PATH]       if PATH is not given, prints the location where executables will be installed
                                 if PATH is given, specifies the location for installing executables
  -s  -script FILENAME           executes script with remaining arguments and exits
  -f  -fetch                     only download, don't extract, build or install
  -v  -verbose                   verbose mode
  -k  -keep                      keeps intermediate files after building and installing
  -c  -csc-option OPTION         passes extra option to csc (if run with `(run (csc ...))')
  -d  -dont-ask                  always download, if asked
  -n  -no-install                does not install generated binaries and support files
  -i  -docindex                  displays path for documentation index
  -e  -eval EXPRESSION           evaluates expression
  -t  -test                      runs test suite, if it exists
      -host-extension            compiles any extensions in "host" mode
      -ls EXTENSION              lists installed files for extension
      -fetch-tree                downloads and show repository catalog
      -create-tree DIRECTORY     creates repository catalog from SVN checkout
      -tree FILENAME             uses repository catalog from given file
      -svn URL                   fetches extension from subversion repository
      -svn-trunk URL             fetches extension from trunk in subversion repository
      -local PATH                fetches extension from local filesystem
      -revision REV              specifies SVN revision for checkout
      -build-prefix PATH         location where chicken-setup will create egg build directories
                                 (default: the value of environment variable CHICKEN_TMPDIR, TMPDIR or 
                                  /tmp/chicken-setup-{MAJOR-VERSION}-{USER} 
				  if none of these variables are found in the environment)
      -download-path PATH         location where chicken-setup will save downloaded files
                                 (default: {BUILD-PREFIX}/downloads)
      -install-prefix PATH       specifies alternative installation prefix
  --                             ignores all following arguments

  Builds and installs extension libraries.

EOF
  )
  (exit) )


;;; Processing setup scripts

(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
  (make-pathname rpath fn setup-file-extension) )

(define installation-prefix
  (make-parameter (or (getenv "CHICKEN_INSTALL_PREFIX") #f)))

(define (with-ext filename ext)
  (if (and (equal? (pathname-extension filename) ext)
	   (file-exists? filename) )
      filename
      (let ((f2 (pathname-replace-extension filename ext)))
	(and (file-exists? f2) f2) ) ) )

(define (run-setup-script filename)
  (when (setup-verbose-flag) (printf "executing ~A ...~%" filename))
  (load filename) 
  (when *run-tests* 
    (if (and (file-exists? "tests")
	     (directory? "tests") 
	     (file-exists? (make-pathname "tests" "run.scm")) )
	(let ((old (current-directory)))
	  (change-directory "tests")
	  (when (setup-verbose-flag)
	    (printf "running test cases ...~%") )
	  (run (csi -s run.scm ,(pathname-file filename))) 
	  (change-directory old))
	(print "egg has no test suite.") ) ) )

(define (write-info id files info)
  (let-values (((exports info) (fix-exports id info)))
    (let ((info `((files ,@files) 
		,@exports
		,@(or (and-let* (*repository-tree*
				 (a (assq id *repository-tree*))
				 (a2 (assq 'date (second a))) )
			`((release ,(second a2))) )
		      '() ) 
		,@info)) )
      (when (setup-verbose-flag) (printf "writing info ~A -> ~S ...~%" id info))
      (let* ((sid (->string id))
	    (setup-file (make-setup-info-pathname sid (repo-path #t)))
	    (write-setup-info (with-output-to-file setup-file
				(cut pp info))))
	(unless *windows-shell* (run (chmod a+r ,(quotewrap setup-file))))
	write-setup-info))))

(define (fix-exports id info)
  (let-values (((einfo oinfo) (partition (lambda (item) (eq? 'exports (car item))) info)))
    (let ((exports
	   (if (pair? einfo)
	       (append-map
		(lambda (eitem)
		  (let loop ((exports (cdr eitem)))
		    (if (null? exports)
			'()
			(let ((x (car exports))
			      (rest (cdr exports)) )
			  (cond ((string? x) (append (read-file x) (loop rest)))
				((symbol? x) (cons x (loop rest)))
				(else (error "invalid export item" x)) ) ) ) ) )
		einfo) 
	       (and-let* ((f (file-exists? (make-pathname #f (->string id) "exports"))))
		 (read-file f) ) ) ) )
      (if exports 
	  (values `((exports ,@exports)) oinfo)
	  (values '() oinfo) ) ) ) )

(define (compute-builddir fpath)
  (if (equal? "egg-dir" (pathname-extension fpath)) fpath
      (let ((fname (pathname-strip-directory fpath))) 
	(let loop ((num (random 10000)))
	  (let* ((buildname (string-append "build." (number->string num)))
		 (path  (make-pathname (setup-build-prefix) buildname (string-append fname "-dir") )))
	    (if (file-exists? path) (loop (random 10000))
		path))))))


(define (chdir dir)
  (when (setup-verbose-flag) (printf "changing working directory to `~A'~%" dir))
  (change-directory dir) )

(define (clear-builddir)
  (unless (string=? (current-directory) *base-directory*)
    (chdir *base-directory*) )
  (when *builddir-created*
    (set! *builddir-created* #f)
    (unless *keep-stuff*
      (when (setup-verbose-flag) (printf "removing egg build directory `~A'~%" (setup-build-directory)))
      (handle-exceptions ex
	  (warning "removal of egg build directory failed" (setup-build-directory))
	(run (,*remove-command* ,(quotewrap (setup-build-directory))) )) ) ))

(define (unpack/enter filename)
  (define (testgz fn)
    (with-input-from-file fn
      (lambda () (string=? "\x1f\x8b" (read-string 2))) ) )
  (let ((tmpdir (compute-builddir filename)))
    (cond ((file-exists? tmpdir) 
	   (chdir tmpdir)
	   (setup-build-directory (current-directory)) )
	  (else
	   (create-directory tmpdir)
	   (set! *builddir-created* #t)
	   (chdir tmpdir)
	   (setup-build-directory (current-directory))
	   (let ((fn2 (if (and (not (or *local-repository* (with-ext filename "egg") (with-ext filename "egg-dir")))
			       (not (string-prefix? (setup-download-directory) filename)))
			  (make-pathname (setup-download-directory) filename)
			  filename))
		 (v (setup-verbose-flag)) )
	     (if (testgz fn2)
		 (run (,*gzip-program* -d -c ,(quotewrap fn2) |\|| ,*tar-program* ,(if v 'xvf 'xf) -))
		 (run (,*tar-program* ,(if v 'xvf 'xf) ,(quotewrap fn2))) ) ) ) )
    ))

(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
  (let ((from (if (pair? from) (car from) from))
	(to ((lambda (pre) (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
			     (if (and pre (not (string-prefix? pre to-path)))
				 (make-pathname pre to-path) to-path)))
	     prefix)))
    (ensure-directory to)
    (cond ((or (glob? from) (file-exists? from))
	   (begin
	     (run (,*copy-command* ,(quotewrap from) ,(quotewrap to))) 
	     to))
	  (err (error "file does not exist" from))
	  (else (warning "file does not exist" from)))))

(define (move-file from to)
  (let ((from  (if (pair? from) (car from) from))
	(to    (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
		 (if (and pre (not (string-prefix? pre to-path)))
		     (make-pathname pre to-path) to-path))))
    (ensure-directory to)
    (run (,*move-command* ,(quotewrap from) ,(quotewrap to)) ) ) )

(define (remove-file* dir)
  (run (,*remove-command* ,(quotewrap dir)) ) )

(define (make-dest-pathname path file)
  (match file
    ((from to) (make-dest-pathname path to))
    (_ (if (absolute-pathname? file)
	   file
	   (make-pathname path file) ) ) ) )

(define (check-filelist flist)
  (map (lambda (f)
	 (match f
	   ((? string?) f)
	   (((? string?) (? string?)) f)
	   (((? string? h) . (? string? t)) (list h t))
	   (_ (error "invalid file-specification" f)) ) )
       flist) )

(define (translate-extension f #!optional default)
  (pathname-replace-extension f
   (match (pathname-extension f)
     (#f default)
     ("so" ##sys#load-dynamic-extension)
     ("a" (if *windows-shell* "lib" "a"))
     (x x) ) ) )


;;; Installation

(define (install-extension id files #!optional (info '()))
  (when (setup-install-flag)
    (let* ((files (check-filelist (if (list? files) files (list files))))
	   (rpath (repo-path))
	   (rpathd (repo-path #t))
	   (dests (map (lambda (f)
			 (let ((from (if (pair? f) (car f) f))
			       (to (make-dest-pathname rpathd f)) )
			   (when (and (not *windows*) 
				      (equal? "so" (pathname-extension to)))
			     (run (,*remove-command* ,(quotewrap to)) ))
			   (copy-file from to)
			   (unless *windows-shell*
			     (run (chmod a+r ,(quotewrap to))))
			   (and-let* ((static (assq 'static info)))
			     (when (and (eq? (software-version) 'macosx)
					(equal? (cadr static) from) 
					(equal? (pathname-extension to) "a"))
			       (run (ranlib ,(quotewrap to)) ) ))
			   (make-dest-pathname rpath f)))
		       files) ) )
      (and-let* ((docs (assq 'documentation info)))