cgit.sxemacs.org Git - packages/blob - xemacs-packages/patcher/lisp/patcher-util.el

   1 ;;; patcher-util.el --- General utilities
   2
   3 ;; Copyright (C) 2008, 2009, 2010 Didier Verna
   4 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Didier Verna
   5
   6 ;; Author:        Didier Verna <didier@xemacs.org>
   7 ;; Maintainer:    Didier Verna <didier@xemacs.org>
   8 ;; Created:       Sat Feb 13 14:31:32 2010
   9 ;; Last Revision: Fri Dec  2 22:06:27 2011
  10 ;; Keywords:      maint
  11
  12
  13 ;; This file is part of Patcher.
  14
  15 ;; Patcher is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License version 3,
  17 ;; as published by the Free Software Foundation.
  18
  19 ;; Patcher is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; if not, write to the Free Software
  26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28
  29 ;;; Commentary:
  30
  31 ;; Contents management by FCM version 0.1.
  32
  33
  34 ;;; Code:
  35
  36 (require 'cl)
  37
  38 (eval-when-compile (require 'patcher-cutil))
  39
  40
  41 \f
  42 ;; ===========================================================================
  43 ;; 21.4 Backward compatibility
  44 ;; ===========================================================================
  45
  46 ;; Byte compilation warnings =================================================
  47
  48 (unless (fboundp 'with-fboundp)
  49   (defmacro* with-fboundp (functions &body body)
  50     `(progn ,@body)))
  51
  52 (unless (fboundp 'with-boundp)
  53   (defmacro* with-boundp (variables &body body)
  54     `(progn ,@body)))
  55
  56 (unless (fboundp 'declare-fboundp)
  57   (defmacro declare-fboundp (form)
  58     `(progn ,form)))
  59
  60 (unless (fboundp 'declare-boundp)
  61   (defmacro declare-boundp (form)
  62     `(progn ,form)))
  63
  64 (unless (fboundp 'globally-declare-boundp)
  65   (defmacro globally-declare-boundp (variables)
  66     (setq variables (eval variables))
  67     (if (not (consp variables))
  68         (setq variables (list variables)))
  69     `(progn
  70       ,@(mapcar #'(lambda (sym) `(defvar ,sym)) variables))))
  71
  72
  73
  74 \f
  75 ;; ===========================================================================
  76 ;; General utilities
  77 ;; ===========================================================================
  78
  79 (defun patcher-symbol (symbol)
  80   ;; Return SYMBOL prefixed with `patcher-'.
  81   (intern (concat "patcher-" (symbol-name symbol))))
  82
  83 (defmacro patcher-endpush (value location)
  84   ;; Like PUSH, but at the end.
  85   `(setf ,location (nconc ,location (list ,value))))
  86
  87 ;; Hacked from read-number.
  88 (defun* patcher-read-natnum
  89     (prompt &optional default-value (min 1)
  90             &aux (pred (lambda (val) (and (integerp val) (>= val min))))
  91                  num)
  92   ;; Read a natural number from the minibuffer, prompting with PROMPT.
  93   ;; If optional second argument DEFAULT-VALUE is non-nil, return that if user
  94   ;; enters an empty line.
  95   ;; MIN (1 by default) specifies the lowest permissible value.
  96   (while (not (funcall pred num))
  97     (setq num (condition-case ()
  98                   (let ((minibuffer-completion-table nil))
  99                     (read-from-minibuffer
 100                      prompt (if num (prin1-to-string num)) nil t
 101                      nil nil (when default-value
 102                                (prin1-to-string default-value))))
 103                 (input-error nil)
 104                 (invalid-read-syntax nil)
 105                 (end-of-file nil)))
 106     (or (funcall pred num) (beep)))
 107   num)
 108
 109 ;; Hacked from y-or-n-p-minibuf. Isn't there something to do this already ??
 110 (defun patcher-read-char (prompt chars)
 111   ;; PROMPT for one character from CHARS in the minibuffer.
 112   (save-excursion
 113     (let* ((pre "")
 114            (answer (concat "(" chars ") "))
 115            event)
 116       (while (stringp answer)
 117         (if (let ((cursor-in-echo-area t)
 118                   (inhibit-quit t))
 119               (message "%s%s%s" pre prompt answer)
 120               (setq event (next-command-event event))
 121               (condition-case nil
 122                   (prog1
 123                       (or quit-flag (eq 'keyboard-quit (key-binding event)))
 124                     (setq quit-flag nil))
 125                 (wrong-type-argument t)))
 126             (progn
 127               (message "%s%s%s%s" pre prompt answer
 128                        (single-key-description event))
 129               (setq quit-flag nil)
 130               (signal 'quit '())))
 131         (let* ((keys (events-to-keys (vector event))))
 132           (cond ((and (= (length keys) 1)
 133                       (find (string-to-char keys) chars))
 134                  (message "%s%s%s" prompt answer keys)
 135                  (setq answer (string-to-char keys)))
 136                 ((button-release-event-p event) ; ignore them
 137                  nil)
 138                 (t
 139                  (message "%s%s%s%s" pre prompt answer
 140                           (single-key-description event))
 141                  (ding nil 'y-or-n-p)
 142                  (discard-input)
 143                  (when (= (length pre) 0)
 144                    (setq pre (format "Please answer one of %s.  " chars)))))))
 145       answer)))
 146
 147 (put 'patcher-list= 'lisp-indent-function 2)
 148 (defun* patcher-list=
 149     (list1 list2
 150      &key (test #'eql)
 151      &aux spurious (missing (copy-list list2)) common)
 152   ;; Compare LIST1 to LIST2 using TEST to compare elements (EQL by default).
 153   ;; Return 4 values: whether the two lists contain exactly the same elements
 154   ;; (regardless of their order), the list of spurious elements in LIST1, the
 155   ;; list of missing elements in LIST1 and the list of common elements.
 156   (dolist (elt list1 (values (and (not spurious) (not missing))
 157                              spurious
 158                              missing
 159                              common))
 160     (if (member* elt list2 :test test)
 161         (progn
 162           (push elt common)
 163           (setq missing (delete* elt missing :count 1 :test test)))
 164       (patcher-endpush elt spurious))))
 165
 166 ;; #### NOTE: this function is currently only used as a gross hack to make
 167 ;; hooks project-specific. Otherwise, we would need to refcount them in case
 168 ;; overlapping instances have hooks in common. However, it might turn out one
 169 ;; day that some hooks actually like having the patcher-project variable set,
 170 ;; I don't know.
 171 (defun patcher-wrap-hook (project hook)
 172   ;; Return a lambda expression wrapping a call to HOOK.
 173   ;; The call is wrapped in a dynamic biding of patcher-project.
 174   `(lambda ()
 175     (let ((patcher-project ,project))
 176       (,hook))))
 177
 178
 179
 180 \f
 181 ;; ===========================================================================
 182 ;; Messaging
 183 ;; ===========================================================================
 184
 185 (defun patcher-message (msg &rest args)
 186   ;; Print a message, letting XEmacs time to display it.  Also, handle command
 187   ;; substitution.
 188   (message (substitute-command-keys (apply #'format msg args)))
 189   (save-current-buffer
 190     ;; sit-for may change the current buffer and we don't want that.
 191     (sit-for 0)))
 192
 193 (defun patcher-warning (msg &rest args)
 194   ;; Like `patcher-message, but triggers a Patcher warning instead.
 195   (warn (substitute-command-keys (apply #'format msg args))))
 196
 197
 198 (put 'patcher-with-progression 'lisp-indent-function 1)
 199 (defmacro* patcher-with-progression (msg &body body)
 200   ;; Wrap BODY in "msg..." / "msg...done" messages.
 201   ;; Return the value of BODY execution.
 202   `(prog2
 203        (patcher-message (concat ,msg "... please wait."))
 204        (progn ,@body)
 205      (patcher-message (concat ,msg "... done."))))
 206
 207 (put 'patcher-with-message 'lisp-indent-function 1)
 208 (defmacro* patcher-with-message (message &body body)
 209   ;; Display MESSAGE in a temporary buffer and execute BODY.
 210   ;; Command keys in MESSAGE are substituted first.
 211   (let ((msg (gensym "msg")))
 212     `(save-window-excursion
 213       (save-excursion
 214         (let ((,msg (substitute-command-keys ,message)))
 215           (with-output-to-temp-buffer " *Patcher Message*"
 216             (set-buffer " *Patcher Message*")
 217             (insert ,msg)))
 218         ,@body))))
 219
 220 (defun patcher-modal-message (message)
 221   ;; Display MESSAGE and wait for user acknowledgment.
 222   (patcher-with-message message
 223     (read-string "Type return to proceed.")))
 224
 225
 226
 227 \f
 228 ;; ===========================================================================
 229 ;; Error management
 230 ;; ===========================================================================
 231
 232 (define-error 'patcher
 233   "Root of the Patcher error hierarchy.")
 234
 235 (put 'patcher-define-error 'lisp-indent-function 1)
 236 (defun* patcher-define-error
 237     (error-symbol
 238      &optional docstring (super-error 'patcher super-error-given-p))
 239   ;; Define a new Patcher error named PATCHER-<ERROR-SYMBOL>.
 240   ;; Optionally provide a DOCSTRING.
 241   ;; Define the error as a sub-error of SUPER-ERROR (PATCHER by default).
 242   (when super-error-given-p
 243     (setq super-error (patcher-symbol super-error)))
 244   (define-error (patcher-symbol error-symbol) docstring super-error))
 245
 246 (defun patcher-error (error &rest data)
 247   ;; Signal patcher ERROR with DATA.
 248   ;; #### WARNING: temporary compatibility hack.
 249   (if (stringp error)
 250       (error (substitute-command-keys (apply #'format error data)))
 251     (apply #'error (patcher-symbol error) data)))
 252
 253 (put 'patcher-condition-case 'lisp-indent-function 2)
 254 (defmacro* patcher-condition-case (var bodyform &rest handlers)
 255   ;; Like condition-case, but prefix condition names with patcher-.
 256   `(condition-case ,var ,bodyform
 257     ,@(mapcar (lambda (handler)
 258                 (cons (patcher-symbol (car handler))
 259                       (cdr handler)))
 260               handlers)))
 261
 262 (defun patcher-display-error-message (message)
 263   ;; Display MESSAGE, beep and wait for user acknowledgment.
 264   (patcher-with-message message
 265     (beep)
 266     (read-string "Type return to proceed.")))
 267
 268
 269
 270 \f
 271 ;; ===========================================================================
 272 ;; Files and buffers
 273 ;; ===========================================================================
 274
 275 (defun* patcher-file-buffer
 276     (file &optional find
 277           &aux (existing (get-file-buffer file))
 278                (buffer (or existing
 279                            (when find
 280                              (find-file-noselect file)))))
 281   ;; Find a buffer visiting FILE.
 282   ;; Return 2 values: a buffer visiting FILE and a boolean indicating whether
 283   ;; FILE was already visited. If FILE is not visited, return nil unless FIND,
 284   ;; in which case force visiting.
 285   (values buffer existing))
 286
 287 (defun* patcher-file-relative-name (file &optional (dir default-directory))
 288   ;; Construct a filename from FILE relative to DIR.
 289   (file-relative-name (expand-file-name file (expand-file-name dir))
 290                       (expand-file-name dir)))
 291
 292 (defun patcher-files-string (files)
 293   ;; Convert FILES to a string of relative file names.
 294   (mapconcat #'patcher-file-relative-name files " "))
 295
 296 (defun patcher-buffers-string (buffers)
 297   ;; Convert BUFFERS file names to a string of relative file names.
 298   (patcher-files-string (mapcar #'buffer-file-name buffers)))
 299
 300 (defun patcher-sort-files (files)
 301   ;; Sort FILES by lexicographic order.
 302   (sort (copy-list files) #'string<))
 303
 304 (defun patcher-save-buffer (buffer &optional force)
 305   ;; Offer to save BUFFER, or FORCE saving.
 306   (when (and (buffer-modified-p buffer)
 307              (not (buffer-base-buffer buffer))
 308              (buffer-file-name buffer)
 309              (or force
 310                  (save-window-excursion
 311                    (display-buffer buffer)
 312                    (y-or-n-p
 313                     (format "Save %s? "
 314                         (patcher-file-relative-name
 315                          (buffer-file-name buffer)))))))
 316     (save-excursion
 317       (set-buffer buffer)
 318       (condition-case ()
 319           (save-buffer)
 320         (error nil)))))
 321
 322 (defun patcher-save-buffers (buffers &optional force)
 323   ;; Offer to save some BUFFERS, or FORCE saving.
 324   (dolist (buffer buffers)
 325     (patcher-save-buffer buffer force)))
 326
 327
 328
 329 \f
 330 ;; ===========================================================================
 331 ;; Extents
 332 ;; ===========================================================================
 333
 334 ;; #### WARNING: dynamic scoping fuckage at places. MAPCAR-EXTENTS uses some
 335 ;; PROPERTY and VALUE arguments so I need other names in BODIES and
 336 ;; PREDICATES.
 337
 338 (put 'patcher-mapcar-extents 'lisp-indent-function 1)
 339 (defmacro* patcher-mapcar-extents
 340     ((extent property &key predicate here value) &body body)
 341   ;; Map BODY over all extents having patcher-PROPERTY in HERE.
 342   ;; Bind EXTENT to every extent in turn.
 343   ;; Optionally restrict patcher-PROPERTY to have VALUE.
 344   ;; If HERE is a buffer and narrowing is in effect, restrict to the narrowed
 345   ;; region.
 346   `(mapcar-extents (lambda (,extent) ,@body)
 347     ,predicate
 348     ,here
 349     (and (or (null ,here) (bufferp ,here))
 350      (point-min ,here))
 351     (and (or (null ,here) (bufferp ,here))
 352      (point-max ,here))
 353     nil (patcher-symbol ,property) ,value))
 354
 355 (defun patcher-collect-extents-property (property &optional here)
 356   ;; Collect the values of patcher-PROPERTY from all extents in HERE.
 357   (let ((dynamic-scoping-sucks-bones (patcher-symbol property)))
 358     (patcher-mapcar-extents (extent property :here here)
 359       (extent-property extent dynamic-scoping-sucks-bones))))
 360
 361 (put 'patcher-extents 'lisp-indent-function 1)
 362 (defun* patcher-extents (property &key value (test #'eq) here)
 363   ;; Get all extents having patcher-PROPERTY equal to VALUE by TEST in HERE.
 364   (if (eq test #'eq)
 365       (mapcar-extents #'identity
 366         nil here nil nil nil (patcher-symbol property) value)
 367     (let ((dynamic-scoping-sucks-bones (patcher-symbol property))
 368           (dynamic-scoping-sucks-bones-big-time value))
 369       (mapcar-extents #'identity
 370         (lambda (extent)
 371           (funcall test
 372                    (extent-property extent dynamic-scoping-sucks-bones)
 373                    dynamic-scoping-sucks-bones-big-time))
 374         here))))
 375
 376 (put 'patcher-extent 'lisp-indent-function 1)
 377 (defun* patcher-extent (property &key value (test #'eq) here)
 378   ;; Get the first extent having patcher-PROPERTY equal to VALUE by TEST in
 379   ;; HERE.
 380   (car (patcher-extents property :value value :test test :here here)))
 381
 382 (defun patcher-delete-extent (extent)
 383   ;; Delete EXTENT.
 384   ;; Return t an extent has actually been deleted.
 385   (when extent
 386     (delete-extent extent)
 387     t))
 388
 389 (defun patcher-delete-extent-and-region (extent)
 390   ;; Delete EXTENT and the corresponding region.
 391   ;; Return t an extent has actually been deleted.
 392   (when extent
 393     (delete-region (extent-start-position extent) (extent-end-position extent)
 394                    (extent-object extent))
 395     (delete-extent extent)
 396     t))
 397
 398 (put 'patcher-within-extent 'lisp-indent-function 1)
 399 (defmacro* patcher-within-extent ((extent property) &body body)
 400   ;; Find an extent having the patcher-PROPERTY set, execute BODY in it.
 401   ;; EXTENT is bound to the extent when BODY is executed.
 402   ;; Start-close EXTENT around BODY so that insertion is possible.
 403   `(let ((,extent (patcher-extent ,property)))
 404     (when ,extent
 405       (save-excursion
 406         (goto-char (extent-start-position ,extent))
 407         (set-extent-property ,extent 'start-open nil)
 408         ,@body
 409         (set-extent-property ,extent 'start-open t)))))
 410
 411
 412
 413 \f
 414 ;; ===========================================================================
 415 ;; Processes
 416 ;; ===========================================================================
 417
 418 (patcher-define-error 'process
 419   "Patcher process error.")
 420
 421 (defun* patcher-call-process
 422     (command &optional (progression (format "Running `%s'" command))
 423                        ignore-exit-status)
 424   ;; Call a shell process to execute COMMAND.
 425   ;; Make people wait with PROGRESSION message.
 426   ;; Process output goes to current buffer, before current point.
 427   ;; Return point delimiting the end of the process output.
 428   ;; Throw a PATCHER-PROCESS error for non-zero exit status.
 429   (patcher-with-progression progression
 430     (unless (or (zerop (funcall #'call-process shell-file-name
 431                                 nil t nil shell-command-switch command))
 432                 ignore-exit-status)
 433       (patcher-error 'process command)))
 434   (point))
 435
 436
 437 (provide 'patcher-util)
 438
 439 ;;; patcher-util.el ends here