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