Pretty decent overhaul of the elisp tools.
[pkgusr] / lisp / pkgusr.el
1 ;; pkgusr.el --- elisp tools for LFS pkgusr package management   -*- Emacs-Lisp -*-
2
3 ;; Copyright (C) 2007 - 2014 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: <Sunday Mar 16, 2014 01:10:12 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 ;;   o Reduce code duplication through use of macros
50 ;;   o View build logs
51 ;;   o Run builds
52 ;;
53
54 ;;; Code:
55 (defvar pkgusr-pkg-history nil
56   "History for pkgusr.")
57
58 ;; Errors
59 (define-error 'pkgusr-unknown-cmd "Can't find command")
60 (define-error 'pkgusr-unknown-file "Don't recognise file")
61 (define-error 'pkgusr-unknown-pkg "Unknown package")
62
63 (defun pkgusr-all-pkgs ()
64   "Return a list of all installed packages."
65   (let ((lst (with-temp-buffer
66                (insert-file-contents "/etc/group")
67                (re-search-forward "^install:x:9999:" nil t)
68                (narrow-to-region (point) (point-at-eol))
69                (split-string-by-char (buffer-string) ?,))))
70     lst))
71
72 (defvar pkgusr-all-pkgs (pkgusr-all-pkgs)
73   "A list of all installed packages.")
74
75 (defun pkgusr-all-pkgs-update ()
76   "Update the list of installed packages."
77   (setq pkgusr-all-pkgs (pkgusr-all-pkgs)))
78
79 (defun pkgusr-pkgs-count (&optional upd-list)
80   "Return the number of installed packages.
81
82 With optional argument UPD-LIST force an update of the packages list."
83   (and upd-list
84        (pkgusr-all-pkgs-update))
85   (length pkgusr-all-pkgs))
86
87 (defun pkgusr-list-pkgs-regexp (regexp &optional upd-list)
88   "Return a list of packages matching REGEXP.
89
90 With 1 prefix arg  insert the result into the current buffer at point.
91 With 2 prefix args force update of the packages list.
92 With 3 prefix args force update and insert into buffer.
93
94 With optional argument UPD-LIST, force update of the packages list."
95   (interactive "sRegexp: \np")
96   (and (or (eq upd-list 16)
97            (eq upd-list 64))
98        (pkgusr-all-pkgs-update))
99   (let ((case-fold-search t)
100         res)
101     (mapcar
102      #'(lambda (pkg)
103          (when (string-match regexp pkg)
104            (setq res (append res (list pkg)))))
105      pkgusr-all-pkgs)
106     (if (interactive-p)
107         (cond
108          ((or (eq upd-list 4)
109               (eq upd-list 64))
110           (insert (mapconcat #'identity res " ")))
111          (t
112           (message "[Matches for \"%s\"]: %s" regexp
113                    (mapconcat #'identity res " "))))
114       res)))
115
116 (defconst pkgusr-url-regexp
117   (concat
118    #r"\(\(https?\|ftp\|rsync\|s\(cp\|sh\)\|git\)://\|file:/\|s?news:\|mailto:\)"
119    "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
120   "A regular expression matching URLs.")
121
122 (defun pkgusr-url-at-point ()
123   "Browse to a URL from the `pkgusr-show-pkg' buffer."
124   (interactive)
125   (when (extentp (extent-at (point)))
126     (browse-url (extent-string (extent-at (point))))))
127
128 (defun pkgusr-url-at-mouse (event)
129   "Browse to a URL at EVENT via the mouse from the `pkgusr-show-pkg' buffer."
130   (interactive "e")
131   (when (extentp (extent-at-event event))
132     (browse-url (extent-string (extent-at-event event)))))
133
134 (defconst pkgusr-ext-map
135   (let* ((map (make-sparse-keymap 'pkgusr-ext-map)))
136     (define-key map [button2] 'pkgusr-url-at-mouse)
137     (define-key map [return] 'pkgusr-url-at-point)
138     map)
139   "A keymap for the extents in the `pkgusr-show-pkg' buffer.")
140
141 (defun pkgusr-make-url-extents ()
142   "Create extent objects for all the URLs in the buffer."
143   (goto-char (point-min))
144   (save-excursion
145     (while (re-search-forward pkgusr-url-regexp nil t)
146       (let ((extent (make-extent (match-beginning 0) (match-end 0)))
147             (echo "RET or Button2 to visit this URL."))
148         (set-extent-property extent 'face 'bold)
149         (set-extent-property extent 'mouse-face 'highlight)
150         (set-extent-property extent 'keymap pkgusr-ext-map)
151         (set-extent-property extent 'help-echo echo)
152         (set-extent-property extent 'balloon-help echo)
153         (set-extent-property extent 'duplicable t)))))
154
155 (defun pkgusr-pkg-details (pkg)
156   (let ((buf (get-buffer-create (format "*Package Details: %s*" pkg)))
157         (detail (shell-command-to-string (format "pinky -l %s" pkg))))
158     (with-current-buffer buf
159       (erase-buffer)
160       (insert detail)
161       (pkgusr-make-url-extents))
162     (push-window-configuration)
163     (pop-to-buffer buf)
164     (view-mode nil
165                #'(lambda (b)
166                    (kill-buffer b)
167                    (pop-window-configuration)))))
168
169 (defun pkgusr-show-pkg ()
170   "Display filelist and other details for a package.
171
172 With a prefix arg, force update of the packages list."
173   (interactive)
174   (and current-prefix-arg
175        (pkgusr-all-pkgs-update))
176   (let ((pkg (completing-read "Show Package: "
177                               (mapcar #'list pkgusr-all-pkgs)
178                               nil t nil pkgusr-pkg-history)))
179     (pkgusr-pkg-details pkg)))
180
181 (defun pkgusr-pkg-install-notes ()
182   "Display the install notes of a package.
183
184 With a prefix arg, force update of the packages list."
185   (interactive)
186   (and current-prefix-arg
187        (pkgusr-all-pkgs-update))
188   (let ((pkg (completing-read "Package: "
189                               (mapcar #'list pkgusr-all-pkgs)
190                               nil t nil pkgusr-pkg-history))
191         start end)
192     (pkgusr-pkg-details pkg)
193     (re-search-forward "^Install Notes:$" nil t)
194     (setq start (point-at-bol))
195     (re-search-forward "^General Notes:$" nil t)
196     (setq end (point-at-bol))
197     (narrow-to-region start end)
198     (goto-char (point-min))))
199
200 (defun pkgusr-pkg-general-notes ()
201   "Display the general notes of a package.
202
203 With a prefix arg, force update of the packages list."
204   (interactive)
205   (and current-prefix-arg
206        (pkgusr-all-pkgs-update))
207   (let ((pkg (completing-read "Package: "
208                               (mapcar #'list pkgusr-all-pkgs)
209                               nil t nil pkgusr-pkg-history))
210         start end)
211     (pkgusr-pkg-details pkg)
212     (re-search-forward "^General Notes:$" nil t)
213     (setq start (point-at-bol))
214     (re-search-forward "^CONTENTS:$" nil t)
215     (setq end (point-at-bol))
216     (narrow-to-region start end)
217     (goto-char (point-min))))
218
219 ;;; FIXME: doesn't work for sub-groups.
220 (defun pkgusr-cmd-pkg (cmd)
221   "Display the package name \(user:group\) which contains CMD.
222
223 With a prefix arg, insert into the current buffer at point.
224
225 If non-interactive, return a list whose car is user and cdr is group."
226   (interactive "sCommand: ")
227   (let* ((cmd (or (executable-find cmd)
228                   (error 'pkgusr-unknown-cmd cmd)))
229          (user (user-login-name
230                 (nth 2 (file-attributes cmd))))
231          (group (user-login-name
232                  (nth 3 (file-attributes cmd)))))
233     (unless (or (member user pkgusr-all-pkgs)
234                 (member group pkgusr-all-pkgs))
235       (error 'pkgusr-unknown-pkg user))
236     (if (interactive-p)
237         (if current-prefix-arg
238             (insert (format "%s: (%s:%s)" cmd user group))
239           (message "Command: %s is from the \"%s\" package (%2$s:%s)"
240                    cmd user group))
241       (list user group))))
242
243 (defun pkgusr-file-pkg (file)
244   "Display the pkg name \(user:group\) which contains FILE.
245
246 With a prefix arg, insert into current buffer at point.
247
248 If non-interactive, return a list whose car is user and cdr is group."
249   (interactive "fFile: ")
250   (let ((user (user-login-name
251                (nth 2 (file-attributes file))))
252         (group (user-login-name
253                 (nth 3 (file-attributes file)))))
254     (unless (or (member user pkgusr-all-pkgs)
255                 (member group pkgusr-all-pkgs))
256       (error 'pkgusr-unknown-pkg user))
257     (if (interactive-p)
258         (if current-prefix-arg
259             (insert (format "%s: (%s:%s)" file user group))
260           (message "File: %s is from the \"%s\" package (%2$s:%s)"
261                    file user group)
262           (list user group)))))
263
264 (defun pkgusr-project-file (pkg)
265   "Return the .project file for PKG."
266   (let ((dir (paths-construct-path (list "/usr" "src" pkg))))
267     (expand-file-name ".project" dir)))
268
269 (defun pkgusr-pkg-url (&optional pkg upd-list)
270   "Return the URL of PKG as a string.
271
272 With 1 prefix arg, insert into current buffer at point.
273 With 2 prefix args, force update of the packages list.
274 With 3 prefix args, force update and insert into buffer.
275 With optional arg UPD-LIST, force update of the packages list."
276   (interactive)
277   (and (or (eq (car current-prefix-arg) 16)
278            (eq (car current-prefix-arg) 64)
279            upd-list)
280        (pkgusr-all-pkgs-update))
281   (let ((pkg (or pkg
282                  (completing-read "Package: "
283                                   (mapcar #'list pkgusr-all-pkgs)
284                                   nil t nil pkgusr-pkg-history)))
285         url)
286     (unless (member pkg pkgusr-all-pkgs)
287       (error 'pkgusr-unknown-pkg pkg))
288     (with-temp-buffer
289       (insert-file-contents (pkgusr-project-file pkg))
290       (goto-char (point-min))
291       (re-search-forward "Web_Site: <\\(.*\\)>$" nil t)
292       (setq url (match-string 1)))
293     (if (interactive-p)
294         (cond
295          ((or (eq (car current-prefix-arg) 4)
296               (eq (car current-prefix-arg) 64))
297           (insert url))
298          (t
299           (message "[URL (%s)]: %s" pkg url)))
300       url)))
301
302 (defun pkgusr-pkg-repo (&optional pkg upd-list)
303   "Return the repo URI of PKG as a string.
304
305 With 1 prefix arg, insert into current buffer at point.
306 With 2 prefix args, force update of the packages list.
307 With 3 prefix args, force update and insert into buffer.
308 With optional arg UPD-LIST, force update of the packages list."
309   (interactive)
310   (and (or (eq (car current-prefix-arg) 16)
311            (eq (car current-prefix-arg) 64)
312            upd-list)
313        (pkgusr-all-pkgs-update))
314   (let ((pkg (or pkg (completing-read "Package: "
315                                       (mapcar #'list pkgusr-all-pkgs)
316                                       nil t nil pkgusr-pkg-history)))
317         repo type)
318     (unless (member pkg pkgusr-all-pkgs)
319       (error 'pkgusr-unknown-pkg pkg))
320     (with-temp-buffer
321       (insert-file-contents (pkgusr-project-file pkg))
322       (goto-char (point-min))
323       (re-search-forward "Repo_Type: <\\(.*\\)>$" nil t)
324       (setq type (match-string 1))
325       (re-search-forward "Repo_Location: <\\(.*\\)>" nil t)
326       (setq repo (match-string 1)))
327     (if (interactive-p)
328         (cond
329          ((or (eq (car current-prefix-arg) 4)
330               (eq (car current-prefix-arg) 64))
331           (insert repo))
332          (t
333           (message "[Repo (%s)]: %s (%s)" pkg repo type)))
334       repo)))
335
336 (defun pkgusr-pkg-version (&optional pkg upd-list)
337   "Return the version of PKG as a string.
338
339 With 1 prefix arg, insert into current buffer at point.
340 With 2 prefix args, force update of the packages list.
341 With 3 prefix args, force update and insert into buffer.
342 With optional arg UPD-LIST, force update of the packages list."
343   (interactive)
344   (and (or (eq (car current-prefix-arg) 16)
345            (eq (car current-prefix-arg) 64)
346            upd-list)
347        (pkgusr-all-pkgs-update))
348   (let ((pkg (or pkg (completing-read "Package: "
349                                       (mapcar #'list pkgusr-all-pkgs)
350                                       nil t nil pkgusr-pkg-history)))
351         version)
352     (unless (member pkg pkgusr-all-pkgs)
353       (error 'pkgusr-unknown-pkg pkg))
354     (with-temp-buffer
355       (insert-file-contents (pkgusr-project-file pkg))
356       (goto-char (point-min))
357       (re-search-forward "Version: \\(.*$\\)" nil t)
358       (setq version (match-string 1)))
359     (if (interactive-p)
360         (cond
361          ((or (eq (car current-prefix-arg) 4)
362               (eq (car current-prefix-arg) 64))
363           (insert version))
364          (t
365           (message "[Version (%s)]: %s" pkg version)))
366       version)))
367
368 (defun pkgusr-pkg-description (&optional pkg upd-list)
369   "Return the description of PKG as a string.
370
371 With 1 prefix arg, insert into current buffer at point.
372 With 2 prefix args, force update of the packages list.
373 With 3 prefix args, force update and insert into buffer.
374 With optional arg UPD-LIST, force update of the packages list."
375   (interactive)
376   (and (or (eq (car current-prefix-arg) 16)
377            (eq (car current-prefix-arg) 64)
378            upd-list)
379        (pkgusr-all-pkgs-update))
380   (let ((pkg (or pkg (completing-read "Package: "
381                                       (mapcar #'list pkgusr-all-pkgs)
382                                       nil t nil pkgusr-pkg-history)))
383         desc)
384     (unless (member pkg pkgusr-all-pkgs)
385       (error 'pkgusr-unknown-pkg pkg))
386     (with-temp-buffer
387       (insert-file-contents (pkgusr-project-file pkg))
388       (goto-char (point-min))
389       (re-search-forward "Description: \\(.*$\\)" nil t)
390       (setq desc (match-string 1)))
391     (if (interactive-p)
392         (cond
393          ((or (eq (car current-prefix-arg) 4)
394               (eq (car current-prefix-arg) 64))
395           (insert desc))
396          (t
397           (message "[Description (%s)]: %s" pkg desc)))
398       desc)))
399
400 (defun pkgusr-pkg-deps (&optional pkg upd-list)
401   "Return a list of dependencies of PKG.
402
403 With 1 prefix arg, insert into current buffer at point.
404 With 2 prefix args, force update of the packages list.
405 With 3 prefix args, force update and insert into buffer.
406 With optional arg UPD-LIST, force update of the packages list."
407   (interactive)
408   (and (or (eq (car current-prefix-arg) 16)
409            (eq (car current-prefix-arg) 64)
410            upd-list)
411        (pkgusr-all-pkgs-update))
412   (let ((pkg (or pkg (completing-read "Package: "
413                                       (mapcar #'list pkgusr-all-pkgs)
414                                       nil t nil pkgusr-pkg-history)))
415         deps)
416     (unless (member pkg pkgusr-all-pkgs)
417       (error 'pkgusr-unknown-pkg pkg))
418     (with-temp-buffer
419       (insert-file-contents (pkgusr-project-file pkg))
420       (goto-char (point-min))
421       (re-search-forward "Deps: \\(.*$\\)" nil t)
422       (setq deps (match-string 1)))
423     (if (interactive-p)
424         (cond
425          ((or (eq (car current-prefix-arg) 4)
426               (eq (car current-prefix-arg) 64))
427           (insert deps))
428          (t
429           (message "[Deps (%s)]: %s" pkg deps)))
430       (split-string-by-char deps ?\ ))))
431
432 ;;; FIXME: This churns like you wouldn't believe, can we make it more
433 ;;; efficient?
434 (defun pkgusr-pkg-rdeps (&optional pkg upd-list)
435   "Return a list of packages which cite PKG as a dependency.
436
437 With 1 prefix arg, insert into current buffer at point.
438 With 2 prefix args, force update of the packages list.
439 With 3 prefix args, force update and insert into buffer.
440 With optional arg UPD-LIST, force update of the packages list."
441   (interactive)
442   (and (or (eq (car current-prefix-arg) 16)
443            (eq (car current-prefix-arg) 64)
444            upd-list)
445        (pkgusr-all-pkgs-update))
446   (let ((pkg (or pkg (completing-read "Package: "
447                                       (mapcar #'list pkgusr-all-pkgs)
448                                       nil t nil pkgusr-pkg-history)))
449         result)
450     (unless (member pkg pkgusr-all-pkgs)
451       (error 'pkgusr-unknown-pkg pkg))
452     (mapcar
453      #'(lambda (maybe-pkg)
454          (let ((deplist (pkgusr-pkg-deps maybe-pkg)))
455            (mapcar
456             #'(lambda (dep)
457                 (and (string-match pkg dep)
458                      (setq result (append result (list maybe-pkg)))))
459             deplist)))
460      pkgusr-all-pkgs)
461     (sort result #'string<)
462     (if (interactive-p)
463         (cond
464          ((or (eq (car current-prefix-arg) 4)
465               (eq (car current-prefix-arg) 64))
466           (insert (mapconcat #'identity result " ")))
467          (t
468           (message "[Reverse Deps (%s)]: %s" pkg
469                    (mapconcat #'identity result " "))))
470       result)))
471
472 ;; A little bogus perhaps, but it works.  `pkgusr-find-file' is
473 ;; something that only I can use because it ssh's through root to
474 ;; get to the pkgusr. And nobody but me would have a need for
475 ;; `pkgusr-file-history' --SY.
476 (defconst pkgusr-pkgmgr "steve"
477   "The Package Manager.
478
479 This is a defconst for a reason... to make it a bit harder to customise.
480 Just setq'ing this in your init.el won't work if you load pkgusr.el
481 after the setq.  Be bold and hard code it in pkgusr.el itself.")
482
483 (defmacro defun-when-pkgmgr (&rest args)
484   "Define a function only if you are the right user."
485   `(when (equal (user-login-name) pkgusr-pkgmgr)
486      (defun ,@args)))
487
488 (defmacro defvar-when-pkgmgr (&rest args)
489   "Define a variable only if you are the right user."
490   `(when (equal (user-login-name) pkgusr-pkgmgr)
491      (defvar ,@args)))
492
493 (defvar-when-pkgmgr pkgusr-file-history nil
494   "History for pkgusr-find-file.")
495
496 (defun-when-pkgmgr pkgusr-find-file (&optional pkgusr file)
497   "Using Tramp, find PKGUSR's FILE.
498
499 With a prefix arg, force update of the packages list."
500   (interactive)
501   (unless (interactive-p)
502     (error 'invalid-operation "Trying to call interactive-only command"))
503   (and current-prefix-arg
504        (pkgusr-all-pkgs-update))
505   (let* ((puser (completing-read "Package User: "
506                                  (mapcar #'list pkgusr-all-pkgs)
507                                  nil t nil pkgusr-pkg-history))
508          (file (read-file-name (format "[%s] find file: " puser)
509                                (file-name-as-directory
510                                 (expand-file-name puser "/usr/src"))
511                                (file-name-as-directory
512                                 (expand-file-name puser "/usr/src"))
513                                nil nil pkgusr-file-history))
514          (tpath (format "[ssh/root@localhost|su/%s@localhost]%s"
515                         puser file))
516          (default-directory "/"))
517     (find-file tpath)))
518
519 ;; Some key bindings
520 (global-set-key [(hyper c) c] #'pkgusr-cmd-pkg)
521 (global-set-key [(hyper c) f] #'pkgusr-file-pkg)
522 (global-set-key [(hyper c) (hyper r)] #'pkgusr-list-pkgs-regexp)
523 (global-set-key [(hyper c) d] #'pkgusr-pkg-description)
524 (global-set-key [(hyper c) D] #'pkgusr-pkg-deps)
525 (global-set-key [(hyper c) g] #'pkgusr-pkg-general-notes)
526 (global-set-key [(hyper c) i] #'pkgusr-pkg-install-notes)
527 (global-set-key [(hyper c) r] #'pkgusr-pkg-repo)
528 (global-set-key [(hyper c) R] #'pkgusr-pkg-rdeps)
529 (global-set-key [(hyper c) u] #'pkgusr-pkg-url)
530 (global-set-key [(hyper c) v] #'pkgusr-pkg-version)
531 (global-set-key [(hyper c) s] #'pkgusr-show-pkg)
532
533 (eval-and-compile
534   (when (equal (user-login-name) pkgusr-pkgmgr)
535     (global-set-key [(hyper x) (hyper f)] #'pkgusr-find-file)))
536
537 (provide 'pkgusr)
538 ;;; pkgusr.el ends here