cgit.sxemacs.org Git - packages/blob - xemacs-packages/hm--html-menus/adapt.el

   1 ;;; $Id: adapt.el,v 6.21 2000-10-06 08:45:59 youngs Exp $
   2 ;;;
   3 ;;; Copyright (C) 1993 - 1997  Heiko Muenkel
   4 ;;; email: muenkel@tnt.uni-hannover.de
   5 ;;;
   6 ;;;  This program is free software; you can redistribute it and/or modify
   7 ;;;  it under the terms of the GNU General Public License as published by
   8 ;;;  the Free Software Foundation; either version 2, or (at your option)
   9 ;;;  any later version.
  10 ;;;
  11 ;;;  This program is distributed in the hope that it will be useful,
  12 ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;  GNU General Public License for more details.
  15 ;;;
  16 ;;;  You should have received a copy of the GNU General Public License
  17 ;;;  along with this program; if not, write to the Free Software
  18 ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19 ;;;
  20 ;;;
  21 ;;; Description:
  22 ;;;
  23 ;;;     General functions to port XEmacs functions to GNU Emacs 19.
  24 ;;;
  25 ;;; Installation:
  26 ;;;
  27 ;;;     Put this file in one of your lisp load directories.
  28 ;;;
  29
  30
  31 (defun adapt-xemacsp ()
  32   "Returns non nil if the editor is the XEmacs."
  33   (or (string-match "Lucid" emacs-version)
  34       (string-match "XEmacs" emacs-version)))
  35
  36
  37 (defun adapt-lemacsp ()
  38   "Returns non nil if the editor is the XEmacs.
  39 Old version, use `adapt-xemacsp' instead of this."
  40   (or (string-match "Lucid" emacs-version)
  41       (string-match "XEmacs" emacs-version)))
  42
  43
  44 (defun adapt-emacsp ()
  45   "Returns non nil if the editor is the GNU Emacs.
  46 The release number must be greater or equal 19."
  47   (and
  48    (not (adapt-xemacsp))
  49    (>= (string-to-int (substring emacs-version 0 2)) 19)))
  50
  51 (defalias 'adapt-emacs19p 'adapt-emacsp)
  52
  53 ;;; Functions, which don't exist in both emacs versions
  54
  55 (defun adapt-region-active-p ()
  56   "Returns t, if a region is active."
  57   (if (adapt-xemacsp)
  58       (mark)
  59     mark-active))
  60
  61 (if (not (fboundp 'file-remote-p))
  62     (defun file-remote-p (file)
  63       "Test whether file resides on the local system.
  64 The special value 'unknown is returned if no remote file access package
  65 has been loaded."
  66       (if (not (featurep 'ange-ftp))
  67           (require 'ange-ftp))
  68       (if (not (fboundp 'ange-ftp-ftp-p))
  69           nil ; better than nothing, if no ange-ftp-ftp-p exists
  70         (ange-ftp-ftp-path file))))
  71
  72
  73 ;;; Functions, which don't exist in the Emacs 19
  74 (if (adapt-emacsp)
  75     (progn
  76       (load-library "lucid")
  77
  78       (load-library "lmenu")
  79
  80       (if window-system
  81           (require 'font-lock)
  82         )
  83
  84       (make-face 'font-lock-comment-face)
  85
  86       (defun read-number (prompt &optional integers-only)
  87         "Reads a number from the minibuffer."
  88         (interactive)
  89         (let ((error t)
  90               (number nil))
  91           (if integers-only
  92               (while error
  93                 (let ((input-string (read-string prompt)))
  94                   (setq number (if (string= "" input-string)
  95                                    nil
  96                                  (read input-string)))
  97                   (if (integerp number)
  98                       (setq error nil))))
  99             (while error
 100               (let ((input-string (read-string prompt)))
 101                 (setq number (if (string= "" input-string)
 102                                  nil
 103                                (read input-string)))
 104                 (if (numberp number)
 105                     (setq error nil)))))
 106           number))
 107
 108       (defvar original-read-string-function nil
 109         "Points to the original Emacs 19 function read-string.")
 110
 111       (if (not original-read-string-function)
 112           (fset 'original-read-string-function
 113                 (symbol-function 'read-string)))
 114
 115       (defun read-string (prompt &optional initial-contents history)
 116         "Return a string from the minibuffer, prompting with string PROMPT.
 117 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
 118 in the minibuffer before reading.
 119 Third arg HISTORY, if non-nil, specifies a history list."
 120         (read-from-minibuffer prompt initial-contents nil nil history))
 121
 122       (defun make-extent (beg end &optional buffer)
 123         (make-overlay beg end buffer))
 124
 125       (defun set-extent-property (extent prop value)
 126         (if (eq prop 'duplicable)
 127             (cond ((and value (not (overlay-get extent prop)))
 128                    ;; If becoming duplicable,
 129                    ;; copy all overlay props to text props.
 130                    (add-text-properties (overlay-start extent)
 131                                         (overlay-end extent)
 132                                         (overlay-properties extent)
 133                                         (overlay-buffer extent)))
 134                   ;; If becoming no longer duplicable, remove these text props.
 135                   ((and (not value) (overlay-get extent prop))
 136                    (remove-text-properties (overlay-start extent)
 137                                            (overlay-end extent)
 138                                            (overlay-properties extent)
 139                                            (overlay-buffer extent))))
 140           ;; If extent is already duplicable, put this property
 141           ;; on the text as well as on the overlay.
 142           (if (overlay-get extent 'duplicable)
 143               (put-text-property  (overlay-start extent)
 144                                   (overlay-end extent)
 145                                   prop value (overlay-buffer extent))))
 146         (overlay-put extent prop value))
 147
 148       (defun set-extent-face (extent face)
 149         (set-extent-property extent 'face face))
 150
 151       (defun delete-extent (extent)
 152         (set-extent-property extent 'duplicable nil)
 153         (delete-overlay extent))
 154
 155 ;      (defun make-extent (from to &optional buffer)
 156 ;       "Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to
 157 ;current buffer.  Insertions at point TO will be outside of the extent;
 158 ;insertions at FROM will be inside the extent (and the extent will grow.).
 159 ;This is only a simple emulation of the Lucid Emacs extents !"
 160 ;       (list 'extent from to buffer))
 161 ;
 162 ;      (defun set-extent-face (extent face)
 163 ;       "Make the given EXTENT have the graphic attributes specified by FACE.
 164 ;This is only a simple emulation of the Lucid Emacs extents !"
 165 ;       (put-text-property (car (cdr extent))
 166 ;                          (car (cdr (cdr extent)))
 167 ;                          'face
 168 ;                          face
 169 ;                          (car (cdr (cdr (cdr extent))))))
 170 ;
 171 ;      (defun delete-extent (extent_obj)
 172 ;       "Remove EXTENT from its buffer; this does not modify the buffer's text,
 173 ;only its display properties.
 174 ;This is only a simple emulation of the Lucid Emacs extents !"
 175 ;       (remove-text-properties (car (cdr extent_obj))
 176 ;                               (car (cdr (cdr extent_obj)))
 177 ;                               (list 'face nil)
 178 ;                               (car (cdr (cdr (cdr extent_obj))))))
 179 ;
 180
 181       (if (not (fboundp 'emacs-pid))
 182           (defun emacs-pid ()
 183             "Return the process ID of Emacs, as an integer.
 184 This is a dummy function for old versions of the Emacs 19.
 185 You should install a new version, which has `emacs-pid' implemented."
 186             0)
 187         )
 188
 189       (if (not (fboundp 'facep))
 190           (defun facep (object)
 191             "Whether OBJECT is a FACE.
 192 It's only a dummy function in the Emacs 19, which returns always nil."
 193             nil))
 194
 195 ;      (if (not (fboundp 'set-extent-property))
 196 ;         (defun set-extent-property (extent  property value)
 197 ;           "Change a property of an extent.
 198 ;Only a dummy version in Emacs 19."))
 199
 200       (if (not (fboundp 'region-active-p))
 201           (defun region-active-p ()
 202             "Non-nil iff the region is active.
 203 If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
 204 Otherwise, this function always returns false."
 205             (adapt-region-active-p)))
 206
 207       (if (not (fboundp 'next-command-event))
 208           (defun next-command-event (&optional event prompt)
 209             "Unlike the XEmacs version it reads the next event, if
 210 it is a command event or not.
 211
 212 Return the next available \"user\" event.
 213  Pass this object to `dispatch-event' to handle it.
 214
 215  If EVENT is non-nil, it should be an event object and will be filled in
 216  and returned; otherwise a new event object will be created and returned.
 217  If PROMPT is non-nil, it should be a string and will be displayed in the
 218  echo area while this function is waiting for an event.
 219
 220  The event returned will be a keyboard, mouse press, or mouse release event.
 221  If there are non-command events available (mouse motion, sub-process output,
 222  etc) then these will be executed (with `dispatch-event') and discarded.  This
 223  function is provided as a convenience; it is equivalent to the lisp code
 224
 225          (while (progn
 226                   (next-event event prompt)
 227                   (not (or (key-press-event-p event)
 228                            (button-press-event-p event)
 229                            (button-release-event-p event)
 230                            (misc-user-event-p event))))
 231             (dispatch-event event))"
 232             (message prompt)
 233             (or event
 234                 (read-event))))
 235
 236       (if (not (fboundp 'button-event-p))
 237           (defun button-event-p (obj)
 238             "True if OBJ is a button-press or button-release event object."
 239             (and (eventp obj)
 240                  (or (eq 'mouse-1 (event-basic-type obj))
 241                      (eq 'mouse-2 (event-basic-type obj))
 242                      (eq 'mouse-3 (event-basic-type obj))
 243                      (eq 'down-mouse-1 (event-basic-type obj))
 244                      (eq 'down-mouse-2 (event-basic-type obj))
 245                      (eq 'down-mouse-3 (event-basic-type obj))
 246                      (eq 'up-mouse-1 (event-basic-type obj))
 247                      (eq 'up-mouse-2 (event-basic-type obj))
 248                      (eq 'up-mouse-3 (event-basic-type obj))
 249                      (eq 'drag-mouse-1 (event-basic-type obj))
 250                      (eq 'drag-mouse-2 (event-basic-type obj))
 251                      (eq 'drag-mouse-3 (event-basic-type obj))
 252                      ))))
 253
 254       (if (not (fboundp 'button-drag-event-p))
 255           (defun button-drag-event-p (obj)
 256             "True if OBJ is a mouse-button-drag event object."
 257             (and (button-event-p obj)
 258                  (member 'drag (event-modifiers obj)))))
 259
 260       (if (not (fboundp 'button-press-event-p))
 261           (defun button-press-event-p (obj)
 262             "True if OBJ is a mouse-button-press event object."
 263             (and (button-event-p obj)
 264                  (member 'down (event-modifiers obj)))))
 265
 266       (if (not (fboundp 'button-release-event-p))
 267           (defun button-release-event-p (obj)
 268             "True if OBJ is a mouse-button-release event object."
 269             (and (button-event-p obj)
 270                  (not (button-press-event-p obj)))))
 271
 272       (if (not (fboundp 'button-click-event-p))
 273           (defun button-click-event-p (obj)
 274             "True if OBJ is a click event obkect."
 275             ;; only for the Emacs 19
 276             ;; doesn't exist and can't (?) exist in the XEmacs
 277             (and (button-event-p obj)
 278                  (member 'click (event-modifiers obj)))))
 279
 280       (if (not (fboundp 'mouse-event-p))
 281           (defun mouse-event-p (obj)
 282             "True if OBJ is a button-press, button-release, or mouse-motion event object."
 283             (or (button-event-p obj)
 284                 (member 'drag (event-modifiers obj)))))
 285
 286       (if (not (fboundp 'event-window))
 287           (defun event-window (event)
 288             "Return the window of the given mouse EVENT.
 289 This may be nil if the event occurred in the border or over a toolbar.
 290 The modeline is considered to be in the window it represents.
 291
 292 If the EVENT is a mouse drag event, then the end event window is returned."
 293             (if (button-drag-event-p event)
 294                 (and (listp event)
 295                      (third event)
 296                      (listp (third event))
 297                      (windowp (car (third event)))
 298                      (car (third event)))
 299               (and (eventp event)
 300                    (listp event)
 301                    (second event)
 302                    (listp (second event))
 303                    (windowp (car (second event)))
 304                    (car (second event))))))
 305
 306 ;                  (listp (cdr event))
 307 ;                  (listp (car (cdr event)))
 308 ;                  (windowp (car (car (cdr event))))
 309 ;                  (car (car (cdr event))))))
 310
 311       (if (not (fboundp 'event-buffer))
 312           (defun event-buffer (event)
 313             "Given a mouse-motion, button-press, or button-release event,
 314 return the buffer on which that event occurred.  This will be nil for
 315 non-mouse events.  If event-over-text-area-p is nil, this will also be nil."
 316             (if (button-event-p event)
 317                 (window-buffer (event-window event)))))
 318
 319
 320       (if (not (fboundp 'event-closest-point))
 321           (defun event-closest-point (event)
 322             "Return the character position of the given mouse EVENT.
 323 If the EVENT did not occur over a window or over text, return the
 324 closest point to the location of the EVENT.  If the Y pixel position
 325 overlaps a window and the X pixel position is to the left of that
 326 window, the closest point is the beginning of the line containing the
 327 Y position.  If the Y pixel position overlaps a window and the X pixel
 328 position is to the right of that window, the closest point is the end
 329 of the line containing the Y position.  If the Y pixel position is
 330 above a window, return 0.  If it is below a window, return the value
 331 of (window-end).
 332
 333 If the EVENT is a drag event, the event-end will be used."
 334             (if (button-drag-event-p event)
 335                 (posn-point (event-end event))
 336               (posn-point (event-start event)))))
 337
 338       (if (not (fboundp 'add-minor-mode))
 339           (defun add-minor-mode (toggle
 340                                  name
 341                                  &optional
 342                                  keymap
 343                                  after
 344                                  toggle-fun)
 345             "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
 346 TOGGLE is a symbol whose value as a variable specifies whether the
 347 minor mode is active.  NAME is the name that should appear in the
 348 modeline (it should be a string beginning with a space).  KEYMAP is a
 349 keymap to make active when the minor mode is active.  AFTER is the
 350 toggling symbol used for another minor mode.  If AFTER is non-nil,
 351 then it is used to position the new mode in the minor-mode alists.
 352
 353 TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs
 354 it has the following description:
 355 TOGGLE-FUN specifies an interactive function that is called to toggle
 356 the mode on and off; this affects what happens when button2 is pressed
 357 on the mode, and when button3 is pressed somewhere in the list of
 358 modes.  If TOGGLE-FUN is nil and TOGGLE names an interactive function,
 359 TOGGLE is used as the toggle function.
 360
 361 Example:  (add-minor-mode 'view-minor-mode \" View\" view-mode-map)
 362
 363 WARNING: THIS FUNCTION ISN'T READ YET."
 364             (if after
 365                 (add-minor-mode-1 toggle name keymap after)
 366               (if (not (assq toggle minor-mode-alist))
 367                   (progn
 368                     (setq minor-mode-alist
 369                           (cons (list toggle name)
 370                                 minor-mode-alist))))
 371               (if (not (assq toggle minor-mode-map-alist))
 372                   (progn
 373                     (setq minor-mode-map-alist
 374                           (cons (cons toggle keymap)
 375                                 minor-mode-map-alist))))
 376               ))
 377         )
 378
 379       (if (not (fboundp 'redraw-modeline))
 380           (defalias 'redraw-modeline 'force-mode-line-update))
 381
 382       (if (not (fboundp 'mouse-track))
 383           (defalias 'mouse-track 'mouse-drag-region))
 384
 385       (if (not (fboundp 'windows-of-buffer))
 386           (defun windows-of-buffer (&optional buffer)
 387             "Returns a list of windows that have BUFFER in them.
 388 If BUFFER is not specified, the current buffer will be used."
 389             (get-buffer-window-list buffer)))
 390
 391       (if (not (boundp 'help-selects-help-window))
 392           (defvar help-selects-help-window t
 393             "*If nil, use the \"old Emacs\" behavior for Help buffers.
 394 This just displays the buffer in another window, rather than selecting
 395 the window."))
 396
 397       (if (not (fboundp 'with-displaying-help-buffer))
 398           (defun with-displaying-help-buffer (thunk)
 399             (let ((winconfig (current-window-configuration))
 400                   (was-one-window (one-window-p))
 401                   (help-not-visible
 402                    (not (and (windows-of-buffer "*Help*") ;shortcut
 403                              (member (selected-frame)
 404                                      (mapcar 'window-frame
 405                                              (windows-of-buffer "*Help*")))))))
 406               (prog1 (with-output-to-temp-buffer "*Help*"
 407                        (prog1 (funcall thunk)
 408                          (save-excursion
 409                            (set-buffer standard-output)
 410                            (help-mode))))
 411                 (let ((helpwin (get-buffer-window "*Help*")))
 412                   (if helpwin
 413                       (progn
 414                         (save-excursion
 415                           (set-buffer (window-buffer helpwin))
 416                           ;;If the *Help* buffer is already displayed on this
 417                           ;; frame, don't override the previous configuration
 418 ;                         (if help-not-visible
 419 ;                             (set-frame-property
 420 ;                              (selected-frame)
 421 ;                              'help-window-config winconfig)))
 422                           )
 423                         (if help-selects-help-window
 424                             (select-window helpwin))
 425                         (cond ((eq helpwin (selected-window))
 426                                (message
 427                                 (substitute-command-keys
 428                                  "\\[scroll-up] to scroll the help."
 429                                  )))
 430                               (was-one-window
 431                                (message
 432                                 (substitute-command-keys
 433                                  "\\[scroll-other-window] to scroll the help."
 434                                  )))
 435                               (t
 436                                (message
 437                                 (substitute-command-keys
 438                                  "\\[scroll-other-window] to scroll the help."
 439                                  )))))))))))
 440
 441       (if (not (fboundp 'set-extent-mouse-face))
 442           (defun set-extent-mouse-face (extent face)
 443             "Set the face used to highlight EXTENT when the mouse passes over it.
 444 FACE can also be a list of faces, and all faces listed will apply,
 445 with faces earlier in the list taking priority over those later in the
 446 list.
 447
 448 In the Emacs 19, the argument FACE could not be a list of faces."
 449             (put-text-property (overlay-start extent)
 450                                (overlay-end extent)
 451                                'mouse-face face)
 452             ))
 453
 454
 455       (if (not (fboundp 'read-directory-name))
 456           (defalias 'read-directory-name 'read-file-name))
 457
 458       (if (not (fboundp 'define-obsolete-function-alias))
 459           (defsubst define-obsolete-function-alias (oldfun newfun)
 460             "Define OLDFUN as an obsolete alias for function NEWFUN.
 461 This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
 462 as obsolete."
 463             (define-function oldfun newfun)
 464             (make-obsolete oldfun newfun)))
 465
 466       (if (not (fboundp 'define-obsolete-variable-alias))
 467           (defsubst define-obsolete-variable-alias (oldvar newvar)
 468             "Define OLDVAR as an obsolete alias for varction NEWVAR.
 469 This makes referencing or setting OLDVAR equivalent to referencing or
 470 setting NEWVAR and marks OLDVAR as obsolete.
 471
 472 It is not full implemented in the Emacs 19, because of the lack of
 473 the function defvaralias.y"
 474             ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34
 475             (make-obsolete-variable oldvar newvar)))
 476
 477       (if (not (fboundp 'defgroup))
 478           (defmacro defgroup (symbol members doc &rest args)
 479             "Dummy definition. Used, if the custom package isn't installed.
 480 The dummy definition makes nothing, it returns only nil."
 481             nil))
 482
 483       (if (not (fboundp 'defcustom))
 484           (defmacro defcustom (symbol value doc &rest args)
 485             "Simulates the defcustom definition from the custom package.
 486 It calls a `defvar' with the arguments SYMBOL, VALUE and DOC."
 487             `(defvar ,symbol ,value ,doc)))
 488
 489
 490       ))
 491
 492
 493 (provide 'adapt)