;;;;
;;;; misc.stk	-- Misc functions for stklos-pkg
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 14-Jan-2007 13:37 (eg)
;;;; Last file update: 29-Jun-2007 18:06 (eg)
;;;;

;; ----------------------------------------------------------------------
;;	get-package-interface ...
;; ----------------------------------------------------------------------
(define (get-package-interface file)
  (let ((in    (open-file file "r"))
	(parse (lambda (in)
		 (let loop ((e (read in)))
		   (if (eof-object? e)
		     '()
		     (match-case e
		       ((interface ?- . ?rest) rest)
		       (else (loop (read e)))))))))
    (unless in
      (error-pkg "Cannot open source file ~S" file))
    (let ((res (parse in)))
      (close-port in)
      res)))

;; ----------------------------------------------------------------------
;;	get-package-info ...
;; ----------------------------------------------------------------------
(define (get-package-info file)
  (let ((in (open-file file "r")))
    (if in
      (let ((res (read in)))
	(close-port in)
	res)
      '())))

;; ----------------------------------------------------------------------
;;	version-number->integer ...
;; ----------------------------------------------------------------------
(define (version-number->integer str release)
  ;; Files without release (i.e. the one in the local repository)
  ;; are given the 9999 pseudo release number. This insure that
  ;; they are greater than the ones on a distant directory
  (define (fmt n)
    (cond
      ((< n 10) (format "000~a" n))
      ((< n 100) (format "00~a" n))
      ((< n 1000) (format "0~a" n))
      (else  (number->string n))))

  (let ((r (or release 9999))
	(v (map string->number (string-split str "."))))
    (if (and (= (length v) 3)
	     (every integer? v))
	(string->number (format "~A~A~A~A" (car v) (fmt (cadr v)) (fmt (caddr v))
				(fmt r)))
	-1)))

;; ----------------------------------------------------------------------
;;	package<? ...
;; ----------------------------------------------------------------------
(define (package<? p1 p2)
  (let ((n1 (package-name p1))
	(n2 (package-name p2))
	(v1 (package-version p1))
	(v2 (package-version p2))
	(r1 (package-release p1))
	(r2 (package-release p2)))
    (if (string=? n1 n2)
	(< (version-number->integer v1 r1) (version-number->integer v2 r2))
	(string<? n1 n2))))

;; ----------------------------------------------------------------------
;;	server-names ...
;; ----------------------------------------------------------------------
(define (server-names)
  (cons "local" (map car (stklos-pkg-sync-urls))))

;; ----------------------------------------------------------------------
;;	package-deps* ...
;; ----------------------------------------------------------------------
(define (package-deps* package)

  (define (list->set lst res)
    (cond
      ((null? lst) 	      (reverse! res))
      ((member (car lst) res) (list->set (cdr lst) res))
      (else                   (list->set (cdr lst) (cons (car lst) res)))))

  (define (build-lang-deps lang)
    ;; convert (foo level2) in (_foo _foo-level2)
    (let ((main (car lang)))
      (cons (format "_~a" main)
	    (map (lambda (x) (format "_~a-~a" main x)) (cdr lang)))))

  (define (deps* package)
    (let ((pkg  (find-package package)))
      (unless pkg
	(error-pkg 'package-deps* "cannot find package ~S" package))
      (let* ((lang (package-language pkg))
	     (deps (map (lambda (x)
			  (let ((name (car x))
				(vers (cadr x)))
			    (if (equal? vers "*")
				name
				(format "~a-~a" name vers))))
			(package-dependencies pkg)))
	     (all  (if (member (car lang) '(stklos r5rs))
		       deps
		       (append (build-lang-deps lang) deps))))
	(if (null? all)
	    all
	    (append (apply append (map deps* all))
		    all)))))

  ;;
  ;; package-deps* starts here
  ;;
  (list->set (deps* package) '()))

;; ----------------------------------------------------------------------
;;	package-sans-version ...
;; ----------------------------------------------------------------------
(define (package-sans-version str)
  (let ((x (regexp-match "(.*)-[0-9]+.[0-9]+.[0-9]+" str)))
    (if x
      (cadr x)
      str)))

;; ----------------------------------------------------------------------
;;	rm-rf ...
;; ----------------------------------------------------------------------
(define (rm-rf path)
  (when (file-exists? path)
    ;(eprintf "rm -rf ~S\n" path)
    (if (file-is-directory? path)
	(let ((files (directory-files path)))
	  (for-each (lambda (f) (rm-rf (make-path path f)))
		    files)
	  (delete-directory path))
	(remove-file path))))

;; ----------------------------------------------------------------------
;;	untar ...
;; ----------------------------------------------------------------------
(define (untar file directory)
  (when (> (stklos-pkg-verbosity) 0)
    (eprintf "Uncompressing pkgball ~s\n" (basename file)))
  (system (format "tar xfz ~a -C ~a" file directory)))


;; ----------------------------------------------------------------------
;; 	sed ...
;; ----------------------------------------------------------------------
(define (sed str substs)
  (if (null? substs)
      str
      (sed  (regexp-replace-all (caar substs) str (cadar substs))
	    (cdr substs))))

;; ----------------------------------------------------------------------
;; 	test-package ...
;; ----------------------------------------------------------------------
(define (test-package name dir)
  (let ((cmd (format "cd ~a; echo 'Testing ~a'; ~a test" dir name (make-command))))
    ;; (eprintf "test command ~S\n" cmd)
    (system cmd)))