lisp/pcvs-util.el

   1 ;;; pcvs-util.el --- Utitlity functions for pcl-cvs
   2
   3 ;; Copyright (C) 1998-2000  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
   6 ;; Keywords: pcl-cvs
   7 ;; Version: $Name:  $
   8 ;; Revision: $Id: pcl-cvs-util.el,v 1.26 2000/03/05 21:32:21 monnier Exp $
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'cl))
  33
  34 ;;;;
  35 ;;;; list processing
  36 ;;;l
  37
  38 (defsubst cvs-car (x) (if (consp x) (car x) x))
  39 (defalias 'cvs-cdr 'cdr-safe)
  40 (defsubst cvs-append (&rest xs)
  41   (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
  42
  43 (defsubst cvs-every (-cvs-every-f -cvs-every-l)
  44   (while (consp -cvs-every-l)
  45     (unless (funcall -cvs-every-f (pop -cvs-every-l))
  46       (setq -cvs-every-l t)))
  47   (not -cvs-every-l))
  48
  49 (defun cvs-union (xs ys)
  50   (let ((zs ys))
  51     (dolist (x xs zs)
  52       (unless (member x ys) (push x zs)))))
  53
  54
  55 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
  56   (unless (cvs-every 'null -cvs-map-ls)
  57     (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
  58           (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls)))))
  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 the 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               (delete-window win)))))
 111     (with-current-buffer buf
 112       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 113                                 (not (window-dedicated-p (selected-window))))
 114                      buf)))
 115     (when mainbuf
 116       (let ((mainwin (or (get-buffer-window mainbuf)
 117                          (get-buffer-window mainbuf 'visible))))
 118         (when mainwin (select-window mainwin))))))
 119
 120 (defun cvs-get-buffer-create (name &optional noreuse)
 121   "Create a buffer NAME unless such a buffer already exists.
 122 If the NAME looks like an absolute file name, the buffer will be created
 123 with `create-file-buffer' and will probably get another name than NAME.
 124 In such a case, the search for another buffer with the same name doesn't
 125 use the buffer name but the buffer's `list-buffers-directory' variable.
 126 If NOREUSE is non-nil, always return a new buffer."
 127   (or (and (not (file-name-absolute-p name)) (get-buffer-create name))
 128       (unless noreuse
 129         (dolist (buf (buffer-list))
 130           (with-current-buffer buf
 131             (when (equal name list-buffers-directory)
 132               (return buf)))))
 133       (with-current-buffer (create-file-buffer name)
 134         (set (make-local-variable 'list-buffers-directory) name)
 135         (current-buffer))))
 136
 137 ;;;;
 138 ;;;; string processing
 139 ;;;;
 140
 141 (defun cvs-file-to-string (file &optional oneline args)
 142   "Read the content of FILE and return it as a string.
 143 If ONELINE is t, only the first line (no \\n) will be returned.
 144 If ARGS is non-nil, the file will be executed with ARGS as its
 145 arguments.  If ARGS is not a list, no argument will be passed."
 146   (with-temp-buffer
 147     (condition-case nil
 148         (progn
 149           (if args
 150               (apply 'call-process
 151                      file nil t nil (when (listp args) args))
 152             (insert-file-contents file))
 153           (buffer-substring (point-min)
 154                             (if oneline
 155                                 (progn (goto-char (point-min)) (end-of-line) (point))
 156                               (point-max))))
 157       (file-error nil))))
 158
 159 (defun cvs-string-prefix-p (str1 str2)
 160   "Tell whether STR1 is a prefix of STR2."
 161   (let ((length1 (length str1)))
 162     (and (>= (length str2) length1)
 163          (string= str1 (substring str2 0 length1)))))
 164
 165 ;; (string->strings (strings->string X)) == X
 166 (defun cvs-strings->string (strings &optional separator)
 167   "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
 168 This tries to quote the strings to avoid ambiguity such that
 169   (cvs-string->strings (cvs-strings->string strs)) == strs
 170 Only some SEPARATOR will work properly."
 171   (let ((sep (or separator " ")))
 172     (mapconcat
 173      (lambda (str)
 174        (if (string-match "[\\\"]" str)
 175            (concat "\"" (replace-regexps-in-string "[\\\"]" "\\\\\\&" str) "\"")
 176          str))
 177      strings sep)))
 178
 179 ;; (string->strings (strings->string X)) == X
 180 (defun cvs-string->strings (string &optional separator)
 181   "Split the STRING into a list of strings.
 182 It understands elisp style quoting within STRING such that
 183   (cvs-string->strings (cvs-strings->string strs)) == strs
 184 The SEPARATOR regexp defaults to \"\\s-+\"."
 185   (let ((sep (or separator "\\s-+"))
 186         (i (string-match "[\"]" string)))
 187     (if (null i) (split-string string sep)      ; no quoting:  easy
 188       (append (unless (eq i 0) (split-string (substring string 0 i) sep))
 189               (let ((rfs (read-from-string string i)))
 190                 (cons (car rfs)
 191                       (cvs-string->strings (substring string (cdr rfs)) sep)))))))
 192
 193
 194 (defun cvs-string-fill (str n &optional filling truncate)
 195   "Add FILLING (defaults to the space char) to STR to reach size N.
 196 If STR is longer than N, truncate if TRUNCATE is set, else don't do anything."
 197   (let ((l (length str)))
 198     (if (> l n)
 199         (if truncate (substring str 0 n) str)
 200       (concat str (make-string (- n l) (or filling ? ))))))
 201
 202 ;;;;
 203 ;;;; file names
 204 ;;;;
 205
 206 (defsubst cvs-expand-dir-name (d)
 207   (file-name-as-directory (expand-file-name d)))
 208
 209 ;;;;
 210 ;;;; (interactive <foo>) support function
 211 ;;;;
 212
 213 (defstruct (cvs-qtypedesc
 214             (:constructor nil) (:copier nil)
 215             (:constructor cvs-qtypedesc-create
 216                           (str2obj obj2str &optional complete hist-sym require)))
 217   str2obj
 218   obj2str
 219   hist-sym
 220   complete
 221   require)
 222
 223
 224 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 225 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 226 (defconst cvs-qtypedesc-strings
 227   (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
 228
 229 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 230   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 231          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 232          (complete (cvs-qtypedesc-complete qtypedesc))
 233          (completions (and (functionp complete) (funcall complete)))
 234          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 235     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 236              (cond
 237               ((null complete) (read-string prompt initval hist-sym))
 238               ((functionp complete)
 239                (completing-read prompt completions
 240                                 nil (cvs-qtypedesc-require qtypedesc)
 241                                 initval hist-sym))
 242               (t initval)))))
 243
 244 ;;;;
 245 ;;;; Flags handling
 246 ;;;;
 247
 248 (defstruct (cvs-flags
 249             (:constructor nil)
 250             (:constructor -cvs-flags-make
 251                           (desc defaults &optional qtypedesc hist-sym)))
 252   defaults persist desc qtypedesc hist-sym)
 253
 254 (defmacro cvs-flags-define (sym defaults
 255                                 &optional desc qtypedesc hist-sym docstring)
 256   `(defconst ,sym
 257      (let ((bound (boundp ',sym)))
 258        (if (and bound (cvs-flags-p ,sym)) ,sym
 259          (let ((defaults ,defaults))
 260            (-cvs-flags-make ,desc
 261                             (if bound (cons ,sym (cdr defaults)) defaults)
 262                             ,qtypedesc ,hist-sym))))
 263      ,docstring))
 264
 265 (defun cvs-flags-query (sym &optional desc arg)
 266   "Query flags based on SYM.
 267 Optional argument DESC will be used for the prompt
 268 If ARG (or a prefix argument) is nil, just use the 0th default.
 269 If it is a non-negative integer, use the corresponding default.
 270 If it is a negative integer query for a new value of the corresponding
 271   default and return that new value.
 272 If it is \\[universal-argument], just query and return a value without
 273   altering the defaults.
 274 If it is \\[universal-argument] \\[universal-argument], behave just
 275   as if a negative zero was provided."
 276   (let* ((flags (symbol-value sym))
 277          (desc (or desc (cvs-flags-desc flags)))
 278          (qtypedesc (cvs-flags-qtypedesc flags))
 279          (hist-sym (cvs-flags-hist-sym flags))
 280          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 281          (numarg (prefix-numeric-value arg))
 282          (defaults (cvs-flags-defaults flags))
 283          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 284     ;; special case for universal-argument
 285     (when (consp arg)
 286       (setq permstr (if (> numarg 4) " (permanent)" ""))
 287       (setq numarg 0))
 288
 289     ;; sanity check
 290     (unless (< (abs numarg) (length defaults))
 291       (error "There is no %sth default." (abs numarg)))
 292
 293     (if permstr
 294         (let* ((prompt (format "%s%s: " desc permstr))
 295                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 296                                    prompt qtypedesc hist-sym)))
 297           (when (not (equal permstr ""))
 298             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 299           fs)
 300       (nth numarg defaults))))
 301
 302 (defsubst cvs-flags-set (sym index value)
 303   "Set SYM's INDEX'th setting to VALUE."
 304   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 305
 306 ;;;;
 307 ;;;; Prefix keys
 308 ;;;;
 309
 310 (defconst cvs-prefix-number 10)
 311
 312 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 313
 314 (defmacro cvs-prefix-define (sym docstring desc defaults
 315                                  &optional qtypedesc hist-sym)
 316   (let ((cps (cvs-prefix-sym sym)))
 317     `(progn
 318        (defvar ,sym nil ,(cons (or docstring "") "
 319 See `cvs-prefix-set' for further description of the behavior."))
 320        (defconst ,cps
 321          (let ((defaults ,defaults))
 322            ;; sanity ensurance
 323            (unless (>= (length defaults) cvs-prefix-number)
 324              (setq defaults (append defaults
 325                                     (make-list (1- cvs-prefix-number)
 326                                                (first defaults)))))
 327            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 328
 329 (defun cvs-prefix-make-local (sym)
 330   (let ((cps (cvs-prefix-sym sym)))
 331     (make-local-variable sym)
 332     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 333
 334 (defun cvs-prefix-set (sym arg)
 335   ;; we could distinguish between numeric and non-numeric prefix args instead of
 336   ;; relying on that magic `4'.
 337   "Set the cvs-prefix contained in SYM.
 338 If ARG is between 0 and 9, it selects the corresponding default.
 339 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 340   it queries the user and sets the -ARG'th default.
 341 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 342   the (ARG mod 10)'th prefix is made persistent.
 343 If ARG is NIL toggle the PREFIX's value between its 0th default and NIL
 344   and reset the persistence."
 345   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 346          (numarg (if (integerp arg) arg 0))
 347          (defs (cvs-flags-defaults prefix)))
 348
 349     ;; set persistence if requested
 350     (when (> (prefix-numeric-value arg) 9)
 351       (setf (cvs-flags-persist prefix) t)
 352       (setq numarg (mod numarg 10)))
 353
 354     ;; set the value
 355     (set sym
 356          (cond
 357           ((null arg)
 358            (setf (cvs-flags-persist prefix) nil)
 359            (unless (symbol-value sym) (first (cvs-flags-defaults prefix))))
 360
 361           ((or (consp arg) (< numarg 0))
 362            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 363                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 364                                  (format "%s: " (cvs-flags-desc prefix))
 365                                  (cvs-flags-qtypedesc prefix)
 366                                  (cvs-flags-hist-sym prefix))))
 367           (t (nth numarg (cvs-flags-defaults prefix)))))
 368     (force-mode-line-update)))
 369
 370 (defun cvs-prefix-get (sym &optional read-only)
 371   "Return the current value of the prefix SYM.
 372 and reset it unless READ-ONLY is non-nil."
 373   (prog1 (symbol-value sym)
 374     (unless (or read-only
 375                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 376       (set sym nil)
 377       (force-mode-line-update))))
 378
 379 (provide 'pcvs-util)
 380
 381 ;;; pcl-cvs-util.el ends here