nxhtml/util/udev.el

   1 ;;; udev.el --- Helper functions for updating from dev sources
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-08-24
   5 (defconst udev:version "0.5");; Version:
   6 ;; Last-Updated: 2009-01-06 Tue
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13   ;; `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'.
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  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
  22 ;; this.
  23 ;;
  24 ;; See `udev-call-first-step' for more information.  Or look in the
  25 ;; file udev-cedet.el for examples.
  26 ;;
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28 ;;
  29 ;;; Change log:
  30 ;;
  31 ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;
  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.
  38 ;;
  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.
  43 ;;
  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.
  48 ;;
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 ;;
  51 ;;; Code:
  52
  53 (eval-when-compile (require 'cl))
  54
  55 (require 'cus-edit)
  56
  57 ;;; Control/log buffer
  58
  59 (defvar udev-log-buffer nil
  60   "Log buffer pointer for sentinel function.")
  61 (make-variable-buffer-local 'udev-log-buffer)
  62
  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)
  66
  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))))
  72
  73 (defvar udev-this-chain nil)
  74 (make-variable-buffer-local 'udev-this-chain)
  75
  76 (defvar udev-last-error nil
  77   "Error found during last step.")
  78 (make-variable-buffer-local 'udev-last-error)
  79
  80 (defun udev-set-last-error (log-buffer msg)
  81   (with-current-buffer log-buffer
  82     (setq udev-last-error msg)))
  83
  84 ;;; Chain utils
  85
  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
  90     udev-this-chain))
  91
  92 (defun udev-this-step (log-buffer)
  93   "Return current function to call from LOG-BUFFER."
  94   (let ((this-chain (udev-chain log-buffer)))
  95     (caar this-chain)))
  96
  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))))
 102
 103 (defun udev-num-steps (log-buffer)
 104   "Return number of steps."
 105   (length (nth 2 (udev-chain log-buffer))))
 106
 107 (defun udev-step-num (log-buffer)
 108   "Return current step number."
 109   (let ((this-chain (udev-chain log-buffer)))
 110     (when this-chain
 111       (1+ (- (udev-num-steps log-buffer)
 112              (length (car this-chain)))))))
 113
 114 (defun udev-finish-function (log-buffer)
 115   "Return setup function to be called when finished."
 116   (nth 3 (udev-chain log-buffer)))
 117
 118
 119 (defvar udev-control-mode-map
 120   (let ((map (make-sparse-keymap)))
 121     (set-keymap-parent map button-buffer-map)
 122     map))
 123
 124 (define-derived-mode udev-control-mode nil
 125   "Udev-Src"
 126   "Mode for udev control buffer."
 127   (setq show-trailing-whitespace nil)
 128   (setq buffer-read-only t)
 129   (nxhtml-menu-mode 1))
 130
 131 ;;; Calling steps
 132
 133 ;;;###autoload
 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.
 139
 140 Write HEADER at the end of LOG-BUFFER.
 141
 142 Call first step.
 143
 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)
 148   (udev-control-mode)
 149   (setq udev-is-log-buffer t)
 150   (let ((this-chain
 151          (cons nil
 152                (cons log-buffer
 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)
 159   (widen)
 160   (goto-char (point-max))
 161   (let ((inhibit-read-only t))
 162     (unless (= (point) (point-min)) (insert "\n\n"))
 163     (insert header))
 164   (udev-call-this-step log-buffer nil)
 165   (current-buffer))
 166
 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)
 172     map))
 173
 174 (defun udev-step-at-point ()
 175   (get-text-property (point) 'udev-step))
 176
 177 (defun udev-rerun-this-step ()
 178   "Rerun this step."
 179   (interactive)
 180   (let ((this-step (udev-step-at-point)))
 181     (udev-call-this-step (current-buffer) this-step)))
 182
 183 (defun udev-continue-from-this-step ()
 184   "Continue from this step."
 185   (interactive)
 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)))
 191
 192 (defun udev-goto-this-step-source ()
 193   "Find source function for this step."
 194   (interactive)
 195   (let ((this-step (udev-step-at-point)))
 196     (find-function-other-window this-step)))
 197
 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.
 203
 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)
 209     (widen)
 210     (goto-char (point-max))
 211     (let* ((inhibit-read-only t)
 212            here
 213            buf
 214            proc)
 215       (if (not this-step)
 216           (let ((finish-fun (udev-finish-function log-buffer)))
 217             (insert (propertize "\nFinished\n" 'face 'compilation-info))
 218             (when finish-fun
 219               (funcall finish-fun log-buffer)))
 220         (insert (format "\nStep %s(%s): "
 221                         (udev-step-num log-buffer)
 222                         (udev-num-steps log-buffer)))
 223         (setq here (point))
 224         (insert (pp-to-string this-step))
 225         (setq buf (funcall this-step log-buffer))
 226         (when (bufferp buf)
 227           (make-text-button here (point)
 228                             'udev-step this-step
 229                             'keymap udev-step-keymap
 230                             'buffer buf
 231                             'help-echo "Push RET to see log buffer, <APPS> for other actions"
 232                             'action (lambda (btn)
 233                                       (display-buffer
 234                                        (button-get btn 'buffer))))
 235           (setq proc (get-buffer-process buf)))
 236         ;; Setup for next step
 237         (if (and proc
 238                  (not udev-last-error))
 239             (progn
 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")
 246           (if udev-last-error
 247               (insert " "
 248                       (propertize udev-last-error 'face 'compilation-error))
 249             (udev-call-next-step log-buffer 0 nil)))))))
 250
 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))
 259       (widen)
 260       (goto-char (point-max))
 261       (insert " ")
 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))))
 266           (progn
 267             (insert
 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))))))
 274
 275
 276 ;;; Sentinel
 277
 278 (defvar udev-orig-sentinel nil
 279   "Old sentinel function remembered by `udev-call-this-step'.")
 280 (make-variable-buffer-local 'udev-orig-sentinel)
 281
 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))
 293                  (= 0 exit-status))
 294         ;; Check for errors
 295         (let ((here (point))
 296               (err-point 1)
 297               (has-error nil))
 298           (widen)
 299           (goto-char (point-min))
 300           (setq has-error
 301                 (catch 'found-error
 302                   (while err-point
 303                     (setq err-point
 304                           (next-single-property-change err-point 'face))
 305                     (when err-point
 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)))))))
 311           (when has-error
 312             (setq exit-status 1)
 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)))
 317           (goto-char here)
 318           ))
 319       (unless (member proc compilation-in-progress)
 320         (udev-call-next-step udev-log-buffer exit-status (current-buffer))))))
 321
 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)))))
 331             (message "%s" msg)
 332             (propertize out-string
 333                         'help-echo msg 'face (if (> (cdr status) 0)
 334                                                  'compilation-error
 335                                                'compilation-info))))))
 336
 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)
 343
 344
 345 ;;; Convenience functions
 346
 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))))
 352
 353 (defvar udev-this-dir
 354   (let ((this-file (or load-file-name (buffer-file-name))))
 355     (file-name-directory this-file)))
 356
 357 (defun udev-batch-compile (emacs-args defdir name-function)
 358   "Compile elisp code in an inferior Emacs.
 359 Start Emacs with
 360
 361   emacs -Q -batch EMACS-ARGS
 362
 363 in the default directory DEFDIR.
 364
 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)))
 369     (compilation-start
 370      (concat this-emacs " -Q -batch " emacs-args)
 371      'compilation-mode
 372      name-function)))
 373
 374 ;;; Convenience functions for CVS
 375
 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)))
 381     (with-current-buffer
 382         (compilation-start
 383          (concat "cvs diff -b -u > " (shell-quote-argument "your-patches.diff"))
 384          'compilation-mode
 385          name-function)
 386       (setq udev-continue-on-error-function 'udev-cvs-diff-continue)
 387       (current-buffer))))
 388
 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
 392 CVS-DIFF-BUFFER.
 393
 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
 398     (let ((here (point))
 399           (ret t))
 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))
 411       (goto-char here)
 412       ret)))
 413
 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
 422       (widen)
 423       (let ((here (point)))
 424         (goto-char (point-min))
 425         ;; Fix-me: Better pattern:
 426         (if (search-forward "<<<<<<<" nil t)
 427             ;; Merge conflict
 428             (with-current-buffer log-buffer
 429               (let ((inhibit-read-only t))
 430                 (setq udev-last-error "Error: merge conflict")))
 431           (goto-char here))))
 432       buf))
 433
 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))
 437
 438 ;;; Misc
 439
 440 (defun udev-send-buffer-process (str)
 441   (interactive "sString to send to process: ")
 442   (let* ((procs (process-list))
 443          (proc (catch 'found
 444                  (dolist (p procs)
 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"))
 451   ))
 452
 453
 454 (provide 'udev)
 455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 456 ;;; udev.el ends here