;;; Code:
+(eval-when-compile
+ (require 'cl))
+
;;; Compatibility:
(defun custom-xmas-add-text-properties (start end props &optional object)
(progn
(fset 'custom-add-text-properties 'custom-xmas-add-text-properties)
(fset 'custom-put-text-property 'custom-xmas-put-text-property)
- (fset 'custom-extent-start-open 'custom-xmas-extent-start-open))
+ (fset 'custom-extent-start-open 'custom-xmas-extent-start-open)
+ (fset 'custom-set-text-properties
+ (if (fboundp 'set-text-properties)
+ 'set-text-properties))
+ (fset 'custom-buffer-substring-no-properties
+ (if (fboundp 'buffer-substring-no-properties)
+ 'buffer-substring-no-properties
+ 'custom-xmas-buffer-substring-no-properties)))
(fset 'custom-add-text-properties 'add-text-properties)
(fset 'custom-put-text-property 'put-text-property)
- (fset 'custom-extent-start-open 'ignore))
-
-(or (fboundp 'buffer-substring-no-properties)
- ;; Introduced in Emacs 19.29.
- (defun buffer-substring-no-properties (beg end)
- "Return the text from BEG to END, without text properties, as a string."
- (let ((string (buffer-substring beg end)))
- (set-text-properties 0 (length string) nil string)
- string)))
-
-(or (fboundp 'add-to-list)
- ;; Introduced in Emacs 19.29.
- (defun add-to-list (list-var element)
- "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
-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))))))
-
-(or (fboundp 'plist-get)
- ;; Introduced in Emacs 19.29.
- (defun plist-get (plist prop)
- "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."
- (let (result)
- (while plist
- (if (eq (car plist) prop)
- (setq result (car (cdr plist))
- plist nil)
- (set plist (cdr (cdr plist)))))
- result)))
-
-(or (fboundp 'plist-put)
- ;; Introduced in Emacs 19.29.
- (defun plist-put (plist prop val)
- "Change value in PLIST of PROP to VAL.
-PLIST is a property list, which is a list of the form
-\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
-If PROP is already a property on the list, its value is set to VAL,
-otherwise the new PROP VAL pair is added. The new plist is returned;
-use `(setq x (plist-put x prop val))' to be sure to use the new value.
-The PLIST is modified by side effects."
- (if (null plist)
- (list prop val)
- (let ((current plist))
- (while current
- (cond ((eq (car current) prop)
- (setcar (cdr current) val)
- (setq current nil))
- ((null (cdr (cdr current)))
- (setcdr (cdr current) (list prop val))
- (setq current nil))
- (t
- (setq current (cdr (cdr current)))))))
- plist)))
-
-(or (fboundp 'match-string)
- ;; Introduced in Emacs 19.29.
- (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))))))
-
-(or (fboundp 'facep)
- ;; Introduced in Emacs 19.29.
- (defun facep (x)
- "Return t if X is a face name or an internal face vector."
- (and (or (and (fboundp 'internal-facep) (internal-facep x))
- (and
- (symbolp x)
- (assq x (and (boundp 'global-face-data) global-face-data))))
- t)))
+ (fset 'custom-extent-start-open 'ignore)
+ (fset 'custom-set-text-properties 'set-text-properties)
+ (fset 'custom-buffer-substring-no-properties
+ 'buffer-substring-no-properties))
+
+(defun custom-xmas-buffer-substring-no-properties (beg end)
+ "Return the text from BEG to END, without text properties, as a string."
+ (let ((string (buffer-substring beg end)))
+ (custom-set-text-properties 0 (length string) nil string)
+ string))
;; XEmacs and Emacs 19.29 facep does different things.
(if (fboundp 'find-face)
(and (fboundp 'set-face-underline-p)
(funcall 'set-face-underline-p 'underline t))))
-(or (fboundp 'set-text-properties)
- ;; Missing in XEmacs 19.12.
- (defun set-text-properties (start end props &optional buffer)
- (if (or (null buffer) (bufferp buffer))
- (if props
- (while props
- (custom-put-text-property
- start end (car props) (nth 1 props) buffer)
- (setq props (nthcdr 2 props)))
- (remove-text-properties start end ())))))
-
-(or (fboundp 'event-closest-point)
+(defun custom-xmas-set-text-properties (start end props &optional buffer)
+ (if (null buffer)
+ (if props
+ (while props
+ (custom-put-text-property
+ start end (car props) (nth 1 props) buffer)
+ (setq props (nthcdr 2 props)))
+ (remove-text-properties start end ()))))
+
+(or (fboundp 'event-point)
;; Missing in Emacs 19.29.
(defun event-point (event)
"Return the character position of the given mouse-motion, button-press,
(defvar custom-mouse-face nil)
(defvar custom-field-active-face nil))
-(or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
- ;; Introduced in Emacs 19.29. Incompatible definition also introduced
- ;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
- ;; face-lock does not call modify-face, so we can safely redefine it.
- (defun modify-face (face foreground background stipple
- bold-p italic-p underline-p)
- "Change the display attributes for face FACE.
-FOREGROUND and BACKGROUND should be color strings or nil.
-STIPPLE should be a stipple pattern name or nil.
-BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
-in italic, and underlined, respectively. (Yes if non-nil.)
-If called interactively, prompts for a face and face attributes."
- (interactive
- (let* ((completion-ignore-case t)
- (face (symbol-name (read-face-name "Modify face: ")))
- (colors (mapcar 'list x-colors))
- (stipples (mapcar 'list
- (apply 'nconc
- (mapcar 'directory-files
- x-bitmap-file-path))))
- (foreground (modify-face-read-string
- face (face-foreground (intern face))
- "foreground" colors))
- (background (modify-face-read-string
- face (face-background (intern face))
- "background" colors))
- (stipple (modify-face-read-string
- face (face-stipple (intern face))
- "stipple" stipples))
- (bold-p (y-or-n-p (concat "Set face " face " bold ")))
- (italic-p (y-or-n-p (concat "Set face " face " italic ")))
- (underline-p (y-or-n-p (concat "Set face " face " underline "))))
- (message "Face %s: %s" face
- (mapconcat 'identity
- (delq nil
- (list (and foreground (concat (downcase foreground) " foreground"))
- (and background (concat (downcase background) " background"))
- (and stipple (concat (downcase stipple) " stipple"))
- (and bold-p "bold") (and italic-p "italic")
- (and underline-p "underline"))) ", "))
- (list (intern face) foreground background stipple
- bold-p italic-p underline-p)))
- (condition-case nil (set-face-foreground face foreground) (error nil))
- (condition-case nil (set-face-background face background) (error nil))
- (condition-case nil (set-face-stipple face stipple) (error nil))
- (if (string-match "XEmacs" emacs-version)
- (progn
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
- (set-face-underline-p face underline-p)
- (and (interactive-p) (redraw-display))))
-
;; We can't easily check for a working intangible.
(defconst intangible (if (and (boundp 'emacs-minor-version)
(or (> emacs-major-version 19)
;; Put it in the Help menu, if possible.
(if (string-match "XEmacs" emacs-version)
- ;; XEmacs (disabled because it doesn't work)
- (and current-menubar
- (add-menu-item '("Help") "Customize..." 'customize nil))
+ (if (featurep 'menubar)
+ ;; XEmacs (disabled because it doesn't work)
+ (and current-menubar
+ (add-menu-item '("Help") "Customize..." 'customize t)))
;; Emacs 19.28 and earlier
(global-set-key [ menu-bar help customize ]
'("Customize..." . customize))
(defun custom-face-import (custom value)
"Modify CUSTOM's VALUE to match internal expectations."
- (let ((name (symbol-name value)))
+ (let ((name (or (and (facep value) (symbol-name (face-name value)))
+ (symbol-name value))))
(list (if (string-match "\
custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
name)
(intern (match-string 6 name)))
value))))
-(defun custom-face-lookup (fg bg stipple bold italic underline)
- "Lookup or create a face with specified attributes.
-FG BG STIPPLE BOLD ITALIC UNDERLINE"
+(defun custom-face-lookup (&optional fg bg stipple bold italic underline)
+ "Lookup or create a face with specified attributes."
(let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
(or fg "default")
(or bg "default")
(if (and (custom-facep name)
(fboundp 'make-face))
()
- (make-face name)
- (modify-face name
- (if (string-equal fg "default") nil fg)
- (if (string-equal bg "default") nil bg)
- (if (string-equal stipple "default") nil stipple)
- bold italic underline))
+ (copy-face 'default name)
+ (when (and fg
+ (not (string-equal fg "default")))
+ (condition-case ()
+ (set-face-foreground name fg)
+ (error nil)))
+ (when (and bg
+ (not (string-equal bg "default")))
+ (condition-case ()
+ (set-face-background name bg)
+ (error nil)))
+ (when (and stipple
+ (not (string-equal stipple "default"))
+ (not (eq stipple 'custom:asis))
+ (fboundp 'set-face-stipple))
+ (set-face-stipple name stipple))
+ (when (and bold
+ (not (eq bold 'custom:asis)))
+ (condition-case ()
+ (make-face-bold name)
+ (error nil)))
+ (when (and italic
+ (not (eq italic 'custom:asis)))
+ (condition-case ()
+ (make-face-italic name)
+ (error nil)))
+ (when (and underline
+ (not (eq underline 'custom:asis)))
+ (condition-case ()
+ (set-face-underline-p name t)
+ (error nil))))
name))
(defun custom-face-hack (field value)
"Describe how to execute COMMAND."
(let ((from (point)))
(insert "`" (key-description (where-is-internal command nil t)) "'")
- (set-text-properties from (point)
- (list 'face custom-button-face
- mouse-face custom-mouse-face
- 'custom-jump t ;Make TAB jump over it.
- 'custom-tag command
- 'start-open t
- 'end-open t))
+ (custom-set-text-properties from (point)
+ (list 'face custom-button-face
+ mouse-face custom-mouse-face
+ 'custom-jump t ;Make TAB jump over it.
+ 'custom-tag command
+ 'start-open t
+ 'end-open t))
(custom-category-set from (point) 'custom-documentation-properties))
(custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
(insert-char (custom-padding custom)
(- (custom-width custom) (- (point) from)))
(custom-field-move field from (point))
- (set-text-properties
+ (custom-set-text-properties
from (point)
(list 'custom-field field
'custom-tag field
(defun custom-field-read (field)
;; Read the screen content of FIELD.
(custom-read (custom-field-custom field)
- (buffer-substring-no-properties (custom-field-start field)
+ (custom-buffer-substring-no-properties (custom-field-start field)
(custom-field-end field))))
;; Fields are shown in a special `active' face when point is inside
projects / gnus / blobdiff