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

[Kon Lovett]

Hi,

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) ) ) )
    (dynamic-wind
      void
      (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)
    (begin0
      (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)))
    (cons
      `(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)) )
    (newline)
    (print "    Local SVN Repository: " eggdir)
    (print "Installed Egg Repository: " repdir)
    (newline)
    (let* ((egdrnms (directory eggdir))
           (siflnms (info-filenames repdir))
           (eggnams (lset-intersection string=? egdrnms siflnms)) )
    (for-each
      (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
(main)