File: psgml-lucid.el

package info (click to toggle)
psgml 1.2.4-5
  • links: PTS
  • area: main
  • in suites: woody
  • size: 1,072 kB
  • ctags: 975
  • sloc: lisp: 9,875; sh: 504; makefile: 196
file content (243 lines) | stat: -rw-r--r-- 6,659 bytes parent folder | download
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
;;;; psgml-lucid.el --- Part of SGML-editing mode with parsing support
;; $Id: psgml-lucid.el,v 2.6 2001/11/08 23:24:29 lenst Exp $

;; Copyright (C) 1994 Lennart Staflin

;; Author: Lennart Staflin <lenst@lysator.liu.se>
;;	   William M. Perry <wmperry@indiana.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.


;;;; Commentary:

;;; Part of psgml.el

;;; Menus for use with Lucid Emacs


;;;; Code:

(require 'psgml)
;;(require 'easymenu)

(eval-and-compile
  (autoload 'sgml-do-set-option "psgml-edit"))

(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
  "*Max number of entries in Tags and Entities menus before they are split
into several panes.")

;;;; Pop Up Menus

(defun sgml-popup-menu (event title entries)
  "Display a popup menu."
  (setq entries
	(loop for ent in entries collect
	      (vector (car ent)
		      (list 'setq 'value (list 'quote (cdr ent)))
		      t)))
  (cond ((> (length entries) sgml-max-menu-size)
	 (setq entries
	       (loop for i from 1 while entries collect
		     (let ((submenu
			    (subseq entries 0 (min (length entries)
						   sgml-max-menu-size))))
		       (setq entries (nthcdr sgml-max-menu-size
					     entries))
		       (cons
			(format "%s '%s'-'%s'"
				title
				(sgml-range-indicator (aref (car submenu) 0))
				(sgml-range-indicator
				 (aref (car (last submenu)) 0)))
			submenu))))))
  (sgml-lucid-get-popup-value (cons title entries)))


(defun sgml-range-indicator (string)
  (substring string
	     0
	     (min (length string) sgml-range-indicator-max-length)))


(defun sgml-lucid-get-popup-value (menudesc)
  (let ((value nil)
	(event nil))
    (popup-menu menudesc)
    (while (popup-up-p)
      (setq event (next-command-event event))
      (cond ((misc-user-event-p event)
	     (cond
	      ((eq (event-object event) 'abort)
	       (signal 'quit nil))
	      ((eq (event-object event) 'menu-no-selection-hook)
	       nil)
	      (t
	       (eval (event-object event)))))
	    ((button-release-event-p event) ; don't beep twice
	     nil)
	    (t
	     (beep)
	     (message "please make a choice from the menu."))))
    value))

(defun sgml-popup-multi-menu (pos title menudesc)
  "Display a popup menu.
MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
if the item is selected."
  (popup-menu
   (cons title
	 (loop for menu in menudesc collect
	       (cons (car menu)		; title
		     (loop for item in (cdr menu) collect
			   (if (stringp item)
			       item
			     (vector (car item) (cadr item) t))))))))


;;;; Lucid menu bar

(defun sgml-make-options-menu (vars)
  (loop for var in vars 
	for type = (sgml-variable-type var)
	for desc = (sgml-variable-description var)
	collect
	(cond
	 ((eq type 'toggle)
	  (vector desc (list 'setq var (list 'not var))
		  ':style 'toggle ':selected var))
	 ((consp type)
	  (cons desc
		(loop for c in type collect
		      (if (atom c)
			  (vector (prin1-to-string c)
				  (`(setq (, var) (, c)))
				  :style 'toggle
				  :selected (`(eq (, var) '(, c))))
			(vector (car c)
				(`(setq (, var) '(,(cdr c))))
				:style 'toggle
				:selected (`(eq (, var) '(,(cdr c)))))))))
	 (t
	  (vector desc
		  (`(sgml-do-set-option '(, var)))
		  t)))))


(unless (or (not (boundp 'emacs-major-version))
	    (and (boundp 'emacs-minor-version)
		 (< emacs-minor-version 10)))
  (loop for ent on sgml-main-menu
	if (vectorp (car ent))
	do (cond
	    ((equal (aref (car ent) 0) "File Options >")
	     (setcar ent
		     (cons "File Options"
			   (sgml-make-options-menu sgml-file-options))))
	    ((equal (aref (car ent) 0) "User Options >")
	     (setcar ent
		     (cons "User Options"
			   (sgml-make-options-menu sgml-user-options)))))))


;;;; Key definitions

(define-key sgml-mode-map [button3] 'sgml-tags-menu)


;;;; Insert with properties

(defun sgml-insert (props format &rest args)
  (let ((start (point))
	tem)
    (insert (apply (function format)
		   format
		   args))
    (remf props 'rear-nonsticky)	; not useful in Lucid

    ;; Copy face prop from category
    (when (setq tem (getf props 'category))
      (when (setq tem (get tem 'face))
	  (set-face-underline-p (make-face 'underline) t)
	  (setf (getf props 'face) tem)))

    (add-text-properties start (point) props)

    ;; A read-only value of 1 is used for the text after values
    ;; and this should in Lucid be open at the front.
    (if (eq 1 (getf props 'read-only))
	(set-extent-property
	 (extent-at start nil 'read-only)
	 'start-open t))))


;;;; Set face of markup

(defun sgml-set-face-for (start end type)
  (let ((face (cdr (assq type sgml-markup-faces)))
	o)
    (loop for e being the extents from start to end
	  do (when (extent-property e 'sgml-type)
	       (cond ((and (null o)
			   (eq type (extent-property e 'sgml-type)))
		      (setq o e))
		     (t (delete-extent e)))))

    (cond (o
	   (set-extent-endpoints o start end))
	  (face
	   (setq o (make-extent start end))
	   (set-extent-property o 'sgml-type type)
	   (set-extent-property o 'face face)
	   (set-extent-property o 'start-open t)
	   (set-extent-face o face)))))

(defun sgml-set-face-after-change (start end &optional pre-len)
  ;; This should not be needed with start-open t
  (when sgml-set-face
    (let ((o (extent-at start nil 'sgml-type)))
      (cond
       ((null o))
       ((= start (extent-start-position o))
	(set-extent-endpoints o end (extent-end-position o)))
       (t (delete-extent o))))))

;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el

(defun sgml-clear-faces ()
  (interactive)
  (loop for o being the overlays
	if (extent-property o 'type)
	do (delete-extent o)))


;;;; Functions not in Lucid Emacs

(unless (fboundp 'frame-width)
  (defalias 'frame-width 'screen-width))

(unless (fboundp 'buffer-substring-no-properties)
  (defalias 'buffer-substring-no-properties 'buffer-substring))


;;;; Provide

(provide 'psgml-lucid)


;;; psgml-lucid.el ends here