xemacs-beta: lisp/w3/w3-sysdp.el comparison

comparison lisp/w3/w3-sysdp.el @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30

author	cvs
date	Mon, 13 Aug 2007 09:02:59 +0200
parents	c53a95d3c46d
children	1ce6082ce73f

comparison

equal deleted inserted replaced

-:804d1389bcd6
+:131b0175ea99
 ;;; sysdep.el --- consolidate Emacs-version dependencies in one file.
-;; Copyright (c) 1995 - 1997 Ben Wing.
+;; Copyright (C) 1995 Ben Wing.
-;; Author: Ben Wing <wing@666.com>, William Perry <wmperry@cs.indiana.edu>
+;; Author: Ben Wing <wing@666.com>
 ;; Keywords: lisp, tools
-;; Version: 0.003
+;; Version: 0.001
 ;; The purpose of this file is to eliminate the cruftiness that
 ;; would otherwise be required of packages that want to run on multiple
 ;; versions of Emacs.  The idea is that we make it look like we're running
 ;; the latest version of XEmacs (currently 19.12) by emulating all the
 ;; You may well discover deficiencies in this file as you use it.
 ;; The preferable way of dealing with this is to send me a patch
 ;; to sysdep.el; that way, the collective body of knowledge gets
 ;; increased.
+;; DO NOT load this file with `require'.
+;; DO NOT put a `provide' statement in this file.
 ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001)
 ;; so that string comparisons to other versions work properly.
-(defconst sysdep-potential-version "0.003")
+(defconst sysdep-potential-version "0.002")
+(if (and (boundp 'sysdep-version)
+	 (not (string-lessp sysdep-version sysdep-potential-version)))
+;; if a more recent version of sysdep was already loaded,
+;; or if the same package is loaded again, don't load.
+nil
+(defconst sysdep-version sysdep-potential-version)
 ;; this macro means: define the function, but only if either it
 ;; wasn't bound before, or the supplied binding comes from an older
 ;; version of sysdep.el.  That way, user-supplied bindings don't
 ;; get overridden.
 ;; esp. since you can do load-time conditionalizing and can
 ;; optionally leave the function undefined. (e.g. frame functions
 ;; in v18.)
 (defmacro sysdep-defun (function &rest everything-else)
-(` (cond ((and (not (fboundp (quote (, function))))
+(` (cond ((or (not (fboundp (quote (, function))))
-		 (or
+		(get (quote (, function)) 'sysdep-defined-this))
-		  (not
+	    (put (quote (, function)) 'sysdep-defined-this t)
-		   (stringp (get (quote (, function)) 'sysdep-defined-this)))
-		  (and (get (quote (, function)) 'sysdep-defined-this)
-		       (string-lessp
-			(get (quote (, function)) 'sysdep-defined-this)
-			sysdep-potential-version))))
-	    (put (quote (, function)) 'sysdep-defined-this
-		 sysdep-potential-version)
 	    (defun (, function) (,@ everything-else))))))
 (defmacro sysdep-defvar (function &rest everything-else)
-(` (cond ((and (not (boundp (quote (, function))))
+(` (cond ((or (not (boundp (quote (, function))))
-		 (or
+		(get (quote (, function)) 'sysdep-defined-this))
-		  (not
-		   (stringp (get (quote (, function)) 'sysdep-defined-this)))
-		  (and (get (quote (, function)) 'sysdep-defined-this)
-		       (string-lessp
-			(get (quote (, function)) 'sysdep-defined-this)
-			sysdep-potential-version))))
 	    (put (quote (, function)) 'sysdep-defined-this t)
 	    (defvar (, function) (,@ everything-else))))))
 (defmacro sysdep-defconst (function &rest everything-else)
-(` (cond ((and (not (boundp (quote (, function))))
+(` (cond ((or (not (boundp (quote (, function))))
-		 (or
+		(get (quote (, function)) 'sysdep-defined-this))
-		  (not
-		   (stringp (get (quote (, function)) 'sysdep-defined-this)))
-		  (and (get (quote (, function)) 'sysdep-defined-this)
-		       (string-lessp
-			(get (quote (, function)) 'sysdep-defined-this)
-			sysdep-potential-version))))
 	    (put (quote (, function)) 'sysdep-defined-this t)
 	    (defconst (, function) (,@ everything-else))))))
 ;; similar for fset and defalias.  No need to quote as the argument
 ;; is already quoted.
 (defmacro sysdep-fset (function def)
-(` (cond ((and (not (fboundp (, function)))
+(` (cond ((and (or (not (fboundp (, function)))
-		 (or (not (stringp
+		     (get (, function) 'sysdep-defined-this))
-			   (get (, function) 'sysdep-defined-this)))
-		     (and (get (, function) 'sysdep-defined-this)
-			  (string-lessp
-			   (get (, function) 'sysdep-defined-this)
-			   sysdep-potential-version)))
 		 (, def))
 	    (put (, function) 'sysdep-defined-this t)
 	    (fset (, function) (, def))))))
 (defmacro sysdep-defalias (function def)
-(` (cond ((and (not (fboundp (, function)))
+(` (cond ((and (or (not (fboundp (, function)))
-		 (or (not (stringp
+		     (get (, function) 'sysdep-defined-this))
-			   (get (, function) 'sysdep-defined-this)))
-		     (and (get (, function) 'sysdep-defined-this)
-			  (string-lessp
-			   (get (, function) 'sysdep-defined-this)
-			   sysdep-potential-version)))
 		 (, def)
 		 (or (listp (, def))
 		     (and (symbolp (, def))
 			  (fboundp (, def)))))
 	    (put (, function) 'sysdep-defined-this t)
 (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer)
 (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect)
 (sysdep-defalias 'get-other-frame 'get-other-screen)
 (sysdep-defalias 'iconify-frame 'iconify-screen)
 (sysdep-defalias 'lower-frame 'lower-screen)
-;(sysdep-defalias 'mail-other-frame 'mail-other-screen)
+(sysdep-defalias 'mail-other-frame 'mail-other-screen)
 (sysdep-defalias 'make-frame
 (cond ((fboundp 'make-screen)
 	 (function (lambda (&optional parameters device)
 		     (make-screen parameters))))
 (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer)
 (sysdep-defalias 'x-display-color-p 'x-color-display-p)
 (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p)
 (sysdep-defalias 'menu-event-p 'misc-user-event-p)
-;; WMP - commention these out so that Emacs 19 doesn't get screwed by them.
+(sysdep-defun add-submenu (menu-path submenu &optional before)
-;; In particular, this makes the 'custom' package blow up quite well.
+"Add a menu to the menubar or one of its submenus.
-;;(sysdep-defun add-submenu (menu-path submenu &optional before)
+If the named menu exists already, it is changed.
-;;  "Add a menu to the menubar or one of its submenus.
+MENU-PATH identifies the menu under which the new menu should be inserted.
-;;If the named menu exists already, it is changed.
+It is a list of strings; for example, (\"File\") names the top-level \"File\"
-;;MENU-PATH identifies the menu under which the new menu should be inserted.
+menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
-;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
+If MENU-PATH is nil, then the menu will be added to the menubar itself.
-;; menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
+SUBMENU is the new menu to add.
-;; If MENU-PATH is nil, then the menu will be added to the menubar itself.
+See the documentation of `current-menubar' for the syntax.
-;;SUBMENU is the new menu to add.
+BEFORE, if provided, is the name of a menu before which this menu should
-;; See the documentation of `current-menubar' for the syntax.
+be added, if this menu is not on its parent already.  If the menu is already
-;;BEFORE, if provided, is the name of a menu before which this menu should
+present, it will not be moved."
-;; be added, if this menu is not on its parent already.  If the menu is already
+(add-menu menu-path (car submenu) (cdr submenu) before))
-;; present, it will not be moved."
-;;  (add-menu menu-path (car submenu) (cdr submenu) before))
+(sysdep-defun add-menu-button (menu-path menu-leaf &optional before)
+"Add a menu item to some menu, creating the menu first if necessary.
-;;(sysdep-defun add-menu-button (menu-path menu-leaf &optional before)
+If the named item exists already, it is changed.
-;;  "Add a menu item to some menu, creating the menu first if necessary.
+MENU-PATH identifies the menu under which the new menu item should be inserted.
-;;If the named item exists already, it is changed.
+It is a list of strings; for example, (\"File\") names the top-level \"File\"
-;;MENU-PATH identifies the menu under which the new menu item should be inserted.
+menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
-;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
+MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
-;; menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
+BEFORE, if provided, is the name of a menu item before which this item should
-;;MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
+be added, if this item is not on the menu already.  If the item is already
-;;BEFORE, if provided, is the name of a menu item before which this item should
+present, it will not be moved."
-;; be added, if this item is not on the menu already.  If the item is already
+(add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1)
-;; present, it will not be moved."
+		(aref menu-leaf 2) before))
-;; (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1)
-;;		(aref menu-leaf 2) before))
 (sysdep-defun make-glyph (&optional spec-list)
 (if (and spec-list (cdr-safe (assq 'x spec-list)))
 (make-pixmap (cdr-safe (assq 'x spec-list)))))
 (sysdep-defalias 'face-list 'list-faces)
-(sysdep-defun set-keymap-parent (keymap new-parent)
-(let ((tail keymap))
-(while (and tail (cdr tail) (not (eq (car (cdr tail)) 'keymap)))
-(setq tail (cdr tail)))
-(if tail
-	(setcdr tail new-parent))))
 (sysdep-defun facep (face)
 "Return t if X is a face name or an internal face vector."
 ;; CAUTION!!! This is Emacs 19.x, for x <= 28, specific
 ;; I know of no version of Lucid Emacs or XEmacs that did not have
 ;; facep.  Even if they did, they are unsupported, so big deal.
-(if (not window-system)
+(and (or (internal-facep face)
-nil				; FIXME if FSF ever does TTY faces
+(and (symbolp face) (assq face global-face-data)))
-(and (or (internal-facep face)
+t))
-	     (and (symbolp face) (assq face global-face-data)))
-	 t)))
 (sysdep-defun set-face-property (face property value &optional locale
 				      tag-set how-to-add)
 "Change a property of FACE."
 (and (symbolp face)
 (put face property value)))
 (sysdep-defun face-property (face property &optional locale tag-set exact-p)
 "Return FACE's value of the given PROPERTY."
 (and (symbolp face) (get face property)))
-;;; Additional text property functions.
-;; The following three text property functions are not generally available (and
-;; it's not certain that they should be) so they are inlined for speed.
-;; The case for `fillin-text-property' is simple; it may or not be generally
-;; useful.  (Since it is used here, it is useful in at least one place.;-)
-;; However, the case for `append-text-property' and `prepend-text-property' is
-;; more complicated.  Should they remove duplicate property values or not?  If
-;; so, should the first or last duplicate item remain?  Or the one that was
-;; added?  In our implementation, the first duplicate remains.
-(sysdep-defun fillin-text-property (start end setprop markprop value &optional object)
-"Fill in one property of the text from START to END.
-Arguments PROP and VALUE specify the property and value to put where none are
-already in place.  Therefore existing property values are not overwritten.
-Optional argument OBJECT is the string or buffer containing the text."
-(let ((start (text-property-any start end markprop nil object)) next)
-(while start
-(setq next (next-single-property-change start markprop object end))
-(put-text-property start next setprop value object)
-(put-text-property start next markprop value object)
-(setq start (text-property-any next end markprop nil object)))))
-;; This function (from simon's unique.el) is rewritten and inlined for speed.
-;(defun unique (list function)
-;  "Uniquify LIST, deleting elements using FUNCTION.
-;Return the list with subsequent duplicate items removed by side effects.
-;FUNCTION is called with an element of LIST and a list of elements from LIST,
-;and should return the list of elements with occurrences of the element removed,
-;i.e., a function such as `delete' or `delq'.
-;This function will work even if LIST is unsorted.  See also `uniq'."
-;  (let ((list list))
-;    (while list
-;      (setq list (setcdr list (funcall function (car list) (cdr list))))))
-;  list)
-(sysdep-defun unique (list)
-"Uniquify LIST, deleting elements using `delq'.
-Return the list with subsequent duplicate items removed by side effects."
-(let ((list list))
-(while list
-(setq list (setcdr list (delq (car list) (cdr list))))))
-list)
-;; A generalisation of `facemenu-add-face' for any property, but without the
-;; removal of inactive faces via `facemenu-discard-redundant-faces' and special
-;; treatment of `default'.  Uses `unique' to remove duplicate property values.
-(sysdep-defun prepend-text-property (start end prop value &optional object)
-"Prepend to one property of the text from START to END.
-Arguments PROP and VALUE specify the property and value to prepend to the value
-already in place.  The resulting property values are always lists, and unique.
-Optional argument OBJECT is the string or buffer containing the text."
-(let ((val (if (listp value) value (list value))) next prev)
-(while (/= start end)
-(setq next (next-single-property-change start prop object end)
-	    prev (get-text-property start prop object))
-(put-text-property
-start next prop
-(unique (append val (if (listp prev) prev (list prev))))
-object)
-(setq start next))))
-(sysdep-defun append-text-property (start end prop value &optional object)
-"Append to one property of the text from START to END.
-Arguments PROP and VALUE specify the property and value to append to the value
-already in place.  The resulting property values are always lists, and unique.
-Optional argument OBJECT is the string or buffer containing the text."
-(let ((val (if (listp value) value (list value))) next prev)
-(while (/= start end)
-(setq next (next-single-property-change start prop object end)
-	    prev (get-text-property start prop object))
-(put-text-property
-start next prop
-(unique (append (if (listp prev) prev (list prev)) val))
-object)
-(setq start next))))
-(sysdep-defun buffer-substring-no-properties (st nd)
-"Return the characters of part of the buffer, without the text properties.
-The two arguments START and END are character positions;
-they can be in either order."
-(buffer-substring st nd))
 ;; Property list functions
 ;;
 (sysdep-defun plist-put (plist prop val)
 "Change value in PLIST of PROP to VAL.
 "Extract a value from a property list.
 PLIST is a property list, which is a list of the form
 (PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
 corresponding to the given PROP, or nil if PROP is not
 one of the properties on the list."
-(while (and plist (not (eq (car plist) prop)))
+(car-safe (cdr-safe (memq prop plist))))
-(setq plist (cdr (cdr plist))))
-(and plist (car (cdr plist))))
 ;; Device functions
 ;; By wmperry@cs.indiana.edu
 ;; This is a complete implementation of all the device-* functions found in
 ;; XEmacs 19.14.  A 'device' for Emacs 19 is just a frame, from which we can
 If CONNECTION specifies an already-existing device connection, that
 device is simply returned; no new device is created, and PROPS
 have no effect."
 (cond
 ((and (eq type 'x) connection)
-(make-frame-on-display connection props))
+(make-frame-on-display display props))
 ((eq type 'x)
 (make-frame props))
 ((eq type 'tty)
 nil)
 (t
 	system.  Not currently implemented.
 win32	A connection to a machine running Microsoft Windows NT or
 	Windows 95.  Not currently implemented.
 pc	A direct-write MS-DOS frame.  Not currently implemented.
-PROPS should be an plist of properties, as in the call to `make-frame'.
+PROPS should be a plist of properties, as in the call to `make-frame'.
 If a connection to CONNECTION already exists, it is reused; otherwise,
 a new connection is opened."
 (make-device type connection props))
 ((fboundp 'x-display-color-cells) 'x-display-color-cells)
 ((fboundp 'ns-display-color-cells) 'ns-display-color-celles)
 (t 'ignore)))
 (sysdep-defun try-font-name (fontname &rest args)
-(cond
+(car-safe (x-list-fonts fontname)))
-((eq window-system 'x) (car-safe (x-list-fonts fontname)))
-((eq window-system 'ns) (car-safe (ns-list-fonts fontname)))
-((eq window-system 'win32) (car-safe (x-list-fonts fontname)))
-((eq window-system 'pm) (car-safe (x-list-fonts fontname)))
-(t nil)))
 (sysdep-defalias 'device-pixel-width
 (cond
-((and (memq window-system '(x win32 pm)) (fboundp 'x-display-pixel-width))
+((and (eq window-system 'x) (fboundp 'x-display-pixel-width))
 'x-display-pixel-width)
 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width))
 'ns-display-pixel-width)
 (t 'ignore)))
 (sysdep-defalias 'device-pixel-height
 (cond
-((and (memq window-system '(x win32 pm)) (fboundp 'x-display-pixel-height))
+((and (eq window-system 'x) (fboundp 'x-display-pixel-height))
 'x-display-pixel-height)
 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height))
 'ns-display-pixel-height)
 (t 'ignore)))
 (sysdep-defalias 'device-mm-width
 (cond
-((and (memq window-system '(x win32 pm)) (fboundp 'x-display-mm-width))
+((and (eq window-system 'x) (fboundp 'x-display-mm-width))
 'x-display-mm-width)
 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width))
 'ns-display-mm-width)
 (t 'ignore)))
 (sysdep-defalias 'device-mm-height
 (cond
-((and (memq window-system '(x win32 pm)) (fboundp 'x-display-mm-height))
+((and (eq window-system 'x) (fboundp 'x-display-mm-height))
 'x-display-mm-height)
 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height))
 'ns-display-mm-height)
 (t 'ignore)))
 (sysdep-defalias 'device-bitplanes
 (cond
-((and (memq window-system '(x win32 pm)) (fboundp 'x-display-planes))
+((and (eq window-system 'x) (fboundp 'x-display-planes))
 'x-display-planes)
 ((and (eq window-system 'ns) (fboundp 'ns-display-planes))
 'ns-display-planes)
 (t 'ignore)))
 (let ((val (symbol-name (ns-display-visual-class))))
 	 (cond
 	  ((string-match "color" val) 'color)
 	  ((string-match "gray-scale" val) 'grayscale)
 	  (t 'mono))))))
-(t (function (lambda (&optional device) 'color)))))
+(t (function (lambda (&optional device) 'mono)))))
 (sysdep-defun device-class-list ()
 "Returns a list of valid device classes."
 (list 'color 'grayscale 'mono))
 (list 'tty)))
 (sysdep-defun valid-device-type-p (type)
 "Given a TYPE, return t if it is valid."
 (memq type (device-type-list)))
 ;; Extent stuff
 (sysdep-fset 'delete-extent 'delete-overlay)
 (sysdep-fset 'extent-end-position 'overlay-end)
 (sysdep-fset 'extent-start-position 'overlay-start)
 				t)))
 		  x))))
 (t 'identity)))			; All others
 ;; Misc.
-;; NT doesn't have make-symbolic-link
-(sysdep-defalias 'make-symbolic-link 'copy-file)
 (sysdep-defun split-string (string pattern)
 "Return a list of substrings of STRING which are separated by PATTERN."
 (let (parts (start 0))
 (while (string-match pattern string start)
 (setq parts (cons (substring string start (match-beginning 0)) parts)
 		(lambda (error-object stream)
 		  (princ "Peculiar error " stream)
 		  (prin1 error-object stream))))
 	   error-object stream))
-(sysdep-defun decode-time (&optional specified-time)
-(let* ((date (current-time-string specified-time))
-	 (dateinfo (and date (timezone-parse-date date)))
-	 (timeinfo (and dateinfo (timezone-parse-time (aref dateinfo 3)))))
-(list (aref timeinfo 2) (aref timeinfo 1)
-	  (aref timeinfo 0) (aref dateinfo 2)
-	  (aref dateinfo 1) (aref dateinfo 0)
-	  "unknown" nil 0)))
 (sysdep-defun find-face (face)
 (car-safe (memq face (face-list))))
 (sysdep-defun set-marker-insertion-type (marker type)
 "Set the insertion-type of MARKER to TYPE.
 ;; window functions
 ;; not defined in v18
 (sysdep-defun eval-buffer (bufname &optional printflag)
-(interactive)
 (save-excursion
 (set-buffer bufname)
 (eval-current-buffer)))
 (sysdep-defun window-minibuffer-p (window)
 (sysdep-defun window-live-p (window)
 "Returns t if OBJ is a window which is currently visible."
 (and (windowp window)
 (window-point window)))
-(provide 'w3-sysdp)
+;; this parenthesis closes the if statement at the top of the file.
+)
+;; DO NOT put a provide statement here.  This file should never be
+;; loaded with `require'.  Use `load-library' instead.
 ;;; sysdep.el ends here
 ;;;(sysdep.el) Local Variables:
 ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun)
 ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun)

Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-sysdp.el @ 70:131b0175ea99 r20-0b30