xemacs-beta: lisp/efs/emacs-19.el comparison

comparison lisp/efs/emacs-19.el @ 22:8fc7fe29b841 r19-15b94

Import from CVS: tag r19-15b94

author	cvs
date	Mon, 13 Aug 2007 08:50:29 +0200
parents
children

comparison

equal deleted inserted replaced

-:b88636d63495
+:8fc7fe29b841
+;;;; Emacs 19 compatibility functions for use in Emacs 18.
+;;;; Based on: $Id: emacs-19.el,v 1.1 1997/02/11 05:05:14 steve Exp $
+;;;;
+;;;; Rewritten by sandy@ibm550.sissa.it after gnu emacs 19 was
+;;;; released to make it closer to V19.
+;;;; Last modified: Sun Jun 12 00:06:06 1994 by sandy on ibm550
+;;; 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 1, 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.
+;;;
+;;; A copy of the GNU General Public License can be obtained from this
+;;; program's author (send electronic mail to roland@ai.mit.edu) or from
+;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+;; These functions are used in dired.el, but are also of general
+;; interest, so you may want to add this to your .emacs:
+;;
+;; (autoload 'make-directory "emacs-19" "Make a directory." t)
+;; (autoload 'delete-directory "emacs-19" "Remove a directory." t)
+;; (autoload 'member "emacs-19" "Like memq, but uses `equal' instead of `eq'.")
+;; (autoload 'compiled-function-p "emacs-19" "Emacs 18 doesn't have these.")
+(provide 'emacs-19)
+;;; Variables
+(defvar insert-directory-program "ls"
+"Absolute or relative name of the `ls' program used by `insert-directory'.")
+(defvar bv-length) ; make the byte compiler a happy camper
+(defconst directory-abbrev-alist
+nil
+"*Alist of abbreviations for file directories.
+A list of elements of the form (FROM . TO), each meaning to replace
+FROM with TO when it appears in a directory name.  This replacement is
+done when setting up the default directory of a newly visited file.
+*Every* FROM string should start with `^'.
+Use this feature when you have directories which you normally refer to
+via absolute symbolic links.  Make TO the name of the link, and FROM
+the name it is linked to.")
+(defconst automount-dir-prefix "^/tmp_mnt/"
+"Regexp to match the automounter prefix in a directory name.")
+(defvar abbreviated-home-dir nil
+"The the user's homedir abbreviated according to `directory-abbrev-list'.")
+;;; Autoloads
+(autoload 'diff "diff" "Diff two files." t)
+(autoload 'diff-backup "diff" "Diff a file with its most recent backup.")
+;;; Functions which are subroutines in Emacs 19.
+;; Provide a non-working version of find-file-name-handler.
+;; If you want it to work, require 'fn-handler.
+(or (fboundp 'find-file-name-handler) (fset 'find-file-name-handler 'ignore))
+(or (boundp 'file-name-handler-alist) (defvar file-name-handler-alist nil))
+;; The name of buffer-flush-undo has changed in V19.
+(fset 'buffer-disable-undo 'buffer-flush-undo)
+(defun current-time ()
+"Returns the number of seconds since midnight.
+A poor man's version of the the function `current-time' in emacs 19."
+(let ((string (current-time-string)))
+(list
+0
+(+ (* 3600 (string-to-int (substring string 11 13)))
+	(* 60 (string-to-int (substring string 14 16)))
+	(string-to-int (substring string 17 19)))
+0)))
+;; call-process below may lose if filename starts with a `-', but I
+;; fear not all mkdir or rmdir implementations understand `--'.
+(defun delete-directory (fn)
+"Delete a directory.
+This is a subr in Emacs 19."
+(interactive
+(list (read-file-name "Delete directory: " nil nil 'confirm)))
+(setq fn (expand-file-name fn))
+(if (file-directory-p fn)
+(call-process "rmdir" nil nil nil fn)
+(error "Not a directory: %s" fn))
+(if (file-exists-p fn)
+(error "Could not remove directory %s" fn)))
+(defun make-directory (dir &optional parents)
+"Create the directory DIR and any nonexistent parent dirs."
+(interactive "FMake directory: \nP")
+(if (not parents)
+(make-directory-internal dir)
+(let ((dir (directory-file-name (expand-file-name dir)))
+	  create-list)
+(while (not (file-exists-p dir))
+	(setq create-list (cons dir create-list)
+	      dir (directory-file-name (file-name-directory dir))))
+(while create-list
+	(make-directory-internal (car create-list))
+	(setq create-list (cdr create-list))))))
+(defun make-directory-internal (fn)
+;; This is a subroutine in emacs 19.
+(let* ((fn (expand-file-name fn))
+	 (handler (find-file-name-handler fn 'make-directory-internal)))
+(if handler
+	(funcall handler 'make-directory-internal fn)
+(setq fn (directory-file-name fn))
+(if (file-exists-p fn)
+	  (error "Cannot make directory %s: file already exists" fn)
+	(call-process "mkdir" nil nil nil fn))
+(or (file-directory-p fn)
+	  (error "Could not make directory %s" fn)))))
+(defun kill-new (string)
+"Save STRING as if killed in a buffer."
+(setq kill-ring (cons string kill-ring))
+(if (> (length kill-ring) kill-ring-max)
+(setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))
+(setq kill-ring-yank-pointer kill-ring))
+(defun insert-directory (file switches &optional wildcard full-directory-p)
+"Insert directory listing for FILE, formatted according to SWITCHES.
+Leaves point after the inserted text.
+SWITCHES may be a string of options, or a list of strings.
+Optional third arg WILDCARD means treat FILE as shell wildcard.
+Optional fourth arg FULL-DIRECTORY-P means file is a directory and
+switches do not contain `d', so that a full listing is expected.
+This works by running a directory listing program
+whose name is in the variable `insert-directory-program'.
+If WILDCARD, it also runs the shell specified by `shell-file-name'."
+;; We need the directory in order to find the right handler.
+(let ((handler (find-file-name-handler (expand-file-name file)
+					 'insert-directory)))
+(if handler
+	(funcall handler 'insert-directory file switches
+		 wildcard full-directory-p)
+(if (eq system-type 'vax-vms)
+	  (vms-read-directory file switches (current-buffer))
+	(if wildcard
+	    ;; Run ls in the directory of the file pattern we asked for.
+	    (let ((default-directory
+		    (if (file-name-absolute-p file)
+			(file-name-directory file)
+		      (file-name-directory (expand-file-name file))))
+		  (pattern (file-name-nondirectory file))
+		  (beg 0))
+	      ;; Quote some characters that have special meanings in shells;
+	      ;; but don't quote the wildcards--we want them to be special.
+	      ;; We also currently don't quote the quoting characters
+	      ;; in case people want to use them explicitly to quote
+	      ;; wildcard characters.
+	      (while (string-match "[ \t\n;<>&|()#$]" pattern beg)
+		(setq pattern
+		      (concat (substring pattern 0 (match-beginning 0))
+			      "\\"
+			      (substring pattern (match-beginning 0)))
+		      beg (1+ (match-end 0))))
+	      (call-process shell-file-name nil t nil
+			    "-c" (concat insert-directory-program
+					 " -d "
+					 (if (stringp switches)
+					     switches
+					   (mapconcat 'identity switches " "))
+					 " "
+					 pattern)))
+	  ;; SunOS 4.1.3, SVr4 and others need the "." to list the
+	  ;; directory if FILE is a symbolic link.
+	  (apply 'call-process
+		 insert-directory-program nil t nil
+		 (let (list)
+		   (if (listp switches)
+		       (setq list switches)
+		     (if (not (equal switches ""))
+			 (progn
+			   ;; Split the switches at any spaces
+			   ;; so we can pass separate options as separate args.
+			   (while (string-match " " switches)
+			     (setq list (cons (substring switches 0
+							 (match-beginning 0))
+					      list)
+				   switches (substring switches
+						       (match-end 0))))
+			   (setq list (cons switches list)))))
+		   (append list
+			   (list
+			    (if full-directory-p
+				(concat (file-name-as-directory file) ".")
+			      file))))))))))
+(defun file-local-copy (file)
+"Copy the file FILE into a temporary file on this machine.
+Returns the name of the local copy, or nil, if FILE is directly
+accessible."
+(let* ((file (expand-file-name file))
+	 (handler (find-file-name-handler file 'file-local-copy)))
+;; Does nothing, if no handler.
+(if handler
+	(funcall handler 'file-local-copy file))))
+(defun file-truename (filename)
+"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."
+(if (or (string= filename "~")
+	  (and (string= (substring filename 0 1) "~")
+	       (string-match "~[^/]*" filename)))
+(progn
+	(setq filename (expand-file-name filename))
+	(if (string= filename "")
+	    (setq filename "/"))))
+(let ((handler (find-file-name-handler filename 'file-truename)))
+;; For file name that has a special handler, call handler.
+;; This is so that ange-ftp can save time by doing a no-op.
+(if handler
+	(funcall handler 'file-truename filename)
+(let ((dir (file-name-directory filename))
+	    target dirfile file-name-handler-alist)
+	;; 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)
+	    (setq dir (file-name-as-directory (file-truename dirfile))))
+	(if (equal ".." (file-name-nondirectory filename))
+	    (directory-file-name (file-name-directory
+				  (directory-file-name dir)))
+	  (if (equal "." (file-name-nondirectory filename))
+	      (directory-file-name dir)
+	    ;; 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.
+		(if (file-name-absolute-p target)
+		    (file-truename target)
+		  (file-truename (concat dir target)))
+	      ;; No, we are done!
+	      filename)))))))
+(defun generate-new-buffer-name (name)
+"Return a string which is the name of no existing buffer based on
+NAME. If there is no live buffer named NAME, return NAME. Otherwise,
+modify name by appending `<NUMBER>', incrementing NUMBER until an
+unused name is found. Return that name."
+(if (get-buffer name)
+(let ((num 2)
+	    attempt)
+	(while (progn
+		 (setq attempt (concat name "<" (int-to-string num) ">"))
+		 (get-buffer attempt))
+	  (setq num (1+ num)))
+	attempt)
+name))
+(defun abbreviate-file-name (filename)
+"Return a version of FILENAME shortened using `directory-abbrev-alist'.
+This also substitutes \"~\" for the user's home directory.
+Type \\[describe-variable] directory-abbrev-alist RET for more information."
+;; Get rid of the prefixes added by the automounter.
+(if (and (string-match automount-dir-prefix filename)
+	   (file-exists-p (file-name-directory
+			   (substring filename (1- (match-end 0))))))
+(setq filename (substring filename (1- (match-end 0)))))
+(let ((tail directory-abbrev-alist))
+;; If any elt of directory-abbrev-alist matches this name,
+;; abbreviate accordingly.
+(while tail
+(if (string-match (car (car tail)) filename)
+	  (setq filename
+		(concat (cdr (car tail)) (substring filename (match-end 0)))))
+(setq tail (cdr tail)))
+;; Compute and save the abbreviated homedir name.
+;; We defer computing this until the first time it's needed, to
+;; give time for directory-abbrev-alist to be set properly.
+(or abbreviated-home-dir
+	(setq abbreviated-home-dir
+	      (let ((abbreviated-home-dir "$foo"))
+		(concat "^" (abbreviate-file-name (expand-file-name "~"))))))
+;; If FILENAME starts with the abbreviated homedir,
+;; make it start with `~' instead.
+(if (string-match abbreviated-home-dir filename)
+	(setq filename
+	      (concat "~"
+		      ;; If abbreviated-home-dir ends with a slash,
+		      ;; don't remove the corresponding slash from
+		      ;; filename.  On MS-DOS and OS/2, you can have
+		      ;; home directories like "g:/", in which it is
+		      ;; important not to remove the slash.  And what
+		      ;; about poor root on Unix systems?
+		      (if (eq ?/ (aref abbreviated-home-dir
+				       (1- (length abbreviated-home-dir))))
+			  "/"
+			"")
+		      (substring filename (match-end 0)))))
+filename))
+(defun file-newest-backup (filename)
+"Return most recent backup file for FILENAME or nil if no backups exist."
+(let* ((filename (expand-file-name filename))
+	 (file (file-name-nondirectory filename))
+	 (dir  (file-name-directory    filename))
+	 (comp (file-name-all-completions file dir))
+	 newest)
+(while comp
+(setq file (concat dir (car comp))
+	    comp (cdr comp))
+(if (and (backup-file-name-p file)
+	       (or (null newest) (file-newer-than-file-p file newest)))
+	  (setq newest file)))
+newest))
+;; This is used in various files.
+;; The usage of bv-length is not very clean,
+;; but I can't see a good alternative,
+;; so as of now I am leaving it alone.
+(defun backup-extract-version (fn)
+"Given the name of a numeric backup file, return the backup number.
+Uses the free variable `bv-length', whose value should be
+the index in the name where the version number begins."
+(if (and (string-match "[0-9]+~$" fn bv-length)
+	   (= (match-beginning 0) bv-length))
+(string-to-int (substring fn bv-length -1))
+0))
+;; The standard V18 version of this function doesn't support
+;; the arg KEEP-BACKUP-VERSION
+(defun file-name-sans-versions (name &optional keep-backup-version)
+"Return FILENAME sans backup versions or strings.
+This is a separate procedure so your site-init or startup file can
+redefine it.
+If the optional argument KEEP-BACKUP-VERSION is non-nil,
+we do not remove backup version numbers, only true file version numbers."
+(let ((handler (find-file-name-handler name 'file-name-sans-versions)))
+(if handler
+	(funcall handler 'file-name-sans-versions name keep-backup-version)
+(substring name 0
+		 (if (eq system-type 'vax-vms)
+		     ;; VMS version number is (a) semicolon, optional
+		     ;; sign, zero or more digits or (b) period, option
+		     ;; sign, zero or more digits, provided this is the
+		     ;; second period encountered outside of the
+		     ;; device/directory part of the file name.
+		     (or (string-match ";[-+]?[0-9]*\\'" name)
+			 (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'"
+					   name)
+			     (match-beginning 1))
+			 (length name))
+		   (if keep-backup-version
+		       (length name)
+		     (or (string-match "\\.~[0-9]+~\\'" name)
+			 (string-match "~\\'" name)
+			 (length name))))))))
+(defun member (x y)
+"Like memq, but uses `equal' for comparison.
+This is a subr in Emacs 19."
+(while (and y (not (equal x (car y))))
+(setq y (cdr y)))
+y)
+(defun compiled-function-p (x)
+"Emacs 18 doesn't have these."
+nil)
+;; punt -- this will at least allow handlers to work for this.
+(defun set-visited-file-modtime (&optional time)
+(error "set-visited-file-modtime not defined in emacs 18."))
+(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)
+	  ;; Clever way to tell whether a given lambda-expression
+	  ;; is equal to anything in the hook.
+	  (let ((tail (assoc (cdr function) (symbol-value hook))))
+	    (equal function tail))
+	(memq function (symbol-value hook)))
+(set hook
+	   (if append
+	       (nconc (symbol-value hook) (list function))
+	     (cons function (symbol-value hook))))))
+;;; after-save.el (Now part of files.el in Gnu Emacs V19)
+;;; Copyright (C) 1990 Roland McGrath
+;;;
+(or (fboundp 'real-save-buffer)
+(fset 'real-save-buffer (symbol-function 'save-buffer)))
+(defvar after-save-hook nil
+"A function or list of functions to be run after saving the current buffer.")
+(defun save-buffer (&optional args)
+"Save the current buffer, and then run `after-save-buffer-hook'.
+The hooks are only run if the buffer was actually written.
+For more documentation, do \\[describe-function] real-save-buffer RET."
+(interactive "p")
+(let ((modp (buffer-modified-p)))
+(real-save-buffer args)
+(if modp
+	(run-hooks 'after-save-hook))))
+;;; end of after-save
+;;;;
+;;;; Correcting for V18 bugs, and hacking around stupidities.
+;;;;
+;; The 18.57 version has a bug that causes C-x C-v RET (which usually
+;; re-visits the current buffer) to fail on dired buffers.
+;; Only the last statement was changed to avoid killing the current
+;; buffer.
+(defun find-alternate-file (filename)
+"Find file FILENAME, select its buffer, kill previous buffer.
+If the current buffer now contains an empty file that you just visited
+\(presumably by mistake), use this command to visit the file you really want."
+(interactive "FFind alternate file: ")
+(and (buffer-modified-p)
+(not buffer-read-only)
+(not (yes-or-no-p (format "Buffer %s is modified; kill anyway? "
+				 (buffer-name))))
+(error "Aborted"))
+(let ((obuf (current-buffer))
+	(ofile buffer-file-name)
+	(oname (buffer-name)))
+(rename-buffer " **lose**")
+(setq buffer-file-name nil)
+(unwind-protect
+	(progn
+	  (unlock-buffer)
+	  (find-file filename))
+(cond ((eq obuf (current-buffer))
+	     (setq buffer-file-name ofile)
+	     (lock-buffer)
+	     (rename-buffer oname))))
+(or (eq (current-buffer) obuf)
+	(kill-buffer obuf))))
+;; At least in Emacs 18.55 this defvar has been forgotten to be copied
+;; from lpr.el into loaddefs.el
+(defvar lpr-command (if (eq system-type 'usg-unix-v)
+			"lp" "lpr")
+"Shell command for printing a file")
+;; buffer-disable-undo used to be called buffer-flush-undo in Emacs
+;; 18.55:
+(or (fboundp 'buffer-disable-undo)
+(fset 'buffer-disable-undo 'buffer-flush-undo))
+;;; end of emacs-19.el

Mercurial > hg > xemacs-beta

comparison lisp/efs/emacs-19.el @ 22:8fc7fe29b841 r19-15b94