[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] Using new chicken-install -reinstall

From: Kon Lovett
Subject: [Chicken-hackers] Using new chicken-install -reinstall
Date: Wed, 11 May 2011 19:41:31 -0700


The new chicken-install -reinstall option in the experimental branch requires an addition to the extension infolist (.setup-info file contents), the "egg-name-and-version". Below is a program which will, given an existing Chicken install & a local copy of the SVN egg repo, add the missing datum. Any eggs installed with the new, experimental, chicken-install will have the new info.

(use extras files posix srfi-1 miscmacros)

;; Write the elements of the list `ls' to the output-port or output- file, using
;; the `writer' procedure. `writer' is a (procedure (* output-port)).
;; (add `newline?' param for write #\newline after every element?)
(define (write-file ls #!optional (file-or-port (current-output-port)) (writer write))
  (let ((port (if (port? file-or-port) file-or-port
                (open-output-file file-or-port) ) ) )
      (lambda () (for-each (cut writer <> port) ls))
(lambda () (unless (port? file-or-port) (close-output-port port)))) ) )

(define (write-file ls #!optional (file-or-port (current-output-port)) (writer write))
  (let* ((port (if (port? file-or-port) file-or-port
                 (open-output-file file-or-port) ) )
(closit (lambda () (unless (port? file-or-port) (close- output-port port)))) )
    (handle-exceptions exn
        (begin (closit) (abort exn))
      (for-each (cut writer <> port) ls))
    (closit) ) )

(define-constant +info-extn+ "setup-info")

(define (info-filenames #!optional (dir (repository-path)))
  (let ((cd (current-directory)))
    (current-directory dir)
      (map pathname-file (glob (make-pathname '() "*" +info-extn+)))
      (current-directory cd) ) ) )

(define (get-info eggnam #!optional (dir (repository-path)))
  (car (read-file (make-pathname dir eggnam +info-extn+))) )

(define (put-info info eggnam #!optional (dir (repository-path)))
  (let ((tmpfil (create-temporary-file)))
    (write-file (list info) tmpfil)
    (file-move tmpfil (make-pathname dir eggnam +info-extn+) #t) ) )

; no protection against existing "egg-name-and-version"
(define (update-info info eggnam)
  (and-let* ((ver (assq 'version info)))
      `(egg-name-and-version (,eggnam ,(->string (cadr ver))))
      info)) )

(define (update-info-file eggnam #!optional (dir (repository-path)))
  (and-let* ((info (update-info (get-info eggnam dir) eggnam)))
    (put-info info eggnam dir)
    #t ) )

(define (main #!optional (svnroot (cadr (argv))))
(let ((eggdir (make-pathname `(,svnroot "chicken-eggs" "release" "4") ""))
        (repdir (repository-path)) )
    (print "    Local SVN Repository: " eggdir)
    (print "Installed Egg Repository: " repdir)
    (let* ((egdrnms (directory eggdir))
           (siflnms (info-filenames repdir))
           (eggnams (lset-intersection string=? egdrnms siflnms)) )
      (lambda (eggnam)
        (print eggnam)
        (unless (update-info-file eggnam)
          (print "Warning: no version detected") ) )
      eggnams ) ) ) )

#; ;remove this line when compiling, otherwise just load into csi & invoke main w/ a dirname

reply via email to

[Prev in Thread] Current Thread [Next in Thread]