1. xemacs
  2. pcl-cvs

Source

pcl-cvs / pcl-cvs-util.el

;;; pcl-cvs-util.el

(defconst rcsid-pcl-cvs-util "$Id")

;; Copyright (C) 1998-1999  Stefan Monnier <monnier@cs.yale.edu>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(require 'cl)
(require 'string)
(require 'pcl-cvs-compat)

;;;
;;; generic functions
;;;

(defun -let-and-expand (bs body)
  (if bs
      (let* ((b (first bs))
	     (var (first b))
	     (val (second b)))
	`(let ((,var ,val))
	   (when ,var
	     ,(-let-and-expand (cdr bs) body))))
    `(progn . ,body)))

(defmacro let-and (bindings &rest body)
  "A mix of let and and.
It's mostly like let* except that as soon as one of the bindings is nil,
the form returns nil."
  (-let-and-expand bindings body))

;;;
;;; buffer management
;;;

(defun get-buffer-var (buffer var)
  "Return the value of VAR in BUFFER."
  (save-excursion
    (set-buffer buffer)
    (symbol-value var)))

;;;
;;; string processing
;;;

(defun file-to-string (file &optional oneline args)
  "Read the content of FILE and return it as a string.
If ONELINE is t, only the first line (no \\n) will be returned.
If ARGS is non-nil, the file will be executed with ARGS as its
arguments.  If ARGS is not a list, no argument will be passed."
  (let ((tmp-buf (generate-new-buffer "tmp")))
    (prog1
	(save-excursion
	  (set-buffer tmp-buf)
	  (condition-case nil
	      (progn
		(if args
		    (apply 'call-process
			   file nil t nil (when (listp args) args))
		  (insert-file-contents file))
		(goto-char (point-min))
		(buffer-substring (point)
				  (if oneline
				      (progn (end-of-line) (point))
				    (point-max))))
	    (file-error nil)))
      (kill-buffer tmp-buf))))

(defun string-prefix-p (str1 str2)
  "Tell whether STR1 is a prefix of STR2."
  (let ((length1 (length str1))
	(length2 (length str2)))
    (and (>= length2 length1)
	 (string= str1 (substring str2 0 length1)))))

;; (string->strings (strings->string X)) == X
(defun strings->string (strs &optional separator)
  "Concatenate the strings, adding the separator (default \" \").
This tries to quote the strings to avoid ambiguity.  SEPARATOR
should be only composed of characters from the whitespace syntax class."
  (let ((sep (or separator " ")))
    (mapconcat
     (lambda (str)
       (let* ((newstr (string-replace-match "[\\\"]" str "\\\\\\&" nil t))
	      (str (or newstr str)))
	 (if (or newstr (string= str "") (string-match "\\(\\s-\\|[']\\)" str))
	     (concat "\"" str "\"")
	   str)))
     strs sep)))

;; (string->strings (strings->string X)) == X
(defun string->strings (str &optional separator)
  "Split the string into a list of strings.
The SEPARATOR regexp defaults to \"\\s-+\"."
  (let ((sep (or separator "\\s-+"))
	(i (string-match "[\"]" str)))
    (if (null i) (split-string str sep)	; no quoting:  easy
      (append (unless (eq i 0) (split-string (substring str 0 i) sep))
	      (let ((rfs (read-from-string str i)))
		(cons (car rfs)
		      (string->strings (substring str (cdr rfs)) sep)))))))
      

(defun string-fill (str n &optional filling truncate)
  "Adds FILLING (defaults to the space char) to STR to reach size N.
If STR is longer than N, truncate if TRUNCATE is set, else don't do anything."
  (let ((l (length str)))
    (if (> l n)
	(if truncate (substring str 0 n) str)
      (concat str (make-string (- n l) (or filling ? ))))))

;;;
;;; file names
;;;

(defun expand-dir-name (d)
  (file-name-as-directory (expand-file-name d)))

;;;
;;; (interactive <foo>) support function
;;;

(defstruct (cvs-qtypedesc
	    (:constructor nil) (:copier nil)
	    (:constructor cvs-qtypedesc-create
			  (str2obj obj2str &optional complete hist-sym))
	    (:conc-name cvs-qtypedesc->))
  str2obj
  obj2str
  hist-sym
  complete)


(defvar cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
(defvar cvs-qtypedesc-strings
  (cvs-qtypedesc-create 'string->strings 'strings->string nil))

(defun cvs-query-read (sym prompt qtypedesc hist-sym)
  (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
	 (hist-sym (or hist-sym (cvs-qtypedesc->hist-sym qtypedesc)))
	 (complete (cvs-qtypedesc->complete qtypedesc))
	 (completions (and complete (funcall complete)))
	 (initval (funcall (cvs-qtypedesc->obj2str qtypedesc)
			   (symbol-value sym))))
    (funcall (cvs-qtypedesc->str2obj qtypedesc)
	     (completing-read prompt completions nil nil initval hist-sym))))

(defun cvs-query-flags (sym desc &optional qtypedesc hist-sym query)
  (if (or current-prefix-arg query)
      (let* ((perm (> (prefix-numeric-value current-prefix-arg) 4))
	     (prompt (format "%s%s: " desc (if perm " (permanent)" "")))
	     (flags (cvs-query-read sym prompt qtypedesc hist-sym)))
	(when perm (set sym flags))
	flags)
    (symbol-value sym)))

;; prefix keys

(defun cvs-set-prefix (sym desc &optional qtypedesc hist-sym)
  (when current-prefix-arg
    (let* ((prompt (format "%s: " desc)))
      (set sym (cvs-query-read sym prompt qtypedesc hist-sym))))
  (setplist sym (plist-put (symbol-plist sym) 'cvs-set-prefix t)))

(defun cvs-get-prefix (sym)
  (let ((plist (symbol-plist sym)))
    (when (plist-get plist 'cvs-set-prefix)
      (setplist sym (plist-put plist 'cvs-set-prefix nil))
      (symbol-value sym))))

(provide 'pcl-cvs-util)