InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/elisp/packages/edb/db-util.el

Text File | 1993-06-14 | 38.0 KB | 1,071 lines

;;; db-util.el --- part of EDB, the Emacs database

;; See database.el for copyright notice, distribution conditions, etc.

;; Author: Michael Ernst <[e-mail]>
;; Keywords: EDB

;;; Commentary:

;; Lisp utilities.
;; This file is largely cannibalized from util-mde.el and util-mdecl.el,
;; which are available on request.

;;; Code:


(provide 'db-util)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Bug fixes
;;;

;; Prevent users of the standard byte-compiler, or users of the new one who
;; haven't yet loaded bytecomp-runtime.el, from barfing on these macros.
;; These could probably all be in one test, but this is more satisfying to
;; paranoid people.

;; This didn't work on all systems when the defuns and defmacros weren't at
;; top level.
;;   "No-op for non-users of the Zawinski byte-compiler."
(defmacro proclaim-inline-hack (&rest args)
  )
(if (not (fboundp 'proclaim-inline))
    (fset 'proclaim-inline 'proclaim-inline-hack))
;;   "No-op for non-users of the Zawinski byte-compiler."
(defmacro proclaim-notinline-hack (&rest args)
  )
(if (not (fboundp 'proclaim-notinline))
    (fset 'proclaim-notinline 'proclaim-notinline-hack))
;;   "No-op for non-users of the Zawinski byte-compiler."
(defun make-obsolete-hack (fn new)
  )
(if (not (fboundp 'make-obsolete))
    (fset 'make-obsolete 'make-obsolete-hack))
(if (not (fboundp 'inline))
    (progn
      (fset 'inline 'progn)
      (put 'inline 'lisp-indent-hook 0)))
;;   "No-op for non-users of the Zawinski byte-compiler."
(defun byte-compile-warn-hack (&rest args)
  )
(if (not (fboundp 'byte-compile-warn))
    (fset 'byte-compile-warn 'byte-compile-warn-hack))


;; In the standard 18.55 through 18.58 distributions (and maybe more),
;; backquote has a bug.  Unfortunately, this fix may trounce on other,
;; correct, implementations of backquote, breaking them.  I don't know how
;; to correct this, but you can prevent the fix from being loaded by
;; setting dont-fix-backquote.  I personally use a backquote implementation
;; that doesn't happen to define the function bq-splicequote.
(defvar dont-fix-backquote nil)
(defvar tailmaker)            ; quiet the byte-compiler
(defvar state)                ; quiet the byte-compiler
(if (or (not dont-fix-backquote) (string-match "^19" emacs-version))
    (progn
      (require 'backquote)
      (defun bq-splicequote (form)
    (setq tailmaker (list form (list 'quote tailmaker)))
    (setq state 'append))))


;; Emacs 19 compatibility.
(if (not (fboundp 'buffer-disable-undo))
    (fset 'buffer-disable-undo 'buffer-flush-undo))
(if (not (fboundp 'frame-width))
    (fset 'frame-width 'screen-width))
(if (not (fboundp 'force-mode-line-update))
    (defun force-mode-line-update (&rest args)
      "Force the mode-line of the current buffer to be redisplayed."
      (set-buffer-modified-p (buffer-modified-p))))
(if (not (fboundp 'generate-new-buffer-name))
    ;; By Joe Wells <[e-mail]>
    ;; derived from generate-new-buffer
    (defun generate-new-buffer-name (name)
      (if (not (get-buffer name))
      name
    (let ((count 1)
          (template (concat name "<%d>"))
          tempname)
      (catch 'found
        (while t
          (setq tempname (format template count))
          (if (not (get-buffer tempname))
          (throw 'found tempname))
          (setq count (1+ count))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Searching, matching, and replacing
;;;


(defun match-string (n &optional source)
  "Return the string matched by parentheses number N.  If there is a
SOURCE string, return the substring of that string; else, return
substring of the current buffer."
  (cond
   ((stringp source)
    (substring source (match-beginning n) (match-end n)))
   (t (buffer-substring (match-beginning n) (match-end n)))))

(defun match-string-maybe (n &optional source)
  "Like match-string, but return nil if there was no match for parenthesis N."
  (and (match-beginning n)
       (match-string n source)))


(defun unused-char-in-buffer ()
  "Return a character not used in the current buffer, or nil.
This function attempts to return a character that can be displayed in a single
screen column."
  (save-excursion
    (let ((candidate ?\ )
      (result t))
      (while (eq result t)
    (goto-char (point-min))
    (if (not (search-forward (char-to-string candidate) nil t))
        (setq result candidate)
      (progn
        (setq candidate (% (1+ candidate) 256))
        (if (eq candidate ?\ )
        (setq result nil)))))
      result)))

(defun unused-char-in-string (string)
  "Return a character not used in STRING, or nil.
This function attempts to return a character that can be displayed in a single
screen column."
  (save-excursion
    (set-buffer (get-buffer-create " *Temporary*"))
    (buffer-disable-undo (current-buffer))
    (erase-buffer)
    (insert string)
    (unused-char-in-buffer)))

;;; Skipping

;; Is this more efficient than regexp-quote and skip-regexp-forward
;; (which equals looking-at-string and goto-char)?
(defmacro skip-string-forward (string)
  "If point is at STRING, move past it and return non-nil;
otherwise return nil."
  (` (let ((s (, string)))
       (if (equal "" s)
       t
     (if (search-forward s (+ (point) (length s)) t)
         (goto-char (match-end 0)))))))

(defmacro skip-string-backward (string)
  "If point is after STRING, move back past it and return t;
otherwise return nil."
  (` (let ((s (, string)))
       (if (equal "" s)
       t
     (search-backward s (- (point) (length s)) t)))))

(defmacro skip-regexp-forward (regexp &optional match-no)
  "If point is at REGEXP, move past it and return point;
otherwise return nil.
Point is left at the end of match MATCH-NO if it is specified."
  (` (if (looking-at (, regexp))
     (goto-char (match-end (or (, match-no) 0))))))

(defmacro skip-regexp-backward (regexp &optional match-no)
  "If point is after REGEXP, move past it and return point;
otherwise return nil."
  (` (let ((here (point)))
       (if (re-search-backward (, regexp))
       (if (= here (match-end 0))
           t
         (progn
           (goto-char here)
           nil))))))


;;; String substitution

(defmacro string-substitute (newchar oldchar string)
  "Substitute NEWCHAR for instances of OLDCHAR in STRING.
NEWCHAR and OLDCHAR are characters."
  (` (string-substitute-opt (, newchar)
                (regexp-quote (char-to-string (, oldchar)))
                (, string))))

;; Optimized version.  oldchar-regexp should only match one-character strings.
(defun string-substitute-opt (newchar oldchar-regexp string)
  (let ((i -1)
    (case-fold-search nil))
    (while (setq i (string-match oldchar-regexp string (1+ i)))
      (aset string i newchar))))


;; Instead of using match-beginning, I could compute the length of the
;; string and use (backward-char (1- string-length)).
(defun how-many-string-overlapping (string)
  "Return number of matches for STRING following point, including overlapping ones."
  (let ((count 0))
    (save-excursion
     (while (search-forward string nil t)
       (goto-char (1+ (match-beginning 0)))
       (setq count (1+ count))))
    count))

(defun how-many-substring-overlapping (substring target)
  "Return number of matches for SUBSTRING in TARGET, including overlapping ones."
  (let ((ss-regexp (regexp-quote substring))
    (count 0)
    (start -1))
    (while (setq start (string-match ss-regexp target (1+ start)))
      (setq count (1+ count)))
    count))

;;; Find-char

(defun find-char (char string &optional count)
  "Look for CHAR in STRING; return first index in STRING whose element is CHAR.
If optional arg COUNT is specified, return the COUNTth occurrance."
  (if (not count)
      (setq count 1))
  (let ((index 0)
    (string-length (length string))
    (result nil))
    (while (and (< index string-length) (not result))
      (if (char-equal char (aref string index))
      (if (= count 1)
          (setq result index)
        (setq count (1- count))))
      (setq index (1+ index)))
    result))

(defun find-char-from-end (char string &optional count)
  "Look for CHAR in STRING; return last index in STRING whose element is CHAR.
If optional arg COUNT is specified, return the COUNTth occurrance from the end."
  (if (not count)
      (setq count 1))
  (let ((index (1- (length string)))
    (string-length )
    (result nil))
    (while (and (> index -1) (not result))
      (if (char-equal char (aref string index))
      (if (= count 1)
          (setq result index)
        (setq count (1- count))))
      (setq index (1- index)))
    result))

(defun string-trim-whitespace (string)
  "Return a substring of STRING with whitespace removed from beginning and end."
  (if (string-match "\\s *\\(.*[^ \t\n]\\)\\s *" string)
      (match-string 1 string)
    ""))
(proclaim-inline string-trim-whitespace)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Structures
;;;

;;; Simple defstruct originally from BBDB, by Jamie Zawinski <[e-mail]>.

;;; Use it like this:
;;; (def-db-struct bbdb-phone
;;;   location area exchange suffix extension)
;;; (setq this-phone-record (make-vector bbdb-phone-length nil))
;;; (bbdb-phone-set-exchange this-phone-record 617)
;;; (bbdb-phone-exchange this-phone-record) ==> 617

;;; Changes by Michael Ernst <[e-mail]>, March 19, 1992:
;;;  * added an extra first slot which holds the struct name; this is good
;;;    for determining a structure's type
;;;  * added def-db-struct-concatenator to permit greater flexibility in
;;;    names of accessor functions
;;;  * added make-foo and foo-p functions

;;; A make- constructor, with default values and overrides, would be nice.
;;; It might just be best to have the programmer define one by hand, but
;;; I'm not convinced by that.

;;; Why does it have such a strange name?  Because I want it to start with
;;; "def", so it shows up in TAGS files, and to end with "struct", so I can
;;; do M-. struct foo to go to the definition of the foo-bar-baz structure.

(defvar def-db-struct-concatenator "-"
  "Inserted between the struct and slot names in slot accessors and setters.
Typical values are \"-\" and \"\".")

;; NAME is a symbol or a list of (symbol (option-name option-value) ...).
(defmacro def-db-struct (name &rest slots)
  "Define NAME as a structure type with a slot for each additional argument.
NAME is a symbol, the name of the new structure, and each slotname is a symbol.
This macro defines functions `make-NAME', `NAME-p', and `copy-NAME' for the
structure, and functions `NAME-SLOTNAME' and `NAME-set-SLOTNAME' to access and
set slots.  It also sets variable  NAME-length  to the number of slots.

NAME may also be a list (struct-name (option-name option-value) ...), where
each option-name is a keyword symbol in \{:constructor :predicate :copier\}
and option-value is a symbol, the name that should be used for that
function instead of the defaults listed above."

  (let ((body '())
    (i 1)
    (L (length slots))
    conc-name options
    name1 name2 makename predname copyname)
    (if (listp name)
    (setq options (cdr name)
          name (car name)))
    (setq conc-name (concat (symbol-name name)
                def-db-struct-concatenator))
    (while slots
      (setq name1 (intern (concat conc-name (symbol-name (car slots))))
        name2 (intern (concat conc-name "set-" (symbol-name (car slots))))
        body (nconc body
            (list
             (list 'defmacro name1 '(vector)
                   (list 'list ''aref 'vector i))
             (list 'defmacro name2 '(vector value)
                   (list 'list ''aset 'vector i 'value))
             (list 'put (list 'quote name1)
                   ''edebug-form-hook ''(form))
             (list 'put (list 'quote name2)
                   ''edebug-form-hook ''(form form))
             ))
        slots (cdr slots)
        i (1+ i)))
    (setq makename (or (car (cdr (assoc ':constructor options)))
               (intern (concat "make" def-db-struct-concatenator
                       (symbol-name name))))
      predname (or (car (cdr (assoc ':predicate options)))
               (intern (concat conc-name "p")))
      copyname (or (car (cdr (assoc ':copier options)))
               (intern (concat "copy" def-db-struct-concatenator
                       (symbol-name name)))))
    (setq body (nconc body (list (list 'defconst
                       (intern (concat conc-name "length"))
                       L)
                 (list 'defun makename '()
                       (list 'let (list (list 'result (list 'make-vector (1+ L) nil)))
                         (list 'aset 'result 0
                           (list 'quote name))
                         'result))
                 (list 'put (list 'quote makename)
                       ''edebug-form-hook ''())
                 (list 'defmacro copyname '(struct)
                       '(list 'copy-sequence struct))
                 (list 'put (list 'quote copyname)
                       ''edebug-form-hook ''(form))
                 (list 'defun predname '(object)
                       (concat "T if OBJECT is a "
                           (symbol-name name) ".")
                       (list 'and
                    '(vectorp object)
                    (list '= '(length object) (1+ L))
                    (list 'eq '(aref object 0)
                          (list 'quote name)))))))
    (cons 'progn body)))
(put 'def-db-struct 'edebug-form-spec '(&rest form))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hooks
;;;

;;; This is add-to-hook.el by Joe Wells.  It is included here to avoid the
;;; overhead of yet another file in some Emacs packages.  I've modified the
;;; function name (to avoid conflicts with other packages) and removed the
;;; provide statement.

;; ----------------------------------------------------------------------
;; Created by: Joe Wells, [e-mail]
;; Created on: Thu Aug 15 15:40:05 1991
;; Last modified by: Joe Wells, [e-mail]
;; Last modified on: Thu Aug 15 15:43:30 1991
;; Filename: add-to-hook.el
;; Purpose: contains add-to-hook function

(defun db-add-to-hook (hook-var &rest items)
  "Add to HOOK one or more FUNCTIONS as correctly as possible.
HOOK evaluates to a symbol.

This is designed to work only with hooks that are run by run-hooks.
Because of run-hooks flexibility, the value a hook has can take a variety
of forms.  This function tries to deal with all of those forms.  If you
find a case it does not handle, please tell me.

After this function is done, the hook variable is a list with each element
one function to be run, regardless of what form the value of the hook took
before."
  (or (symbolp hook-var)
      (error "first argument must be symbol"))
  (or (boundp hook-var)
      (set hook-var nil))
  (let ((hook-value (symbol-value hook-var))
    item)
    (if (or (and (symbolp hook-value)
         ;; should be not eq nil:
         hook-value)
        (and (consp hook-value)
         (eq 'lambda (car hook-value))))
    (setq hook-value (list hook-value)))
    (while (consp items)
      (setq item (car items))
      (or (memq item hook-value)
      (setq hook-value (cons item hook-value)))
      (setq items (cdr items)))
    (set hook-var hook-value)))

;;(provide 'add-to-hook)
;;----------------------------------------------------------------------


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Variables
;;;

;; Ought to have a way to set the default value, too.
(defmacro deflocalvar (&rest args)
  "Like defvar, but defines a buffer-local variable."
  (` (progn
       (defvar (,@ args))
       (make-variable-buffer-local (quote (, (car args)))))))
(put 'deflocalvar 'edebug-form-spec '(&rest form))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keys
;;;

;;; Semi-transparent way to meta-ify a key.  This still isn't quite what we
;;; want.  The problem is that some patches to permit 8-bit character sets
;;; to be displayed change meta sequences to escape sequences, even without
;;; changing meta-flag to nil.

(defmacro db-meta-prefix-ify (keys)
  "Prepend `meta-prefix-char' to KEYS, a string."
  (` (concat (list meta-prefix-char) (, keys))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions
;;;

;; Lifted from edebug 2.7 with very minor modifications.
(defun functionp (object)
  "Return t if OBJECT is a function (is funcallable), nil otherwise."
  (while (and (symbolp object) (fboundp object))
    (setq object (symbol-function object)))
  (or (subrp object)
      (and (listp object)
       (eq (car object) 'lambda)
       (listp (car (cdr object))))))
;; This can't be a macro because epoch funcalls  (function functionp).
(proclaim-inline functionp)

(defun funcall-maybe (fun &rest args)
  "If FUN is non-nil, apply it to ARGS.  Otherwise return second argument,
which would have been the first argument to which FUN was applied.
FUN should be a funcallable object or nil.  Compare to `maybe-funcall'."
  (if fun
      (apply fun args)
    (if args
    (car args))))
(put 'funcall-maybe 'edebug-form-spec '(function &rest form))

;; Perhaps I should change the order of arguments.
(defun funcall-maybe-default (default fun &rest args)
  "If FUN is non-nil, apply it to ARGS.  Otherwise return DEFAULT.
FUN should be a funcallable object or nil."
  (if fun
      (apply fun args)
    default))
(put 'funcall-maybe-default 'edebug-form-spec '(form function &rest form))

(defmacro maybe-funcall (fun &rest args)
  "If FUN is non-nil, apply it to ARGS.  Otherwise return nil.
FUN should be a funcallable object or nil.  Compare to `funcall-maybe'."
  (` (funcall-maybe-default nil (, fun) (,@ args))))
(put 'maybe-funcall 'edebug-form-spec '(function &rest form))


;; Obviously this could be (easily) generalized to take a list of integers
;; and to try all of those numbers of arguments; but why would I want that?
(defmacro vararg-call (func noargs1 noargs2 &rest args)
  "Apply FUNC to NOARGS1 (an integer), then (if that fails), to NOARGS2
of the ARGS.  -1 means all arguments.  This macro lets you deal with functions
expecting different numbers of arguments in a uniform way.  Since this is a
macro, don't supply something of the form (function foo) as its first argument;
just supply foo itself."
  (let ((noargs (length args))
    nocommon-args
    common-vars
    common-bindings
    thisvar
    (thisargno 0))

    (if (< noargs1 0) (setq noargs1 (- noargs)))
    (if (< noargs2 0) (setq noargs2 (- noargs)))
    (if (not (= (max noargs1 noargs2) noargs))
    (progn
      (byte-compile-warn "`%s' was vararg-called with a maximum of %d arguments, but you supplied %d."
               func (max noargs1 noargs2) noargs)
      (setq args (firstn (max noargs1 noargs2) args))))
    (setq nocommon-args (min noargs1 noargs2))
    (if (= noargs1 noargs2)
    ;; aka (` ((, func) (,@ args)))
    (cons func args)
      (while (< thisargno nocommon-args)
    (setq thisargno (1+ thisargno)
          thisvar (make-symbol (concat "vararg-common-"
                       (int-to-string thisargno)))
          common-vars (cons thisvar common-vars)
          common-bindings (cons (list thisvar (car args)) common-bindings)
          args (cdr args)))
      (setq common-vars (nreverse common-vars)
        common-bindings (nreverse common-bindings))
      (` (let (, common-bindings)
       (condition-case err
           ;; Try calling it with first number of arguments.
           ((, func) (,@ common-vars)
        (,@ (if (< nocommon-args noargs1) args)))
         (wrong-number-of-arguments
          ;; Call it with second number of arguments.
          ((, func) (,@ common-vars)
           (,@ (if (< nocommon-args noargs2) args))))
         (error
          ;; Otherwise resignal; "while t" makes this work under the
          ;; debugger (see, eg, the code for the "error" function).
          (while t
        (signal (car err) (cdr err))))))))))

;; Test cases:
;; (macroexpand '(vararg-call foo 3 1 bar baz bum))
;; (macroexpand '(vararg-call foo 3 5 bar baz bum quux quux2))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Files
;;;

(defvar filename-extension-regexp "[^.]\\(\\.\\([-a-z]*\\)\\)$"
  "Submatch 1 is the extension with leading period; submatch 2 is without.")

(defun filename-extension (filename &optional period)
  "Return the file extension of FILENAME.
Return nil for extensionless files such as \"foo\".
Return the empty string for files such as \"foo.\".
The leading period is included only if optional arguemnt PERIOD is specified,
in which case nil is never returned."
  (if (string-match filename-extension-regexp filename)
      (substring filename (match-beginning (if period 1 2)))
    (if period
    "")))

(defun filename-sans-extension (filename)
  (if (string-match filename-extension-regexp filename)
      (substring filename 0 (match-beginning 1))
    filename))

(defun if-file-readable-p (filename)
  "Return FILENAME if the file is readable, nil otherwise."
  (if (file-readable-p filename)
      filename))

(defun locate-file-with-extensions (filename extensions)
  "Return the name of a readable file starting with FILENAME
or FILENAME's basename and ending with a string in EXTENSIONS, which is a list.
EXTENSIONS may be nil, in which case FILENAME is searched for as is."
  (if extensions
      (let (result)
    (while (and extensions (not result))
      (setq result (or (if-file-readable-p (concat filename (car extensions)))
               (if-file-readable-p (concat (filename-sans-extension
                            filename)
                               (car extensions))))
        extensions (cdr extensions)))
    result)
    (if-file-readable-p filename)))

(defun locate-file-with-extensions-on-path (filename extensions path)
  "Return the name of a readable file starting with FILENAME
or FILENAME's basename and ending with a string in EXTENSIONS, which is a list.
PATH is a list of strings representing directories to be searched in
order after the current one; they may be relative directories.
Nil means the current directory."
  (or (locate-file-with-extensions filename extensions)
      (let ((filename-directory (file-name-directory filename))
        (filename-nondirectory (file-name-nondirectory filename))
        result candidate-directory)
    (while (and path (not result))
      (setq candidate-directory (if (car path)
                    (file-name-as-directory (car path))
                      default-directory)
        path (cdr path)
        result (locate-file-with-extensions
            ;; This check is so we return something reasonable,
            ;; not because the code requires the simpler form.
            (if (file-name-absolute-p candidate-directory)
                (concat candidate-directory filename-nondirectory)
              ;; This probably only works on Unix.
              (concat filename-directory candidate-directory
                  filename-nondirectory))
            extensions)))
    result)))

(defun locate-file-on-path (filename path)
  "Return the full path of a file named FILENAME located
in the current directory or on PATH, which is a list of directories (strings)
or nil for the current directory."
  (locate-file-with-extensions-on-path filename nil path))


(defun same-file-p (file1 file2)
  "Return t if FILE1 and FILE2 are names for the same file."
  (setq file1 (file-resolve-symlink file1)
    file2 (file-resolve-symlink file2))
  (or (equal file1 file2)
      (equal file1 (file-name-nondirectory file2))
      (equal file2 (file-name-nondirectory file1))
      ;; Works for hard links.  If neither file exists, attributes are nil
      ;; and so trivially equal.
      (and (file-exists-p file1) (file-exists-p file2)
       (equal (file-attributes file1)
          (file-attributes file2)))))

(defun file-resolve-symlink (file)
  "Return the non-link FILE eventually points to, or FILE if it's not a symbolic link.
This gets in an infinite loop if FILE points into a circular list of symlinks."
  (while (file-symlink-p file)
    (setq file (expand-file-name (car (file-attributes file))
                 (file-name-directory file))))
  file)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Conversion
;;;

;; string-to-int is unacceptable because it returns 0 for unparseable values.

(defun string->integer-default (string &optional default)
  "If STRING represents an integer, return it; otherwise return DEFAULT."
  (let ((result (condition-case nil
            (car (read-from-string string))
          (error nil))))
    (if (integerp result)
    result
      default)))
(fset 'string->number-default (symbol-function 'string->integer-default))

(defun string->integer-or-nil (string)
  (string->integer-default string nil))
(fset 'string->number-or-nil (symbol-function 'string->integer-or-nil))

(defun string->integer (string)
  "Return the integer represented by STRING, or err.
See also `string->integer-default'."
  (or (string->integer-or-nil string)
      (error "string->integer:  `%s' doesn't look like an integer." string)))
(fset 'string->number (symbol-function 'string->integer))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Buffers
;;;

;;; This macro duplicates BODY.  This should be fixed.
;; This version, which works when body moves point in a buffer displayed in
;; a window other than the selected window, is from Joe Wells
;; <[e-mail]>.  (If Lisp code moves point in a buffer displayed in a
;; window other than the selected window, Emacs kindly restores point in
;; the buffer to its window's version of point.)
(defmacro in-buffer (buffer &rest body)
  "Executes, in BUFFER, forms of BODY."
  ;; Need get-buffer-create because BUFFER might be a string.
  (` (let ((target-buffer (get-buffer-create (, buffer)))
       (this-buffer (current-buffer)))
       (if (eq target-buffer this-buffer)
       (progn
         (,@ body))
     ;; Can't use save-excursion here because we only want to save the
     ;; current buffer, not its value for point.
     (unwind-protect
         (progn
           (set-buffer target-buffer)
           (let* ((target-window (get-buffer-window target-buffer))
              (track-window-point-p
               (and (not (eq target-window (selected-window)))
                (eq (window-point target-window) (point)))))
         (prog1
             (progn
               (,@ body))
           (if (and track-window-point-p
                ;; *** Do I need this check?
                (eq (current-buffer) target-buffer)
                (eq target-window (get-buffer-window target-buffer))
                (not (eq target-window (selected-window))))
               (set-window-point target-window (point))))))
       (if (and (bufferp this-buffer)
            (buffer-name this-buffer))
           (set-buffer this-buffer)))))))
(put 'in-buffer 'lisp-indent-hook 1)
(put 'in-buffer 'edebug-form-spec '(&rest form))

(defmacro in-window (window &rest body)
  "Executes, in WINDOW, forms of BODY.
This is more useful than `in-buffer' for window manipulation, as by `scroll-up'."
  (` (let ((this-window (selected-window)))
       (unwind-protect
       (progn
         (select-window (, window))
         (,@ body))
     (select-window this-window)))))
(put 'in-window 'lisp-indent-hook 1)
(put 'in-window 'edebug-form-spec '(&rest form))


;; Similar tricks can be done with syntax-table and current-local-map.
;; Adapted from code by Joe Wells.
(defun copy-buffer-local-variables (buffer)
  "Copy the values of all of BUFFER's local variables into the current buffer."
  (let ((blv (in-buffer buffer (buffer-local-variables)))
    pair symbol)
    (while (consp blv)
      (setq pair (car blv))
      (setq symbol (car pair))
      (if (memq symbol '(0 buffer-undo-list)) ; 18.57 brain-damage!!!!!
      nil
    (progn
      (if (not (and symbol (symbolp symbol))) (error "impossible"))
      (make-local-variable symbol)
      (set symbol (cdr pair))))
      (setq blv (cdr blv)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Windows
;;;

;; I'm not sure whether this works if the last line is wrapped.
;; Likewise for bob-visible-p and wrapped first line (is that possible?).
(defun eob-visible-p ()
  (save-excursion
    (let ((ht (window-height (selected-window))))
      (move-to-window-line (- ht 2))
      (end-of-line)
      (eobp))))

(defun bob-visible-p ()
  (save-excursion
    (move-to-window-line 0)
    (beginning-of-line)
    (bobp)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Strings
;;;

(defun string-substitute-substring-general-case (new old-regexp string)
  "Call `string-replace-regexp-2'.  Beware special meaning of \\!."
  (string-replace-regexp-2 string old-regexp new))

;; If much replacement is going to happen, this is more efficient.
;; Original version from [e-mail] (Silver).
(defun string-replace-regexp-2 (string regexp replacement)
  "Return the string resulting by replacing all of STRING's instances of REGEXP
with REPLACEMENT."
  (save-excursion
    (set-buffer (get-buffer-create " *Temporary*"))
    (buffer-disable-undo (current-buffer))
    (erase-buffer)
    (save-excursion (insert string))
    (while (re-search-forward regexp nil t)
      (replace-match replacement))
    (buffer-string)
    ))

;; It would be nice to make the delimiter an optional argument to these.

;; A syntax table implementation would be too complicated, so hardcode space
;; and tab.
(defun string-split-last-word (splitee &optional exceptions delimiter)
  "Return list of two strings (all-but-last-word last-word).
If there is only one word, return (SPLITEE \"\").
The result strings can be concatenated to return the original string,
with the exception of some number (at least one) of spaces and tabs,
and possibly a comma immediately preceding them.
Optional arg EXCEPTIONS, if non-nil, is a regexp (containing spaces or tabs)
which, if found at the end of SPLITEE, should be considered a single word.
Optional arg DELIMITER, if non-nil, is used instead of the default word
delimiter.  It should be a regexp."
  (if (not delimiter) (setq delimiter ",?[ \t]+"))
  (if (or (and exceptions
           (string-match (concat delimiter "\\(" exceptions "\\)$") splitee))
      (string-match (concat delimiter "\\([a-zA-Z0-9'-]+\\)$") splitee))
      (list (substring splitee 0 (match-beginning 0))
        (substring splitee (match-beginning 1)))
    (list splitee "")))

;; maybe what I really want is string-to-word-list
(defun string-split-first-word (splitee &optional delimiter)
  "Return list of strings (first-word remaining-words).
Argument SPLITEE is split at the first sequence of spaces and tabs.
Optional arg DELIMITER, if non-nil, is used instead of the default word
delimiter.  It should be a regexp."
  (if (string-match (or delimiter "[ \t]+") splitee)
      (list (substring splitee 0 (match-beginning 0))
        (substring splitee (match-end 0)))
    (list splitee "")))

(defun count-array (item array)
  "Return the number of times that ITEM appears in ARRAY; test with `equal'."
  (let ((limit (length array))
    (result 0)
    (index 0))
    (while (< index limit)
      (if (equal item (aref array index))
      (setq result (1+ result)))
      (setq index (1+ index)))
    result))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Lists
;;;

;; Which should come first, N or LIST?
(defun firstn (n list)
  "Return a copy of the first N elements of LIST."
  (let ((result '()))
    (while (and list (> n 0))
      (setq result (cons (car list) result)
        n (1- n)
        list (cdr list)))
    (nreverse result)))

;; from bytecomp.el
(or (and (fboundp 'member)
     ;; avoid using someone else's possibly bogus definition of this.
     (subrp (symbol-function 'member)))
    (defun member (elt list)
      "like memq, but uses equal instead of eq.  In v19, this is a subr."
      (while (and list (not (equal elt (car list))))
    (setq list (cdr list)))
      list))

;;; Emacs provides rassq, but rassoc is nice to have too.
(defun rassoc (elt list)
  "Return non-nil if ELT is the cdr of an element of LIST.  Comparison done with  `equal'.
The value is actually the element of LIST whose cdr is ELT."
  (let (result)
    (while list
      (if (equal elt (cdr (car list)))
      (setq result (car list)
        list nil)
    (setq list (cdr list))))
    result))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Messages
;;;

(defvar use-electric-help-p nil
  "*Non-nil if Emacs programs should use electric help where possible.
Don't set this to a non-nil value unless the ehelp package is available.")

;; Regrettably, this produces big code by including its argument twice.
(defmacro with-electric-help-maybe (&rest body)
  "Similar to `with-electric-help' if `use-electric-help-p' is non-nil;
otherwise like `with-output-to-temp-buffer' with the \"*Help*\" buffer.
Ehelp is loaded if necessary.
BODY is not a thunk (a function of no arguments) but simply a set of forms."
  (` (if use-electric-help-p
     (progn
       (require 'ehelp)
       (with-electric-help
        (function (lambda ()
            (,@ body)))))
       (with-output-to-temp-buffer "*Help*"
     (,@ body)))))

;; Originally by Joe Wells <[e-mail]>
(defun best-fit-message (text &optional buffer)
  "Show TEXT in echo area if it fits or in optional BUFFER (default *Message*)."
  (or buffer (setq buffer "*Message*"))
  (save-excursion
    (set-buffer (get-buffer-create " temp printing buffer"))
    (erase-buffer)
    (buffer-disable-undo (current-buffer))
    (insert text)
    (delete-region (point)
           (progn
             (skip-chars-backward " \t\n")
             (point)))
    (cond ((and (< (current-column) (frame-width))
        (progn
          (beginning-of-line 1)
          (bobp)))
       ;; This can't be just buffer, even though that's non-nil,
       ;; because it might not be an existing buffer.
       (delete-windows-on (get-buffer-create buffer))
       (message "%s" (buffer-substring (point-min) (point-max))))
      (t
       (with-electric-help-maybe
        (princ text))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Cursor movement
;;;

(defun forward-line-wrapping (arg)
  "Like forward-line, but wrap around to the beginning of the buffer if
it encounters the end."
  (interactive "p")
  (let ((to-go (forward-line arg)))
    (cond ((or (> to-go 0) (not (bolp)))
       (goto-char (point-min))
       (forward-line-wrapping to-go))
      ((< to-go 0)
       (goto-char (point-max))
       (forward-line-wrapping (1+ to-go))))))

(defun current-line ()
  "Return the line number of the line containing point."
  (save-restriction
    (widen)
    (save-excursion
      (beginning-of-line)
      (1+ (count-lines 1 (point))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Buffer substitution
;;;

(defun buffer-substitute (substitutions backward check)
  "Make replacements in the current buffer according to SUBSTITUTIONS.
  SUBSTITUTIONS is list of pairs of strings; the cdr of each pair will be
substituted for the car, in order, unless optional argument BACKWARD is
non-nil, in which case the car is substituted for the cdr and the
substitutions are done in reverse order.
  If optional third argument CHECK is non-nil, the user is warned if any of
the substituted-in strings already appears in the buffer; such a situation
would make substitution, then unsubstitution, not yield a result identical
to the original buffer, since all instances of the substituted-in string
will be assumed on the reverse substitution to have been the result of
replacing a substituted-for string.
  Return nil if CHECK is nil or there were no ambiguities; otherwise
return a list of replacements creating ambiguity."

  (if backward
      (setq substitutions (mapcar (function (lambda (sub-cons)
                     (cons (cdr sub-cons) (car sub-cons))))
                  (reverse substitutions))))
    ;;; Much too tricky, and modified the argument besides.
    ;; (let ((subs (reverse substitutions))
    ;;         temp)
    ;;     (while subs
    ;;       (setq temp (caar subs))
    ;;       (setcar (car subs) (cdar subs))
    ;;       (setcdr (car subs) temp)
    ;;       (setq subs (cdr subs)))
    ;;     (setq substitutions (nreverse substitutions)))

  ;; (message "buffer-substitute:  substitutions = %s" substitutions)

  ;; Should do all checking before any substitutions are done.
  ;; Bad:
  ;;  * any to-string appears in text, unless it's an earlier from-string.
  ;;  * any to-string appears in previous to-string without intervening
  ;;    from-string.  (but then it's just stupidly inefficient)

  ;; Perhaps be able to override checks of the substitutions pairs.  Such
  ;; checks will be hairy anyway because we may create an ambiguity by
  ;; replacing part of a match such that the other part is still in the
  ;; buffer unchanged.  With one-character stuff this is obviously much
  ;; easier.
  ;; Perhaps do the checks by character...?

  ;; Don't want to do checks as we do the substitutions because that leaves
  ;; us in a bad state:  the work is partially done.  We want to let the
  ;; guy know before we start.

  ;; If, in the case of an ambiguity, we're just going to give up anyway,
  ;; then perhaps it isn't so bad to do the checks after part of the work
  ;; is done (except that the work already done would have been a waste of
  ;; time).  So maybe make the check of the pairs a preliminary one and do
  ;; the real check as we go.  But in some cases such checks won't be
  ;; necessary.

  ;; Perhaps if we want checks on the substitution strings themselves, then
  ;; do that separately beforehand and call this with check = nil.

  ;; And hey, searching for one instance of a string is pretty cheap, after
  ;; all.  And I don't expect to be calling this with a truly enormous list
  ;; of substitutions anyway.

  ;; I think I'm being too paranoid here.  In many cases I'm not even going
  ;; to call this with check = t.

  (let (from-string to-string ambiguity ambiguities)
    (while substitutions
      (setq from-string (car (car substitutions))
        to-string (cdr (car substitutions)))
      ;; (message "Substituting %s for %s." to-string from-string)
      (goto-char (point-min))

      (if (and check (search-forward to-string nil t))
      (progn
        (setq ambiguity (car substitutions))
        (goto-char (point-min))))

      (replace-string from-string to-string)

      ;; Don't complain if we didn't actually do any substitution.
      (if ambiguity
      (progn
        (if (not (= (point) (point-min)))
        (setq ambiguities (cons ambiguity ambiguities)))
        (setq ambiguity nil)))

      (setq substitutions (cdr substitutions)))
    ambiguities))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File local variables
;;;

(defun operate-on-local-variables (region-function)
  "Apply REGION-FUNCTION to the local-variables region of the buffer.
Return t if a local-variables region was found; REGION-FUNCTION should act
by side effect."
  (goto-char (point-max))
  (search-backward "\n\^L"
           (max (- (point-max) 3000) (point-min)) 'move)
  (if (search-forward "Local Variables:" nil t)
      (progn
    (beginning-of-line 1)
    (funcall region-function (point) (point-max))
    t)))

(defun really-hack-local-variables ()
  "Call `hack-local-variables', ignoring variables that limit it."
  ;; Bah!  Hulk not impressed by puny attempts to thwart him!
  (let ((ignore-local-eval nil)        ; Emacs 18
    (enable-local-eval t)        ; Emacs 19
    ;; Emacs 19 hack-local-variables doesn't take an argument, so set this.
    (inhibit-local-variables nil))
    (hack-local-variables)))


;; This page feed is to defeat local variables processing.

;;; db-util.el ends here