melpa/package-build.el

;;; package-build.el --- Tools for curating the package archive

;; Copyright (C) 2011 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com>

;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Created: 2011-09-30
;; Version: 0.1
;; Keywords: tools

;;
;; Credits:
;;   Steve Purcell
;;

;; This file is not (yet) part of GNU Emacs.
;; However, it is distributed under the same license.

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

;; GNU Emacs 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This file allows a curator to publish an archive of Emacs packages.

;; The archive is generated from an index, which contains a list of
;; projects and repositories from which to get them. The term
;; "package" here is used to mean a specific version of a project that
;; is prepared for download and installation.

;;; Code:

;; Since this library is not meant to be loaded by users
;; at runtime, use of cl functions should not be a problem.
(require 'cl)

(require 'package)

(defcustom package-build-working-dir (expand-file-name "working/")
  "Directory in which to keep checkouts."
  :group 'package-build
  :type 'string)

(defcustom package-build-archive-dir (expand-file-name "packages/")
  "Directory in which to keep compiled archives."
  :group 'package-build
  :type 'string)

(defcustom package-build-alist-file (expand-file-name "pkglist")
  "File containing pkg alist."
  :group 'package-build
  :type 'string)

(defun package-build-find-parse-time (regex)
  "Find REGEX in current buffer and format as a proper time version."
  (format-time-string
   "%Y%m%d"
   (date-to-time
    (print (progn (re-search-backward regex)
                  (match-string-no-properties 1))))))

(defun package-run-process (dir prog &rest args)
  "In DIR (or `default-directory' if unset) run command PROG with ARGS.
Output is written to the current buffer."
  (let ((default-directory (or dir default-directory)))
    (apply 'process-file prog nil (current-buffer) t args)))


(defun package-build-checkout (name config cwd)
  "Check out source for package NAME with CONFIG under working dir CWD.
In turn, this function uses the :fetcher option in the config to
choose a source-specific fetcher function, which it calls with
the same arguments."
  (let ((repo-type (plist-get config :fetcher)))
    (print repo-type)
    (funcall (intern (format "package-build-checkout-%s" repo-type))
             name config cwd)))

(defun package-build-checkout-wiki (name config dir)
  "Checkout package NAME with config CONFIG from the EmacsWiki into DIR."
  (with-current-buffer (get-buffer-create "*package-build-checkout*")
    (message dir)
    (unless (file-exists-p dir)
      (make-directory dir))
    (let* ((filename (or (car (plist-get config :files))
                         (format "%s.el" name)))
           (default-directory dir)
           (download-url (format "http://www.emacswiki.org/emacs/download/%s" filename))
           (wiki-url (format "http://www.emacswiki.org/emacs/%s" filename)))
      (url-copy-file download-url filename t)
      (with-current-buffer (url-retrieve-synchronously wiki-url)
        (package-build-find-parse-time
         "Last edited \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\} [A-Z]\\{3\\}\\)")))))

(defun package-build-checkout-darcs (name config dir)
  "Check package NAME with config CONFIG out of darcs into DIR."
  (let ((repo (plist-get config :url)))
    (with-current-buffer (get-buffer-create "*package-build-checkout*")
      (cond
       ((file-exists-p dir)
        (print "checkout directory exists, updating...")
        (package-run-process dir "darcs" "pull"))
       (t
        (print "cloning repository")
        (package-run-process nil "darcs" "get" repo dir)))
      (package-run-process dir "darcs" "changes" "--last" "1")
      (package-build-find-parse-time
       "\\([a-zA-Z]\\{3\\} [a-zA-Z]\\{3\\} \\( \\|[0-9]\\)[0-9] [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\} [A-Za-z]\\{3\\} [0-9]\\{4\\}\\)"))))

(defun package-build-checkout-svn (name config dir)
  "Check package NAME with config CONFIG out of svn into DIR."
  (let ((repo (plist-get config :url)))
    (with-current-buffer (get-buffer-create "*package-build-checkout*")
      (goto-char (point-max))
      (cond
       ((file-exists-p dir)
        (print "checkout directory exists, updating...")
        (package-run-process dir "svn" "up"))
       (t
        (print "cloning repository")
        (package-run-process nil "svn" "checkout" repo dir)))
      (package-run-process dir "svn" "info")
      (package-build-find-parse-time
       "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)"))))

(defun package-build-checkout-git (name config dir)
  "Check package NAME with config CONFIG out of git into DIR."
  (let ((repo (plist-get config :url))
        (commit (plist-get config :commit)))
    (with-current-buffer (get-buffer-create "*package-build-checkout*")
      (goto-char (point-max))
      (cond
       ((file-exists-p dir)
        (print "checkout directory exists, updating...")
        (package-run-process dir "git" "pull"))
       (t
        (print (format "cloning %s to %s" repo dir))
        (package-run-process nil "git" "clone" repo dir)))
      (when commit
        (package-run-process dir "git" "checkout" commit))
      (package-run-process dir "git" "show" "-s" "--format='\%ci'" "HEAD")
      (package-build-find-parse-time
       "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)"))))


(defun package-build-dump (data file)
  "Write DATA to FILE as a pretty-printed Lisp sexp."
  (write-region (concat (pp-to-string data) "\n") nil file nil nil nil nil))

(defun package-build-pkg-file (pkg-file pkg-info)
  "Write PKG-FILE containing PKG-INFO."
  (package-build-dump
   `(define-package
      ,(aref pkg-info 0)
      ,(aref pkg-info 3)
      ,(aref pkg-info 2)
      ,@(mapcar
         (lambda (elt)
           (list (car elt)
                 (package-version-join (cadr elt))))
         (aref pkg-info 1)))
   pkg-file))

(defun package-read-from-file (file-name)
  "Read and return the Lisp data stored in FILE-NAME, or nil if no such file exists."
  (when (file-exists-p file-name)
    (with-temp-buffer
      (insert-file-contents-literally file-name)
      (goto-char (point-min))
      (read (current-buffer)))))

(defun package-build-get-config (file-name)
  "Get the configuration information for the given FILE-NAME."
  (package-read-from-file (format "epkgs/%s/.config" file-name)))

(defun package-build-get-master (file-name)
  "Get the configuration information for the given FILE-NAME."
  (package-read-from-file (format "epkgs/%s/master" file-name)))


(defun package-build-create-tar (dir file &optional files)
  "Create a tar in DIR with name FILE containing FILES."
  (let* ((default-directory package-build-working-dir))
    (if files
        (setq files (mapcar (lambda (fn) (concat dir "/" fn)) files))
      (setq files (list dir)))
    (apply 'process-file
           "tar" nil
           (get-buffer-create "*package-build-checkout*")
           nil "-cvf"
           file
           "--exclude=.svn"
           "--exclude=.git*"
           "--exclude=_darcs"
           files)))

(defun package-build-get-package-info (file-path)
  "Get a vector of package info from the docstrings in FILE-PATH."
  (when (file-exists-p file-path)
    (ignore-errors
      (save-window-excursion
        (find-file file-path)
        ;; next two lines are a hack for some packages that aren't
        ;; commented properly.
        (goto-char (point-max))
        (insert (concat "\n;;; "
                        (file-name-nondirectory file-path) " ends here"))
        (flet ((package-strip-rcs-id (str) "0"))
          (package-buffer-info))))))

(defun package-build-get-pkg-file-info (file-path)
  "Get a vector of package info from \"-pkg.el\" file FILE-PATH."
  (when (file-exists-p file-path)
    (let ((pkgfile-info (cdr (package-read-from-file file-path))))
      (vector
       (nth 0 pkgfile-info)
       (mapcar
        (lambda (elt)
          (list (car elt) (version-to-list (cadr elt))))
        (eval (nth 3 pkgfile-info)))
       (nth 2 pkgfile-info)
       (nth 1 pkgfile-info)))))


(defun package-build-all ()
  "Build all packages in the `package-build-alist'."
  (interactive)
  (apply 'package-build-archives
         (mapcar 'symbol-name (mapcar 'car package-build-alist))))

(defun package-build-archives (&rest pkgs)
  "Build archives for packages PKGS."
  (interactive)
  (mapc 'package-build-archive pkgs))

(defun package-expand-file-list (dir files)
  "In DIR, expand FILES, some of which may be shell-style wildcards."
  (let ((default-directory dir))
    (mapcan 'file-expand-wildcards files)))

(defun package-build-archive (file-name)
  "Build a package archive for package FILE-NAME."
  (interactive (list (completing-read "Package: "
                                      (mapc 'car package-build-alist))))

  (let* ((name (intern file-name))
         (cfg (cdr (assoc name package-build-alist)))
         (pkg-cwd
          (file-name-as-directory
           (expand-file-name file-name package-build-working-dir))))

    (if cfg
        (let* ((version (package-build-checkout name cfg pkg-cwd))
               (files (package-expand-file-list pkg-cwd (plist-get cfg :files)))
               (default-directory package-build-working-dir))
          (cond
           ((not version)
            (print (format "Unable to check out repository for %s" name)))
           ((or (eq 'wiki (plist-get cfg :fetcher))
                (= 1 (length files)))
            (let* ((pkgsrc (expand-file-name (or (car files)
                                                 (concat file-name ".el"))
                                             pkg-cwd))
                   (pkgdst (expand-file-name
                            (concat file-name "-" version ".el")
                            package-build-archive-dir))
                   (pkg-info (package-build-get-package-info pkgsrc)))
              (unless pkg-info
                (setq pkg-info
                      (vector
                       file-name nil "No description available." version)))
              (aset pkg-info 3 version)
              (aset pkg-info 0 (downcase file-name))
              (print pkg-info)
              (if (file-exists-p pkgdst)
                  (delete-file pkgdst t))
              (copy-file pkgsrc pkgdst)
              (package-build-add-to-archive-contents pkg-info 'single)))
           (t
            (let* ((pkg-dir (concat file-name "-" version))
                   (pkg-file (concat file-name "-pkg.el"))
                   (pkg-info (package-build-get-pkg-file-info
                              (expand-file-name pkg-file pkg-cwd))))

              (copy-directory file-name pkg-dir)

              (unless pkg-info
                (setq pkg-info (package-build-get-package-info
                                (expand-file-name (concat file-name ".el")
                                                  pkg-cwd))))

              ;; some packages (like magit) provide name-pkg.el.in
              (unless pkg-info
                (setq pkg-info (package-build-get-pkg-file-info
                                (expand-file-name (concat pkg-file ".in")
                                                  pkg-cwd))))

              (unless pkg-info
                (setq pkg-info
                      (vector
                       file-name nil "No description available." version)))

              (aset pkg-info 3 version)
              (aset pkg-info 0 (downcase (aref pkg-info 0)))
              (print pkg-info)
              (package-build-pkg-file (expand-file-name
                                       pkg-file
                                       (file-name-as-directory
                                        (expand-file-name
                                         pkg-dir
                                         package-build-working-dir)))
                                      pkg-info)

              (when files
                (add-to-list 'files pkg-file))

              (package-build-create-tar
               pkg-dir
               (expand-file-name
                (concat file-name "-" version ".tar") package-build-archive-dir)
               files)

              (delete-directory pkg-dir t nil)
              (package-build-add-to-archive-contents pkg-info 'tar))))
          (package-build-dump-archive-contents))
      (message "\nERROR: Cannot find package %s\n" file-name))))



(defvar package-build-alist
  (package-read-from-file package-build-alist-file)
  "List of package build specs.")

(defvar package-build-archive-alist
  (cdr (package-read-from-file
        (expand-file-name "archive-contents" package-build-archive-dir)))
  "List of already-built packages, in the standard package.el format.")

(defun package-build-dump-archive-contents ()
  "Dump the list of built packages back to the archive-contents file."
  (package-build-dump (cons 1 package-build-archive-alist)
                      (expand-file-name "archive-contents"
                                        package-build-archive-dir)))

(defun package-build-add-to-archive-contents (pkg-info type)
  "Add the built archive with info PKG-INFO and TYPE to `package-build-archive-alist'."
  (let* ((name (intern (aref pkg-info 0)))
         (requires (aref pkg-info 1))
         (desc (or (aref pkg-info 2) "No description available."))
         (version (aref pkg-info 3))
         (existing (assq name package-build-archive-alist)))
    (when existing
      (setq package-build-archive-alist
            (delq existing package-build-archive-alist)))
    (add-to-list 'package-build-archive-alist
                 (cons name
                       (vector
                        (version-to-list version)
                        requires
                        desc
                        type)))))

;;; package-build.el ends here