;; pkgusr.el --- elisp tools for LFS pkgusr package management   -*- Emacs-Lisp -*-

;; Copyright (C) 2007 Steve Youngs

;; Author:     Steve Youngs <steve@sxemacs.org>
;; Maintainer: Steve Youngs <steve@sxemacs.org>
;; Created:    <2007-07-13>
;; Time-stamp: <Sunday Feb  3, 2013 12:17:39 steve>
;; Homepage:   N/A
;; Keywords:   utils package-management

;; This file is part of pkgusr.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; 3. Neither the name of the author nor the names of any contributors
;;    may be used to endorse or promote products derived from this
;;    software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:
;; 
;;   This is a collection of tools I use with package management here
;;   on bastard.  A lot of them are elisp ports of some shell functions
;;   I use for the same.

;;; Todo:
;;
;;     

;;; ChangeLog:
;;
;;  This is just a place holder so `pkgusr-commentary' will work
;;  properly.  See the ChangeLog file for changes.

;;; Code:
(defvar pkgusr-pkg-history nil
  "History for pkgusr.")

;; Errors
(define-error 'pkgusr-unknown-cmd "Can't find command")
(define-error 'pkgusr-unknown-file "Don't recognise file")
(define-error 'pkgusr-unknown-pkg "Unknown package")

(defun pkgusr-all-pkgs ()
  "Return a list of all installed packages."
  (let ((lst (with-temp-buffer
	       (erase-buffer)
	       (insert-file-contents "/etc/group")
	       (re-search-forward "^install:x:9999:" nil t)
	       (narrow-to-region (point) (point-at-eol))
	       (split-string-by-char (buffer-string) ?,))))
    lst))

(defun pkgusr-pkgs-count ()
  "Return the number of installed packages."
  (length (pkgusr-all-pkgs)))

(defun pkgusr-list-pkgs-regexp (regexp)
  "Return a list of packages matching REGEXP."
  (interactive "sRegexp: ")
  (let ((pkgs (pkgusr-all-pkgs))
	(case-fold-search t)
	res)
    (mapcar
     #'(lambda (pkg)
	 (when (string-match regexp pkg)
	   (push pkg res)))
     pkgs)
    (if (interactive-p)
	(message "%S" (nreverse res))
      (nreverse res))))

(defconst pkgusr-url-regexp
  (concat
   #r"\(\(https?\|ftp\|gopher\|telnet\|wais\)://\|file:/\|s?news:\|mailto:\)"
   "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
  "A regular expression matching URLs.")

(defun pkgusr-url-at-point ()
  "Browse to a URL from the `pkgusr-show-pkg' buffer."
  (interactive)
  (when (extentp (extent-at (point)))
    (browse-url (extent-string (extent-at (point))))))

(defun pkgusr-url-at-mouse (event)
  "Browse to a URL at EVENT via the mouse from the `pkgusr-show-pkg' buffer."
  (interactive "e")
  (when (extentp (extent-at-event event))
    (browse-url (extent-string (extent-at-event event)))))

(defconst pkgusr-ext-map
  (let* ((map (make-sparse-keymap 'pkgusr-ext-map)))
    (define-key map [button2] 'pkgusr-url-at-mouse)
    (define-key map [return] 'pkgusr-url-at-point)
    map)
  "A keymap for the extents in the `pkgusr-show-pkg' buffer.")

(defun pkgusr-make-url-extents ()
  "Create extent objects for all the URLs in the buffer."
  (goto-char (point-min))
  (save-excursion
    (while (re-search-forward pkgusr-url-regexp nil t)
      (let ((extent (make-extent (match-beginning 0) (match-end 0)))
	    (echo "RET or Button2 to visit this URL."))
	(set-extent-property extent 'face 'bold)
	(set-extent-property extent 'mouse-face 'highlight)
	(set-extent-property extent 'keymap pkgusr-ext-map)
	(set-extent-property extent 'help-echo echo)
	(set-extent-property extent 'balloon-help echo)
	(set-extent-property extent 'duplicable t)))))

(defun pkgusr-show-pkg (&optional pkg)
  "Display a buffer of package details for PKG."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Show Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (buf (get-buffer-create (format "*Package Details: %s*" pkg)))
	 (detail (shell-command-to-string (format "pinky -l %s" pkg))))
    (with-current-buffer buf
      (erase-buffer)
      (insert detail)
      (pkgusr-make-url-extents))
    (push-window-configuration)
    (pop-to-buffer buf)
    (view-mode nil
	       #'(lambda (b)
		   (kill-buffer b)
		   (pop-window-configuration)))))

(defun pkgusr-pkg-install-notes (&optional pkg)
  "Display the install notes of a PKG."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Show Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 start end)
    (pkgusr-show-pkg pkg)
    (re-search-forward "^Install Notes:$" nil t)
    (setq start (point-at-bol))
    (re-search-forward "^General Notes:$" nil t)
    (setq end (point-at-bol))
    (narrow-to-region start end)
    (goto-char (point-min))))

(defun pkgusr-pkg-general-notes (&optional pkg)
  "Display the general notes of a PKG."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Show Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 start end)
    (pkgusr-show-pkg pkg)
    (re-search-forward "^General Notes:$" nil t)
    (setq start (point-at-bol))
    (re-search-forward "^CONTENTS:$" nil t)
    (setq end (point-at-bol))
    (narrow-to-region start end)
    (goto-char (point-min))))

(defun pkgusr-cmd-pkg (cmd)
  "Display the package name \(user:group\) which contains CMD.

If non-interactive, return a list whose car is user and cdr is group."
  (interactive "sCommand: ")
  (unless (executable-find cmd)
    (error 'pkgusr-unknown-cmd cmd))
  (let* ((cmd (executable-find cmd))
	 (user (user-login-name
		(nth 2 (file-attributes cmd))))
	 (group (user-login-name
		 (nth 3 (file-attributes cmd)))))
    (if (interactive-p)
	(message "Command: %s is from the \"%s\" package \(%s:%2$s\)"
		 cmd group user)
      (list user group))))

(defun pkgusr-file-pkg (file)
  "Display the pkg name \(user:group\) which contains FILE.

If non-interactive, return a list whose car is user and cdr is group."
  (interactive "fFile: ")
  (let* ((user (user-login-name
		(nth 2 (file-attributes file))))
	 (group (user-login-name
		 (nth 3 (file-attributes file)))))
    (if (member user (pkgusr-all-pkgs))
	(if (interactive-p)
	    (message "File: %s is from the \"%s\" package \(%s:%2$s\)"
		     file group user)
	  (list user group))
      (error 'pkgusr-unknown-file file))))

(defun pkgusr-pkg-url (&optional pkg)
  "Return the URL of PKG as a string."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (pkgfile (format "/usr/src/%s/.project" pkg)))
    (when (member pkg allpkgs)
      (with-temp-buffer
	(erase-buffer)
	(insert-file-contents pkgfile)
	(goto-char (point-min))
	(re-search-forward "Web_Site: <\\(.*\\)>$" nil t)
	(if (interactive-p)
	    (message "[%s URL] %s" pkg (match-string 1))
	  (match-string 1))))))

(defun pkgusr-pkg-repo (&optional pkg)
  "Return the repo URI of PKG as a string."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (pkgfile (format "/usr/src/%s/.project" pkg))
	 repo type)
    (when (member pkg allpkgs)
      (with-temp-buffer
	(erase-buffer)
	(insert-file-contents pkgfile)
	(goto-char (point-min))
	(re-search-forward "Repo_Type: <?\\(.*\\)>?$" nil t)
	(setq type (match-string 1))
	(re-search-forward "Repo_Location: <\\(.*\\)>" nil t)
	(setq repo (match-string 1)))
      (if (interactive-p)
	  (message "[%s Repo] %s (%s)" pkg repo type)
	repo))))

(defun pkgusr-pkg-version (&optional pkg)
  "Return the version of PKG as a string."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (pkgfile (format "/usr/src/%s/.project" pkg)))
    (if (member pkg allpkgs)
	(with-temp-buffer
	  (erase-buffer)
	  (insert-file-contents pkgfile)
	  (goto-char (point-min))
	  (re-search-forward "Version: \\(.*$\\)" nil t)
	  (if (interactive-p)
	      (message "[%s Ver] %s" pkg (match-string 1))
	    (match-string 1)))
      (error 'pkgusr-unknown-pkg pkg))))

(defun pkgusr-pkg-description (&optional pkg)
  "Return the description of PKG as a string."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (pkgfile (format "/usr/src/%s/.project" pkg)))
    (if (member pkg allpkgs)
	(with-temp-buffer
	  (erase-buffer)
	  (insert-file-contents pkgfile)
	  (goto-char (point-min))
	  (re-search-forward "Description: \\(.*$\\)" nil t)
	  (if (interactive-p)
	      (message "[%s Desc] %s" pkg (match-string 1))
	    (match-string 1)))
      (error 'pkgusr-unknown-pkg pkg))))

(defun pkgusr-pkg-deps (&optional pkg)
  "Return the dependencies of PKG as a string."
  (interactive)
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (pkg (or pkg (completing-read "Package: "
				       (mapcar #'list allpkgs)
				       nil t nil pkgusr-pkg-history)))
	 (pkgfile (format "/usr/src/%s/.project" pkg)))
    (if (member pkg allpkgs)
	(with-temp-buffer
	  (erase-buffer)
	  (insert-file-contents pkgfile)
	  (goto-char (point-min))
	  (re-search-forward "Deps: \\(.*$\\)" nil t)
	  (if (interactive-p)
	      (message "[%s Deps] %s" pkg (match-string 1))
	    (match-string 1)))
      (error 'pkgusr-unknown-pkg pkg))))

;; A little bogus perhaps, but it works.  `pkgusr-find-file' is
;; something that only I can use because it ssh's through root to
;; get to the pkgusr. And nobody but me would have a need for
;; `pkgusr-file-history' --SY.
(defconst pkgusr-pkgmgr "steve"
  "The Package Manager.

This is a defconst for a reason... to make it a bit harder to customise.
Just setq'ing this in your init.el won't work if you load pkgusr.el
after the setq.  Be bold and hard code it in pkgusr.el itself.")

(defmacro defun-when-pkgmgr (&rest args)
  "Define a function only if you are the right user."
  `(when (equal (user-login-name) pkgusr-pkgmgr)
     (defun ,@args)))

(defmacro defvar-when-pkgmgr (&rest args)
  "Define a variable only if you are the right user."
  `(when (equal (user-login-name) pkgusr-pkgmgr)
     (defvar ,@args)))

(defvar-when-pkgmgr pkgusr-file-history nil
  "History for pkgusr-find-file.")

(defun-when-pkgmgr pkgusr-find-file (pkgusr file)
  "Using Tramp, find PKGUSR's FILE."
  (interactive "i\ni")
  (unless (interactive-p)
    (error 'invalid-operation "Trying to call interactive-only command"))
  (let* ((allpkgs (pkgusr-all-pkgs))
	 (puser (completing-read "Package User: "
				 (mapcar #'list allpkgs)
				 nil t nil pkgusr-pkg-history))
	 (file (read-file-name (format "[%s] find file: " puser)
			       (file-name-as-directory
				(expand-file-name puser "/usr/src"))
			       (file-name-as-directory
				(expand-file-name puser "/usr/src"))
			       nil nil pkgusr-file-history))
	 (tpath (format "[ssh/root@localhost|su/%s@localhost]%s"
			puser file))
	 (default-directory "/"))
    (find-file tpath)))

;; Some key bindings
(global-set-key [(hyper c) c] #'pkgusr-cmd-pkg)
(global-set-key [(hyper c) f] #'pkgusr-file-pkg)
(global-set-key [(hyper c) (hyper r)] #'pkgusr-list-pkgs-regexp)
(global-set-key [(hyper c) d] #'pkgusr-pkg-description)
(global-set-key [(hyper c) D] #'pkgusr-pkg-deps)
(global-set-key [(hyper c) g] #'pkgusr-pkg-general-notes)
(global-set-key [(hyper c) i] #'pkgusr-pkg-install-notes)
(global-set-key [(hyper c) r] #'pkgusr-pkg-repo)
(global-set-key [(hyper c) u] #'pkgusr-pkg-url)
(global-set-key [(hyper c) v] #'pkgusr-pkg-version)
(global-set-key [(hyper c) s] #'pkgusr-show-pkg)

(eval-and-compile
  (when (equal (user-login-name) pkgusr-pkgmgr)
    (global-set-key [(hyper x) (hyper f)] #'pkgusr-find-file)))

(provide 'pkgusr)
;;; pkgusr.el ends here