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,92,93,94,95,96,97,98,99, 2000,01,04
   4 ;;  Free Software Foundation, Inc.
   5
   6 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
   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 2, 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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, 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   (unless (cvs-every 'null -cvs-map-ls)
  55     (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
  56           (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls)))))
  57
  58 (defun cvs-first (l &optional n)
  59   (if (null n) (car l)
  60     (when l
  61       (let* ((nl (list (pop l)))
  62              (ret nl))
  63         (while (and l (> n 1))
  64           (setcdr nl (list (pop l)))
  65           (setq nl (cdr nl))
  66           (decf n))
  67         ret))))
  68
  69 (defun cvs-partition (p l)
  70   "Partition a list L into two lists based on predicate P.
  71 The function returns a `cons' cell where the `car' contains
  72 elements of L for which P is true while the `cdr' contains
  73 the other elements.  The ordering among elements is maintained."
  74   (let (car cdr)
  75     (dolist (x l)
  76       (if (funcall p x) (push x car) (push x cdr)))
  77     (cons (nreverse car) (nreverse cdr))))
  78
  79 ;;;
  80 ;;; frame, window, buffer handling
  81 ;;;
  82
  83 (defun cvs-pop-to-buffer-same-frame (buf)
  84   "Pop to BUF like `pop-to-buffer' but staying on the same frame.
  85 If `pop-to-buffer' would have opened a new frame, this function would
  86 try to split a new window instead."
  87   (let ((pop-up-windows (or pop-up-windows pop-up-frames))
  88         (pop-up-frames nil))
  89     (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
  90         (and pop-up-windows
  91              (ignore-errors (select-window (split-window-vertically)))
  92              (switch-to-buffer buf))
  93         (pop-to-buffer (current-buffer)))))
  94
  95 (defun cvs-bury-buffer (buf &optional mainbuf)
  96   "Hide the buffer BUF that was temporarily popped up.
  97 BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
  98   (interactive (list (current-buffer)))
  99   (save-current-buffer
 100     (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
 101                  (get-buffer-window buf t))))
 102       (when win
 103         (if (window-dedicated-p win)
 104             (condition-case ()
 105                 (delete-window win)
 106               (error (iconify-frame (window-frame win))))
 107           (if (and mainbuf (get-buffer-window mainbuf))
 108               ;; FIXME: if the buffer popped into a pre-existing window,
 109               ;; we don't want to delete that window.
 110               t ;;(delete-window win)
 111               ))))
 112     (with-current-buffer buf
 113       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 114                                 (not (window-dedicated-p (selected-window))))
 115                      buf)))
 116     (when mainbuf
 117       (let ((mainwin (or (get-buffer-window mainbuf)
 118                          (get-buffer-window mainbuf 'visible))))
 119         (when mainwin (select-window mainwin))))))
 120
 121 (defun cvs-get-buffer-create (name &optional noreuse)
 122   "Create a buffer NAME unless such a buffer already exists.
 123 If the NAME looks like an absolute file name, the buffer will be created
 124 with `create-file-buffer' and will probably get another name than NAME.
 125 In such a case, the search for another buffer with the same name doesn't
 126 use the buffer name but the buffer's `list-buffers-directory' variable.
 127 If NOREUSE is non-nil, always return a new buffer."
 128   (or (and (not (file-name-absolute-p name)) (get-buffer-create name))
 129       (unless noreuse
 130         (dolist (buf (buffer-list))
 131           (with-current-buffer buf
 132             (when (equal name list-buffers-directory)
 133               (return buf)))))
 134       (with-current-buffer (create-file-buffer name)
 135         (set (make-local-variable 'list-buffers-directory) name)
 136         (current-buffer))))
 137
 138 ;;;;
 139 ;;;; string processing
 140 ;;;;
 141
 142 (defun cvs-insert-strings (strings)
 143   "Insert a list of STRINGS into the current buffer.
 144 Uses columns to keep the listing readable but compact."
 145   (when (consp strings)
 146     (let* ((length (apply 'max (mapcar 'length strings)))
 147            (wwidth (1- (window-width)))
 148            (columns (min
 149                      ;; At least 2 columns; at least 2 spaces between columns.
 150                      (max 2 (/ wwidth (+ 2 length)))
 151                      ;; Don't allocate more columns than we can fill.
 152                      ;; Windows can't show less than 3 lines anyway.
 153                      (max 1 (/ (length strings) 2))))
 154            (colwidth (/ wwidth columns)))
 155       ;; Use tab-width rather than indent-to.
 156       (setq tab-width colwidth)
 157       ;; The insertion should be "sensible" no matter what choices were made.
 158       (dolist (str strings)
 159         (unless (bolp) (insert " \t"))
 160         (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 161           (delete-char -2) (insert "\n"))
 162         (insert str)))))
 163
 164
 165 (defun cvs-file-to-string (file &optional oneline args)
 166   "Read the content of FILE and return it as a string.
 167 If ONELINE is t, only the first line (no \\n) will be returned.
 168 If ARGS is non-nil, the file will be executed with ARGS as its
 169 arguments.  If ARGS is not a list, no argument will be passed."
 170   (condition-case nil
 171       (with-temp-buffer
 172         (if args
 173             (apply 'call-process
 174                    file nil t nil (when (listp args) args))
 175           (insert-file-contents file))
 176         (goto-char (point-min))
 177         (buffer-substring (point)
 178                           (if oneline (line-end-position) (point-max))))
 179     (file-error nil)))
 180
 181 (defun cvs-string-prefix-p (str1 str2)
 182   "Tell whether STR1 is a prefix of STR2."
 183   (let ((length1 (length str1)))
 184     (and (>= (length str2) length1)
 185          (string= str1 (substring str2 0 length1)))))
 186
 187 ;; (string->strings (strings->string X)) == X
 188 (defun cvs-strings->string (strings &optional separator)
 189   "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
 190 This tries to quote the strings to avoid ambiguity such that
 191   (cvs-string->strings (cvs-strings->string strs)) == strs
 192 Only some SEPARATOR will work properly."
 193   (let ((sep (or separator " ")))
 194     (mapconcat
 195      (lambda (str)
 196        (if (string-match "[\\\"]" str)
 197            (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
 198          str))
 199      strings sep)))
 200
 201 ;; (string->strings (strings->string X)) == X
 202 (defun cvs-string->strings (string &optional separator)
 203   "Split the STRING into a list of strings.
 204 It understands elisp style quoting within STRING such that
 205   (cvs-string->strings (cvs-strings->string strs)) == strs
 206 The SEPARATOR regexp defaults to \"\\s-+\"."
 207   (let ((sep (or separator "\\s-+"))
 208         (i (string-match "[\"]" string)))
 209     (if (null i) (split-string string sep)      ; no quoting:  easy
 210       (append (unless (eq i 0) (split-string (substring string 0 i) sep))
 211               (let ((rfs (read-from-string string i)))
 212                 (cons (car rfs)
 213                       (cvs-string->strings (substring string (cdr rfs))
 214                                            sep)))))))
 215
 216 ;;;;
 217 ;;;; file names
 218 ;;;;
 219
 220 (defsubst cvs-expand-dir-name (d)
 221   (file-name-as-directory (expand-file-name d)))
 222
 223 ;;;;
 224 ;;;; (interactive <foo>) support function
 225 ;;;;
 226
 227 (defstruct (cvs-qtypedesc
 228             (:constructor nil) (:copier nil)
 229             (:constructor cvs-qtypedesc-create
 230                           (str2obj obj2str &optional complete hist-sym require)))
 231   str2obj
 232   obj2str
 233   hist-sym
 234   complete
 235   require)
 236
 237
 238 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 239 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 240 (defconst cvs-qtypedesc-strings
 241   (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
 242
 243 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 244   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 245          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 246          (complete (cvs-qtypedesc-complete qtypedesc))
 247          (completions (and (functionp complete) (funcall complete)))
 248          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 249     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 250              (cond
 251               ((null complete) (read-string prompt initval hist-sym))
 252               ((functionp complete)
 253                (completing-read prompt completions
 254                                 nil (cvs-qtypedesc-require qtypedesc)
 255                                 initval hist-sym))
 256               (t initval)))))
 257
 258 ;;;;
 259 ;;;; Flags handling
 260 ;;;;
 261
 262 (defstruct (cvs-flags
 263             (:constructor nil)
 264             (:constructor -cvs-flags-make
 265                           (desc defaults &optional qtypedesc hist-sym)))
 266   defaults persist desc qtypedesc hist-sym)
 267
 268 (defmacro cvs-flags-define (sym defaults
 269                                 &optional desc qtypedesc hist-sym docstring)
 270   `(defconst ,sym
 271      (let ((bound (boundp ',sym)))
 272        (if (and bound (cvs-flags-p ,sym)) ,sym
 273          (let ((defaults ,defaults))
 274            (-cvs-flags-make ,desc
 275                             (if bound (cons ,sym (cdr defaults)) defaults)
 276                             ,qtypedesc ,hist-sym))))
 277      ,docstring))
 278
 279 (defun cvs-flags-query (sym &optional desc arg)
 280   "Query flags based on SYM.
 281 Optional argument DESC will be used for the prompt
 282 If ARG (or a prefix argument) is nil, just use the 0th default.
 283 If it is a non-negative integer, use the corresponding default.
 284 If it is a negative integer query for a new value of the corresponding
 285   default and return that new value.
 286 If it is \\[universal-argument], just query and return a value without
 287   altering the defaults.
 288 If it is \\[universal-argument] \\[universal-argument], behave just
 289   as if a negative zero was provided."
 290   (let* ((flags (symbol-value sym))
 291          (desc (or desc (cvs-flags-desc flags)))
 292          (qtypedesc (cvs-flags-qtypedesc flags))
 293          (hist-sym (cvs-flags-hist-sym flags))
 294          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 295          (numarg (prefix-numeric-value arg))
 296          (defaults (cvs-flags-defaults flags))
 297          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 298     ;; special case for universal-argument
 299     (when (consp arg)
 300       (setq permstr (if (> numarg 4) " (permanent)" ""))
 301       (setq numarg 0))
 302
 303     ;; sanity check
 304     (unless (< (abs numarg) (length defaults))
 305       (error "There is no %sth default" (abs numarg)))
 306
 307     (if permstr
 308         (let* ((prompt (format "%s%s: " desc permstr))
 309                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 310                                    prompt qtypedesc hist-sym)))
 311           (when (not (equal permstr ""))
 312             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 313           fs)
 314       (nth numarg defaults))))
 315
 316 (defsubst cvs-flags-set (sym index value)
 317   "Set SYM's INDEX'th setting to VALUE."
 318   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 319
 320 ;;;;
 321 ;;;; Prefix keys
 322 ;;;;
 323
 324 (defconst cvs-prefix-number 10)
 325
 326 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 327
 328 (defmacro cvs-prefix-define (sym docstring desc defaults
 329                                  &optional qtypedesc hist-sym)
 330   (let ((cps (cvs-prefix-sym sym)))
 331     `(progn
 332        (defvar ,sym nil ,(concat (or docstring "") "
 333 See `cvs-prefix-set' for further description of the behavior."))
 334        (defvar ,cps
 335          (let ((defaults ,defaults))
 336            ;; sanity ensurance
 337            (unless (>= (length defaults) cvs-prefix-number)
 338              (setq defaults (append defaults
 339                                     (make-list (1- cvs-prefix-number)
 340                                                (nth 0 defaults)))))
 341            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 342
 343 (defun cvs-prefix-make-local (sym)
 344   (let ((cps (cvs-prefix-sym sym)))
 345     (make-local-variable sym)
 346     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 347
 348 (defun cvs-prefix-set (sym arg)
 349   ;; we could distinguish between numeric and non-numeric prefix args instead of
 350   ;; relying on that magic `4'.
 351   "Set the cvs-prefix contained in SYM.
 352 If ARG is between 0 and 9, it selects the corresponding default.
 353 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 354   it queries the user and sets the -ARG'th default.
 355 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 356   the (ARG mod 10)'th prefix is made persistent.
 357 If ARG is nil toggle the PREFIX's value between its 0th default and nil
 358   and reset the persistence."
 359   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 360          (numarg (if (integerp arg) arg 0))
 361          (defs (cvs-flags-defaults prefix)))
 362
 363     ;; set persistence if requested
 364     (when (> (prefix-numeric-value arg) 9)
 365       (setf (cvs-flags-persist prefix) t)
 366       (setq numarg (mod numarg 10)))
 367
 368     ;; set the value
 369     (set sym
 370          (cond
 371           ((null arg)
 372            (setf (cvs-flags-persist prefix) nil)
 373            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 374
 375           ((or (consp arg) (< numarg 0))
 376            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 377                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 378                                  (format "%s: " (cvs-flags-desc prefix))
 379                                  (cvs-flags-qtypedesc prefix)
 380                                  (cvs-flags-hist-sym prefix))))
 381           (t (nth numarg (cvs-flags-defaults prefix)))))
 382     (force-mode-line-update)))
 383
 384 (defun cvs-prefix-get (sym &optional read-only)
 385   "Return the current value of the prefix SYM.
 386 and reset it unless READ-ONLY is non-nil."
 387   (prog1 (symbol-value sym)
 388     (unless (or read-only
 389                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 390       (set sym nil)
 391       (force-mode-line-update))))
 392
 393 (provide 'pcvs-util)
 394
 395 ;;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
 396 ;;; pcvs-util.el ends here