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

;; Copyright (C) 2007 - 2014 Steve Youngs

;; Author:     Steve Youngs <steve@sxemacs.org>
;; Maintainer: Steve Youngs <steve@sxemacs.org>
;; Created:    <2007-07-13>
;; Time-stamp: <Friday Feb 12, 2021 16:19:09 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:
;;
;;   o Reduce code duplication through use of macros
;;   o View build logs
;;   o Run builds
;;

;;; 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 ((pkgs ""))
    (with-temp-buffer
      (insert-file-contents "/etc/group")
      (catch 'done
	(while t
	  (if (re-search-forward "^install:x:9999:" nil t)
	      (setq pkgs (concat pkgs
				 (buffer-substring (point)
						   (point-at-eol))
				 ","))
	    (throw 'done nil))))
      (split-string-by-char (substring pkgs 0 -1) ?,))))

(defvar pkgusr-all-pkgs (pkgusr-all-pkgs)
  "A list of all installed packages.")

(defun pkgusr-all-pkgs-update ()
  "Update the list of installed packages."
  (setq pkgusr-all-pkgs (pkgusr-all-pkgs)))

(defun pkgusr-pkgs-count (&optional upd-list)
  "Return the number of installed packages.

With optional argument UPD-LIST force an update of the packages list."
  (and upd-list
       (pkgusr-all-pkgs-update))
  (length pkgusr-all-pkgs))

(defun pkgusr-list-pkgs-regexp (regexp &optional upd-list)
  "Return a list of packages matching REGEXP.

With 1 prefix arg  insert the result into the current buffer at point.
With 2 prefix args force update of the packages list.
With 3 prefix args force update and insert into buffer.

With optional argument UPD-LIST, force update of the packages list."
  (interactive "sRegexp: \np")
  (and (or (eq upd-list 16)
	   (eq upd-list 64))
       (pkgusr-all-pkgs-update))
  (let ((case-fold-search t)
	res)
    (mapcar
     #'(lambda (pkg)
	 (when (string-match regexp pkg)
	   (setq res (append res (list pkg)))))
     pkgusr-all-pkgs)
    (if (interactive-p)
	(cond
	 ((or (eq upd-list 4)
	      (eq upd-list 64))
	  (insert (mapconcat #'identity res " ")))
	 (t
	  (message "[Matches for \"%s\"]: %s" regexp
		   (mapconcat #'identity res " "))))
      res)))

(defconst pkgusr-url-regexp
  (concat
   #r"\(\(https?\|ftp\|rsync\|s\(cp\|sh\)\|git\)://\|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-pkg-details (pkg)
  (let ((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-show-pkg ()
  "Display filelist and other details for a package.

With a prefix arg, force update of the packages list."
  (interactive)
  (and current-prefix-arg
       (pkgusr-all-pkgs-update))
  (let ((pkg (completing-read "Show Package: "
			      (mapcar #'list pkgusr-all-pkgs)
			      nil t nil pkgusr-pkg-history)))
    (pkgusr-pkg-details pkg)))

(defun pkgusr-pkg-install-notes ()
  "Display the install notes of a package.

With a prefix arg, force update of the packages list."
  (interactive)
  (and current-prefix-arg
       (pkgusr-all-pkgs-update))
  (let ((pkg (completing-read "Package: "
			      (mapcar #'list pkgusr-all-pkgs)
			      nil t nil pkgusr-pkg-history))
	start end)
    (pkgusr-pkg-details 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 ()
  "Display the general notes of a package.

With a prefix arg, force update of the packages list."
  (interactive)
  (and current-prefix-arg
       (pkgusr-all-pkgs-update))
  (let ((pkg (completing-read "Package: "
			      (mapcar #'list pkgusr-all-pkgs)
			      nil t nil pkgusr-pkg-history))
	start end)
    (pkgusr-pkg-details 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.

With a prefix arg, insert into the current buffer at point.

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

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

With a prefix arg, insert into current buffer at point.

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 (or (declare-fboundp (user-group-name
				     (nth 3 (file-attributes file))))
		   (user-login-name
		    (nth 3 (file-attributes file))))))
    (unless (or (member user pkgusr-all-pkgs)
		(member group pkgusr-all-pkgs))
      (error 'pkgusr-unknown-pkg user))
    (if (interactive-p)
	(if current-prefix-arg
	    (insert (format "%s: (%s:%s)" file user group))
	  (message "File: %s is from the \"%s\" package (%2$s:%s)"
		   file user group)
	  (list user group)))))

(defun pkgusr-project-file (pkg)
  "Return the .project file for PKG."
  (let ((dir (paths-construct-path (list "/usr" "src" pkg))))
    (expand-file-name ".project" dir)))

(defun pkgusr-pkg-url (&optional pkg upd-list)
  "Return the URL of PKG as a string.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg
		 (completing-read "Package: "
				  (mapcar #'list pkgusr-all-pkgs)
				  nil t nil pkgusr-pkg-history)))
	url)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (with-temp-buffer
      (insert-file-contents (pkgusr-project-file pkg))
      (goto-char (point-min))
      (re-search-forward "Web_Site: <\\(.*\\)>$" nil t)
      (setq url (match-string 1)))
    (if (interactive-p)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert url))
	 (t
	  (message "[URL (%s)]: %s" pkg url)))
      url)))

(defun pkgusr-pkg-repo (&optional pkg upd-list)
  "Return the repo URI of PKG as a string.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg (completing-read "Package: "
				      (mapcar #'list pkgusr-all-pkgs)
				      nil t nil pkgusr-pkg-history)))
	repo type)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (with-temp-buffer
      (insert-file-contents (pkgusr-project-file pkg))
      (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)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert repo))
	 (t
	  (message "[Repo (%s)]: %s (%s)" pkg repo type)))
      repo)))

(defun pkgusr-pkg-version (&optional pkg upd-list)
  "Return the version of PKG as a string.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg (completing-read "Package: "
				      (mapcar #'list pkgusr-all-pkgs)
				      nil t nil pkgusr-pkg-history)))
	version)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (with-temp-buffer
      (insert-file-contents (pkgusr-project-file pkg))
      (goto-char (point-min))
      (re-search-forward "Version: \\(.*$\\)" nil t)
      (setq version (match-string 1)))
    (if (interactive-p)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert version))
	 (t
	  (message "[Version (%s)]: %s" pkg version)))
      version)))

(defun pkgusr-pkg-description (&optional pkg upd-list)
  "Return the description of PKG as a string.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg (completing-read "Package: "
				      (mapcar #'list pkgusr-all-pkgs)
				      nil t nil pkgusr-pkg-history)))
	desc)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (with-temp-buffer
      (insert-file-contents (pkgusr-project-file pkg))
      (goto-char (point-min))
      (re-search-forward "Description: \\(.*$\\)" nil t)
      (setq desc (match-string 1)))
    (if (interactive-p)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert desc))
	 (t
	  (message "[Description (%s)]: %s" pkg desc)))
      desc)))

(defun pkgusr-pkg-deps (&optional pkg upd-list)
  "Return a list of dependencies of PKG.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg (completing-read "Package: "
				      (mapcar #'list pkgusr-all-pkgs)
				      nil t nil pkgusr-pkg-history)))
	deps)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (with-temp-buffer
      (insert-file-contents (pkgusr-project-file pkg))
      (goto-char (point-min))
      (re-search-forward "Deps: \\(.*$\\)" nil t)
      (setq deps (match-string 1)))
    (if (interactive-p)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert deps))
	 (t
	  (message "[Deps (%s)]: %s" pkg deps)))
      (split-string-by-char deps ?\ ))))

;;; FIXME: This churns like you wouldn't believe, can we make it more
;;; efficient?
(defun pkgusr-pkg-rdeps (&optional pkg upd-list)
  "Return a list of packages which cite PKG as a dependency.

With 1 prefix arg, insert into current buffer at point.
With 2 prefix args, force update of the packages list.
With 3 prefix args, force update and insert into buffer.
With optional arg UPD-LIST, force update of the packages list."
  (interactive)
  (and (or (eq (car current-prefix-arg) 16)
	   (eq (car current-prefix-arg) 64)
	   upd-list)
       (pkgusr-all-pkgs-update))
  (let ((pkg (or pkg (completing-read "Package: "
				      (mapcar #'list pkgusr-all-pkgs)
				      nil t nil pkgusr-pkg-history)))
	result)
    (unless (member pkg pkgusr-all-pkgs)
      (error 'pkgusr-unknown-pkg pkg))
    (mapcar
     #'(lambda (maybe-pkg)
	 (let ((deplist (pkgusr-pkg-deps maybe-pkg)))
	   (mapcar
	    #'(lambda (dep)
		(and (string-match pkg dep)
		     (setq result (append result (list maybe-pkg)))))
	    deplist)))
     pkgusr-all-pkgs)
    (sort result #'string<)
    (if (interactive-p)
	(cond
	 ((or (eq (car current-prefix-arg) 4)
	      (eq (car current-prefix-arg) 64))
	  (insert (mapconcat #'identity result " ")))
	 (t
	  (message "[Reverse Deps (%s)]: %s" pkg
		   (mapconcat #'identity result " "))))
      result)))

;; 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 (&optional pkgusr file)
  "Using Tramp, find PKGUSR's FILE.

With a prefix arg, force update of the packages list."
  (interactive)
  (unless (interactive-p)
    (error 'invalid-operation "Trying to call interactive-only command"))
  (and current-prefix-arg
       (pkgusr-all-pkgs-update))
  (let* ((puser (completing-read "Package User: "
				 (mapcar #'list pkgusr-all-pkgs)
				 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) R] #'pkgusr-pkg-rdeps)
(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