Source

pcl-cvs / pcl-cvs-compat.el

Full commit
;;; pcl-cvs-compat.el

(defconst rcsid-pcl-cvs-compat "@(#)$Name$:$Id$")

;; Copyright (C) 1999  Stefan Monnier <monnier@cs.yale.edu>
;;
;; 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 of the License, 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(require 'cl)
(require 'string)

;; recent versions of Emacs provide split-string
;; for other versions, we define it in terms of string's string-split
(unless (fboundp 'split-string)
  (defun split-string (str &optional sep)
    ;; this is not quite correct since we should only eliminate
    ;; a leading and a trailing empty string, but it's enough for our use.
    (delete-if (lambda (str) (string= str "")) (string-split sep str))))

(unless (fboundp 'set-keymap-parent)
  (defun set-keymap-parent (keymap parent)
    (unless (and (consp keymap) (eq 'keymap (car keymap)))
      (error "unknown keymap type"))
    (setf (cdr (last keymap)) parent)))

(unless (fboundp 'set-face-bold-p)
  (defun set-face-bold-p (face v &optional f)
    (when v (ignore-errors (make-face-bold face)))))
(unless (fboundp 'set-face-italic-p)
  (defun set-face-italic-p (face v &optional f)
    (when v (ignore-errors (make-face-italic face)))))

;; deal with custom-deprived Emacsen
(ignore-errors (require 'custom))
(unless (fboundp 'defgroup)
  (defmacro defgroup (&rest rest) ()))
(unless (fboundp 'defcustom)
  (defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str)))
(unless (fboundp 'defface)
  (defmacro defface (sym val str &rest rest)
    `(defvar ,sym (-defface-intern ',sym ,val) ,str))
  (defun -defface-display (val)
    (let* ((frame-params (frame-parameters))
	   (background (cdr (assq 'background-mode frame-params)))
	   (class (cdr (assq 'display-type frame-params))))
      (assoc-if
       (lambda (cs)
	 (or (eq cs t)
	     (every (lambda (c)
		      (ignore-errors (eq (eval (car c)) (cadr c))))
		    cs)))
       val)))
  (defun -defface-intern (sym val)
    (let* ((plist (cadr (-defface-display val)))
	   (face (make-face sym)))
      (dolist (prop '((:foreground set-face-foreground)
		      (:background set-face-background)
		      (:italic set-face-italic-p)
		      (:bold set-face-bold-p)
		      (:underline set-face-underline-p)))
	(let ((v (plist-get plist (car prop))))
	  (when v (ignore-errors (funcall (cadr prop) face v)))))
      face)))

;; hopefully Emacs will end up providing this
(unless (fboundp 'read-directory-name)
  (defalias 'read-directory-name 'read-file-name))

;;
(provide 'pcl-cvs-compat)