Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-other.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children bcdc7deadc19
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;;; psgml-other.el --- Part of SGML-editing mode with parsing support 1 ;;;; psgml-other.el --- Part of SGML-editing mode with parsing support
2 ;; $Id: psgml-other.el,v 1.1.1.1 1996/12/18 03:35:21 steve Exp $ 2 ;; $Id: psgml-other.el,v 1.1.1.2 1996/12/18 03:47:14 steve Exp $
3 3
4 ;; Copyright (C) 1994 Lennart Staflin 4 ;; Copyright (C) 1994 Lennart Staflin
5 5
6 ;; Author: Lennart Staflin <lenst@lysator.liu.se> 6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
7 7
21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
22 22
23 23
24 ;;;; Commentary: 24 ;;;; Commentary:
25 25
26 ;;; Part of psgml.el 26 ;;; Part of psgml.el. Code not compatible with XEmacs.
27
28 ;;; Menus for use with FSF Emacs 19
29 27
30 28
31 ;;;; Code: 29 ;;;; Code:
32 30
33 (require 'psgml) 31 (require 'psgml)
34 (require 'easymenu) 32 (require 'easymenu)
35 33
36 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3) 34 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
37 "*Max number of entries in Tags and Entities menus before they are split 35 "*Max number of entries in Tags and Entities menus before they are split
38 into several panes.") 36 into several panes.")
39
40
41 ;;;; Menu bar
42
43 (easy-menu-define
44 sgml-dtd-menu sgml-mode-map "DTD menu"
45 '("DTD"))
46
47 (defconst sgml-dtd-root-menu
48 '("DTD"
49 ["Parse DTD" sgml-parse-prolog t]
50 ("Info"
51 ["General DTD info" sgml-general-dtd-info t]
52 ["Describe element type" sgml-describe-element-type t]
53 ["Describe entity" sgml-describe-entity t]
54 ["List elements" sgml-list-elements t]
55 ["List attributes" sgml-list-attributes t]
56 ["List terminals" sgml-list-terminals t]
57 ["List content elements" sgml-list-content-elements t]
58 ["List occur in elements" sgml-list-occur-in-elements t]
59 )
60 "--"
61 ["Load Parsed DTD" sgml-load-dtd t]
62 ["Save Parsed DTD" sgml-save-dtd t]
63 ))
64
65 (easy-menu-define
66 sgml-view-menu sgml-mode-map "View menu"
67 '("View"
68 ["Fold Element" sgml-fold-element t]
69 ["Fold Subelement" sgml-fold-subelement t]
70 ["Unfold Line" sgml-unfold-line t]
71 ["Unfold Element" sgml-unfold-element t]
72 ["Expand" sgml-expand-element t]
73 ["Fold Region" sgml-fold-region t]
74 ["Unfold All" sgml-unfold-all t]
75 ["Hide Tags" sgml-hide-tags t]
76 ["Hide Attributes" sgml-hide-attributes t]
77 ["Show All Tags" sgml-show-tags t]
78 )
79 )
80
81
82 (easy-menu-define
83 sgml-markup-menu sgml-mode-map "Markup menu"
84 '("Markup")
85 )
86
87 (defconst sgml-markup-root-menu
88 '("Markup"
89 ["Insert Element" sgml-element-menu t]
90 ["Insert Start-Tag" sgml-start-tag-menu t]
91 ["Insert End-Tag" sgml-end-tag-menu t]
92 ["Tag Region" sgml-tag-region-menu t]
93 ["Insert Attribute" sgml-attrib-menu t]
94 ["Insert Entity" sgml-entities-menu t]
95 ))
96
97 (easy-menu-define
98 sgml-move-menu sgml-mode-map "Menu of move commands"
99 '("Move"
100 ["Next trouble spot" sgml-next-trouble-spot t]
101 ["Next data field" sgml-next-data-field t]
102 ["Forward element" sgml-forward-element t]
103 ["Backward element" sgml-backward-element t]
104 ["Up element" sgml-up-element t]
105 ["Down element" sgml-down-element t]
106 ["Backward up element" sgml-backward-up-element t]
107 ["Beginning of element" sgml-beginning-of-element t]
108 ["End of element" sgml-end-of-element t]
109 ))
110
111 (easy-menu-define
112 sgml-modify-menu sgml-mode-map "Menu of modification commands"
113 '("Modify"
114 ["Normalize" sgml-normalize t]
115 ["Expand All Short References" sgml-expand-all-shortrefs t]
116 ["Expand Entity Reference" sgml-expand-entity-reference t]
117 ["Normalize Element" sgml-normalize-element t]
118 ["Make Character Reference" sgml-make-character-reference t]
119 ["Unmake Character Reference" (sgml-make-character-reference t) t]
120 ["Fill Element" sgml-fill-element t]
121 ["Change Element Name..." sgml-change-element-name t]
122 ["Edit Attributes..." sgml-edit-attributes t]
123 ["Kill Markup" sgml-kill-markup t]
124 ["Kill Element" sgml-kill-element t]
125 ["Untag Element" sgml-untag-element t]
126 ["Trim and leave element" sgml-trim-and-leave-element t]
127 ["Decode Character Entities" sgml-charent-to-display-char t]
128 ["Encode Characters" sgml-display-char-to-charent t]
129 )
130 )
131
132 (easy-menu-define
133 sgml-main-menu sgml-mode-map "Main menu"
134 '("SGML"
135 ["Reset Buffer" normal-mode t]
136 ["End Element" sgml-insert-end-tag t]
137 ["Show Context" sgml-show-context t]
138 ["What Element" sgml-what-element t]
139 ["List Valid Tags" sgml-list-valid-tags t]
140 ["Show/Hide Warning Log" sgml-show-or-clear-log t]
141 ["Validate" sgml-validate t]
142 ["File Options >" sgml-file-options-menu t]
143 ["User Options >" sgml-user-options-menu t]
144 ["Save File Options" sgml-save-options t]
145 ["Submit Bug Report" sgml-submit-bug-report t]
146 )
147 )
148 37
149 38
150 ;;;; Key Commands 39 ;;;; Key Commands
151 40
152 ;; Doesn't this work in Lucid? *** 41 ;; Doesn't this work in Lucid? ***
162 ENTRIES is a list where every element has the form (STRING . VALUE) or 51 ENTRIES is a list where every element has the form (STRING . VALUE) or
163 STRING." 52 STRING."
164 (x-popup-menu 53 (x-popup-menu
165 event 54 event
166 (let ((menus (list (cons title entries)))) 55 (let ((menus (list (cons title entries))))
167 (cond ((> (length entries) 56 (cond
168 sgml-max-menu-size) 57 ((> (length entries) sgml-max-menu-size)
169 (setq menus 58 (setq menus
170 (loop for i from 1 while entries 59 (loop for i from 1 while entries
171 collect 60 collect
172 (let ((submenu 61 (let ((submenu
173 (subseq entries 0 (min (length entries) 62 (subseq entries 0 (min (length entries)
174 sgml-max-menu-size)))) 63 sgml-max-menu-size))))
175 (setq entries (nthcdr sgml-max-menu-size 64 (setq entries (nthcdr sgml-max-menu-size entries))
176 entries)) 65 (cons
177 (cons 66 (format "%s '%s'-'%s'"
178 (format "%s '%s'-'%s'" 67 title
179 title 68 (sgml-range-indicator (caar submenu))
180 (sgml-range-indicator (caar submenu)) 69 (sgml-range-indicator (caar (last submenu))))
181 (sgml-range-indicator (caar (last submenu)))) 70 submenu))))))
182 submenu))))))
183 (cons title menus)))) 71 (cons title menus))))
184 72
185 (defun sgml-range-indicator (string) 73 (defun sgml-range-indicator (string)
186 (substring string 74 (substring string
187 0 75 0
194 if the item is selected." 82 if the item is selected."
195 (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level 83 (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level
196 ; menu even if there is only one entry 84 ; menu even if there is only one entry
197 ; on the first level 85 ; on the first level
198 (eval (car (x-popup-menu event (cons title menus))))) 86 (eval (car (x-popup-menu event (cons title menus)))))
199
200
201
202 ;;;; Build Custom Menus
203
204 (defun sgml-build-custom-menus ()
205 ;; Build custom menus
206 ;; (sgml-add-custom-entries
207 ;; sgml-markup-menu
208 ;; (mapcar (function (lambda (e)
209 ;; (sgml-markup (car e) (cadr e))))
210 ;; sgml-custom-markup))
211 (easy-menu-define
212 sgml-markup-menu sgml-mode-map "Markup menu"
213 (append sgml-markup-root-menu
214 (list "----")
215 (loop for e in sgml-custom-markup collect
216 (vector (first e)
217 (` (sgml-insert-markup (, (cadr e))))
218 t))))
219 (easy-menu-define
220 sgml-dtd-menu sgml-mode-map "DTD menu"
221 (append sgml-dtd-root-menu
222 (list "----")
223 (loop for e in sgml-custom-dtd collect
224 (vector (first e)
225 (` (sgml-doctype-insert (, (cadr e))
226 '(, (cddr e))))
227 t)))))
228
229
230 ;(defun sgml-add-custom-entries (keymap entries)
231 ; "Add to KEYMAP the ENTRIES, a list of (name . command) pairs.
232 ;The entries are added last in keymap and a blank line precede it."
233 ; (let ((l keymap)
234 ; (last (last keymap))) ; cons with keymap name
235 ; ;; Find the cons before 'blank-c' event, or last cons.
236 ; (while (and (cdr l)
237 ; (consp (cadr l))
238 ; (not (eq 'blank-c (caadr l))))
239 ; (setq l (cdr l)))
240 ; ;; Delete entries after
241 ; (setcdr l nil)
242 ; (when entries ; now add the entries
243 ; (setcdr l
244 ; (cons
245 ; '(blank-c "") ; a blank line before custom entries
246 ; (loop for i from 0 as e in entries
247 ; collect (cons (intern (concat "custom" i)) e)))))
248 ; ;; add keymap name to keymap
249 ; (setcdr (last keymap) last)))
250
251
252
253
254 87
255 88
256 ;;;; Insert with properties 89 ;;;; Insert with properties
257 90
258 (defvar sgml-write-protect-intagible 91 (defvar sgml-write-protect-intagible
269 (add-text-properties start (point) props))) 102 (add-text-properties start (point) props)))
270 103
271 104
272 ;;;; Set face of markup 105 ;;;; Set face of markup
273 106
107 (defvar sgml-use-text-properties nil)
108
274 (defun sgml-set-face-for (start end type) 109 (defun sgml-set-face-for (start end type)
275 (let ((current (overlays-at start)) 110 (let ((face (cdr (assq type sgml-markup-faces))))
276 (face (cdr (assq type sgml-markup-faces))) 111 (cond
277 (pos start) 112 (sgml-use-text-properties
278 o) 113 (let ((inhibit-read-only t)
279 (while current 114 (after-change-function nil)
280 (cond ((and (null o) 115 (before-change-function nil))
281 (eq type (overlay-get (car current) 'sgml-type))) 116 (put-text-property start end 'face face)))
282 (setq o (car current))) 117 (t
283 ((overlay-get (car current) 'sgml-type) 118 (let ((current (overlays-at start))
284 (delete-overlay (car current)))) 119 (pos start)
285 (setq current (cdr current))) 120 old-overlay)
286 (while (< (setq pos (next-overlay-change pos)) 121 (while current
287 end) 122 (cond ((and (null old-overlay)
288 (setq current (overlays-at pos)) 123 (eq type (overlay-get (car current) 'sgml-type)))
289 (while current 124 (setq old-overlay (car current)))
290 (when (overlay-get (car current) 'sgml-type) 125 ((overlay-get (car current) 'sgml-type)
291 (delete-overlay (car current))) 126 (message "delov: %s" (overlay-get (car current) 'sgml-type))
292 (setq current (cdr current)))) 127 (delete-overlay (car current))))
293 (cond (o 128 (setq current (cdr current)))
294 (move-overlay o start end) 129 (while (< (setq pos (next-overlay-change pos))
295 (if (null (overlay-get o 'face)) 130 end)
296 (overlay-put o 'face face))) 131 (setq current (overlays-at pos))
297 (face 132 (while current
298 (setq o (make-overlay start end)) 133 (when (overlay-get (car current) 'sgml-type)
299 (overlay-put o 'sgml-type type) 134 (delete-overlay (car current)))
300 (overlay-put o 'face face))))) 135 (setq current (cdr current))))
136 (cond (old-overlay
137 (move-overlay old-overlay start end)
138 (if (null (overlay-get old-overlay 'face))
139 (overlay-put old-overlay 'face face)))
140 (face
141 (setq old-overlay (make-overlay start end))
142 (overlay-put old-overlay 'sgml-type type)
143 (overlay-put old-overlay 'face face))))))))
301 144
302 (defun sgml-set-face-after-change (start end &optional pre-len) 145 (defun sgml-set-face-after-change (start end &optional pre-len)
303 (when sgml-set-face 146 ;; If inserting in front of an markup overlay, move that overlay.
147 ;; this avoids the overlay beeing deleted and recreated by
148 ;; sgml-set-face-for.
149 (when (and sgml-set-face (not sgml-use-text-properties))
304 (loop for o in (overlays-at start) 150 (loop for o in (overlays-at start)
305 do (cond 151 do (cond
306 ((not (overlay-get o 'sgml-type))) 152 ((not (overlay-get o 'sgml-type)))
307 ((= start (overlay-start o)) 153 ((= start (overlay-start o))
308 (move-overlay o end (overlay-end o))))))) 154 (move-overlay o end (overlay-end o)))))))
155
156 (defun sgml-fix-overlay-after-change (overlay flag start end &optional size)
157 (message "sfix(%s): %d-%d (%s)" flag start end size)
158 (overlay-put overlay 'front-nonsticky t)
159 (when nil
160 (move-overlay overlay end (overlay-end overlay))))
309 161
310 (defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el 162 (defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
311 163
312 (defun sgml-clear-faces () 164 (defun sgml-clear-faces ()
313 (interactive) 165 (interactive)
314 (loop for o being the overlays 166 (loop for o being the overlays
315 if (overlay-get o 'sgml-type) 167 if (overlay-get o 'sgml-type)
316 do (delete-overlay o))) 168 do (delete-overlay o)))
317 169
318 170
171 ;;;; Emacs before 19.29
172
173 (unless (fboundp 'buffer-substring-no-properties)
174 (defalias 'buffer-substring-no-properties 'buffer-substring))
175
176
319 ;;;; Provide 177 ;;;; Provide
320 178
321 (provide 'psgml-other) 179 (provide 'psgml-other)
322 180
323 ;;; psgml-other.el ends here 181 ;;; psgml-other.el ends here