Mercurial > hg > xemacs-beta
diff lisp/url/url-sysdp.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | ac2d302a0011 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-sysdp.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,917 @@ +;;; sysdep.el --- consolidate Emacs-version dependencies in one file. + +;; Copyright (C) 1995 Ben Wing. + +;; Author: Ben Wing <wing@666.com> +;; Keywords: lisp, tools +;; 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 +;; missing functions. + +;; #### This file does not currently do any advising but should. +;; Unfortunately, advice.el is a hugely big package. Is any such +;; thing as `advice-lite' possible? + +;; #### - This package is great, but its role needs to be thought out a bit +;; more. Sysdep will not permit programs written for the old XEmacs API to +;; run on new versions of XEmacs. Sysdep is a backward-compatibility +;; package for the latest and greatest XEmacs API. It permits programmers +;; to use the latest XEmacs functionality and still have their programs run +;; on older versions of XEmacs...perhaps even on FSF Emacs. It should NEVER +;; ever need to be loaded in the newest XEmacs. It doesn't even make sense +;; to put it in the lisp/utils part of the XEmacs distribution because it's +;; real purpose is to be distributed with packages like w3 which take +;; advantage of the latest and greatest features of XEmacs but still need to +;; be run on older versions. --Stig + +;; Any packages that wish to use this file should load it using +;; `load-library'. It will not load itself if a version of sysdep.el +;; that is at least as recent has already been loaded, but will +;; load over an older version of sysdep.el. It will attempt to +;; not redefine functions that have already been custom-redefined, +;; but will redefine a function if the supplied definition came from +;; an older version of sysdep.el. + +;; Packages such as w3 that wish to include this file with the package +;; should rename it to something unique, such as `w3-sysdep.el', and +;; load it with `load-library'. That will ensure that no conflicts +;; arise if more than one package in the load path provides a version +;; of sysdep.el. If multiple packages load sysdep.el, the most recent +;; version will end up loaded; as long as I'm careful not to +;; introduce bugs in previously working definitions, this should work +;; fine. + +;; 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.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. + +;; note: sysdep-defalias is often more useful than this function, +;; 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 ((or (not (fboundp (quote (, function)))) + (get (quote (, function)) 'sysdep-defined-this)) + (put (quote (, function)) 'sysdep-defined-this t) + (defun (, function) (,@ everything-else)))))) + +(defmacro sysdep-defvar (function &rest everything-else) + (` (cond ((or (not (boundp (quote (, function)))) + (get (quote (, function)) 'sysdep-defined-this)) + (put (quote (, function)) 'sysdep-defined-this t) + (defvar (, function) (,@ everything-else)))))) + +(defmacro sysdep-defconst (function &rest everything-else) + (` (cond ((or (not (boundp (quote (, function)))) + (get (quote (, function)) 'sysdep-defined-this)) + (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 (or (not (fboundp (, function))) + (get (, function) 'sysdep-defined-this)) + (, def)) + (put (, function) 'sysdep-defined-this t) + (fset (, function) (, def)))))) + +(defmacro sysdep-defalias (function def) + (` (cond ((and (or (not (fboundp (, function))) + (get (, function) 'sysdep-defined-this)) + (, def) + (or (listp (, def)) + (and (symbolp (, def)) + (fboundp (, def))))) + (put (, function) 'sysdep-defined-this t) + (defalias (, function) (, def)))))) + +;; bootstrapping: defalias and define-function don't exist +;; in older versions of lemacs + +(sysdep-fset 'defalias 'fset) +(sysdep-defalias 'define-function 'defalias) + +;; useful ways of determining what version is running +;; emacs-major-version and emacs-minor-version are +;; already defined in recent versions of FSF Emacs and XEmacs + +(sysdep-defconst emacs-major-version + ;; will string-match ever fail? If so, assume 19.0. + ;; (should we assume 18.something?) + (if (string-match "^[0-9]+" emacs-version) + (string-to-int + (substring emacs-version + (match-beginning 0) (match-end 0))) + 19)) + +(sysdep-defconst emacs-minor-version + (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) + (string-to-int + (substring emacs-version + (match-beginning 1) (match-end 1))) + 0)) + +(sysdep-defconst sysdep-running-xemacs + (or (string-match "Lucid" emacs-version) + (string-match "XEmacs" emacs-version))) + +(sysdep-defconst window-system nil) +(sysdep-defconst window-system-version 0) + +(sysdep-defvar list-buffers-directory nil) +(sysdep-defvar x-library-search-path '("/usr/X11R6/lib/X11/" + "/usr/X11R5/lib/X11/" + "/usr/lib/X11R6/X11/" + "/usr/lib/X11R5/X11/" + "/usr/local/X11R6/lib/X11/" + "/usr/local/X11R5/lib/X11/" + "/usr/local/lib/X11R6/X11/" + "/usr/local/lib/X11R5/X11/" + "/usr/X11/lib/X11/" + "/usr/lib/X11/" + "/usr/local/lib/X11/" + "/usr/X386/lib/X11/" + "/usr/x386/lib/X11/" + "/usr/XFree86/lib/X11/" + "/usr/unsupported/lib/X11/" + "/usr/athena/lib/X11/" + "/usr/local/x11r5/lib/X11/" + "/usr/lpp/Xamples/lib/X11/" + "/usr/openwin/lib/X11/" + "/usr/openwin/share/lib/X11/") + "Search path used for X11 libraries.") + +;; frame-related stuff. + +(sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen) +(sysdep-defalias 'deiconify-frame + (cond ((fboundp 'deiconify-screen) 'deiconify-screen) + ;; make-frame-visible will be defined as necessary + (t 'make-frame-visible))) +(sysdep-defalias 'delete-frame 'delete-screen) +(sysdep-defalias 'event-frame 'event-screen) +(sysdep-defalias 'event-glyph-extent 'event-glyph) +(sysdep-defalias 'find-file-other-frame 'find-file-other-screen) +(sysdep-defalias 'find-file-read-only-other-frame + 'find-file-read-only-other-screen) +(sysdep-defalias 'frame-height 'screen-height) +(sysdep-defalias 'frame-iconified-p 'screen-iconified-p) +(sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width) +(sysdep-defalias 'frame-list 'screen-list) +(sysdep-defalias 'frame-live-p + (cond ((fboundp 'screen-live-p) 'screen-live-p) + ((fboundp 'live-screen-p) 'live-screen-p) + ;; #### not sure if this is correct (this is for Epoch) + ;; but gnuserv.el uses it this way + ((fboundp 'screenp) 'screenp))) +(sysdep-defalias 'frame-name 'screen-name) +(sysdep-defalias 'frame-parameters 'screen-parameters) +(sysdep-defalias 'frame-pixel-height 'screen-pixel-height) +(sysdep-defalias 'frame-pixel-width 'screen-pixel-width) +(sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width) +(sysdep-defalias 'frame-root-window 'screen-root-window) +(sysdep-defalias 'frame-selected-window 'screen-selected-window) +(sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p) +(sysdep-defalias 'frame-visible-p 'screen-visible-p) +(sysdep-defalias 'frame-width 'screen-width) +(sysdep-defalias 'framep 'screenp) +(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 'make-frame + (cond ((fboundp 'make-screen) + (function (lambda (&optional parameters device) + (make-screen parameters)))) + ((fboundp 'x-create-screen) + (function (lambda (&optional parameters device) + (x-create-screen parameters)))))) + +(sysdep-defalias 'make-frame-invisible 'make-screen-invisible) +(sysdep-defalias 'make-frame-visible + (cond ((fboundp 'make-screen-visible) 'make-screen-visible) + ((fboundp 'mapraised-screen) 'mapraised-screen) + ((fboundp 'x-remap-window) + (lambda (&optional x) + (x-remap-window) + (accept-process-output))))) +(sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters) +(sysdep-defalias 'new-frame 'new-screen) +(sysdep-defalias 'next-frame 'next-screen) +(sysdep-defalias 'next-multiframe-window 'next-multiscreen-window) +(sysdep-defalias 'other-frame 'other-screen) +(sysdep-defalias 'previous-frame 'previous-screen) +(sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window) +(sysdep-defalias 'raise-frame + (cond ((fboundp 'raise-screen) 'raise-screen) + ((fboundp 'mapraise-screen) 'mapraise-screen))) +(sysdep-defalias 'redraw-frame 'redraw-screen) +(sysdep-defalias 'select-frame 'select-screen) +(sysdep-defalias 'selected-frame 'selected-screen) +(sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen) +(sysdep-defalias 'set-frame-height 'set-screen-height) +(sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width) +(sysdep-defalias 'set-frame-position 'set-screen-position) +(sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width) +(sysdep-defalias 'set-frame-size 'set-screen-size) +(sysdep-defalias 'set-frame-width 'set-screen-width) +(sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen) +(sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen) +(sysdep-defalias 'visible-frame-list 'visible-screen-list) +(sysdep-defalias 'window-frame 'window-screen) +(sysdep-defalias 'x-create-frame 'x-create-screen) +(sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap) +(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) + +(sysdep-defun add-submenu (menu-path submenu &optional before) + "Add a menu to the menubar or one of its submenus. +If the named menu exists already, it is changed. +MENU-PATH identifies the menu under which the new menu should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". + If MENU-PATH is nil, then the menu will be added to the menubar itself. +SUBMENU is the new menu to add. + See the documentation of `current-menubar' for the syntax. +BEFORE, if provided, is the name of a menu before which this menu should + be added, if this menu is not on its parent already. If the menu is already + 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. +If the named item exists already, it is changed. +MENU-PATH identifies the menu under which the new menu item should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". +MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. +BEFORE, if provided, is the name of a menu item before which this item should + be added, if this item is not on the menu already. If the item is already + present, it will not be moved." + (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-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))) + +;; Device functions +;; By wmperry@spry.com +;; 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 +;; determine the connection to an X display, etc. + +(sysdep-defalias 'selected-device 'ignore) +(sysdep-defalias 'device-or-frame-p 'framep) +(sysdep-defalias 'device-console 'ignore) +(sysdep-defalias 'device-sound-enabled-p 'ignore) +(sysdep-defalias 'device-live-p 'frame-live-p) +(sysdep-defalias 'devicep 'framep) +(sysdep-defalias 'frame-device 'identity) +(sysdep-defalias 'redisplay-device 'redraw-frame) +(sysdep-defalias 'redraw-device 'redraw-frame) +(sysdep-defalias 'select-device 'select-frame) +(sysdep-defalias 'set-device-class 'ignore) + +(sysdep-defun make-device (type connection &optional props) + "Create a new device of type TYPE, attached to connection CONNECTION. + +The valid values for CONNECTION are device-specific; however, +CONNECTION is generally a string. (Specifically, for X devices, +CONNECTION should be a display specification such as \"foo:0\", and +for TTY devices, CONNECTION should be the filename of a TTY device +file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard +input/output.) + +PROPS, if specified, should be a plist of properties controlling +device creation. + +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 display props)) + ((eq type 'x) + (make-frame props)) + ((eq type 'tty) + nil) + (t + (error "Unsupported device-type: %s" type)))) + +(sysdep-defun make-frame-on-device (type connection &optional props) + "Create a frame of type TYPE on CONNECTION. +TYPE should be a symbol naming the device type, i.e. one of + +x An X display. CONNECTION should be a standard display string + such as \"unix:0\", or nil for the display specified on the + command line or in the DISPLAY environment variable. Only if + support for X was compiled into XEmacs. +tty A standard TTY connection or terminal. CONNECTION should be + a TTY device name such as \"/dev/ttyp2\" (as determined by + the Unix command `tty') or nil for XEmacs' standard input + and output (usually the TTY in which XEmacs started). Only + if support for TTY's was compiled into XEmacs. +ns A connection to a machine running the NeXTstep windowing + 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'. + +If a connection to CONNECTION already exists, it is reused; otherwise, +a new connection is opened." + (make-device type connection props)) + +(sysdep-defun make-tty-device (&optional tty terminal-type) + "Create a new device on TTY. + TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under +SunOS et al.), as returned by the `tty' command. A value of nil means +use the stdin and stdout as passed to XEmacs from the shell. + If TERMINAL-TYPE is non-nil, it should be a string specifying the +type of the terminal attached to the specified tty. If it is nil, +the terminal type will be inferred from the TERM environment variable." + (make-device 'tty tty (list 'terminal-type terminal-type))) + +(sysdep-defun make-x-device (&optional display) + (make-device 'x display)) + +(sysdep-defun set-device-selected-frame (device frame) + "Set the selected frame of device object DEVICE to FRAME. +If DEVICE is nil, the selected device is used. +If DEVICE is the selected device, this makes FRAME the selected frame." + (select-frame frame)) + +(sysdep-defun set-device-baud-rate (device rate) + "Set the output baud rate of DEVICE to RATE. +On most systems, changing this value will affect the amount of padding +and other strategic decisions made during redisplay." + (setq baud-rate rate)) + +(sysdep-defun dfw-device (obj) + "Given a device, frame, or window, return the associated device. +Return nil otherwise." + (cond + ((windowp obj) + (window-frame obj)) + ((framep obj) + obj) + (t + nil))) + +(sysdep-defun event-device (event) + "Return the device that EVENT occurred on. +This will be nil for some types of events (e.g. keyboard and eval events)." + (dfw-device (posn-window (event-start event)))) + +(sysdep-defun find-device (connection &optional type) + "Look for an existing device attached to connection CONNECTION. +Return the device if found; otherwise, return nil. + +If TYPE is specified, only return devices of that type; otherwise, +return devices of any type. (It is possible, although unlikely, +that two devices of different types could have the same connection +name; in such a case, the first device found is returned.)" + (let ((devices (device-list)) + (retval nil)) + (while (and devices (not nil)) + (if (equal connection (device-connection (car devices))) + (setq retval (car devices))) + (setq devices (cdr devices))) + retval)) + +(sysdep-defalias 'get-device 'find-device) + +(sysdep-defun device-baud-rate (&optional device) + "Return the output baud rate of DEVICE." + baud-rate) + +(sysdep-defun device-on-window-system-p (&optional device) + "Return non-nil if DEVICE is on a window system. +This generally means that there is support for the mouse, the menubar, +the toolbar, glyphs, etc." + (and (cdr-safe (assq 'display (frame-parameters device))) t)) + +(sysdep-defun device-name (&optional device) + "Return the name of the specified device." + ;; doesn't handle the 19.29 multiple X display stuff yet + ;; doesn't handle NeXTStep either + (cond + ((null window-system) "stdio") + ((getenv "DISPLAY") + (let ((str (getenv "DISPLAY")) + (x (1- (length (getenv "DISPLAY")))) + (y 0)) + (while (/= y x) + (if (or (= (aref str y) ?:) + (= (aref str y) ?.)) + (aset str y ?-)) + (setq y (1+ y))) + str)) + (t "stdio"))) + + +(sysdep-defun device-connection (&optional device) + "Return the connection of the specified device. +DEVICE defaults to the selected device if omitted" + (or (cdr-safe (assq 'display (frame-parameters device))) "stdio")) + +(sysdep-defun device-frame-list (&optional device) + "Return a list of all frames on DEVICE. +If DEVICE is nil, the selected device will be used." + (let ((desired (device-connection device))) + (filtered-frame-list (function (lambda (x) (equal (device-connection x) + desired)))))) +(sysdep-defun device-list () + "Return a list of all devices" + (let ((seen nil) + (cur nil) + (conn nil) + (retval nil) + (not-heard (frame-list))) + (while not-heard + (setq cur (car not-heard) + conn (device-connection cur) + not-heard (cdr not-heard)) + (if (member conn seen) + nil ; Already got it + (setq seen (cons conn seen) ; Whoo hoo, a new one! + retval (cons cur retval)))) + retval)) + +(sysdep-defvar delete-device-hook nil + "Function or functions to call when a device is deleted. +One argument, the to-be-deleted device.") + +(sysdep-defun delete-device (device &optional force) + "Delete DEVICE, permanently eliminating it from use. +Normally, you cannot delete the last non-minibuffer-only frame (you must +use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional +second argument FORCE is non-nil, you can delete the last frame. (This +will automatically call `save-buffers-kill-emacs'.)" + (let ((frames (device-frame-list device))) + (run-hook-with-args 'delete-device-hook device) + (while frames + (delete-frame (car frames) force) + (setq frames (cdr frames))))) + +(sysdep-defalias 'device-color-cells + (cond + ((null window-system) 'ignore) + ((fboundp 'display-color-cells) 'display-color-cells) + ((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) + (car-safe (x-list-fonts fontname))) + +(sysdep-defalias 'device-pixel-width + (cond + ((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 (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 (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 (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 (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))) + +(sysdep-defalias 'device-class + (cond + ((and (eq window-system 'x) (fboundp 'x-display-visual-class)) + (function + (lambda (&optional device) + (let ((val (symbol-name (x-display-visual-class device)))) + (cond + ((string-match "color" val) 'color) + ((string-match "gray-scale" val) 'grayscale) + (t 'mono)))))) + ((fboundp 'number-of-colors) + (function + (lambda (&optional device) + (if (= 2 (number-of-colors)) + 'mono + 'color)))) + ((and (eq window-system 'x) (fboundp 'x-color-p)) + (function + (lambda (&optional device) + (if (x-color-p) + 'color + 'mono)))) + ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class)) + (function + (lambda (&optional device) + (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) 'mono))))) + +(sysdep-defun device-class-list () + "Returns a list of valid device classes." + (list 'color 'grayscale 'mono)) + +(sysdep-defun valid-device-class-p (class) + "Given a CLASS, return t if it is valid. +Valid classes are 'color, 'grayscale, and 'mono." + (memq class (device-class-list))) + +(sysdep-defun device-or-frame-type (device-or-frame) + "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. +DEVICE-OR-FRAME should be a device or a frame object. See `device-type' +for a description of the possible types." + (if (cdr-safe (assq 'display (frame-parameters device-or-frame))) + window-system + 'tty)) + +(sysdep-defun device-type (&optional device) + "Return the type of the specified device (e.g. `x' or `tty'). +Value is `tty' for a tty device (a character-only terminal), +`x' for a device which is a connection to an X server, +'ns' for a device which is a connection to a NeXTStep dps server, +'win32' for a Windows-NT window, +'pm' for an OS/2 Presentation Manager window, +'intuition' for an Amiga screen" + (device-or-frame-type device)) + +(sysdep-defun device-type-list () + "Return a list of valid console types." + (if window-system + (list window-system 'tty) + (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) +(sysdep-fset 'set-extent-endpoints 'move-overlay) + +(sysdep-defun extent-property (extent property &optional default) + (or (overlay-get extent property) default)) + +(sysdep-defun extent-at (pos &optional object property before at-flag) + (let ((tmp (overlays-at (point))) + ovls) + (if property + (while tmp + (if (extent-property (car tmp) property) + (setq ovls (cons (car tmp) ovls))) + (setq tmp (cdr tmp))) + (setq ovls tmp + tmp nil)) + (car-safe + (sort ovls + (function + (lambda (a b) + (< (- (extent-end-position a) (extent-start-position a)) + (- (extent-end-position b) (extent-start-position b))))))))) + + +(sysdep-defun overlays-in (beg end) + "Return a list of the overlays that overlap the region BEG ... END. +Overlap means that at least one character is contained within the overlay +and also contained within the specified region. +Empty overlays are included in the result if they are located at BEG +or between BEG and END." + (let ((ovls (overlay-lists)) + tmp retval) + (if (< end beg) + (setq tmp end + end beg + beg tmp)) + (setq ovls (nconc (car ovls) (cdr ovls))) + (while ovls + (setq tmp (car ovls) + ovls (cdr ovls)) + (if (or (and (<= (overlay-start tmp) end) + (>= (overlay-start tmp) beg)) + (and (<= (overlay-end tmp) end) + (>= (overlay-end tmp) beg))) + (setq retval (cons tmp retval)))) + retval)) + +(sysdep-defun map-extents (function &optional object from to + maparg flags property value) + (let ((tmp (overlays-in (or from (point-min)) + (or to (point-max)))) + ovls) + (if property + (while tmp + (if (extent-property (car tmp) property) + (setq ovls (cons (car tmp) ovls))) + (setq tmp (cdr tmp))) + (setq ovls tmp + tmp nil)) + (catch 'done + (while ovls + (setq tmp (funcall function (car ovls) maparg) + ovls (cdr ovls)) + (if tmp + (throw 'done tmp)))))) + +;; misc +(sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value) + "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." + (save-excursion + (set-buffer buffer) + (if (not (boundp symbol)) + unbound-value + (symbol-value symbol)))) + +(sysdep-defun insert-file-contents-literally + (file &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ((file-name-handler-alist nil) + (find-file-hooks nil)) + (insert-file-contents file visit beg end replace))) + +(sysdep-defun alist-to-plist (alist) + "Convert association list ALIST into the equivalent property-list form. +The plist is returned. This converts from + +\((a . 1) (b . 2) (c . 3)) + +into + +\(a 1 b 2 c 3) + +The original alist is not modified. See also `destructive-alist-to-plist'." + (let (plist) + (while alist + (let ((el (car alist))) + (setq plist (cons (cdr el) (cons (car el) plist)))) + (setq alist (cdr alist))) + (nreverse plist))) + +(sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun) + "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. +TOGGLE is a symbol which is used as the variable which toggle the minor mode, +NAME is the name that should appear in the modeline (it should be a string +beginning with a space), KEYMAP is a keymap to make active when the minor +mode is active, and AFTER is the toggling symbol used for another minor +mode. If AFTER is non-nil, then it is used to position the new mode in the +minor-mode alists. TOGGLE-FUN specifies an interactive function that +is called to toggle the mode on and off; this affects what appens when +button2 is pressed on the mode, and when button3 is pressed somewhere +in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an +interactive function, TOGGLE is used as the toggle function. + +Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" + (if (not (assq toggle minor-mode-alist)) + (setq minor-mode-alist (cons (list toggle name) minor-mode-alist))) + (if (and keymap (not (assq toggle minor-mode-map-alist))) + (setq minor-mode-map-alist (cons (cons toggle keymap) + minor-mode-map-alist)))) + +(sysdep-defvar x-font-regexp-foundry-and-family + (let ((- "[-?]") + (foundry "[^-]+") + (family "[^-]+") + ) + (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) + +(sysdep-defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) + +(sysdep-defun add-hook (hook-var function &optional at-end) + "Add a function to a hook. +First argument HOOK-VAR (a symbol) is the name of a hook, second + argument FUNCTION is the function to add. +Third (optional) argument AT-END means to add the function at the end + of the hook list instead of the beginning. If the function is already + present, this has no effect. +Returns nil if FUNCTION was already present in HOOK-VAR, else new + value of HOOK-VAR." + (if (not (boundp hook-var)) (set hook-var nil)) + (let ((old (symbol-value hook-var))) + (if (or (not (listp old)) (eq (car old) 'lambda)) + (setq old (list old))) + (if (member function old) + nil + (set hook-var + (if at-end + (append old (list function)) ; don't nconc + (cons function old)))))) + +(sysdep-defalias 'valid-color-name-p + (cond + ((fboundp 'x-valid-color-name-p) ; XEmacs/Lucid + 'x-valid-color-name-p) + ((and window-system + (fboundp 'color-defined-p)) ; NS/Emacs 19 + 'color-defined-p) + ((and window-system + (fboundp 'x-color-defined-p)) ; Emacs 19 + 'x-color-defined-p) + ((fboundp 'get-color) ; Epoch + (function (lambda (color) + (let ((x (get-color color))) + (if x + (setq x (progn + (free-color x) + t))) + x)))) + (t 'identity))) ; All others + +;; Misc. +(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) + start (match-end 0))) + (nreverse (cons (substring string start) parts)) + )) + +(sysdep-defun member (elt list) + (while (and list (not (equal elt (car list)))) + (setq list (cdr list))) + list) + +(sysdep-defun rassoc (key list) + (let ((found nil)) + (while (and list (not found)) + (if (equal (cdr (car list)) key) (setq found (car list))) + (setq list (cdr list))) + found)) + +(sysdep-defun display-error (error-object stream) + "Display `error-object' on `stream' in a user-friendly way." + (funcall (or (let ((type (car-safe error-object))) + (catch 'error + (and (consp error-object) + (symbolp type) + ;;(stringp (get type 'error-message)) + (consp (get type 'error-conditions)) + (let ((tail (cdr error-object))) + (while (not (null tail)) + (if (consp tail) + (setq tail (cdr tail)) + (throw 'error nil))) + t) + ;; (check-type condition condition) + (get type 'error-conditions) + ;; Search class hierarchy + (let ((tail (get type 'error-conditions))) + (while (not (null tail)) + (cond ((not (and (consp tail) + (symbolp (car tail)))) + (throw 'error nil)) + ((get (car tail) 'display-error) + (throw 'error (get (car tail) + 'display-error))) + (t + (setq tail (cdr tail))))) + ;; Default method + (function + (lambda (error-object stream) + (let ((type (car error-object)) + (tail (cdr error-object)) + (first t)) + (if (eq type 'error) + (progn (princ (car tail) stream) + (setq tail (cdr tail))) + (princ (or (get type 'error-message) type) + stream)) + (while tail + (princ (if first ": " ", ") stream) + (prin1 (car tail) stream) + (setq tail (cdr tail) + first nil))))))))) + (function + (lambda (error-object stream) + (princ "Peculiar error " stream) + (prin1 error-object stream)))) + error-object stream)) + +(sysdep-defun find-face (face) + (car-safe (memq face (face-list)))) + +;; window functions + +;; not defined in v18 +(sysdep-defun eval-buffer (bufname &optional printflag) + (save-excursion + (set-buffer bufname) + (eval-current-buffer))) + +(sysdep-defun window-minibuffer-p (window) + "Returns non-nil if WINDOW is a minibuffer window." + (eq window (minibuffer-window))) + +;; not defined in v18 +(sysdep-defun window-live-p (window) + "Returns t if OBJ is a window which is currently visible." + (and (windowp window) + (window-point window))) + +;; 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) +;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun) +;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun) +;;;(sysdep.el) End: