calendar / cal-compat.el

Full commit
;;; cal-compat.el --- calendar compatibility functions

;; Author: Jeff Miller <>

;; This file is part of XEmacs.

;; XEmacs 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, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; Provide functional equivalents to code present only in Emacs or
;; currently only found in XEmacs betas.

;; XEmacs change
(if (featurep 'xemacs)
    (defalias 'appt-cancel-timer 'delete-itimer)
  (defalias 'appt-cancel-timer 'cancel-timer))

;; XEmacs change
  (unless (fboundp 'line-beginning-position)
    (defalias 'line-beginning-position 'point-at-bol))
  (unless (fboundp 'line-end-position)
    (defalias 'line-end-position 'point-at-eol)))

;; XEmacs change, mimic button.el from Emacs 22
(defun make-button (beg end &rest properties)
  "Make a button from BEG to END in the current buffer.
The remaining arguments form a sequence of PROPERTY VALUE pairs,

This function is included with calendar for compatability with Emacs."
  (let ((extent  (make-extent beg end))
        (map (make-sparse-keymap)))

    (define-key map [button2] 'diary-goto-entry)
    ;;    (define-key map [return] 'diary-goto-entry)
    (set-extent-keymap extent map)

    (set-extent-mouse-face extent 'highlight)
    (set-extent-property extent 'button extent)
    (set-extent-face extent 'diary-button)
    ;; set the properties from the calling function
    (set-extent-properties extent  properties )

    extent ))

;; XEmacs change, mimic button.el from Emacs 22
(defun insert-button (label &rest properties)
  "Insert a button with the label LABEL.
The remaining arguments form a sequence of PROPERTY VALUE pairs.

This function is included with calendar for compatability with Emacs."
  (apply #'make-button (prog1 (point) (insert label))

;; XEmacs change, this shows up in XEmacs 21.5
(unless (fboundp 'match-string-no-properties)
  (defun match-string-no-properties (num &optional string)
    "Return string of text matched by last search, without text properties.
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
            (let ((result
                   (substring string (match-beginning num) (match-end num))))
              (set-text-properties 0 (length result) nil result)
          (buffer-substring-no-properties (match-beginning num)
                                          (match-end num))))))

;; XEmacs change, this shows up in XEmacs 21.5
(unless (fboundp 'add-to-invisibility-spec)
  (defun add-to-invisibility-spec (arg)
    "Add elements to `buffer-invisibility-spec'.
See documentation for `buffer-invisibility-spec' for the kind of elements
that can be added."
    (if (eq buffer-invisibility-spec t)
        (setq buffer-invisibility-spec (list t)))
    (setq buffer-invisibility-spec
          (cons arg buffer-invisibility-spec))))

(if (fboundp 'assoc-string)
    (defalias 'cal-assoc-string 'assoc-string)
  (defun cal-assoc-string (key list case-fold)
    (if case-fold
        (assoc-ignore-case key list)
      (assoc key list)))  

;; XEmacs change
;; not available until 21.5
(unless (fboundp 'display-multi-frame-p)
  (defun display-multi-frame-p ()
    (not (null (memq (device-type) '(x mswindows gtk))))

;; XEmacs change
;; not available until 21.5
(unless (fboundp 'display-color-p)
  (defun display-color-p ()
    (eq  'color (device-class))

;; XEmacs change
;; only available in MULE
(unless (featurep 'mule)
  (setq enable-multibyte-characters nil))

; propertize appeared in XEmacs subr.el r21-5-7: 1.26
(unless (fboundp 'propertize)
  ;; `propertize' is a builtin in GNU Emacs 21.
  (defun propertize (string &rest properties)
    "Return a copy of STRING with text properties added.
First argument is the string to copy.
Remaining arguments form a sequence of PROPERTY VALUE pairs for text
properties to add to the result."
    (let ((str (copy-sequence string)))
      (add-text-properties 0 (length str)

;; XEmacs change
;; fit-window-to-buffer is only available in Emacs.
;; shamelessly taken from ibuffer
(unless (fboundp 'fit-window-to-buffer)
  (defun cal-fit-window-to-buffer (&optional owin)
    "Make window the right size to display its contents exactly."
    (if owin
    (when (> (length (window-list nil 'nomini)) 1)
      (let* ((window (selected-window))
	     (buf (window-buffer window))
	     (height (window-displayed-height (selected-window)))
	     (new-height (with-current-buffer buf
			   (count-lines (point-min) (point-max))))
	     (diff (- new-height height)))
	(unless (zerop diff)
	  (enlarge-window diff))
	(let ((end (with-current-buffer buf (point-max))))
	  (while (and (> (length (window-list nil 'nomini)) 1)
		      (not (pos-visible-in-window-p end)))
	    (enlarge-window 1)))))))

;; XEmacs change. Mimic remove-overlays from Emacs, but for extents
(defun cal-remove-extents (&optional beg end name val)   
  "Clear BEG and END of overlays whose property NAME has value VAL.
Extents might be moved and or split. "
  ;; Stolen from planner as planner-remove-overlays
  (if (< end beg)
      (setq beg (prog1 end (setq end beg))))
      (dolist (e (extent-list nil  beg end))
        (when (eq (extent-property e name) val)
          ;; Either push this overlay outside beg...end
          ;; or split it to exclude beg...end
          ;; or delete it entirely (if it is contained in beg...end).
          (if (< (extent-start-position e) beg)
              (if (> (extent-end-position e) end)
                    (let ((e1  (copy-extent e))
                          (props (extent-properties e)))
                      (set-extent-endpoints e1
                                            (extent-start-position e) beg)
                      (set-extent-endpoints e end (extent-end-position e))
                      (while props
                        (set-extent-property e1 (pop props) (pop props)))))
                (set-extent-endpoints e (extent-start-position e) beg))
          (if (> (extent-end-position e) end)
              (set-extent-endpoints e end (extent-end-position e))
            (delete-extent e)))))))

(defun cal-tp-ml-conv (string)
"Used to convert a propertized calendar modeline string to the XEmacs modeline format. 
If there are any text properties present in the string, it will be split on the text-property 
boundaries and extents added to the substrings with text properties."
  (let* ((start 0)
         (end (length string))
    (while (/= start end)
      (setq next (next-property-change start string end))
      (setq s (substring string start next))
      (setq plist (text-properties-at start string))
      (if plist (progn
                  (setq e  (make-extent nil nil))
                  (set-extent-properties e plist)
                  (setq ml (append ml (list (cons e s )))))
        (setq  ml (append ml (list s))))
      (setq start next))

;; Available in Emacs 22 
(defun cal-make-mode-line-mouse-map (mouse function) "\
Return a keymap with single entry for mouse key MOUSE on the mode line.
MOUSE is defined to run function FUNCTION with no args in the buffer
corresponding to the mode line clicked."
  (let ((map (make-sparse-keymap)))
    (define-key map (vector  mouse) function)

(provide 'cal-compat)