path: root/emacs.d/nxhtml/util/udev.el

;;; udev.el --- Helper functions for updating from dev sources
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Created: 2008-08-24
(defconst udev:version "0.5");; Version:
;; Last-Updated: 2009-01-06 Tue
;; URL:
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
  ;; `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; When you want to fetch and install sources from a repository you
;; may have to call several async processes and wait for the answer
;; before calling the next function.  These functions may help you with
;; this.
;;
;; See `udev-call-first-step' for more information.  Or look in the
;; file udev-cedet.el for examples.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(eval-when-compile (require 'cl))

(require 'cus-edit)

;;; Control/log buffer

(defvar udev-log-buffer nil
  "Log buffer pointer for sentinel function.")
(make-variable-buffer-local 'udev-log-buffer)

(defvar udev-is-log-buffer nil
  "This is t if this is an udev log/control buffer.")
(make-variable-buffer-local 'udev-is-log-buffer)

(defun udev-check-is-log-buffer (buffer)
  "Check that BUFFER is an udev log/control buffer."
  (with-current-buffer buffer
    (unless udev-is-log-buffer
      (error "Internal error, not a log buffer: %s" buffer))))

(defvar udev-this-chain nil)
(make-variable-buffer-local 'udev-this-chain)

(defvar udev-last-error nil
  "Error found during last step.")
(make-variable-buffer-local 'udev-last-error)

(defun udev-set-last-error (log-buffer msg)
  (with-current-buffer log-buffer
    (setq udev-last-error msg)))

;;; Chain utils

(defun udev-chain (log-buffer)
  "Return value of `udev-this-chain' in buffer LOG-BUFFER."
  (udev-check-is-log-buffer log-buffer)
  (with-current-buffer log-buffer
    udev-this-chain))

(defun udev-this-step (log-buffer)
  "Return current function to call from LOG-BUFFER."
  (let ((this-chain (udev-chain log-buffer)))
    (caar this-chain)))

(defun udev-goto-next-step (log-buffer)
  "Set next function as current in LOG-BUFFER."
  (let* ((this-chain (udev-chain log-buffer))
        (this-step (car this-chain)))
    (setcar this-chain (cdr this-step))))

(defun udev-num-steps (log-buffer)
  "Return number of steps."
  (length (nth 2 (udev-chain log-buffer))))

(defun udev-step-num (log-buffer)
  "Return current step number."
  (let ((this-chain (udev-chain log-buffer)))
    (when this-chain
      (1+ (- (udev-num-steps log-buffer)
             (length (car this-chain)))))))

(defun udev-finish-function (log-buffer)
  "Return setup function to be called when finished."
  (nth 3 (udev-chain log-buffer)))


(defvar udev-control-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map button-buffer-map)
    map))

(define-derived-mode udev-control-mode nil
  "Udev-Src"
  "Mode for udev control buffer."
  (setq show-trailing-whitespace nil)
  (setq buffer-read-only t)
  (nxhtml-menu-mode 1))

;;; Calling steps

;;;###autoload
(defun udev-call-first-step (log-buffer steps header finish-fun)
  "Set up and call first step.
Set up buffer LOG-BUFFER to be used for log messages and
controling of the execution of the functions in list STEPS which
are executed one after another.

Write HEADER at the end of LOG-BUFFER.

Call first step.

If FINISH-FUN non-nil it should be a function. This is called
after last step with LOG-BUFFER as parameter."
  ;;(dolist (step steps) (unless (functionp step) (error "Not a known function: %s" step)))
  (switch-to-buffer log-buffer)
  (udev-control-mode)
  (setq udev-is-log-buffer t)
  (let ((this-chain
         (cons nil
               (cons log-buffer
                     (cons (copy-tree steps)
                           (cons finish-fun nil))))))
    (setcar this-chain (caddr this-chain))
    (setq udev-this-chain this-chain))
  (assert (eq (car steps) (udev-this-step log-buffer)) t)
  (assert (eq finish-fun (udev-finish-function log-buffer)) t)
  (widen)
  (goto-char (point-max))
  (let ((inhibit-read-only t))
    (unless (= (point) (point-min)) (insert "\n\n"))
    (insert header))
  (udev-call-this-step log-buffer nil)
  (current-buffer))

(defvar udev-step-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map [(control ?c) ?r] 'udev-rerun-this-step)
    (define-key map [(control ?c) ?c] 'udev-continue-from-this-step)
    (define-key map [(control ?c) ?s] 'udev-goto-this-step-source)
    map))

(defun udev-step-at-point ()
  (get-text-property (point) 'udev-step))

(defun udev-rerun-this-step ()
  "Rerun this step."
  (interactive)
  (let ((this-step (udev-step-at-point)))
    (udev-call-this-step (current-buffer) this-step)))

(defun udev-continue-from-this-step ()
  "Continue from this step."
  (interactive)
  (let ((this-step (udev-step-at-point)))
    (goto-char (point-max))
    (let ((inhibit-read-only t))
      (insert (format "\n\nContinuing from %s..." this-step)))
    (udev-call-this-step (current-buffer) this-step)))

(defun udev-goto-this-step-source ()
  "Find source function for this step."
  (interactive)
  (let ((this-step (udev-step-at-point)))
    (find-function-other-window this-step)))

(defun udev-call-this-step (log-buffer this-step)
  "Call the current function in LOG-BUFFER.
If this function returns a buffer and the buffer has a process
then change the process sentinel to `udev-compilation-sentinel'.
Otherwise continue to call the next function.

Also put a log message in in LOG-BUFFER with a link to the buffer
returned above if any."
  (setq this-step (or this-step (udev-this-step log-buffer)))
  (with-current-buffer log-buffer
    (setq udev-last-error nil)
    (widen)
    (goto-char (point-max))
    (let* ((inhibit-read-only t)
           here
           buf
           proc)
      (if (not this-step)
          (let ((finish-fun (udev-finish-function log-buffer)))
            (insert (propertize "\nFinished\n" 'face 'compilation-info))
            (when finish-fun
              (funcall finish-fun log-buffer)))
        (insert (format "\nStep %s(%s): "
                        (udev-step-num log-buffer)
                        (udev-num-steps log-buffer)))
        (setq here (point))
        (insert (pp-to-string this-step))
        (setq buf (funcall this-step log-buffer))
        (when (bufferp buf)
          (make-text-button here (point)
                            'udev-step this-step
                            'keymap udev-step-keymap
                            'buffer buf
                            'help-echo "Push RET to see log buffer, <APPS> for other actions"
                            'action (lambda (btn)
                                      (display-buffer
                                       (button-get btn 'buffer))))
          (setq proc (get-buffer-process buf)))
        ;; Setup for next step
        (if (and proc
                 (not udev-last-error))
            (progn
              (with-current-buffer buf
                ;; Make a copy here for the sentinel function.
                (setq udev-log-buffer log-buffer)
                (setq udev-orig-sentinel (process-sentinel proc))
                (set-process-sentinel proc 'udev-compilation-sentinel)))
          ;;(message "proc is nil")
          (if udev-last-error
              (insert " "
                      (propertize udev-last-error 'face 'compilation-error))
            (udev-call-next-step log-buffer 0 nil)))))))

(defun udev-call-next-step (log-buffer prev-exit-status exit-status-buffer)
  "Go to next step in LOG-BUFFER and call `udev-call-this-step'.
However if PREV-EXIT-STATUS \(which is the exit status from the
previous step) is not 0 and there is in EXIT-STATUS-BUFFER no
`udev-continue-on-error-function' then stop and insert an error
message in LOG-BUFFER."
  (with-current-buffer log-buffer
    (let ((inhibit-read-only t))
      (widen)
      (goto-char (point-max))
      (insert " ")
      (if (or (= 0 prev-exit-status)
              (with-current-buffer exit-status-buffer
                (when udev-continue-on-error-function
                  (funcall udev-continue-on-error-function exit-status-buffer))))
          (progn
            (insert
             (if (= 0 prev-exit-status)
                 (propertize "Ok" 'face 'compilation-info)
               (propertize "Warning, check next step" 'face 'compilation-warning)))
            (udev-goto-next-step log-buffer)
            (udev-call-this-step log-buffer nil))
        (insert (propertize "Error" 'face 'compilation-error))))))


;;; Sentinel

(defvar udev-orig-sentinel nil
  "Old sentinel function remembered by `udev-call-this-step'.")
(make-variable-buffer-local 'udev-orig-sentinel)

(defun udev-compilation-sentinel (proc msg)
  "Sentinel to use for processes started by `udev-call-this-step'.
Check for error messages and call next step.  PROC and MSG have
the same meaning as for `compilation-sentinel'."
  ;;(message "udev-compilation-sentinel proc=%s msg=%s" proc msg)
  (let ((buf (process-buffer proc))
        (exit-status (process-exit-status proc)))
    (with-current-buffer buf
      (when udev-orig-sentinel
        (funcall udev-orig-sentinel proc msg))
      (when (and (eq 'exit (process-status proc))
                 (= 0 exit-status))
        ;; Check for errors
        (let ((here (point))
              (err-point 1)
              (has-error nil))
          (widen)
          (goto-char (point-min))
          (setq has-error
                (catch 'found-error
                  (while err-point
                    (setq err-point
                          (next-single-property-change err-point 'face))
                    (when err-point
                      (let ((face (get-text-property err-point 'face)))
                        (when (or (and (listp face)
                                       (memq 'compilation-error face))
                                  (eq 'compilation-error face))
                          (throw 'found-error t)))))))
          (when has-error
            (setq exit-status 1)
            (goto-char (point-max))
            (let ((inhibit-read-only t))
              (insert (propertize "There were errors" 'font-lock-face 'compilation-error)))
            (udev-set-compilation-end-message buf 'exit (cons "has errors" 1)))
          (goto-char here)
          ))
      (unless (member proc compilation-in-progress)
        (udev-call-next-step udev-log-buffer exit-status (current-buffer))))))

(defun udev-set-compilation-end-message (buffer process-status status)
  "Change the message shown after compilation.
This is similar to `compilation-end-message' and BUFFER,
PROCESS-STATUS and STATUS have the same meaning as there."
  (with-current-buffer buffer
    (setq mode-line-process
          (let ((out-string (format ":%s [%s]" process-status (cdr status)))
                (msg (format "%s %s" mode-name
                             (replace-regexp-in-string "\n?$" "" (car status)))))
            (message "%s" msg)
            (propertize out-string
                        'help-echo msg 'face (if (> (cdr status) 0)
                                                 'compilation-error
                                               'compilation-info))))))

(defvar udev-continue-on-error-function nil
  "One-time helper to resolve exit status error problem.
This can be used for example after calling `cvs diff' which
returns error exit status if there is a difference - even though
there does not have to be an error.")
(make-variable-buffer-local 'udev-continue-on-error-function)


;;; Convenience functions

(defun udev-buffer-name (fmt log-buffer mode)
  "Return a name for compilation buffer.
Use format string FMT and buffer LOG-BUFFER, but ignoring MODE."
  (format fmt (when (buffer-live-p log-buffer)
                (udev-this-step log-buffer))))

(defvar udev-this-dir
  (let ((this-file (or load-file-name (buffer-file-name))))
    (file-name-directory this-file)))

(defun udev-batch-compile (emacs-args defdir name-function)
  "Compile elisp code in an inferior Emacs.
Start Emacs with

  emacs -Q -batch EMACS-ARGS

in the default directory DEFDIR.

Set the buffer name for the inferior process with NAME-FUNCTION
by giving this to `compilation-start'."
  (let ((default-directory (file-name-as-directory defdir))
        (this-emacs (ourcomments-find-emacs)))
    (compilation-start
     (concat this-emacs " -Q -batch " emacs-args)
     'compilation-mode
     name-function)))

;;; Convenience functions for CVS

(defun udev-fetch-cvs-diff (defdir name-function)
  "Fetch cvs diff in directory DEFDIR.
Put the diff in file 'your-patches.diff' in DEFDIR.
Give inferior buffer name with NAME-FUNCTION."
  (let ((default-directory (file-name-as-directory defdir)))
    (with-current-buffer
        (compilation-start
         (concat "cvs diff -b -u > " (shell-quote-argument "your-patches.diff"))
         'compilation-mode
         name-function)
      (setq udev-continue-on-error-function 'udev-cvs-diff-continue)
      (current-buffer))))

(defun udev-cvs-diff-continue (cvs-diff-buffer)
  "Return non-nil if it is ok to continue.
Check the output from the `cvs diff' command in buffer
CVS-DIFF-BUFFER.

The cvs command exits with a failure status if there is a
difference, which means that it is hard to know whether there was
an error or just a difference.  This function tries to find out."
  (with-current-buffer cvs-diff-buffer
    (let ((here (point))
          (ret t))
      (goto-char (point-min))
      (when (search-forward "cvs [diff aborted]" nil t) (setq ret nil))
      (goto-char (point-min))
      (when (search-forward "merge conflict" nil t) (setq ret t))
      ;; From cvs co command:
      ;; rcsmerge: warning: conflicts during merge
      (goto-char (point-min))
      (when (search-forward "conflicts during merge" nil t) (setq ret t))
      ;; cvs checkout: conflicts found in emacs/lisp/startup.el
      (goto-char (point-min))
      (when (search-forward "conflicts found in" nil t) (setq ret t))
      (goto-char here)
      ret)))

(defun udev-check-cvs-diff (diff-file log-buffer)
  "Check cvs diff output in file DIFF-FILE for merge conflicts.
Return buffer containing DIFF-FILE."
  (let ((buf (find-buffer-visiting diff-file)))
    ;; Kill buffer to avoid question about revert.
    (when buf (kill-buffer buf))
    (setq buf (find-file-noselect diff-file))
    (with-current-buffer buf
      (widen)
      (let ((here (point)))
        (goto-char (point-min))
        ;; Fix-me: Better pattern:
        (if (search-forward "<<<<<<<" nil t)
            ;; Merge conflict
            (with-current-buffer log-buffer
              (let ((inhibit-read-only t))
                (setq udev-last-error "Error: merge conflict")))
          (goto-char here))))
      buf))

;;(setq compilation-scroll-output t)
;;(add-to-list 'compilation-error-regexp-alist 'cvs)
;;(setq compilation-error-regexp-alist (delq 'cvs compilation-error-regexp-alist))

;;; Misc

(defun udev-send-buffer-process (str)
  (interactive "sString to send to process: ")
  (let* ((procs (process-list))
         (proc (catch 'found
                 (dolist (p procs)
                   (when (eq (process-buffer p) (current-buffer))
                     (throw 'found p))))))
    (unless proc (error "Can't find process in buffer"))
    ;;(message "str=%s" str)
    ;;(message "proc=%s" proc)
    (process-send-string proc (concat str "\n"))
  ))


(provide 'udev)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; udev.el ends here