Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-xemacs.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 131b0175ea99
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support 1 ;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
2 ;; $Id: psgml-xemacs.el,v 1.1.1.1 1996/12/18 03:35:23 steve Exp $ 2 ;; $Id: psgml-xemacs.el,v 1.1.1.2 1996/12/18 03:47:15 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 ;; William M. Perry <wmperry@indiana.edu> 7 ;; William M. Perry <wmperry@indiana.edu>
8 ;; Synced up with Ben Wing's changes for XEmacs 19.14 by
9 ;; Steven L Baur <steve@miranova.com>
8 10
9 ;; 11 ;;
10 ;; This program is free software; you can redistribute it and/or 12 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License 13 ;; modify it under the terms of the GNU General Public License
12 ;; as published by the Free Software Foundation; either version 2 14 ;; as published by the Free Software Foundation; either version 2
88 nil) 90 nil)
89 (t 91 (t
90 (eval (event-object event))))) 92 (eval (event-object event)))))
91 ((button-release-event-p event) ; don't beep twice 93 ((button-release-event-p event) ; don't beep twice
92 nil) 94 nil)
95 ;; [sb] added condition
93 ((and (fboundp 'event-matches-key-specifier-p) 96 ((and (fboundp 'event-matches-key-specifier-p)
94 (event-matches-key-specifier-p event (quit-char))) 97 (event-matches-key-specifier-p event (quit-char)))
95 (signal 'quit nil)) 98 (signal 'quit nil))
96 (t 99 (t
97 (beep) 100 (beep)
112 item 115 item
113 (vector (car item) (cadr item) t)))))))) 116 (vector (car item) (cadr item) t))))))))
114 117
115 118
116 ;;;; XEmacs menu bar 119 ;;;; XEmacs menu bar
117
118 (defvar sgml-dtd-menu
119 '("DTD"
120 ["Parse DTD" sgml-parse-prolog t]
121 ("Info"
122 ["Describe element type" sgml-describe-element-type t]
123 ["Describe entity" sgml-describe-entity t]
124 ["List elements" sgml-list-elements t]
125 ["List attributes" sgml-list-attributes t]
126 ["List terminals" sgml-list-terminals t]
127 ["List content elements" sgml-list-content-elements t]
128 ["List occur in elements" sgml-list-occur-in-elements t]
129 )
130 "---"
131 ["Load Parsed DTD" sgml-load-dtd t]
132 ["Save Parsed DTD" sgml-save-dtd t]
133 ))
134
135 (defvar sgml-fold-menu
136 '("Fold"
137 ["Fold Element" sgml-fold-element t]
138 ["Fold Subelement" sgml-fold-subelement t]
139 ["Fold Region" sgml-fold-region t]
140 ["Unfold Line" sgml-unfold-line t]
141 ["Unfold Element" sgml-unfold-element t]
142 ["Unfold All" sgml-unfold-all t]
143 ["Expand" sgml-expand-element t]
144 ))
145
146 (defvar sgml-markup-menu
147 '("Markup"
148 ["Insert Element" (sgml-element-menu last-command-event) t]
149 ["Insert Start-Tag" (sgml-start-tag-menu last-command-event) t]
150 ["Insert End-Tag" (sgml-end-tag-menu last-command-event) t]
151 ["Tag Region" (sgml-tag-region-menu last-command-event) t]
152 ["Insert Attribute" (sgml-attrib-menu last-command-event) t]
153 ["Insert Entity" (sgml-entities-menu last-command-event) t]
154 ))
155
156 (defvar
157 sgml-move-menu
158 '("Move"
159 ["Next trouble spot" sgml-next-trouble-spot t]
160 ["Next data field" sgml-next-data-field t]
161 ["Forward element" sgml-forward-element t]
162 ["Backward element" sgml-backward-element t]
163 ["Up element" sgml-up-element t]
164 ["Down element" sgml-down-element t]
165 ["Backward up element" sgml-backward-up-element t]
166 ["Beginning of element" sgml-beginning-of-element t]
167 ["End of element" sgml-end-of-element t]
168 )
169 "Menu of move commands"
170 )
171
172 (defvar
173 sgml-modify-menu
174 '("Modify"
175 ["Normalize" sgml-normalize t]
176 ["Expand All Short References" sgml-expand-all-shortrefs t]
177 ["Expand Entity Reference" sgml-expand-entity-reference t]
178 ["Normalize Element" sgml-normalize-element t]
179 ["Make Character Reference" sgml-make-character-reference t]
180 ["Unmake Character Reference" (sgml-make-character-reference t) t]
181 ["Fill Element" sgml-fill-element t]
182 ["Change Element Name..." sgml-change-element-name t]
183 ["Edit Attributes..." sgml-edit-attributes t]
184 ["Kill Markup" sgml-kill-markup t]
185 ["Kill Element" sgml-kill-element t]
186 ["Untag Element" sgml-untag-element t]
187 ["Decode Character Entities" sgml-charent-to-display-char t]
188 ["Encode Characters" sgml-display-char-to-charent t]
189 )
190 "Menu of modification commands"
191 )
192 120
193 (defun sgml-make-options-menu (vars) 121 (defun sgml-make-options-menu (vars)
194 (loop for var in vars 122 (loop for var in vars
195 for type = (sgml-variable-type var) 123 for type = (sgml-variable-type var)
196 for desc = (sgml-variable-description var) 124 for desc = (sgml-variable-description var)
214 (t 142 (t
215 (vector desc 143 (vector desc
216 (`(sgml-do-set-option '(, var))) 144 (`(sgml-do-set-option '(, var)))
217 t))))) 145 t)))))
218 146
219 (defvar sgml-sgml-menu 147
220 (append 148 (unless (or (not (boundp 'emacs-major-version))
221 '("SGML" 149 (and (boundp 'emacs-minor-version)
222 ["Reset Buffer" normal-mode t] 150 (< emacs-minor-version 10)))
223 ["Show Context" sgml-show-context t] 151 (loop for ent on sgml-main-menu
224 ["What Element" sgml-what-element t] 152 if (vectorp (car ent))
225 ["Show Valid Tags" sgml-list-valid-tags t] 153 do (cond
226 ["Show/Hide Warning Log" sgml-show-or-clear-log t] 154 ((equal (aref (car ent) 0) "File Options >")
227 ["Validate" sgml-validate t]) 155 (setcar ent
228 (if (or (not (boundp 'emacs-major-version)) 156 (cons "File Options"
229 (and (boundp 'emacs-minor-version) 157 (sgml-make-options-menu sgml-file-options))))
230 (< emacs-minor-version 10))) 158 ((equal (aref (car ent) 0) "User Options >")
231 '( 159 (setcar ent
232 ["File Options" sgml-file-options-menu t] 160 (cons "User Options"
233 ["User Options" sgml-user-options-menu t] 161 (sgml-make-options-menu sgml-user-options)))))))
234 )
235 (list
236 (cons "File Options" (sgml-make-options-menu sgml-file-options))
237 (cons "User Options" (sgml-make-options-menu sgml-user-options))))
238 '(["Save File Options" sgml-save-options t]
239 ["Submit Bug Report" sgml-submit-bug-report t]
240 )))
241
242 (defun sgml-install-xemacs-menus ()
243 "Install xemacs menus for psgml mode"
244 (set-buffer-menubar (copy-sequence current-menubar))
245 (add-menu nil (car sgml-sgml-menu) (cdr sgml-sgml-menu))
246 (add-menu nil (car sgml-markup-menu) (copy-sequence (cdr sgml-markup-menu)))
247 (add-menu nil (car sgml-modify-menu) (cdr sgml-modify-menu))
248 (add-menu nil (car sgml-move-menu) (cdr sgml-move-menu))
249 (add-menu nil (car sgml-fold-menu) (cdr sgml-fold-menu))
250 (add-menu nil (car sgml-dtd-menu) (cdr sgml-dtd-menu))
251 )
252
253
254 ;;;; Custom menus
255
256 (defun sgml-build-custom-menus ()
257 (and sgml-custom-markup (add-menu-item '("Markup") "------------" nil t
258 "Insert Element"))
259 (mapcar (function
260 (lambda (x)
261 (add-menu-item '("Markup") (nth 0 x)
262 (list 'sgml-insert-markup (nth 1 x))
263 t
264 "------------")))
265 sgml-custom-markup)
266 (and sgml-custom-dtd (add-menu-item '("DTD") "-------------" nil t))
267 (mapcar (function
268 (lambda (x)
269 (add-menu-item '("DTD") (nth 0 x)
270 (list 'apply ''sgml-doctype-insert
271 (cadr x)
272 (list 'quote (cddr x)))
273 t)))
274 sgml-custom-dtd))
275 162
276 163
277 ;;;; Key definitions 164 ;;;; Key definitions
278 165
279 (define-key sgml-mode-map [button3] 'sgml-tags-menu) 166 (define-key sgml-mode-map [button3] 'sgml-tags-menu)
309 196
310 (defun sgml-set-face-for (start end type) 197 (defun sgml-set-face-for (start end type)
311 (let ((face (cdr (assq type sgml-markup-faces))) 198 (let ((face (cdr (assq type sgml-markup-faces)))
312 o) 199 o)
313 (loop for e being the extents from start to end 200 (loop for e being the extents from start to end
314 do (when (extent-property e 'type) 201 do (when (extent-property e 'sgml-type)
315 (cond ((and (null o) 202 (cond ((and (null o)
316 (eq type (extent-property e 'type))) 203 (eq type (extent-property e 'sgml-type)))
317 (setq o e)) 204 (setq o e))
318 (t (delete-extent e))))) 205 (t (delete-extent e)))))
319 206
320 (cond (o 207 (cond (o
321 (set-extent-endpoints o start end)) 208 (set-extent-endpoints o start end))
322 (face 209 (face
323 (setq o (make-extent start end)) 210 (setq o (make-extent start end))
324 (set-extent-property o 'type type) 211 (set-extent-property o 'sgml-type type)
325 (set-extent-property o 'face face) 212 (set-extent-property o 'face face)
213 (set-extent-property o 'start-open t)
326 (set-extent-face o face))))) 214 (set-extent-face o face)))))
327 215
328 (defun sgml-set-face-after-change (start end &optional pre-len) 216 (defun sgml-set-face-after-change (start end &optional pre-len)
217 ;; This should not be needed with start-open t
329 (when sgml-set-face 218 (when sgml-set-face
330 (let ((o (extent-at start nil 'type))) 219 (let ((o (extent-at start nil 'sgml-type)))
331 (cond 220 (cond
332 ((null o)) 221 ((null o))
333 ((= start (extent-start-position o)) 222 ((= start (extent-start-position o))
334 (set-extent-endpoints o end (extent-end-position o))) 223 (set-extent-endpoints o end (extent-end-position o)))
335 (t (delete-extent o)))))) 224 (t (delete-extent o))))))