cgit.sxemacs.org Git - pkgusr/blob - lisp/pkgusr.el

   1 ;; pkgusr.el --- elisp tools for LFS pkgusr package management   -*- Emacs-Lisp -*-
   2
   3 ;; Copyright (C) 2007 Steve Youngs
   4
   5 ;; Author:     Steve Youngs <steve@sxemacs.org>
   6 ;; Maintainer: Steve Youngs <steve@sxemacs.org>
   7 ;; Created:    <2007-07-13>
   8 ;; Time-stamp: <Wednesday Mar 12, 2014 17:01:00 steve>
   9 ;; Homepage:   N/A
  10 ;; Keywords:   utils package-management
  11
  12 ;; This file is part of pkgusr.
  13
  14 ;; Redistribution and use in source and binary forms, with or without
  15 ;; modification, are permitted provided that the following conditions
  16 ;; are met:
  17 ;;
  18 ;; 1. Redistributions of source code must retain the above copyright
  19 ;;    notice, this list of conditions and the following disclaimer.
  20 ;;
  21 ;; 2. Redistributions in binary form must reproduce the above copyright
  22 ;;    notice, this list of conditions and the following disclaimer in the
  23 ;;    documentation and/or other materials provided with the distribution.
  24 ;;
  25 ;; 3. Neither the name of the author nor the names of any contributors
  26 ;;    may be used to endorse or promote products derived from this
  27 ;;    software without specific prior written permission.
  28 ;;
  29 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  30 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  31 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  32 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  33 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  34 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  35 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  36 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  37 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  38 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  39 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  40
  41 ;;; Commentary:
  42 ;;
  43 ;;   This is a collection of tools I use with package management here
  44 ;;   on bastard.  A lot of them are elisp ports of some shell functions
  45 ;;   I use for the same.
  46
  47 ;;; Todo:
  48 ;;
  49 ;;
  50
  51 ;;; ChangeLog:
  52 ;;
  53 ;;  This is just a place holder so `pkgusr-commentary' will work
  54 ;;  properly.  See the ChangeLog file for changes.
  55
  56 ;;; Code:
  57 (defvar pkgusr-pkg-history nil
  58   "History for pkgusr.")
  59
  60 ;; Errors
  61 (define-error 'pkgusr-unknown-cmd "Can't find command")
  62 (define-error 'pkgusr-unknown-file "Don't recognise file")
  63 (define-error 'pkgusr-unknown-pkg "Unknown package")
  64
  65 (defun pkgusr-all-pkgs ()
  66   "Return a list of all installed packages."
  67   (let ((lst (with-temp-buffer
  68                (erase-buffer)
  69                (insert-file-contents "/etc/group")
  70                (re-search-forward "^install:x:9999:" nil t)
  71                (narrow-to-region (point) (point-at-eol))
  72                (split-string-by-char (buffer-string) ?,))))
  73     lst))
  74
  75 (defun pkgusr-pkgs-count ()
  76   "Return the number of installed packages."
  77   (length (pkgusr-all-pkgs)))
  78
  79 (defun pkgusr-list-pkgs-regexp (regexp)
  80   "Return a list of packages matching REGEXP."
  81   (interactive "sRegexp: ")
  82   (let ((pkgs (pkgusr-all-pkgs))
  83         (case-fold-search t)
  84         res)
  85     (mapcar
  86      #'(lambda (pkg)
  87          (when (string-match regexp pkg)
  88            (push pkg res)))
  89      pkgs)
  90     (if (interactive-p)
  91         (message "%S" (nreverse res))
  92       (nreverse res))))
  93
  94 (defconst pkgusr-url-regexp
  95   (concat
  96    #r"\(\(https?\|ftp\|rsync\|s\(cp\|sh\)\|git\)://\|file:/\|s?news:\|mailto:\)"
  97    "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
  98   "A regular expression matching URLs.")
  99
 100 (defun pkgusr-url-at-point ()
 101   "Browse to a URL from the `pkgusr-show-pkg' buffer."
 102   (interactive)
 103   (when (extentp (extent-at (point)))
 104     (browse-url (extent-string (extent-at (point))))))
 105
 106 (defun pkgusr-url-at-mouse (event)
 107   "Browse to a URL at EVENT via the mouse from the `pkgusr-show-pkg' buffer."
 108   (interactive "e")
 109   (when (extentp (extent-at-event event))
 110     (browse-url (extent-string (extent-at-event event)))))
 111
 112 (defconst pkgusr-ext-map
 113   (let* ((map (make-sparse-keymap 'pkgusr-ext-map)))
 114     (define-key map [button2] 'pkgusr-url-at-mouse)
 115     (define-key map [return] 'pkgusr-url-at-point)
 116     map)
 117   "A keymap for the extents in the `pkgusr-show-pkg' buffer.")
 118
 119 (defun pkgusr-make-url-extents ()
 120   "Create extent objects for all the URLs in the buffer."
 121   (goto-char (point-min))
 122   (save-excursion
 123     (while (re-search-forward pkgusr-url-regexp nil t)
 124       (let ((extent (make-extent (match-beginning 0) (match-end 0)))
 125             (echo "RET or Button2 to visit this URL."))
 126         (set-extent-property extent 'face 'bold)
 127         (set-extent-property extent 'mouse-face 'highlight)
 128         (set-extent-property extent 'keymap pkgusr-ext-map)
 129         (set-extent-property extent 'help-echo echo)
 130         (set-extent-property extent 'balloon-help echo)
 131         (set-extent-property extent 'duplicable t)))))
 132
 133 (defun pkgusr-show-pkg (&optional pkg)
 134   "Display a buffer of package details for PKG."
 135   (interactive)
 136   (let* ((allpkgs (pkgusr-all-pkgs))
 137          (pkg (or pkg (completing-read "Show Package: "
 138                                        (mapcar #'list allpkgs)
 139                                        nil t nil pkgusr-pkg-history)))
 140          (buf (get-buffer-create (format "*Package Details: %s*" pkg)))
 141          (detail (shell-command-to-string (format "pinky -l %s" pkg))))
 142     (with-current-buffer buf
 143       (erase-buffer)
 144       (insert detail)
 145       (pkgusr-make-url-extents))
 146     (push-window-configuration)
 147     (pop-to-buffer buf)
 148     (view-mode nil
 149                #'(lambda (b)
 150                    (kill-buffer b)
 151                    (pop-window-configuration)))))
 152
 153 (defun pkgusr-pkg-install-notes (&optional pkg)
 154   "Display the install notes of a PKG."
 155   (interactive)
 156   (let* ((allpkgs (pkgusr-all-pkgs))
 157          (pkg (or pkg (completing-read "Show Package: "
 158                                        (mapcar #'list allpkgs)
 159                                        nil t nil pkgusr-pkg-history)))
 160          start end)
 161     (pkgusr-show-pkg pkg)
 162     (re-search-forward "^Install Notes:$" nil t)
 163     (setq start (point-at-bol))
 164     (re-search-forward "^General Notes:$" nil t)
 165     (setq end (point-at-bol))
 166     (narrow-to-region start end)
 167     (goto-char (point-min))))
 168
 169 (defun pkgusr-pkg-general-notes (&optional pkg)
 170   "Display the general notes of a PKG."
 171   (interactive)
 172   (let* ((allpkgs (pkgusr-all-pkgs))
 173          (pkg (or pkg (completing-read "Show Package: "
 174                                        (mapcar #'list allpkgs)
 175                                        nil t nil pkgusr-pkg-history)))
 176          start end)
 177     (pkgusr-show-pkg pkg)
 178     (re-search-forward "^General Notes:$" nil t)
 179     (setq start (point-at-bol))
 180     (re-search-forward "^CONTENTS:$" nil t)
 181     (setq end (point-at-bol))
 182     (narrow-to-region start end)
 183     (goto-char (point-min))))
 184
 185 (defun pkgusr-cmd-pkg (cmd)
 186   "Display the package name \(user:group\) which contains CMD.
 187
 188 If non-interactive, return a list whose car is user and cdr is group."
 189   (interactive "sCommand: ")
 190   (unless (executable-find cmd)
 191     (error 'pkgusr-unknown-cmd cmd))
 192   (let* ((cmd (executable-find cmd))
 193          (user (user-login-name
 194                 (nth 2 (file-attributes cmd))))
 195          (group (user-login-name
 196                  (nth 3 (file-attributes cmd)))))
 197     (if (interactive-p)
 198         (message "Command: %s is from the \"%s\" package \(%s:%2$s\)"
 199                  cmd group user)
 200       (list user group))))
 201
 202 (defun pkgusr-file-pkg (file)
 203   "Display the pkg name \(user:group\) which contains FILE.
 204
 205 If non-interactive, return a list whose car is user and cdr is group."
 206   (interactive "fFile: ")
 207   (let* ((user (user-login-name
 208                 (nth 2 (file-attributes file))))
 209          (group (user-login-name
 210                  (nth 3 (file-attributes file)))))
 211     (if (member user (pkgusr-all-pkgs))
 212         (if (interactive-p)
 213             (message "File: %s is from the \"%s\" package \(%s:%2$s\)"
 214                      file group user)
 215           (list user group))
 216       (error 'pkgusr-unknown-file file))))
 217
 218 (defun pkgusr-pkg-url (&optional pkg)
 219   "Return the URL of PKG as a string."
 220   (interactive)
 221   (let* ((allpkgs (pkgusr-all-pkgs))
 222          (pkg (or pkg (completing-read "Package: "
 223                                        (mapcar #'list allpkgs)
 224                                        nil t nil pkgusr-pkg-history)))
 225          (pkgfile (format "/usr/src/%s/.project" pkg)))
 226     (when (member pkg allpkgs)
 227       (with-temp-buffer
 228         (erase-buffer)
 229         (insert-file-contents pkgfile)
 230         (goto-char (point-min))
 231         (re-search-forward "Web_Site: <\\(.*\\)>$" nil t)
 232         (if (interactive-p)
 233             (message "[%s URL] %s" pkg (match-string 1))
 234           (match-string 1))))))
 235
 236 (defun pkgusr-pkg-repo (&optional pkg)
 237   "Return the repo URI of PKG as a string."
 238   (interactive)
 239   (let* ((allpkgs (pkgusr-all-pkgs))
 240          (pkg (or pkg (completing-read "Package: "
 241                                        (mapcar #'list allpkgs)
 242                                        nil t nil pkgusr-pkg-history)))
 243          (pkgfile (format "/usr/src/%s/.project" pkg))
 244          repo type)
 245     (when (member pkg allpkgs)
 246       (with-temp-buffer
 247         (erase-buffer)
 248         (insert-file-contents pkgfile)
 249         (goto-char (point-min))
 250         (re-search-forward "Repo_Type: <?\\(.*\\)>?$" nil t)
 251         (setq type (match-string 1))
 252         (re-search-forward "Repo_Location: <\\(.*\\)>" nil t)
 253         (setq repo (match-string 1)))
 254       (if (interactive-p)
 255           (message "[%s Repo] %s (%s)" pkg repo type)
 256         repo))))
 257
 258 (defun pkgusr-pkg-version (&optional pkg)
 259   "Return the version of PKG as a string."
 260   (interactive)
 261   (let* ((allpkgs (pkgusr-all-pkgs))
 262          (pkg (or pkg (completing-read "Package: "
 263                                        (mapcar #'list allpkgs)
 264                                        nil t nil pkgusr-pkg-history)))
 265          (pkgfile (format "/usr/src/%s/.project" pkg)))
 266     (if (member pkg allpkgs)
 267         (with-temp-buffer
 268           (erase-buffer)
 269           (insert-file-contents pkgfile)
 270           (goto-char (point-min))
 271           (re-search-forward "Version: \\(.*$\\)" nil t)
 272           (if (interactive-p)
 273               (message "[%s Ver] %s" pkg (match-string 1))
 274             (match-string 1)))
 275       (error 'pkgusr-unknown-pkg pkg))))
 276
 277 (defun pkgusr-pkg-description (&optional pkg)
 278   "Return the description of PKG as a string."
 279   (interactive)
 280   (let* ((allpkgs (pkgusr-all-pkgs))
 281          (pkg (or pkg (completing-read "Package: "
 282                                        (mapcar #'list allpkgs)
 283                                        nil t nil pkgusr-pkg-history)))
 284          (pkgfile (format "/usr/src/%s/.project" pkg)))
 285     (if (member pkg allpkgs)
 286         (with-temp-buffer
 287           (erase-buffer)
 288           (insert-file-contents pkgfile)
 289           (goto-char (point-min))
 290           (re-search-forward "Description: \\(.*$\\)" nil t)
 291           (if (interactive-p)
 292               (message "[%s Desc] %s" pkg (match-string 1))
 293             (match-string 1)))
 294       (error 'pkgusr-unknown-pkg pkg))))
 295
 296 (defun pkgusr-pkg-deps (&optional pkg)
 297   "Return the dependencies of PKG as a string."
 298   (interactive)
 299   (let* ((allpkgs (pkgusr-all-pkgs))
 300          (pkg (or pkg (completing-read "Package: "
 301                                        (mapcar #'list allpkgs)
 302                                        nil t nil pkgusr-pkg-history)))
 303          (pkgfile (format "/usr/src/%s/.project" pkg)))
 304     (if (member pkg allpkgs)
 305         (with-temp-buffer
 306           (erase-buffer)
 307           (insert-file-contents pkgfile)
 308           (goto-char (point-min))
 309           (re-search-forward "Deps: \\(.*$\\)" nil t)
 310           (if (interactive-p)
 311               (message "[%s Deps] %s" pkg (match-string 1))
 312             (match-string 1)))
 313       (error 'pkgusr-unknown-pkg pkg))))
 314
 315 ;; A little bogus perhaps, but it works.  `pkgusr-find-file' is
 316 ;; something that only I can use because it ssh's through root to
 317 ;; get to the pkgusr. And nobody but me would have a need for
 318 ;; `pkgusr-file-history' --SY.
 319 (defconst pkgusr-pkgmgr "steve"
 320   "The Package Manager.
 321
 322 This is a defconst for a reason... to make it a bit harder to customise.
 323 Just setq'ing this in your init.el won't work if you load pkgusr.el
 324 after the setq.  Be bold and hard code it in pkgusr.el itself.")
 325
 326 (defmacro defun-when-pkgmgr (&rest args)
 327   "Define a function only if you are the right user."
 328   `(when (equal (user-login-name) pkgusr-pkgmgr)
 329      (defun ,@args)))
 330
 331 (defmacro defvar-when-pkgmgr (&rest args)
 332   "Define a variable only if you are the right user."
 333   `(when (equal (user-login-name) pkgusr-pkgmgr)
 334      (defvar ,@args)))
 335
 336 (defvar-when-pkgmgr pkgusr-file-history nil
 337   "History for pkgusr-find-file.")
 338
 339 (defun-when-pkgmgr pkgusr-find-file (pkgusr file)
 340   "Using Tramp, find PKGUSR's FILE."
 341   (interactive "i\ni")
 342   (unless (interactive-p)
 343     (error 'invalid-operation "Trying to call interactive-only command"))
 344   (let* ((allpkgs (pkgusr-all-pkgs))
 345          (puser (completing-read "Package User: "
 346                                  (mapcar #'list allpkgs)
 347                                  nil t nil pkgusr-pkg-history))
 348          (file (read-file-name (format "[%s] find file: " puser)
 349                                (file-name-as-directory
 350                                 (expand-file-name puser "/usr/src"))
 351                                (file-name-as-directory
 352                                 (expand-file-name puser "/usr/src"))
 353                                nil nil pkgusr-file-history))
 354          (tpath (format "[ssh/root@localhost|su/%s@localhost]%s"
 355                         puser file))
 356          (default-directory "/"))
 357     (find-file tpath)))
 358
 359 ;; Some key bindings
 360 (global-set-key [(hyper c) c] #'pkgusr-cmd-pkg)
 361 (global-set-key [(hyper c) f] #'pkgusr-file-pkg)
 362 (global-set-key [(hyper c) (hyper r)] #'pkgusr-list-pkgs-regexp)
 363 (global-set-key [(hyper c) d] #'pkgusr-pkg-description)
 364 (global-set-key [(hyper c) D] #'pkgusr-pkg-deps)
 365 (global-set-key [(hyper c) g] #'pkgusr-pkg-general-notes)
 366 (global-set-key [(hyper c) i] #'pkgusr-pkg-install-notes)
 367 (global-set-key [(hyper c) r] #'pkgusr-pkg-repo)
 368 (global-set-key [(hyper c) u] #'pkgusr-pkg-url)
 369 (global-set-key [(hyper c) v] #'pkgusr-pkg-version)
 370 (global-set-key [(hyper c) s] #'pkgusr-show-pkg)
 371
 372 (eval-and-compile
 373   (when (equal (user-login-name) pkgusr-pkgmgr)
 374     (global-set-key [(hyper x) (hyper f)] #'pkgusr-find-file)))
 375
 376 (provide 'pkgusr)
 377 ;;; pkgusr.el ends here