;;; emacs18-v19compat.el --- emacs 19 compatibility routines for emacs 18

;; Copyright (C) 1985, 86, 92, 94, 95 Free Software Foundation, Inc.
;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2002 Noah S. Friedman

;; Maintainer: Noah Friedman <friedman@splode.com>

;; $Id: emacs18-v19compat.el,v 1.4 2005/05/24 17:45:50 friedman Exp $

;; 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, 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, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This file contains variable and function definitions for emacs 18 that
;; are compatible with those found in emacs 19 and later.  Some of the
;; definitions were lifted verbatim from emacs 19, but they may have been
;; slightly modified or even rewritten completely.

;; This compatibility module is by no means complete.
;; Some v19 behavior is emulated by other packages, e.g. killbuf.el.

;;; Code:

;; The docstring for this came from v19's definition.
;; In v19 this is actually declared in src/lread.c, not in lisp.
(defvar after-load-alist nil
  "An alist of expressions to be evalled when particular files are loaded.
Each element looks like (FILENAME FORMS...).
When `load' is run and the file-name argument is FILENAME, the FORMS in the
corresponding element are executed at the end of loading.

FILENAME must match exactly!  Normally FILENAME is the name of a library,
with no directory specified, since that is how `load' is normally called.
An error in FORMS does not undo the load, but does prevent execution of the
rest of the FORMS.")


;;;;;;
;;; Macros
;;;;;;

(defmacro lambda (&rest cdr)
  (list 'function (cons 'lambda cdr)))

;; ----------
;; From v19 subr.el
(defmacro save-match-data (&rest body)
  "Execute the BODY forms, restoring the global value of the match data."
  (let ((original (make-symbol "match-data")))
    (list
     'let (list (list original '(match-data)))
     (list 'unwind-protect
           (cons 'progn body)
           (list 'store-match-data original)))))

;; ----------
(defmacro unless (pred &rest body)
  (cons 'if (cons pred (cons nil body))))

;; ----------
(defmacro when (pred &rest body)
  (list 'if pred (cons 'progn body)))


;;;;;;
;;; Defuns
;;;
;;; Some of these are copied verbatim from emacs 19 sources, others are
;;; compatible reimplementations or stubs.
;;;;;;

;; ----------
;; From 19.27 subr.el
(defun add-hook (hook function &optional append)
  "Add to the value of HOOK the function FUNCTION.
FUNCTION is not added if already present.
FUNCTION is added (if necessary) at the beginning of the hook list
unless the optional argument APPEND is non-nil, in which case
FUNCTION is added at the end.

HOOK should be a symbol, and FUNCTION may be any valid function.  If
HOOK is void, it is first set to nil.  If HOOK's value is a single
function, it is changed to a list of functions."
  (or (boundp hook) (set hook nil))
  ;; If the hook value is a single function, turn it into a list.
  (let ((old (symbol-value hook)))
    (if (or (not (listp old)) (eq (car old) 'lambda))
	(set hook (list old))))
  (or (if (consp function)
	  (member function (symbol-value hook))
	(memq function (symbol-value hook)))
      (set hook
	   (if append
	       (nconc (symbol-value hook) (list function))
	     (cons function (symbol-value hook))))))

;; From 19.27 subr.el
(defun remove-hook (hook function)
  "Remove from the value of HOOK the function FUNCTION.
HOOK should be a symbol, and FUNCTION may be any valid function.  If
FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
list of hooks to run in HOOK, then nothing is done.  See `add-hook'."
  (if (or (not (boundp hook))		;unbound symbol, or
	  (null (symbol-value hook))	;value is nil, or
	  (null function))		;function is nil, then
      nil				;Do nothing.
    (let ((hook-value (symbol-value hook)))
      (if (consp hook-value)
	  (setq hook-value (delete function hook-value))
	(if (equal hook-value function)
	    (setq hook-value nil)))
      (set hook hook-value))))

;; ----------
;; From v19.34 subr.el
(defun add-to-list (list-var element)
  "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
The test for presence of ELEMENT is done with `equal'.
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
into a hook function that will be run only after loading the package.
`eval-after-load' provides one way to do this.  In some cases
other hooks, such as major mode hooks, can do the job."
  (or (member element (symbol-value list-var))
      (set list-var (cons element (symbol-value list-var)))))

;; ----------
(defun current-time ()
  "Return the current time, as the number of seconds since 1970-01-01 00:00:00.
The time is returned as a list of three integers.  The first has the
most significant 16 bits of the seconds, while the second has the
least significant 16 bits.  The third integer gives the microsecond
count.

The microsecond count is zero on systems that do not provide
resolution finer than a second."
  (let ((buf (generate-new-buffer " *current-time*")))
    (call-process "perl" nil buf nil
                  "-e"
                  "$t = time; printf \"(%d %d 0)\n\", $t & 65535, $t >> 16;")
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min)))
    (prog1
        (read buf)
      (kill-buffer buf))))

;; ----------
(defun current-time-zone (&rest args)
  "Return the offset and name for the local time zone.
Some operating systems cannot provide all this information to Emacs;
in this case, `current-time-zone' returns a list containing nil for
the data it can't find in GNU Emacs 19.

This facility does not exist in GNU Emacs 18, so this dummy function always
returns the empty list."
  nil)

;; ----------
;; A similar (and better) version of this is in v19 simple.el, but it
;; doesn't work in emacs 18.
(defun current-word ()
  "Word cursor is over, as a string."
  (save-excursion
    (let (beg end)
      (re-search-backward "\\w" nil 2)
      (re-search-backward "\\b" nil 2)
      (setq beg (point))
      (re-search-forward "\\w*\\b" nil 2)
      (setq end (point))
      (buffer-substring beg end))))

;; ----------
(defun delete (elt list)
  "Delete by side effect any occurrences of ELT as a member of LIST.
The modified LIST is returned.  Comparison is done with `equal'.
If the first member of LIST is ELT, deleting it is not a side effect;
it is simply using a different list.
Therefore, write `(setq foo (delete element foo))'
to be sure of changing the value of `foo'."
  (let ((p list)
        (l (cdr list)))
    (while l
      (if (equal elt (car l))
          (setcdr p (cdr l))
        (setq p (cdr p)))
      (setq l (cdr l))))
  (if (equal elt (car list))
      (cdr list)
    list))

;; ----------
;; Save old definition
(or (fboundp 'expand-file-name-subr)
    (fset 'expand-file-name-subr (symbol-function 'expand-file-name)))

(defun expand-file-name (string &optional default)
  "Convert FILENAME to absolute, and canonicalize it.
Second arg DEFAULT is directory to start with if FILENAME is relative
 (does not start with slash); if DEFAULT is nil or missing,
the current buffer's value of default-directory is used.
Filenames containing . or .. as components are simplified;
initial ~ is expanded.  See also the function  substitute-in-file-name."
  (condition-case nil
      (expand-file-name-subr string default)
    (error (concat (or default default-directory) string))))

;; ----------
;; This isn't quite right; we need to know if we have search permission on
;; the directory too, but this is hard to check without using the `access'
;; system call, since we would have to reimplement all the execute bit
;; checks to get the right semantics.
(defun file-accessible-directory-p (file)
  "Return t if FILE is the name of a directory that can be opened by you."
  (and (file-directory-p file)
       (file-readable-p file)))

;; ----------
;; From v19 files.el, edited to remove file-name-handler lookups.
(defun file-truename (filename &optional counter prev-dirs)
  "Return the truename of FILENAME, which should be absolute.
The truename of a file name is found by chasing symbolic links
both at the level of the file and at the level of the directories
containing it, until no links are left at any level.

The arguments COUNTER and PREV-DIRS are used only in recursive calls.
Do not specify them in other calls."
  (if (or (string= filename "") (string= filename "~")
	  (and (string= (substring filename 0 1) "~")
	       (string-match "~[^/]*" filename)))
      (progn
	(setq filename (expand-file-name filename))
	(if (string= filename "")
	    (setq filename "/"))))
  (or counter (setq counter (list 100)))
  (let (done)
    (or prev-dirs (setq prev-dirs (list nil)))
    ;; If this file directly leads to a link, process that iteratively
    ;; so that we don't use lots of stack.
    (while (not done)
      (setcar counter (1- (car counter)))
      (if (< (car counter) 0)
	  (error "Apparent cycle of symbolic links for %s" filename))
      (let ((dir (or (file-name-directory filename) default-directory))
            target dirfile)
        ;; Get the truename of the directory.
        (setq dirfile (directory-file-name dir))
        ;; If these are equal, we have the (or a) root directory.
        (or (string= dir dirfile)
            ;; If this is the same dir we last got the truename for,
            ;; save time--don't recalculate.
            (if (assoc dir (car prev-dirs))
                (setq dir (cdr (assoc dir (car prev-dirs))))
              (let ((old dir)
                    (new (file-name-as-directory (file-truename dirfile counter prev-dirs))))
                (setcar prev-dirs (cons (cons old new) (car prev-dirs)))
                (setq dir new))))
        (if (equal ".." (file-name-nondirectory filename))
            (setq filename
                  (directory-file-name (file-name-directory (directory-file-name dir)))
                  done t)
          (if (equal "." (file-name-nondirectory filename))
              (setq filename (directory-file-name dir)
                    done t)
            ;; Put it back on the file name.
            (setq filename (concat dir (file-name-nondirectory filename)))
            ;; Is the file name the name of a link?
            (setq target (file-symlink-p filename))
            (if target
                ;; Yes => chase that link, then start all over
                ;; since the link may point to a directory name that uses links.
                ;; We can't safely use expand-file-name here
                ;; since target might look like foo/../bar where foo
                ;; is itself a link.  Instead, we handle . and .. above.
                (setq filename
                      (if (file-name-absolute-p target)
                          target
                        (concat dir target))
                      done nil)
              ;; No, we are done!
              (setq done t))))))
    filename))

;; ----------
;; From v19 files.el
(defun file-chase-links (filename)
  "Chase links in FILENAME until a name that is not a link.
Does not examine containing directories for links,
unlike `file-truename'."
  (let (tem (count 100) (newname filename))
    (while (setq tem (file-symlink-p newname))
      (if (= count 0)
          (error "Apparent cycle of symbolic links for %s" filename))
      ;; Handle `..' by hand, since it needs to work in the
      ;; target of any directory symlink.
      ;; This code is not quite complete; it does not handle
      ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose.
      (while (save-match-data (string-match "\\.\\./" tem))
        (setq tem (substring tem 3))
        (setq newname (file-name-as-directory
                       ;; Do the .. by hand.
                       (directory-file-name
                        (file-name-directory
                         ;; Chase links in the default dir of the symlink.
                         (file-chase-links
                          (directory-file-name
                           (file-name-directory newname))))))))
      (setq newname (expand-file-name tem (file-name-directory newname)))
      (setq count (1- count)))
    newname))

;; ----------
;; From v19 subr.el
(defun force-mode-line-update (&optional all)
  "Force the mode-line of the current buffer to be redisplayed.
With optional non-nil ALL then force then force redisplay of all mode-lines."
  (if all (save-excursion (set-buffer (other-buffer))))
  (set-buffer-modified-p (buffer-modified-p)))

;; ----------
;; From v20 files.el
(defun file-name-sans-extension (filename)
  "Return FILENAME sans final \"extension\".
The extension, in a file name, is the part that follows the last `.'."
  (save-match-data
    (let ((file (file-name-sans-versions (file-name-nondirectory filename)))
	  directory)
      (if (string-match "\\.[^.]*\\'" file)
	  (if (setq directory (file-name-directory filename))
	      (expand-file-name (substring file 0 (match-beginning 0))
				directory)
	    (substring file 0 (match-beginning 0)))
	filename))))

;; ----------
;; This is a subr in emacs 19, but I wrote it in lisp for 18.
(defun generate-new-buffer-name (name &optional ignore)
  "Return a string that is the name of no existing buffer based on NAME.
If there is no live buffer named NAME, then return NAME.
Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
until an unused name is found, and then return that name.
Optional second argument IGNORE specifies a name that is okay to use
\(if it is in the sequence to be tried\) even if a buffer with that name
exists."
  (cond ((not (get-buffer name))
         name)
        (t
         (let ((n 2)
               new)
           (while (null new)
             (setq new (format "%s<%d>" name n))
             (cond ((and ignore
                         (string= new ignore)))
                   ((get-buffer new)
                    (setq new nil)
                    (setq n (1+ n)))))
           new))))

;; ----------
;; save old definition
(and (subrp (symbol-function 'getenv))
     (fset 'getenv-subr (symbol-function 'getenv)))

(defun getenv (var)
  "Return the value of the environment variable VAR, or nil if none
exists.  First look in process-environment, then in the actual environment."
  (let ((env process-environment)
	(pattern (concat "^" (regexp-quote var) "="))
	found)
    (while env
      (and (string-match pattern (car env))
	   (setq found (car env)))
      (setq env (cdr env)))
    (if found
	(substring found (match-end 0))
      (getenv-subr var))))

;; ----------
;; Save original
(let ((orig (symbol-function 'load)))
  (and (subrp orig)
       (fset 'load-subr orig)))

(defun load (str &rest args)
  (and (apply 'load-subr str args)
       (mapc 'eval (cdr (assoc str after-load-alist)))))

;; ----------
(defun mapc (function sequence)
  (while sequence
    (funcall function (car sequence))
    (setq sequence (cdr sequence))))

;; ----------
(defun member (x y)
  "Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.
The value is actually the tail of LIST whose car is ELT."
  (while (and y (not (equal x (car y))))
      (setq y (cdr y)))
    y)

;; ----------
;; Save original
(let ((orig (symbol-function 'require)))
  (and (subrp orig)
       (fset 'require-subr orig)))

(defun require (feature &optional file-name)
  (if (featurep feature)
      ()
    (require-subr feature file-name)
    (mapc 'eval (cdr (assoc (or file-name
                                (format "%s" feature))
                            after-load-alist)))))

;; ----------
(or (fboundp 'setenv)
    (defun setenv (variable &optional value)
      "Set the value of the environment variable named VARIABLE to VALUE.
VARIABLE should be a string.  VALUE is optional; if not provided or is
`nil', the environment variable VARIABLE will be removed.
This function works by modifying `process-environment'."
      (interactive "sSet environment variable: \nsSet %s to value: ")
      (if (string-match "=" variable)
          (error "Environment variable name `%s' contains `='" variable)
        (let ((pattern (concat "\\`" (regexp-quote (concat variable "="))))
              (scan process-environment))
          (while scan
            (cond
             ((string-match pattern (car scan))
              (if (eq nil value)
                  (setq process-environment
                        (delq (car scan) process-environment))
                (setcar scan (concat variable "=" value)))
              (setq scan nil))
             ((null (setq scan (cdr scan)))
              (setq process-environment
                    (cons (concat variable "=" value)
                          process-environment))))))))
    )

;; ----------
;; From v19 subr.el
(defun start-process-shell-command (name buffer &rest args)
  "Start a program in a subprocess.  Return the process object for it.
Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
NAME is name for process.  It is modified if necessary to make it unique.
BUFFER is the buffer or (buffer-name) to associate with the process.
 Process output goes at end of that buffer, unless you specify
 an output stream or filter function to handle the output.
 BUFFER may be also nil, meaning that this process is not associated
 with any buffer
Third arg is command name, the name of a shell command.
Remaining arguments are the arguments for the command.
Wildcards and redirection are handle as usual in the shell."
  (if (eq system-type 'vax-vms)
      (apply 'start-process name buffer args)
    (start-process name buffer shell-file-name "-c"
                   (concat "exec " (mapconcat 'identity args " ")))))


;; ----------
;; From v19 subr.el.
;; In Emacs 19, `ignored' is actually an `all-frames' flag.
;; Emacs 18 doesn't have multiple frames, so don't use it here.
(defun walk-windows (proc &optional minibuf ignored)
  "Cycle through all visible windows, calling PROC for each one.
PROC is called with a window as argument.
Optional second arg MINIBUF t means count the minibuffer window
even if not active.  If MINIBUF is neither t nor nil it means
not to count the minibuffer even if it is active."
  ;; If we start from the minibuffer window, don't fail to come back to it.
  (if (window-minibuffer-p (selected-window))
      (setq minibuf t))
  (let* ((walk-windows-start (selected-window))
	 (walk-windows-current walk-windows-start))
    (while (progn
	     (setq walk-windows-current
		   (next-window walk-windows-current minibuf))
	     (funcall proc walk-windows-current)
	     (not (eq walk-windows-current walk-windows-start))))))

;; ----------
;; In emacs 19, the window end is managed internally and getting it is done
;; with a builtin function.  In emacs 18, we have to search for it by
;; scanning forward until point is no longer "visible".
(defun window-end (&optional window)
  "Return position at which display currently ends in WINDOW."
  (or window (setq window (selected-window)))
  (let ((orig-buf (current-buffer))
        point-max)
    (set-buffer (window-buffer window))
    (setq point-max (point-max))
    (set-buffer orig-buf)
    (cond
     ((pos-visible-in-window-p point-max window)
      point-max)
     (t
      (let ((incr (min (* (window-width window) (window-height window))
                       (- point-max (window-start window))))
            (end (window-start window)))
        (while (not (zerop (setq incr (/ incr 2))))
          (while (and (< end point-max)
                      (pos-visible-in-window-p end window))
            (setq end (+ end incr)))
          (setq end (- end incr)))
        (1+ end))))))

;; ----------
(defun window-minibuffer-p (&optional window)
  "Returns non-nil if WINDOW is a minibuffer window."
  (or window (setq window (selected-window)))
  (eq window (minibuffer-window)))

;; Aliases for compatibility with emacs 19.
(fset 'defalias            'fset)
(fset 'defsubst            'defun)
(fset 'buffer-disable-undo 'buffer-flush-undo)
(fset 'frame-width         'screen-width)
(fset 'frame-height        'screen-height)


;; Define process-environment and initialize it if it doesn't already
;; exist.  Since there is no way to get emacs' environment without
;; process-environment already set, we run an external program which
;; prints its environment (which will be inherited from emacs).  The
;; two standard programs which usually do this are `env' or `printenv'.
;; Newer versions of emacs (at least as of version 18.58) have
;; process-environment already defined, so some time is saved.
(or (boundp 'process-environment)
    (progn
      (defvar process-environment nil
        "List of strings to append to environment of \
subprocesses that are started.
Each string should have the format ENVVARNAME=VALUE.")

      (let ((env-program
             (let* ((proglist '("printenv" "env"))
                    (filename (car proglist)))
               (while (not (file-in-pathlist-p filename exec-path))
                 (setq proglist (cdr proglist))
                 (setq filename (car proglist)))
               filename))
            env-buffer)
        (and env-program
             (save-excursion
               (setq env-buffer (generate-new-buffer " *Environment Strings*"))
               (call-process env-program nil env-buffer nil)
               (set-buffer env-buffer)
               (goto-char (point-min))
               (insert "(setq-default process-environment '(")
               (while (not (eq (point) (point-max)))
                 (insert "\"")
                 (if (re-search-forward "^.*=" (point-max) t)
                     (progn
                       (move-to-column 0)
                       (goto-char (1- (point)))
                       (insert "\"")
                       (forward-line 1))
                   (goto-char (point-max))))
               (goto-char (1- (point)))
               (insert "\"))")
               (eval-current-buffer)
               (kill-buffer env-buffer))))))

(provide 'emacs18-v19compat)

;;; emacs18-v19compat.el ends here