1 ;; pkgusr.el --- elisp tools for LFS pkgusr package management -*- Emacs-Lisp -*-
3 ;; Copyright (C) 2007 Steve Youngs
5 ;; Author: Steve Youngs <steve@sxemacs.org>
6 ;; Maintainer: Steve Youngs <steve@sxemacs.org>
7 ;; Created: <2007-07-13>
8 ;; Time-stamp: <Saturday Jun 23, 2012 13:56:29 steve>
10 ;; Keywords: utils package-management
12 ;; This file is part of pkgusr.
14 ;; Redistribution and use in source and binary forms, with or without
15 ;; modification, are permitted provided that the following conditions
18 ;; 1. Redistributions of source code must retain the above copyright
19 ;; notice, this list of conditions and the following disclaimer.
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.
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.
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.
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.
53 ;; This is just a place holder so `pkgusr-commentary' will work
54 ;; properly. See the ChangeLog file for changes.
57 (defvar pkgusr-pkg-history nil
58 "History for pkgusr.")
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")
65 (defun pkgusr-all-pkgs ()
66 "Return a list of all installed packages."
67 (let ((lst (with-temp-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) ?,))))
75 (defun pkgusr-pkgs-count ()
76 "Return the number of installed packages."
77 (length (pkgusr-all-pkgs)))
79 (defun pkgusr-list-pkgs-regexp (regexp)
80 "Return a list of packages matching REGEXP."
81 (interactive "sRegexp: ")
82 (let ((pkgs (pkgusr-all-pkgs))
87 (when (string-match regexp pkg)
91 (message "%S" (nreverse res))
94 (defconst pkgusr-url-regexp
96 #r"\(\(https?\|ftp\|gopher\|telnet\|wais\)://\|file:/\|s?news:\|mailto:\)"
97 "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
98 "A regular expression matching URLs.")
100 (defun pkgusr-url-at-point ()
101 "Browse to a URL from the `pkgusr-show-pkg' buffer."
103 (when (extentp (extent-at (point)))
104 (browse-url (extent-string (extent-at (point))))))
106 (defun pkgusr-url-at-mouse (event)
107 "Browse to a URL at EVENT via the mouse from the `pkgusr-show-pkg' buffer."
109 (when (extentp (extent-at-event event))
110 (browse-url (extent-string (extent-at-event event)))))
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)
117 "A keymap for the extents in the `pkgusr-show-pkg' buffer.")
119 (defun pkgusr-make-url-extents ()
120 "Create extent objects for all the URLs in the buffer."
121 (goto-char (point-min))
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)))))
133 (defun pkgusr-show-pkg (&optional pkg)
134 "Display a buffer of package details for PKG."
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
145 (pkgusr-make-url-extents))
146 (push-window-configuration)
151 (pop-window-configuration)))))
153 (defun pkgusr-pkg-install-notes (&optional pkg)
154 "Display the install notes of a PKG."
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)))
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))))
169 (defun pkgusr-pkg-general-notes (&optional pkg)
170 "Display the general notes of a PKG."
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)))
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))))
185 (defun pkgusr-cmd-pkg (cmd)
186 "Display the package name \(user:group\) which contains CMD.
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)))))
198 (message "Command: %s is from the \"%s\" package \(%s:%2$s\)"
202 (defun pkgusr-file-pkg (file)
203 "Display the pkg name \(user:group\) which contains FILE.
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))
213 (message "File: %s is from the \"%s\" package \(%s:%2$s\)"
216 (error 'pkgusr-unknown-file file))))
218 (defun pkgusr-pkg-url (&optional pkg)
219 "Return the URL of PKG as a string."
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 (when (member pkg allpkgs)
228 (insert (shell-command-to-string (format "pinky -l %s" pkg)))
229 (goto-char (point-min))
230 (re-search-forward "Web_Site: <\\(.*\\)>$" nil t)
232 (message "[%s URL] %s" pkg (match-string 1))
233 (match-string 1))))))
235 (defun pkgusr-pkg-repo (&optional pkg)
236 "Return the repo URI of PKG as a string."
238 (let* ((allpkgs (pkgusr-all-pkgs))
239 (pkg (or pkg (completing-read "Package: "
240 (mapcar #'list allpkgs)
241 nil t nil pkgusr-pkg-history)))
243 (when (member pkg allpkgs)
246 (insert (shell-command-to-string (format "pinky -l %s" pkg)))
247 (goto-char (point-min))
248 (re-search-forward "Repo_Type: <?\\(.*\\)>?$" nil t)
249 (setq type (match-string 1))
250 (re-search-forward "Repo_Location: <\\(.*\\)>" nil t)
251 (setq repo (match-string 1)))
253 (message "[%s Repo] %s (%s)" pkg repo type)
256 (defun pkgusr-pkg-version (&optional pkg)
257 "Return the version of PKG as a string."
259 (let* ((allpkgs (pkgusr-all-pkgs))
260 (pkg (or pkg (completing-read "Package: "
261 (mapcar #'list allpkgs)
262 nil t nil pkgusr-pkg-history))))
263 (if (member pkg allpkgs)
266 (insert (shell-command-to-string (format "pinky -l %s" pkg)))
267 (goto-char (point-min))
268 (re-search-forward "Version: \\(.*$\\)" nil t)
270 (message "[%s Ver] %s" pkg (match-string 1))
272 (error 'pkgusr-unknown-pkg pkg))))
274 (defun pkgusr-pkg-description (&optional pkg)
275 "Return the description of PKG as a string."
277 (let* ((allpkgs (pkgusr-all-pkgs))
278 (pkg (or pkg (completing-read "Package: "
279 (mapcar #'list allpkgs)
280 nil t nil pkgusr-pkg-history))))
281 (if (member pkg allpkgs)
284 (insert (shell-command-to-string (format "pinky -l %s" pkg)))
285 (goto-char (point-min))
286 (re-search-forward "Description: \\(.*$\\)" nil t)
288 (message "[%s Desc] %s" pkg (match-string 1))
290 (error 'pkgusr-unknown-pkg pkg))))
292 ;; A little bogus perhaps, but it works. `pkgusr-find-file' is
293 ;; something that only I can use because it ssh's through root to
294 ;; get to the pkgusr. And nobody but me would have a need for
295 ;; `pkgusr-file-history' --SY.
296 (defconst pkgusr-pkgmgr "steve"
297 "The Package Manager.
299 This is a defconst for a reason... to make it a bit harder to customise.
300 Just setq'ing this in your init.el won't work if you load pkgusr.el
301 after the setq. Be bold and hard code it in pkgusr.el itself.")
303 (defmacro defun-when-pkgmgr (&rest args)
304 "Define a function only if you are the right user."
305 `(when (equal (user-login-name) pkgusr-pkgmgr)
308 (defmacro defvar-when-pkgmgr (&rest args)
309 "Define a variable only if you are the right user."
310 `(when (equal (user-login-name) pkgusr-pkgmgr)
313 (defvar-when-pkgmgr pkgusr-file-history nil
314 "History for pkgusr-find-file.")
316 (defun-when-pkgmgr pkgusr-find-file (pkgusr file)
317 "Using Tramp, find PKGUSR's FILE."
319 (unless (interactive-p)
320 (error 'invalid-operation "Trying to call interactive-only command"))
321 (let* ((allpkgs (pkgusr-all-pkgs))
322 (puser (completing-read "Package User: "
323 (mapcar #'list allpkgs)
324 nil t nil pkgusr-pkg-history))
325 (file (read-file-name (format "[%s] find file: " puser)
326 (file-name-as-directory
327 (expand-file-name puser "/usr/src"))
328 (file-name-as-directory
329 (expand-file-name puser "/usr/src"))
330 nil nil pkgusr-file-history))
331 (tpath (format "[ssh/root@localhost|su/%s@localhost]%s"
333 (default-directory "/"))
337 (global-set-key [(hyper c) c] #'pkgusr-cmd-pkg)
338 (global-set-key [(hyper c) f] #'pkgusr-file-pkg)
339 (global-set-key [(hyper c) (hyper r)] #'pkgusr-list-pkgs-regexp)
340 (global-set-key [(hyper c) d] #'pkgusr-pkg-description)
341 (global-set-key [(hyper c) g] #'pkgusr-pkg-general-notes)
342 (global-set-key [(hyper c) i] #'pkgusr-pkg-install-notes)
343 (global-set-key [(hyper c) r] #'pkgusr-pkg-repo)
344 (global-set-key [(hyper c) u] #'pkgusr-pkg-url)
345 (global-set-key [(hyper c) v] #'pkgusr-pkg-version)
346 (global-set-key [(hyper c) s] #'pkgusr-show-pkg)
349 (when (equal (user-login-name) pkgusr-pkgmgr)
350 (global-set-key [(hyper x) (hyper f)] #'pkgusr-find-file)))
353 ;;; pkgusr.el ends here