hm--html-menus / adapt.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
;;; $Id$
;;;
;;; Copyright (C) 1993 - 1997  Heiko Muenkel
;;; email: muenkel@tnt.uni-hannover.de
;;;
;;;  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, 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.
;;;
;;; 
;;; Description:
;;;
;;;	General functions to port XEmacs functions to GNU Emacs 19.
;;; 
;;; Installation: 
;;;   
;;;	Put this file in one of your lisp load directories.
;;;


(defun adapt-xemacsp ()
  "Returns non nil if the editor is the XEmacs."
  (or (string-match "Lucid" emacs-version)
      (string-match "XEmacs" emacs-version)))


(defun adapt-lemacsp ()
  "Returns non nil if the editor is the XEmacs.
Old version, use `adapt-xemacsp' instead of this."
  (or (string-match "Lucid" emacs-version)
      (string-match "XEmacs" emacs-version)))


(defun adapt-emacsp ()
  "Returns non nil if the editor is the GNU Emacs.
The release number must be greater or equal 19."
  (and 
   (not (adapt-xemacsp))
   (>= (string-to-int (substring emacs-version 0 2)) 19)))

(defalias 'adapt-emacs19p 'adapt-emacsp)

;;; Functions, which don't exist in both emacs versions

(defun adapt-region-active-p ()
  "Returns t, if a region is active."
  (if (adapt-xemacsp)
      (mark)
    mark-active))

(if (not (fboundp 'file-remote-p))
    (defun file-remote-p (file)
      "Test whether file resides on the local system.
The special value 'unknown is returned if no remote file access package
has been loaded."
      (if (not (featurep 'ange-ftp))
	  (require 'ange-ftp))
      (if (not (fboundp 'ange-ftp-ftp-p))
	  nil ; better than nothing, if no ange-ftp-ftp-p exists
	(ange-ftp-ftp-path file))))


;;; Functions, which don't exist in the Emacs 19
(if (adapt-emacsp)
    (progn
      (load-library "lucid")

      (load-library "lmenu")

      (if window-system
	  (require 'font-lock)
	)

      (make-face 'font-lock-comment-face)

      (defun read-number (prompt &optional integers-only)
	"Reads a number from the minibuffer."
	(interactive)
	(let ((error t)
	      (number nil))
	  (if integers-only
	      (while error
		(let ((input-string (read-string prompt)))
		  (setq number (if (string= "" input-string)
				   nil
				 (read input-string)))
		  (if (integerp number)
		      (setq error nil))))
	    (while error
	      (let ((input-string (read-string prompt)))
		(setq number (if (string= "" input-string)
				 nil
			       (read input-string)))		
		(if (numberp number)
		    (setq error nil)))))
	  number))

      (defvar original-read-string-function nil
	"Points to the original Emacs 19 function read-string.")

      (if (not original-read-string-function)
	  (fset 'original-read-string-function
		(symbol-function 'read-string)))

      (defun read-string (prompt &optional initial-contents history)
	"Return a string from the minibuffer, prompting with string PROMPT.
If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
in the minibuffer before reading.
Third arg HISTORY, if non-nil, specifies a history list."
	(read-from-minibuffer prompt initial-contents nil nil history))

      (defun make-extent (beg end &optional buffer)
	(make-overlay beg end buffer))

      (defun set-extent-property (extent prop value)
	(if (eq prop 'duplicable)
	    (cond ((and value (not (overlay-get extent prop)))
		   ;; If becoming duplicable, 
		   ;; copy all overlay props to text props.
		   (add-text-properties (overlay-start extent)
					(overlay-end extent)
					(overlay-properties extent)
					(overlay-buffer extent)))
		  ;; If becoming no longer duplicable, remove these text props.
		  ((and (not value) (overlay-get extent prop))
		   (remove-text-properties (overlay-start extent)
					   (overlay-end extent)
					   (overlay-properties extent)
					   (overlay-buffer extent))))
	  ;; If extent is already duplicable, put this property
	  ;; on the text as well as on the overlay.
	  (if (overlay-get extent 'duplicable)
	      (put-text-property  (overlay-start extent)
				  (overlay-end extent)
				  prop value (overlay-buffer extent))))
	(overlay-put extent prop value))
      
      (defun set-extent-face (extent face)
	(set-extent-property extent 'face face))
      
      (defun delete-extent (extent)
	(set-extent-property extent 'duplicable nil)
	(delete-overlay extent))
      
;      (defun make-extent (from to &optional buffer)
;	"Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to 
;current buffer.  Insertions at point TO will be outside of the extent;
;insertions at FROM will be inside the extent (and the extent will grow.).
;This is only a simple emulation of the Lucid Emacs extents !"
;	(list 'extent from to buffer))
;
;      (defun set-extent-face (extent face)
;	"Make the given EXTENT have the graphic attributes specified by FACE.
;This is only a simple emulation of the Lucid Emacs extents !"
;	(put-text-property (car (cdr extent))
;			   (car (cdr (cdr extent)))
;			   'face
;			   face
;			   (car (cdr (cdr (cdr extent))))))
;
;      (defun delete-extent (extent_obj)
;	"Remove EXTENT from its buffer; this does not modify the buffer's text,
;only its display properties.
;This is only a simple emulation of the Lucid Emacs extents !"
;	(remove-text-properties (car (cdr extent_obj))
;				(car (cdr (cdr extent_obj)))
;				(list 'face nil)
;				(car (cdr (cdr (cdr extent_obj))))))
;      

      (if (not (fboundp 'emacs-pid))
	  (defun emacs-pid ()
	    "Return the process ID of Emacs, as an integer.
This is a dummy function for old versions of the Emacs 19.
You should install a new version, which has `emacs-pid' implemented."
	    0)
	)

      (if (not (fboundp 'facep))
	  (defun facep (object)
	    "Whether OBJECT is a FACE.
It's only a dummy function in the Emacs 19, which returns always nil."
	    nil))
      
;      (if (not (fboundp 'set-extent-property))
;	  (defun set-extent-property (extent  property value)
;	    "Change a property of an extent.
;Only a dummy version in Emacs 19."))

      (if (not (fboundp 'region-active-p))
	  (defun region-active-p ()
	    "Non-nil iff the region is active.
If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
Otherwise, this function always returns false."
	    (adapt-region-active-p)))

      (if (not (fboundp 'next-command-event))
	  (defun next-command-event (&optional event prompt)
	    "Unlike the XEmacs version it reads the next event, if
it is a command event or not.

Return the next available \"user\" event.
 Pass this object to `dispatch-event' to handle it.

 If EVENT is non-nil, it should be an event object and will be filled in
 and returned; otherwise a new event object will be created and returned.
 If PROMPT is non-nil, it should be a string and will be displayed in the
 echo area while this function is waiting for an event.

 The event returned will be a keyboard, mouse press, or mouse release event.
 If there are non-command events available (mouse motion, sub-process output,
 etc) then these will be executed (with `dispatch-event') and discarded.  This
 function is provided as a convenience; it is equivalent to the lisp code

	 (while (progn
		  (next-event event prompt)
		  (not (or (key-press-event-p event)
			   (button-press-event-p event)
			   (button-release-event-p event)
			   (misc-user-event-p event))))
	    (dispatch-event event))"
	    (message prompt)
	    (or event
		(read-event))))

      (if (not (fboundp 'button-event-p))
	  (defun button-event-p (obj)
	    "True if OBJ is a button-press or button-release event object."
	    (and (eventp obj)
		 (or (eq 'mouse-1 (event-basic-type obj))
		     (eq 'mouse-2 (event-basic-type obj))
		     (eq 'mouse-3 (event-basic-type obj))
		     (eq 'down-mouse-1 (event-basic-type obj))
		     (eq 'down-mouse-2 (event-basic-type obj))
		     (eq 'down-mouse-3 (event-basic-type obj))
		     (eq 'up-mouse-1 (event-basic-type obj))
		     (eq 'up-mouse-2 (event-basic-type obj))
		     (eq 'up-mouse-3 (event-basic-type obj))
		     (eq 'drag-mouse-1 (event-basic-type obj))
		     (eq 'drag-mouse-2 (event-basic-type obj))
		     (eq 'drag-mouse-3 (event-basic-type obj))
		     ))))

      (if (not (fboundp 'button-drag-event-p))
	  (defun button-drag-event-p (obj)
	    "True if OBJ is a mouse-button-drag event object."
	    (and (button-event-p obj)
		 (member 'drag (event-modifiers obj)))))

      (if (not (fboundp 'button-press-event-p))
	  (defun button-press-event-p (obj)
	    "True if OBJ is a mouse-button-press event object."
	    (and (button-event-p obj)
		 (member 'down (event-modifiers obj)))))

      (if (not (fboundp 'button-release-event-p))
	  (defun button-release-event-p (obj)
	    "True if OBJ is a mouse-button-release event object."
	    (and (button-event-p obj)
		 (not (button-press-event-p obj)))))

      (if (not (fboundp 'button-click-event-p))
	  (defun button-click-event-p (obj)
	    "True if OBJ is a click event obkect."
	    ;; only for the Emacs 19
	    ;; doesn't exist and can't (?) exist in the XEmacs
	    (and (button-event-p obj)
		 (member 'click (event-modifiers obj)))))
      
      (if (not (fboundp 'mouse-event-p))
	  (defun mouse-event-p (obj)
	    "True if OBJ is a button-press, button-release, or mouse-motion event object."
	    (or (button-event-p obj)
		(member 'drag (event-modifiers obj)))))

      (if (not (fboundp 'event-window))
	  (defun event-window (event)
	    "Return the window of the given mouse EVENT.
This may be nil if the event occurred in the border or over a toolbar.
The modeline is considered to be in the window it represents.

If the EVENT is a mouse drag event, then the end event window is returned."
	    (if (button-drag-event-p event)
		(and (listp event)
		     (third event)
		     (listp (third event))
		     (windowp (car (third event)))
		     (car (third event)))
	      (and (eventp event)
		   (listp event)
		   (second event)
		   (listp (second event))
		   (windowp (car (second event)))
		   (car (second event))))))

;		   (listp (cdr event))
;		   (listp (car (cdr event)))
;		   (windowp (car (car (cdr event))))
;		   (car (car (cdr event))))))

      (if (not (fboundp 'event-buffer))
	  (defun event-buffer (event)
	    "Given a mouse-motion, button-press, or button-release event,
return the buffer on which that event occurred.  This will be nil for 
non-mouse events.  If event-over-text-area-p is nil, this will also be nil."
	    (if (button-event-p event)
		(window-buffer (event-window event)))))


      (if (not (fboundp 'event-closest-point))
	  (defun event-closest-point (event)
	    "Return the character position of the given mouse EVENT.
If the EVENT did not occur over a window or over text, return the
closest point to the location of the EVENT.  If the Y pixel position
overlaps a window and the X pixel position is to the left of that
window, the closest point is the beginning of the line containing the
Y position.  If the Y pixel position overlaps a window and the X pixel
position is to the right of that window, the closest point is the end
of the line containing the Y position.  If the Y pixel position is
above a window, return 0.  If it is below a window, return the value
of (window-end).

If the EVENT is a drag event, the event-end will be used."
	    (if (button-drag-event-p event)
		(posn-point (event-end event))
	      (posn-point (event-start event)))))

      (if (not (fboundp 'add-minor-mode))
	  (defun add-minor-mode (toggle 
				 name 
				 &optional 
				 keymap 
				 after 
				 toggle-fun)
	    "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
TOGGLE is a symbol whose value as a variable specifies whether the
minor mode is active.  NAME is the name that should appear in the
modeline (it should be a string beginning with a space).  KEYMAP is a
keymap to make active when the minor mode is active.  AFTER is the
toggling symbol used for another minor mode.  If AFTER is non-nil,
then it is used to position the new mode in the minor-mode alists.

TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs
it has the following description:
TOGGLE-FUN specifies an interactive function that is called to toggle
the mode on and off; this affects what happens when button2 is pressed
on the mode, and when button3 is pressed somewhere in the list of
modes.  If TOGGLE-FUN is nil and TOGGLE names an interactive function,
TOGGLE is used as the toggle function.

Example:  (add-minor-mode 'view-minor-mode \" View\" view-mode-map)

WARNING: THIS FUNCTION ISN'T READ YET."
	    (if after
		(add-minor-mode-1 toggle name keymap after)
	      (if (not (assq toggle minor-mode-alist))
		  (progn
		    (setq minor-mode-alist
			  (cons (list toggle name)
				minor-mode-alist))))
	      (if (not (assq toggle minor-mode-map-alist))
		  (progn
		    (setq minor-mode-map-alist
			  (cons (cons toggle keymap)
				minor-mode-map-alist))))
	      ))
	)

      (if (not (fboundp 'redraw-modeline))
	  (defalias 'redraw-modeline 'force-mode-line-update))

      (if (not (fboundp 'mouse-track))
	  (defalias 'mouse-track 'mouse-drag-region))

      (if (not (fboundp 'windows-of-buffer))
	  (defun windows-of-buffer (&optional buffer)
	    "Returns a list of windows that have BUFFER in them.
If BUFFER is not specified, the current buffer will be used."
	    (get-buffer-window-list buffer)))

      (if (not (boundp 'help-selects-help-window))
	  (defvar help-selects-help-window t
	    "*If nil, use the \"old Emacs\" behavior for Help buffers.
This just displays the buffer in another window, rather than selecting
the window."))

      (if (not (fboundp 'with-displaying-help-buffer))
	  (defun with-displaying-help-buffer (thunk)
	    (let ((winconfig (current-window-configuration))
		  (was-one-window (one-window-p))
		  (help-not-visible
		   (not (and (windows-of-buffer "*Help*") ;shortcut
			     (member (selected-frame)
				     (mapcar 'window-frame
					     (windows-of-buffer "*Help*")))))))
	      (prog1 (with-output-to-temp-buffer "*Help*"
		       (prog1 (funcall thunk)
			 (save-excursion
			   (set-buffer standard-output)
			   (help-mode))))
		(let ((helpwin (get-buffer-window "*Help*")))
		  (if helpwin
		      (progn
			(save-excursion
			  (set-buffer (window-buffer helpwin))
			  ;;If the *Help* buffer is already displayed on this
			  ;; frame, don't override the previous configuration
;			  (if help-not-visible
;			      (set-frame-property
;			       (selected-frame)
;			       'help-window-config winconfig)))
			  )
			(if help-selects-help-window
			    (select-window helpwin))
			(cond ((eq helpwin (selected-window))
			       (message
				(substitute-command-keys
				 "\\[scroll-up] to scroll the help."
				 )))
			      (was-one-window
			       (message
				(substitute-command-keys
				 "\\[scroll-other-window] to scroll the help."
				 )))
			      (t
			       (message
				(substitute-command-keys
				 "\\[scroll-other-window] to scroll the help."
				 )))))))))))

      (if (not (fboundp 'set-extent-mouse-face))
	  (defun set-extent-mouse-face (extent face)
	    "Set the face used to highlight EXTENT when the mouse passes over it.
FACE can also be a list of faces, and all faces listed will apply,
with faces earlier in the list taking priority over those later in the
list.

In the Emacs 19, the argument FACE could not be a list of faces."
	    (put-text-property (overlay-start extent)
			       (overlay-end extent)
			       'mouse-face face)
	    ))


      (if (not (fboundp 'read-directory-name))
	  (defalias 'read-directory-name 'read-file-name))

      (if (not (fboundp 'define-obsolete-function-alias))
	  (defsubst define-obsolete-function-alias (oldfun newfun)
	    "Define OLDFUN as an obsolete alias for function NEWFUN.
This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
as obsolete."
	    (define-function oldfun newfun)
	    (make-obsolete oldfun newfun)))

      (if (not (fboundp 'define-obsolete-variable-alias))
	  (defsubst define-obsolete-variable-alias (oldvar newvar)
	    "Define OLDVAR as an obsolete alias for varction NEWVAR.
This makes referencing or setting OLDVAR equivalent to referencing or
setting NEWVAR and marks OLDVAR as obsolete.

It is not full implemented in the Emacs 19, because of the lack of
the function defvaralias.y"
	    ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34
	    (make-obsolete-variable oldvar newvar)))

      (if (not (fboundp 'defgroup))
	  (defmacro defgroup (symbol members doc &rest args)
	    "Dummy definition. Used, if the custom package isn't installed.
The dummy definition makes nothing, it returns only nil."
	    nil))

      (if (not (fboundp 'defcustom))
	  (defmacro defcustom (symbol value doc &rest args)
	    "Simulates the defcustom definition from the custom package.
It calls a `defvar' with the arguments SYMBOL, VALUE and DOC."
	    `(defvar ,symbol ,value ,doc)))

	
      ))


(provide 'adapt)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.