1 ;;; udev.el --- Helper functions for updating from dev sources
3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
5 (defconst udev:version "0.5");; Version:
6 ;; Last-Updated: 2009-01-06 Tue
11 ;; Features that might be required by this library:
13 ;; `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'.
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 ;; When you want to fetch and install sources from a repository you
20 ;; may have to call several async processes and wait for the answer
21 ;; before calling the next function. These functions may help you with
24 ;; See `udev-call-first-step' for more information. Or look in the
25 ;; file udev-cedet.el for examples.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;; This program is free software; you can redistribute it and/or
35 ;; modify it under the terms of the GNU General Public License as
36 ;; published by the Free Software Foundation; either version 2, or
37 ;; (at your option) any later version.
39 ;; This program is distributed in the hope that it will be useful,
40 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
41 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
42 ;; General Public License for more details.
44 ;; You should have received a copy of the GNU General Public License
45 ;; along with this program; see the file COPYING. If not, write to
46 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
47 ;; Floor, Boston, MA 02110-1301, USA.
49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53 (eval-when-compile (require 'cl))
57 ;;; Control/log buffer
59 (defvar udev-log-buffer nil
60 "Log buffer pointer for sentinel function.")
61 (make-variable-buffer-local 'udev-log-buffer)
63 (defvar udev-is-log-buffer nil
64 "This is t if this is an udev log/control buffer.")
65 (make-variable-buffer-local 'udev-is-log-buffer)
67 (defun udev-check-is-log-buffer (buffer)
68 "Check that BUFFER is an udev log/control buffer."
69 (with-current-buffer buffer
70 (unless udev-is-log-buffer
71 (error "Internal error, not a log buffer: %s" buffer))))
73 (defvar udev-this-chain nil)
74 (make-variable-buffer-local 'udev-this-chain)
76 (defvar udev-last-error nil
77 "Error found during last step.")
78 (make-variable-buffer-local 'udev-last-error)
80 (defun udev-set-last-error (log-buffer msg)
81 (with-current-buffer log-buffer
82 (setq udev-last-error msg)))
86 (defun udev-chain (log-buffer)
87 "Return value of `udev-this-chain' in buffer LOG-BUFFER."
88 (udev-check-is-log-buffer log-buffer)
89 (with-current-buffer log-buffer
92 (defun udev-this-step (log-buffer)
93 "Return current function to call from LOG-BUFFER."
94 (let ((this-chain (udev-chain log-buffer)))
97 (defun udev-goto-next-step (log-buffer)
98 "Set next function as current in LOG-BUFFER."
99 (let* ((this-chain (udev-chain log-buffer))
100 (this-step (car this-chain)))
101 (setcar this-chain (cdr this-step))))
103 (defun udev-num-steps (log-buffer)
104 "Return number of steps."
105 (length (nth 2 (udev-chain log-buffer))))
107 (defun udev-step-num (log-buffer)
108 "Return current step number."
109 (let ((this-chain (udev-chain log-buffer)))
111 (1+ (- (udev-num-steps log-buffer)
112 (length (car this-chain)))))))
114 (defun udev-finish-function (log-buffer)
115 "Return setup function to be called when finished."
116 (nth 3 (udev-chain log-buffer)))
119 (defvar udev-control-mode-map
120 (let ((map (make-sparse-keymap)))
121 (set-keymap-parent map button-buffer-map)
124 (define-derived-mode udev-control-mode nil
126 "Mode for udev control buffer."
127 (setq show-trailing-whitespace nil)
128 (setq buffer-read-only t)
129 (nxhtml-menu-mode 1))
134 (defun udev-call-first-step (log-buffer steps header finish-fun)
135 "Set up and call first step.
136 Set up buffer LOG-BUFFER to be used for log messages and
137 controling of the execution of the functions in list STEPS which
138 are executed one after another.
140 Write HEADER at the end of LOG-BUFFER.
144 If FINISH-FUN non-nil it should be a function. This is called
145 after last step with LOG-BUFFER as parameter."
146 ;;(dolist (step steps) (unless (functionp step) (error "Not a known function: %s" step)))
147 (switch-to-buffer log-buffer)
149 (setq udev-is-log-buffer t)
153 (cons (copy-tree steps)
154 (cons finish-fun nil))))))
155 (setcar this-chain (caddr this-chain))
156 (setq udev-this-chain this-chain))
157 (assert (eq (car steps) (udev-this-step log-buffer)) t)
158 (assert (eq finish-fun (udev-finish-function log-buffer)) t)
160 (goto-char (point-max))
161 (let ((inhibit-read-only t))
162 (unless (= (point) (point-min)) (insert "\n\n"))
164 (udev-call-this-step log-buffer nil)
167 (defvar udev-step-keymap
168 (let ((map (make-sparse-keymap)))
169 (define-key map [(control ?c) ?r] 'udev-rerun-this-step)
170 (define-key map [(control ?c) ?c] 'udev-continue-from-this-step)
171 (define-key map [(control ?c) ?s] 'udev-goto-this-step-source)
174 (defun udev-step-at-point ()
175 (get-text-property (point) 'udev-step))
177 (defun udev-rerun-this-step ()
180 (let ((this-step (udev-step-at-point)))
181 (udev-call-this-step (current-buffer) this-step)))
183 (defun udev-continue-from-this-step ()
184 "Continue from this step."
186 (let ((this-step (udev-step-at-point)))
187 (goto-char (point-max))
188 (let ((inhibit-read-only t))
189 (insert (format "\n\nContinuing from %s..." this-step)))
190 (udev-call-this-step (current-buffer) this-step)))
192 (defun udev-goto-this-step-source ()
193 "Find source function for this step."
195 (let ((this-step (udev-step-at-point)))
196 (find-function-other-window this-step)))
198 (defun udev-call-this-step (log-buffer this-step)
199 "Call the current function in LOG-BUFFER.
200 If this function returns a buffer and the buffer has a process
201 then change the process sentinel to `udev-compilation-sentinel'.
202 Otherwise continue to call the next function.
204 Also put a log message in in LOG-BUFFER with a link to the buffer
205 returned above if any."
206 (setq this-step (or this-step (udev-this-step log-buffer)))
207 (with-current-buffer log-buffer
208 (setq udev-last-error nil)
210 (goto-char (point-max))
211 (let* ((inhibit-read-only t)
216 (let ((finish-fun (udev-finish-function log-buffer)))
217 (insert (propertize "\nFinished\n" 'face 'compilation-info))
219 (funcall finish-fun log-buffer)))
220 (insert (format "\nStep %s(%s): "
221 (udev-step-num log-buffer)
222 (udev-num-steps log-buffer)))
224 (insert (pp-to-string this-step))
225 (setq buf (funcall this-step log-buffer))
227 (make-text-button here (point)
229 'keymap udev-step-keymap
231 'help-echo "Push RET to see log buffer, <APPS> for other actions"
232 'action (lambda (btn)
234 (button-get btn 'buffer))))
235 (setq proc (get-buffer-process buf)))
236 ;; Setup for next step
238 (not udev-last-error))
240 (with-current-buffer buf
241 ;; Make a copy here for the sentinel function.
242 (setq udev-log-buffer log-buffer)
243 (setq udev-orig-sentinel (process-sentinel proc))
244 (set-process-sentinel proc 'udev-compilation-sentinel)))
245 ;;(message "proc is nil")
248 (propertize udev-last-error 'face 'compilation-error))
249 (udev-call-next-step log-buffer 0 nil)))))))
251 (defun udev-call-next-step (log-buffer prev-exit-status exit-status-buffer)
252 "Go to next step in LOG-BUFFER and call `udev-call-this-step'.
253 However if PREV-EXIT-STATUS \(which is the exit status from the
254 previous step) is not 0 and there is in EXIT-STATUS-BUFFER no
255 `udev-continue-on-error-function' then stop and insert an error
256 message in LOG-BUFFER."
257 (with-current-buffer log-buffer
258 (let ((inhibit-read-only t))
260 (goto-char (point-max))
262 (if (or (= 0 prev-exit-status)
263 (with-current-buffer exit-status-buffer
264 (when udev-continue-on-error-function
265 (funcall udev-continue-on-error-function exit-status-buffer))))
268 (if (= 0 prev-exit-status)
269 (propertize "Ok" 'face 'compilation-info)
270 (propertize "Warning, check next step" 'face 'compilation-warning)))
271 (udev-goto-next-step log-buffer)
272 (udev-call-this-step log-buffer nil))
273 (insert (propertize "Error" 'face 'compilation-error))))))
278 (defvar udev-orig-sentinel nil
279 "Old sentinel function remembered by `udev-call-this-step'.")
280 (make-variable-buffer-local 'udev-orig-sentinel)
282 (defun udev-compilation-sentinel (proc msg)
283 "Sentinel to use for processes started by `udev-call-this-step'.
284 Check for error messages and call next step. PROC and MSG have
285 the same meaning as for `compilation-sentinel'."
286 ;;(message "udev-compilation-sentinel proc=%s msg=%s" proc msg)
287 (let ((buf (process-buffer proc))
288 (exit-status (process-exit-status proc)))
289 (with-current-buffer buf
290 (when udev-orig-sentinel
291 (funcall udev-orig-sentinel proc msg))
292 (when (and (eq 'exit (process-status proc))
299 (goto-char (point-min))
304 (next-single-property-change err-point 'face))
306 (let ((face (get-text-property err-point 'face)))
307 (when (or (and (listp face)
308 (memq 'compilation-error face))
309 (eq 'compilation-error face))
310 (throw 'found-error t)))))))
313 (goto-char (point-max))
314 (let ((inhibit-read-only t))
315 (insert (propertize "There were errors" 'font-lock-face 'compilation-error)))
316 (udev-set-compilation-end-message buf 'exit (cons "has errors" 1)))
319 (unless (member proc compilation-in-progress)
320 (udev-call-next-step udev-log-buffer exit-status (current-buffer))))))
322 (defun udev-set-compilation-end-message (buffer process-status status)
323 "Change the message shown after compilation.
324 This is similar to `compilation-end-message' and BUFFER,
325 PROCESS-STATUS and STATUS have the same meaning as there."
326 (with-current-buffer buffer
327 (setq mode-line-process
328 (let ((out-string (format ":%s [%s]" process-status (cdr status)))
329 (msg (format "%s %s" mode-name
330 (replace-regexp-in-string "\n?$" "" (car status)))))
332 (propertize out-string
333 'help-echo msg 'face (if (> (cdr status) 0)
335 'compilation-info))))))
337 (defvar udev-continue-on-error-function nil
338 "One-time helper to resolve exit status error problem.
339 This can be used for example after calling `cvs diff' which
340 returns error exit status if there is a difference - even though
341 there does not have to be an error.")
342 (make-variable-buffer-local 'udev-continue-on-error-function)
345 ;;; Convenience functions
347 (defun udev-buffer-name (fmt log-buffer mode)
348 "Return a name for compilation buffer.
349 Use format string FMT and buffer LOG-BUFFER, but ignoring MODE."
350 (format fmt (when (buffer-live-p log-buffer)
351 (udev-this-step log-buffer))))
353 (defvar udev-this-dir
354 (let ((this-file (or load-file-name (buffer-file-name))))
355 (file-name-directory this-file)))
357 (defun udev-batch-compile (emacs-args defdir name-function)
358 "Compile elisp code in an inferior Emacs.
361 emacs -Q -batch EMACS-ARGS
363 in the default directory DEFDIR.
365 Set the buffer name for the inferior process with NAME-FUNCTION
366 by giving this to `compilation-start'."
367 (let ((default-directory (file-name-as-directory defdir))
368 (this-emacs (ourcomments-find-emacs)))
370 (concat this-emacs " -Q -batch " emacs-args)
374 ;;; Convenience functions for CVS
376 (defun udev-fetch-cvs-diff (defdir name-function)
377 "Fetch cvs diff in directory DEFDIR.
378 Put the diff in file 'your-patches.diff' in DEFDIR.
379 Give inferior buffer name with NAME-FUNCTION."
380 (let ((default-directory (file-name-as-directory defdir)))
383 (concat "cvs diff -b -u > " (shell-quote-argument "your-patches.diff"))
386 (setq udev-continue-on-error-function 'udev-cvs-diff-continue)
389 (defun udev-cvs-diff-continue (cvs-diff-buffer)
390 "Return non-nil if it is ok to continue.
391 Check the output from the `cvs diff' command in buffer
394 The cvs command exits with a failure status if there is a
395 difference, which means that it is hard to know whether there was
396 an error or just a difference. This function tries to find out."
397 (with-current-buffer cvs-diff-buffer
400 (goto-char (point-min))
401 (when (search-forward "cvs [diff aborted]" nil t) (setq ret nil))
402 (goto-char (point-min))
403 (when (search-forward "merge conflict" nil t) (setq ret t))
404 ;; From cvs co command:
405 ;; rcsmerge: warning: conflicts during merge
406 (goto-char (point-min))
407 (when (search-forward "conflicts during merge" nil t) (setq ret t))
408 ;; cvs checkout: conflicts found in emacs/lisp/startup.el
409 (goto-char (point-min))
410 (when (search-forward "conflicts found in" nil t) (setq ret t))
414 (defun udev-check-cvs-diff (diff-file log-buffer)
415 "Check cvs diff output in file DIFF-FILE for merge conflicts.
416 Return buffer containing DIFF-FILE."
417 (let ((buf (find-buffer-visiting diff-file)))
418 ;; Kill buffer to avoid question about revert.
419 (when buf (kill-buffer buf))
420 (setq buf (find-file-noselect diff-file))
421 (with-current-buffer buf
423 (let ((here (point)))
424 (goto-char (point-min))
425 ;; Fix-me: Better pattern:
426 (if (search-forward "<<<<<<<" nil t)
428 (with-current-buffer log-buffer
429 (let ((inhibit-read-only t))
430 (setq udev-last-error "Error: merge conflict")))
434 ;;(setq compilation-scroll-output t)
435 ;;(add-to-list 'compilation-error-regexp-alist 'cvs)
436 ;;(setq compilation-error-regexp-alist (delq 'cvs compilation-error-regexp-alist))
440 (defun udev-send-buffer-process (str)
441 (interactive "sString to send to process: ")
442 (let* ((procs (process-list))
445 (when (eq (process-buffer p) (current-buffer))
446 (throw 'found p))))))
447 (unless proc (error "Can't find process in buffer"))
448 ;;(message "str=%s" str)
449 ;;(message "proc=%s" proc)
450 (process-send-string proc (concat str "\n"))
455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
456 ;;; udev.el ends here