;;; jem-pkg.el --- Some kind of elisp packaging for and by jemarch

;; Copyright (C) 2005  Jose E. Marchesi

;; Author: Jose E. Marchesi <jemarch@gnu.org>
;; Maintainer: Jose E. Marchesi <jemarch@gnu.org>
;; Keywords: extensions

;; This file 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, or (at your option)
;; any later version.

;; This file 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; A kind of elisp packaging for and by jemarch

;;; Code:

;; Constants

(defconst jem-pkg-version (list 0 0 2)
  "jem-pkg version")

(defconst jem-pkg-version-string
  (concat (number-to-string (nth 0 jem-pkg-version)) 
	  "."
	  (number-to-string (nth 0 jem-pkg-version))
	  "."
	  (number-to-string (nth 2 jem-pkg-version)))
  "Printable jem-pkg version")

(defconst jem-pkg-system-name
  system-name
  "Name of the system where JemPkg is running")

(defconst jem-pkg-system-configuration
  system-configuration
  "System configuration of the system where JemPkg is running")

(defconst jem-pkg-system-type
  system-type
  "System configuration of the system where JemPkg is running")


;; Variables

(defvar jem-pkg-package-db nil
  "JemPkg package database

This association list contains the existing packages on the
current local site.

The entry for each package is as:

  (package-name package-version)

")

(defvar jem-pkg-sites nil
  "List with the names of local sites configurations")

(defvar jem-pkg-listing-mode-map nil
  "Keymap for JemPkg packages list")


;; Customization

(defgroup jem-pkg nil
  "Elisp packaging for and by jemarch"
  :link '(url-link "http://es.gnu.org/~jemarch/jem-pkg/index.html")
  :prefix "jem-pkg-"
  :group 'local)

(defcustom jem-pkg-site-base "~/emacs"
  "Path to the jem-pkg site on the local machine"
  :group 'jem-pkg
  :type '(file :must-match t))


;; Functions

(defun jem-pkg-site-init ()
  "Initialization of the site"

  (let* ((site-name jem-pkg-system-name))

    ;; Build the package database
    (setq jem-pkg-package-db (jem-pkg-build-package-db))

    ;; Set up the load path to the package database
    (jem-pkg-set-load-path)

    ;; Load the common configuration
    (jem-pkg-load-common-configuration)

    ;; Load the site configuration
    (jem-pkg-load-site-configuration)))

(defun jem-pkg-set-load-path ()
  "Set the load path according to common and the current site"

  (jem-pkg-set-site-load-path "common")
  (jem-pkg-set-site-load-path jem-pkg-system-name))

(defun jem-pkg-set-site-load-path (site-name)
  ""
  (mapcar (lambda (pkg)
	    (let ((pkg-name (if (listp pkg)
				(car pkg)
			      pkg))
		  (pkg-version (if (listp pkg)
				   (cadr pkg)
				 nil)))
	      ;; Only add the directory to the load-path if
	      ;; the package is not virtual
	      (if (and (assoc pkg-name jem-pkg-package-db)
		       (or (not pkg-version)
			   (equal (cadr (assoc pkg-name jem-pkg-package-db))
				  pkg-version)))
		  (add-to-list 'load-path
			       (concat jem-pkg-site-base
				       "/elisp/"
				       pkg-name
				       (let ((pkg-dir-version (cadr (assoc pkg-name jem-pkg-package-db))))
					 (if pkg-dir-version
					   (concat "%" pkg-dir-version))))))))
	  
	  (cadr (assoc site-name jem-pkg-sites))))

(defun jem-pkg-build-package-db-parse-dir (dirname)
  "packagename(%packageversion)?"

  ;; Match the two parts
  (string-match "^\\([^%]+\\)\\(%\\(.*\\)\\)?$" dirname)
  ;; Get the list
  (list (match-string 1 dirname)
	(match-string 3 dirname)))

(defun jem-pkg-build-package-db ()
  "Traverses elisp/ and build jem-pkg-package-db"

  (let* ((elisp-dir (concat jem-pkg-site-base "/elisp" ))
	 (pkg-dir-list (cddr (directory-files elisp-dir nil))))

    (mapcar 'jem-pkg-build-package-db-parse-dir pkg-dir-list)))

(defun jem-pkg-load-common-configuration ()
  "Load the common Emacs environment"
  
  (let ((conf-filename (concat jem-pkg-site-base "/etc/common/common.el")))
    (if (file-readable-p conf-filename)
	(load-file conf-filename)))
  (mapcar 'jem-pkg-load-common-package (jem-pkg-get-site-configuration "common")))

(defun jem-pkg-get-site-configuration (site-name)
  "Get a configuration from jem-pkg-sites"
  (cadr (assoc site-name jem-pkg-sites)))

(defun jem-pkg-load-site-configuration ()
  "Load the Emacs environment for SITENAME"

  (let* ((site-name jem-pkg-system-name)
	 (site-configuration (jem-pkg-get-site-configuration site-name)))

    (load-file (concat jem-pkg-site-base "/etc/" 
		       site-name  "/" site-name ".el"))

    (mapcar 'jem-pkg-load-site-package site-configuration)))

(defun jem-pkg-load-common-package (package-name)
  ""
  (jem-pkg-load-package "common" package-name))

(defun jem-pkg-load-site-package (package-name)
  ""
  (jem-pkg-load-package jem-pkg-system-name package-name))

(defun jem-pkg-load-package (site-name package-name)
  ""
  (let ((package-version (cadr (assoc package-name jem-pkg-package-db)))
	(filename (concat jem-pkg-site-base
			  "/etc/"
			  site-name
			  "/"
			  package-name)))

    ;; Get the appropiate load file
    (if package-version
	(if (file-readable-p (concat filename "%" package-version ".el"))
	    (setq filename (concat filename "%" package-version))))

    ;; Load the file if it exist
    (if (file-readable-p (concat filename ".el"))
	(load-file (concat filename ".el")))))

(defun jem-pkg-get-site-pkg-db (sitename)
  "Return the subset of the packages database that were
loaded using the SITENAME configuration"
  (let ((pkg-db nil))
    (mapcar 
     (lambda (pname)
       (let ((pkg-entry (assoc pname jem-pkg-package-db)))
	 (if pkg-entry
	     (setq pkg-db (cons 
			   (list (car pkg-entry) (cadr pkg-entry))
			   pkg-db))
	   ;; This is a phantom package, so insert a dummy
	   ;; entry
	   (setq pkg-db (cons
			 (list pname nil)
			 pkg-db)))))
     (jem-pkg-get-site-configuration sitename))

    pkg-db))

(defun jem-pkg-print-site-packages (site-name)
  "Print a section with the packages of SITE-NAME into
the current buffer"
  (let ((pkg-db (jem-pkg-get-site-pkg-db site-name))
	(max-pname-length 0))
    
    ;; Insert a header
    (insert (propertize (concat site-name
				":")
			'face 'bold))
    (insert "\n\n")

    ;; Calculate the maximum package name length
    (let ((aux-pkg-db pkg-db))
      (while aux-pkg-db
	(progn
	  (if (> (length (caar aux-pkg-db)) max-pname-length)
	      (setq max-pname-length (length (caar aux-pkg-db))))
	  (setq aux-pkg-db (cdr aux-pkg-db)))))

    ;; Print package information
    (mapcar
     (lambda (package-entry)
       (insert " ")
       (let ((package-name (propertize 
			    (car package-entry) 
			    'jempkgpkgname (car package-entry))))
	 (insert package-name)
	 (if (equal site-name "common")
	     (add-text-properties (- (point) (length (car package-entry)))
				  (point)
				  '(jempkgcommon t))))
       (let ((i (- (+ max-pname-length 2) (length (car package-entry)))))
	 (while (not (= i 0))
	   (progn
	     (insert " ")
	     (setq i (- i 1)))))
       (if (cadr package-entry)
	   (let ((package-version (propertize
				   (cadr package-entry)
				   'bold t
				   'jempkgpkgversion (cadr package-entry))))
	     (insert package-version)
	     (if (equal site-name "common")
			(add-text-properties (- (point) (length (cadr package-entry)))
					     (point)
					     '(jempkgcommon t))))
	 (insert (propertize "(unknown)"
			     'jempkgpkgversion "(unknown)")))
       (insert "\n"))
     pkg-db)))

(defun jem-pkg-list-packages ()
  "List all loaded packages on the running emacs"
  (interactive)

  (save-excursion
    
    (if (get-buffer "*Packages*")
	(kill-buffer (get-buffer "*Packages*")))

    (let ((pkg-buffer (get-buffer-create "*Packages*")))

      ;; Change the current buffer
      (set-buffer pkg-buffer)

      ;; Print some instructions
      (insert "This buffer list all the packages currently loaded into your emacs by
JemPkg.\n\n")

      ;; Print package listings
      (jem-pkg-print-site-packages "common")
      (insert "\n")
      (jem-pkg-print-site-packages jem-pkg-system-name)

      ;; Make the entire buffer read-only
      (add-text-properties (point-min) (point-max)
			   '(read-only true))

      ;; Set the major mode
      (jem-pkg-listing-mode)

      ;; Goto the first package and show it
      ;; into some other window
      (goto-char (next-single-property-change 1 'jempkgpkgname))
      (switch-to-buffer-other-window pkg-buffer))))

(defun jem-pkg-listing-configure-site ()
  "Open a buffer with the configuration of the site that contain
the package at point"
  (interactive)

  (if (get-text-property (point) 'jempkgpkgname)
      (find-file-other-window
       (concat jem-pkg-site-base
	       "/etc/"
	       (if (get-text-property (point) 'jempkgcommon)
		   "common"
		 jem-pkg-system-name)
	       "/"
	       (if (get-text-property (point) 'jempkgcommon)
		   "common"
		 jem-pkg-system-name)
	       ".el"))
    (error "No package at point")))

(defun jem-pkg-listing-configure-generic-package ()
  "Open a buffer with the configuration of the package at point"
  (interactive)

  (if (get-text-property (point) 'jempkgpkgname)
      (find-file-other-window 
       (concat jem-pkg-site-base
	       "/etc/"
	       (if (get-text-property (point) 'jempkgcommon)
		   "common"
		 jem-pkg-system-name)
	       "/"
	       (get-text-property (point) 'jempkgpkgname)
	       ".el"))
    (error "No package at point")))

(defun jem-pkg-listing-configure-package ()
  "Open a buffer with the configuration of the package (taking care about the
version) at point"
  (interactive)

  (save-excursion
    (if (get-text-property (point) 'jempkgpkgname)
	(let ((package-name (get-text-property (point) 'jempkgpkgname))
	      (commonp (get-text-property (point) 'jempkgcommon)))
	  (goto-char (next-single-property-change (point) 'jempkgpkgversion))
	  
	  (if (equal (get-text-property (point) 'jempkgpkgversion)
		     "(unknown)")
	      (error "This package is not versioned"))
	  (find-file-other-window
	   (concat jem-pkg-site-base
		   "/etc/"
		   (if commonp
		       "common"
		     jem-pkg-system-name)
		   "/"
		   package-name
		   "%"
		   (get-text-property (point) 'jempkgpkgversion)
		   ".el")))

      (error "No package at point"))))

(defun jem-pkg-listing-next-package ()
  "Goto the next package (if any)"
  (interactive)

  (save-excursion
    (goto-char (next-single-property-change (point) 'jempkgpkgname))
    (if (not (get-text-property (point) 'jempkgpkgname))
	(if (not (next-single-property-change (point) 'jempkgpkgname))
	    (error "No more packages"))))
  (goto-char (next-single-property-change (point) 'jempkgpkgname))
  (if (not (get-text-property (point) 'jempkgpkgname))
      (goto-char (next-single-property-change (point) 'jempkgpkgname))))

(defun jem-pkg-listing-previous-package ()
  "Goto the next package (if any)"
  (interactive)

  (if (not (previous-single-property-change (point) 'jempkgpkgname))
      (error "No previous package"))

  (goto-char (previous-single-property-change (point) 'jempkgpkgname))
  (if (not (get-text-property (point) 'jempkgpkgname))
      (goto-char (previous-single-property-change (point) 'jempkgpkgname))))

(defun jem-pkg-listing-load-site-configurationl ()
  "Load the configuration file of the site of the package at point,
if it exist"
  (interactive)

  (let ((package-name (get-text-property (point) 'jempkgpkgname))
	(commonp (get-text-property (point) 'jempkgcommon)))
    (if (not package-name)
	(error "No package at point"))
    (let ((filename (concat jem-pkg-site-base
			    "/etc/"
			    (if commonp
				"common"
			      jem-pkg-system-name)
			    "/"
			    (if commonp
				"common"
			      jem-pkg-system-name)
			    ".el")))
      (if (file-readable-p filename)
	  (load-file filename)
	(error "This site do not have a configuration file")))))
    

(defun jem-pkg-listing-load-configuration ()
  "Load the configuration files of the package at point.
Note that the common configuration (if any) is load before the specific one (if any)."
  (interactive)
  
  (let* ((package-name (get-text-property (point) 'jempkgpkgname))
	 (commonp (get-text-property (point) 'jempkgcommon))
	 (generic-filename (concat jem-pkg-site-base
				   "/etc/"
				   (if commonp
				       "common"
				     jem-pkg-system-name)
				   "/"
				   package-name
				   ".el")))

    ;; Load generic configuration, if it exist
    (if (file-readable-p generic-filename)
	(load-file generic-filename))

    ;; Load the versioned configuration, if it exist
    (save-excursion
      (goto-char (next-single-property-change (point) 'jempkgpkgversion))
      (let ((versioned-filename (concat
				 jem-pkg-site-base
				 "/etc/"
				 (if commonp
				     "common"
				   jem-pkg-system-name)
				 "/"
				 package-name
				 "%"
				 (get-text-property (point) 'jempkgpkgversion)
				 ".el")))
	(if (file-readable-p versioned-filename)
	    (load-file versioned-filename))))))

(defun jem-pkg-listing-quit ()
  "Delete the listing window and the *Packages* buffer"
  (interactive)

  (delete-windows-on "*Packages*")
  (kill-buffer "*Packages*"))

(defun jem-pkg-listing-mode ()
  "Major mode for editing JemPkg listings.

Commands:
\\{jem-pkg-listing-mode-map}"
  (interactive)

  (kill-all-local-variables)
  (setq jem-pkg-listing-mode-map (make-keymap))
  (define-key jem-pkg-listing-mode-map "n" 'jem-pkg-listing-next-package)
  (define-key jem-pkg-listing-mode-map "p" 'jem-pkg-listing-previous-package)
  (define-key jem-pkg-listing-mode-map "c" 'jem-pkg-listing-configure-package)
  (define-key jem-pkg-listing-mode-map "C" 'jem-pkg-listing-configure-generic-package)
  (define-key jem-pkg-listing-mode-map "s" 'jem-pkg-listing-configure-site)
  (define-key jem-pkg-listing-mode-map "l" 'jem-pkg-listing-load-configuration)
  (define-key jem-pkg-listing-mode-map "L" 'jem-pkg-listing-load-site-configuration)
  (define-key jem-pkg-listing-mode-map "q" 'jem-pkg-listing-quit)
  (use-local-map jem-pkg-listing-mode-map)

  (setq mode-name "JemPkg-Listing")
  (setq major-mode 'jem-pkg-listing-mode))

(provide 'jem-pkg)
;;; jem-pkg.el ends here