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