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: pcvs-util.el,v 1.1 2000/08/05 19:33:53 gerd Exp gerd $
   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-regexp-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 ;;;; file names
 195 ;;;;
 196
 197 (defsubst cvs-expand-dir-name (d)
 198   (file-name-as-directory (expand-file-name d)))
 199
 200 ;;;;
 201 ;;;; (interactive <foo>) support function
 202 ;;;;
 203
 204 (defstruct (cvs-qtypedesc
 205             (:constructor nil) (:copier nil)
 206             (:constructor cvs-qtypedesc-create
 207                           (str2obj obj2str &optional complete hist-sym require)))
 208   str2obj
 209   obj2str
 210   hist-sym
 211   complete
 212   require)
 213
 214
 215 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 216 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 217 (defconst cvs-qtypedesc-strings
 218   (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
 219
 220 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 221   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 222          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 223          (complete (cvs-qtypedesc-complete qtypedesc))
 224          (completions (and (functionp complete) (funcall complete)))
 225          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 226     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 227              (cond
 228               ((null complete) (read-string prompt initval hist-sym))
 229               ((functionp complete)
 230                (completing-read prompt completions
 231                                 nil (cvs-qtypedesc-require qtypedesc)
 232                                 initval hist-sym))
 233               (t initval)))))
 234
 235 ;;;;
 236 ;;;; Flags handling
 237 ;;;;
 238
 239 (defstruct (cvs-flags
 240             (:constructor nil)
 241             (:constructor -cvs-flags-make
 242                           (desc defaults &optional qtypedesc hist-sym)))
 243   defaults persist desc qtypedesc hist-sym)
 244
 245 (defmacro cvs-flags-define (sym defaults
 246                                 &optional desc qtypedesc hist-sym docstring)
 247   `(defconst ,sym
 248      (let ((bound (boundp ',sym)))
 249        (if (and bound (cvs-flags-p ,sym)) ,sym
 250          (let ((defaults ,defaults))
 251            (-cvs-flags-make ,desc
 252                             (if bound (cons ,sym (cdr defaults)) defaults)
 253                             ,qtypedesc ,hist-sym))))
 254      ,docstring))
 255
 256 (defun cvs-flags-query (sym &optional desc arg)
 257   "Query flags based on SYM.
 258 Optional argument DESC will be used for the prompt
 259 If ARG (or a prefix argument) is nil, just use the 0th default.
 260 If it is a non-negative integer, use the corresponding default.
 261 If it is a negative integer query for a new value of the corresponding
 262   default and return that new value.
 263 If it is \\[universal-argument], just query and return a value without
 264   altering the defaults.
 265 If it is \\[universal-argument] \\[universal-argument], behave just
 266   as if a negative zero was provided."
 267   (let* ((flags (symbol-value sym))
 268          (desc (or desc (cvs-flags-desc flags)))
 269          (qtypedesc (cvs-flags-qtypedesc flags))
 270          (hist-sym (cvs-flags-hist-sym flags))
 271          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 272          (numarg (prefix-numeric-value arg))
 273          (defaults (cvs-flags-defaults flags))
 274          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 275     ;; special case for universal-argument
 276     (when (consp arg)
 277       (setq permstr (if (> numarg 4) " (permanent)" ""))
 278       (setq numarg 0))
 279
 280     ;; sanity check
 281     (unless (< (abs numarg) (length defaults))
 282       (error "There is no %sth default." (abs numarg)))
 283
 284     (if permstr
 285         (let* ((prompt (format "%s%s: " desc permstr))
 286                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 287                                    prompt qtypedesc hist-sym)))
 288           (when (not (equal permstr ""))
 289             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 290           fs)
 291       (nth numarg defaults))))
 292
 293 (defsubst cvs-flags-set (sym index value)
 294   "Set SYM's INDEX'th setting to VALUE."
 295   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 296
 297 ;;;;
 298 ;;;; Prefix keys
 299 ;;;;
 300
 301 (defconst cvs-prefix-number 10)
 302
 303 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 304
 305 (defmacro cvs-prefix-define (sym docstring desc defaults
 306                                  &optional qtypedesc hist-sym)
 307   (let ((cps (cvs-prefix-sym sym)))
 308     `(progn
 309        (defvar ,sym nil ,(cons (or docstring "") "
 310 See `cvs-prefix-set' for further description of the behavior."))
 311        (defconst ,cps
 312          (let ((defaults ,defaults))
 313            ;; sanity ensurance
 314            (unless (>= (length defaults) cvs-prefix-number)
 315              (setq defaults (append defaults
 316                                     (make-list (1- cvs-prefix-number)
 317                                                (nth 0 defaults)))))
 318            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 319
 320 (defun cvs-prefix-make-local (sym)
 321   (let ((cps (cvs-prefix-sym sym)))
 322     (make-local-variable sym)
 323     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 324
 325 (defun cvs-prefix-set (sym arg)
 326   ;; we could distinguish between numeric and non-numeric prefix args instead of
 327   ;; relying on that magic `4'.
 328   "Set the cvs-prefix contained in SYM.
 329 If ARG is between 0 and 9, it selects the corresponding default.
 330 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 331   it queries the user and sets the -ARG'th default.
 332 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 333   the (ARG mod 10)'th prefix is made persistent.
 334 If ARG is NIL toggle the PREFIX's value between its 0th default and NIL
 335   and reset the persistence."
 336   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 337          (numarg (if (integerp arg) arg 0))
 338          (defs (cvs-flags-defaults prefix)))
 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 ;;; pcl-cvs-util.el ends here