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