Mercurial > urweb

annotate src/elisp/urweb-compat.el @ 853:19fdeef40ada

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out common request functionality, in preparation for supporting different protocols
author Adam Chlipala <adamc@hcoop.net>
date Tue, 23 Jun 2009 14:05:12 -0400
parents 3a1e36b14105
children
rev   line source
adamc@350 1 ;;; urweb-compat.el --- Compatibility functions for Emacs variants for urweb-mode
adamc@350 2
adamc@350 3 ;; Based on sml-mode:
adamc@350 4 ;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org>
adamc@350 5 ;;
adamc@350 6 ;; Modified for urweb-mode:
adamc@350 7 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
adamc@350 8 ;;
adamc@350 9 ;; This program is free software; you can redistribute it and/or modify
adamc@350 10 ;; it under the terms of the GNU General Public License as published by
adamc@350 11 ;; the Free Software Foundation; either version 2 of the License, or
adamc@350 12 ;; (at your option) any later version.
adamc@350 13 ;;
adamc@350 14 ;; This program is distributed in the hope that it will be useful,
adamc@350 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
adamc@350 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
adamc@350 17 ;; GNU General Public License for more details.
adamc@350 18 ;;
adamc@350 19 ;; You should have received a copy of the GNU General Public License
adamc@350 20 ;; along with this program; if not, write to the Free Software
adamc@350 21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
adamc@350 22
adamc@350 23 ;;; Commentary:
adamc@350 24
adamc@350 25 ;;; Code:
adamc@350 26
adamc@350 27 (require 'cl)
adamc@350 28
adamc@350 29 (unless (fboundp 'set-keymap-parents)
adamc@350 30 (defun set-keymap-parents (m parents)
adamc@350 31 (if (keymapp parents) (setq parents (list parents)))
adamc@350 32 (set-keymap-parent
adamc@350 33 m
adamc@350 34 (if (cdr parents)
adamc@350 35 (reduce (lambda (m1 m2)
adamc@350 36 (let ((m (copy-keymap m1)))
adamc@350 37 (set-keymap-parent m m2) m))
adamc@350 38 parents
adamc@350 39 :from-end t)
adamc@350 40 (car parents)))))
adamc@350 41
adamc@350 42 ;; for XEmacs
adamc@350 43 (when (fboundp 'temp-directory)
adamc@350 44 (defvar temporary-file-directory (temp-directory)))
adamc@350 45
adamc@350 46 (unless (fboundp 'make-temp-file)
adamc@350 47 ;; Copied from Emacs-21's subr.el
adamc@350 48 (defun make-temp-file (prefix &optional dir-flag)
adamc@350 49 "Create a temporary file.
adamc@350 50 The returned file name (created by appending some random characters at the end
adamc@350 51 of PREFIX, and expanding against `temporary-file-directory' if necessary,
adamc@350 52 is guaranteed to point to a newly created empty file.
adamc@350 53 You can then use `write-region' to write new data into the file.
adamc@350 54
adamc@350 55 If DIR-FLAG is non-nil, create a new empty directory instead of a file."
adamc@350 56 (let (file)
adamc@350 57 (while (condition-case ()
adamc@350 58 (progn
adamc@350 59 (setq file
adamc@350 60 (make-temp-name
adamc@350 61 (expand-file-name prefix temporary-file-directory)))
adamc@350 62 (if dir-flag
adamc@350 63 (make-directory file)
adamc@350 64 (write-region "" nil file nil 'silent))
adamc@350 65 nil)
adamc@350 66 (file-already-exists t))
adamc@350 67 ;; the file was somehow created by someone else between
adamc@350 68 ;; `make-temp-name' and `write-region', let's try again.
adamc@350 69 nil)
adamc@350 70 file)))
adamc@350 71
adamc@350 72
adamc@350 73
adamc@350 74 (unless (fboundp 'regexp-opt)
adamc@350 75 (defun regexp-opt (strings &optional paren)
adamc@350 76 (let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
adamc@350 77 (concat open (mapconcat 'regexp-quote strings "\\|") close))))
adamc@350 78
adamc@350 79
adamc@350 80 ;;;;
adamc@350 81 ;;;; Custom
adamc@350 82 ;;;;
adamc@350 83
adamc@350 84 ;; doesn't exist in Emacs < 20.1
adamc@350 85 (unless (fboundp 'set-face-bold-p)
adamc@350 86 (defun set-face-bold-p (face v &optional f)
adamc@350 87 (when v (ignore-errors (make-face-bold face)))))
adamc@350 88 (unless (fboundp 'set-face-italic-p)
adamc@350 89 (defun set-face-italic-p (face v &optional f)
adamc@350 90 (when v (ignore-errors (make-face-italic face)))))
adamc@350 91
adamc@350 92 ;; doesn't exist in Emacs < 20.1
adamc@350 93 (ignore-errors (require 'custom))
adamc@350 94 (unless (fboundp 'defgroup)
adamc@350 95 (defmacro defgroup (&rest rest) ()))
adamc@350 96 (unless (fboundp 'defcustom)
adamc@350 97 (defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str)))
adamc@350 98 (unless (fboundp 'defface)
adamc@350 99 (defmacro defface (sym val str &rest rest)
adamc@350 100 `(defvar ,sym (make-face ',sym) ,str)))
adamc@350 101
adamc@350 102 (defvar :group ':group)
adamc@350 103 (defvar :type ':type)
adamc@350 104 (defvar :copy ':copy)
adamc@350 105 (defvar :dense ':dense)
adamc@350 106 (defvar :inherit ':inherit)
adamc@350 107 (defvar :suppress ':suppress)
adamc@350 108
adamc@350 109 (provide 'urweb-compat)
adamc@350 110
adamc@350 111 ;;; urweb-compat.el ends here