code.delx.au - gnu-emacs/blob - lisp/pcvs-util.el

   1 ;;; pcvs-util.el --- utility functions for PCL-CVS  -*- byte-compile-dynamic: t -*-
   2
   3 ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4 ;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   7 ;; Keywords: pcl-cvs
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 ;;;;
  34 ;;;; list processing
  35 ;;;;
  36
  37 (defsubst cvs-car (x) (if (consp x) (car x) x))
  38 (defalias 'cvs-cdr 'cdr-safe)
  39 (defsubst cvs-append (&rest xs)
  40   (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
  41
  42 (defsubst cvs-every (-cvs-every-f -cvs-every-l)
  43   (while (consp -cvs-every-l)
  44     (unless (funcall -cvs-every-f (pop -cvs-every-l))
  45       (setq -cvs-every-l t)))
  46   (not -cvs-every-l))
  47
  48 (defun cvs-union (xs ys)
  49   (let ((zs ys))
  50     (dolist (x xs zs)
  51       (unless (member x ys) (push x zs)))))
  52
  53 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
  54   (let ((accum ()))
  55     (while (not (cvs-every 'null -cvs-map-ls))
  56       (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
  57       (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
  58     (nreverse accum)))
  59
  60 (defun cvs-first (l &optional n)
  61   (if (null n) (car l)
  62     (when l
  63       (let* ((nl (list (pop l)))
  64              (ret nl))
  65         (while (and l (> n 1))
  66           (setcdr nl (list (pop l)))
  67           (setq nl (cdr nl))
  68           (decf n))
  69         ret))))
  70
  71 (defun cvs-partition (p l)
  72   "Partition a list L into two lists based on predicate P.
  73 The function returns a `cons' cell where the `car' contains
  74 elements of L for which P is true while the `cdr' contains
  75 the other elements.  The ordering among elements is maintained."
  76   (let (car cdr)
  77     (dolist (x l)
  78       (if (funcall p x) (push x car) (push x cdr)))
  79     (cons (nreverse car) (nreverse cdr))))
  80
  81 ;;;
  82 ;;; frame, window, buffer handling
  83 ;;;
  84
  85 (defun cvs-pop-to-buffer-same-frame (buf)
  86   "Pop to BUF like `pop-to-buffer' but staying on the same frame.
  87 If `pop-to-buffer' would have opened a new frame, this function would
  88 try to split a new window instead."
  89   (let ((pop-up-windows (or pop-up-windows pop-up-frames))
  90         (pop-up-frames nil))
  91     (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
  92         (and pop-up-windows
  93              (ignore-errors (select-window (split-window-vertically)))
  94              (switch-to-buffer buf))
  95         (pop-to-buffer (current-buffer)))))
  96
  97 (defun cvs-bury-buffer (buf &optional mainbuf)
  98   "Hide the buffer BUF that was temporarily popped up.
  99 BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
 100   (interactive (list (current-buffer)))
 101   (save-current-buffer
 102     (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
 103                  (get-buffer-window buf t))))
 104       (when win
 105         (if (window-dedicated-p win)
 106             (condition-case ()
 107                 (delete-window win)
 108               (error (iconify-frame (window-frame win))))
 109 ;;;       (if (and mainbuf (get-buffer-window mainbuf))
 110 ;;;           ;; FIXME: if the buffer popped into a pre-existing window,
 111 ;;;           ;; we don't want to delete that window.
 112 ;;;           t ;;(delete-window win)
 113 ;;;           )
 114           )))
 115     (with-current-buffer buf
 116       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 117                                 (not (window-dedicated-p (selected-window))))
 118                      buf)))
 119     (when mainbuf
 120       (let ((mainwin (or (get-buffer-window mainbuf)
 121                          (get-buffer-window mainbuf 'visible))))
 122         (when mainwin (select-window mainwin))))))
 123
 124 (defun cvs-get-buffer-create (name &optional noreuse)
 125   "Create a buffer NAME unless such a buffer already exists.
 126 If the NAME looks like an absolute file name, the buffer will be created
 127 with `create-file-buffer' and will probably get another name than NAME.
 128 In such a case, the search for another buffer with the same name doesn't
 129 use the buffer name but the buffer's `list-buffers-directory' variable.
 130 If NOREUSE is non-nil, always return a new buffer."
 131   (or (and (not (file-name-absolute-p name))
 132            (if noreuse (generate-new-buffer name)
 133              (get-buffer-create name)))
 134       (unless noreuse
 135         (dolist (buf (buffer-list))
 136           (with-current-buffer buf
 137             (when (equal name list-buffers-directory)
 138               (return buf)))))
 139       (with-current-buffer (create-file-buffer name)
 140         (set (make-local-variable 'list-buffers-directory) name)
 141         (current-buffer))))
 142
 143 ;;;;
 144 ;;;; string processing
 145 ;;;;
 146
 147 (defun cvs-insert-strings (strings)
 148   "Insert a list of STRINGS into the current buffer.
 149 Uses columns to keep the listing readable but compact."
 150   (when (consp strings)
 151     (let* ((length (apply 'max (mapcar 'length strings)))
 152            (wwidth (1- (window-width)))
 153            (columns (min
 154                      ;; At least 2 columns; at least 2 spaces between columns.
 155                      (max 2 (/ wwidth (+ 2 length)))
 156                      ;; Don't allocate more columns than we can fill.
 157                      ;; Windows can't show less than 3 lines anyway.
 158                      (max 1 (/ (length strings) 2))))
 159            (colwidth (/ wwidth columns)))
 160       ;; Use tab-width rather than indent-to.
 161       (setq tab-width colwidth)
 162       ;; The insertion should be "sensible" no matter what choices were made.
 163       (dolist (str strings)
 164         (unless (bolp)
 165           (insert " \t")
 166           (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 167             (delete-char -2) (insert "\n")))
 168         (insert str)))))
 169
 170
 171 (defun cvs-file-to-string (file &optional oneline args)
 172   "Read the content of FILE and return it as a string.
 173 If ONELINE is t, only the first line (no \\n) will be returned.
 174 If ARGS is non-nil, the file will be executed with ARGS as its
 175 arguments.  If ARGS is not a list, no argument will be passed."
 176   (condition-case nil
 177       (with-temp-buffer
 178         (if args
 179             (apply 'call-process
 180                    file nil t nil (when (listp args) args))
 181           (insert-file-contents file))
 182         (goto-char (point-min))
 183         (buffer-substring (point)
 184                           (if oneline (line-end-position) (point-max))))
 185     (file-error nil)))
 186
 187 (defun cvs-string-prefix-p (str1 str2)
 188   "Tell whether STR1 is a prefix of STR2."
 189   (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
 190
 191 ;;;;
 192 ;;;; file names
 193 ;;;;
 194
 195 (defsubst cvs-expand-dir-name (d)
 196   (file-name-as-directory (expand-file-name d)))
 197
 198 ;;;;
 199 ;;;; (interactive <foo>) support function
 200 ;;;;
 201
 202 (defstruct (cvs-qtypedesc
 203             (:constructor nil) (:copier nil)
 204             (:constructor cvs-qtypedesc-create
 205                           (str2obj obj2str &optional complete hist-sym require)))
 206   str2obj
 207   obj2str
 208   hist-sym
 209   complete
 210   require)
 211
 212
 213 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 214 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 215 (defconst cvs-qtypedesc-strings
 216   (cvs-qtypedesc-create 'split-string-and-unquote
 217                         'combine-and-quote-strings nil))
 218
 219 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 220   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 221          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 222          (complete (cvs-qtypedesc-complete qtypedesc))
 223          (completions (and (functionp complete) (funcall complete)))
 224          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 225     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 226              (cond
 227               ((null complete) (read-string prompt initval hist-sym))
 228               ((functionp complete)
 229                (completing-read prompt completions
 230                                 nil (cvs-qtypedesc-require qtypedesc)
 231                                 initval hist-sym))
 232               (t initval)))))
 233
 234 ;;;;
 235 ;;;; Flags handling
 236 ;;;;
 237
 238 (defstruct (cvs-flags
 239             (:constructor nil)
 240             (:constructor -cvs-flags-make
 241                           (desc defaults &optional qtypedesc hist-sym)))
 242   defaults persist desc qtypedesc hist-sym)
 243
 244 (defmacro cvs-flags-define (sym defaults
 245                                 &optional desc qtypedesc hist-sym docstring)
 246   `(defconst ,sym
 247      (let ((bound (boundp ',sym)))
 248        (if (and bound (cvs-flags-p ,sym)) ,sym
 249          (let ((defaults ,defaults))
 250            (-cvs-flags-make ,desc
 251                             (if bound (cons ,sym (cdr defaults)) defaults)
 252                             ,qtypedesc ,hist-sym))))
 253      ,docstring))
 254
 255 (defun cvs-flags-query (sym &optional desc arg)
 256   "Query flags based on SYM.
 257 Optional argument DESC will be used for the prompt.
 258 If ARG (or a prefix argument) is nil, just use the 0th default.
 259 If it is a non-negative integer, use the corresponding default.
 260 If it is a negative integer query for a new value of the corresponding
 261   default and return that new value.
 262 If it is \\[universal-argument], just query and return a value without
 263   altering the defaults.
 264 If it is \\[universal-argument] \\[universal-argument], behave just
 265   as if a negative zero was provided."
 266   (let* ((flags (symbol-value sym))
 267          (desc (or desc (cvs-flags-desc flags)))
 268          (qtypedesc (cvs-flags-qtypedesc flags))
 269          (hist-sym (cvs-flags-hist-sym flags))
 270          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 271          (numarg (prefix-numeric-value arg))
 272          (defaults (cvs-flags-defaults flags))
 273          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 274     ;; special case for universal-argument
 275     (when (consp arg)
 276       (setq permstr (if (> numarg 4) " (permanent)" ""))
 277       (setq numarg 0))
 278
 279     ;; sanity check
 280     (unless (< (abs numarg) (length defaults))
 281       (error "There is no %sth default" (abs numarg)))
 282
 283     (if permstr
 284         (let* ((prompt (format "%s%s: " desc permstr))
 285                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 286                                    prompt qtypedesc hist-sym)))
 287           (when (not (equal permstr ""))
 288             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 289           fs)
 290       (nth numarg defaults))))
 291
 292 (defsubst cvs-flags-set (sym index value)
 293   "Set SYM's INDEX'th setting to VALUE."
 294   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 295
 296 ;;;;
 297 ;;;; Prefix keys
 298 ;;;;
 299
 300 (defconst cvs-prefix-number 10)
 301
 302 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 303
 304 (defmacro cvs-prefix-define (sym docstring desc defaults
 305                                  &optional qtypedesc hist-sym)
 306   (let ((cps (cvs-prefix-sym sym)))
 307     `(progn
 308        (defvar ,sym nil ,(concat (or docstring "") "
 309 See `cvs-prefix-set' for further description of the behavior."))
 310        (defvar ,cps
 311          (let ((defaults ,defaults))
 312            ;; sanity ensurance
 313            (unless (>= (length defaults) cvs-prefix-number)
 314              (setq defaults (append defaults
 315                                     (make-list (1- cvs-prefix-number)
 316                                                (nth 0 defaults)))))
 317            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 318
 319 (defun cvs-prefix-make-local (sym)
 320   (let ((cps (cvs-prefix-sym sym)))
 321     (make-local-variable sym)
 322     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 323
 324 (defun cvs-prefix-set (sym arg)
 325   ;; we could distinguish between numeric and non-numeric prefix args instead of
 326   ;; relying on that magic `4'.
 327   "Set the cvs-prefix contained in SYM.
 328 If ARG is between 0 and 9, it selects the corresponding default.
 329 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 330   it queries the user and sets the -ARG'th default.
 331 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 332   the (ARG mod 10)'th prefix is made persistent.
 333 If ARG is nil toggle the PREFIX's value between its 0th default and nil
 334   and reset the persistence."
 335   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 336          (numarg (if (integerp arg) arg 0))
 337          ;; (defs (cvs-flags-defaults prefix))
 338          )
 339
 340     ;; set persistence if requested
 341     (when (> (prefix-numeric-value arg) 9)
 342       (setf (cvs-flags-persist prefix) t)
 343       (setq numarg (mod numarg 10)))
 344
 345     ;; set the value
 346     (set sym
 347          (cond
 348           ((null arg)
 349            (setf (cvs-flags-persist prefix) nil)
 350            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 351
 352           ((or (consp arg) (< numarg 0))
 353            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 354                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 355                                  (format "%s: " (cvs-flags-desc prefix))
 356                                  (cvs-flags-qtypedesc prefix)
 357                                  (cvs-flags-hist-sym prefix))))
 358           (t (nth numarg (cvs-flags-defaults prefix)))))
 359     (force-mode-line-update)))
 360
 361 (defun cvs-prefix-get (sym &optional read-only)
 362   "Return the current value of the prefix SYM.
 363 And reset it unless READ-ONLY is non-nil."
 364   (prog1 (symbol-value sym)
 365     (unless (or read-only
 366                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 367       (set sym nil)
 368       (force-mode-line-update))))
 369
 370 (provide 'pcvs-util)
 371
 372 ;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
 373 ;;; pcvs-util.el ends here