Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-other.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 $
3
4 ;; Copyright (C) 1994 Lennart Staflin
5
6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
7
8 ;;
9 ;; This program is free software; you can redistribute it and/or
10 ;; modify it under the terms of the GNU General Public License
11 ;; as published by the Free Software Foundation; either version 2
12 ;; of the License, or (at your option) any later version.
13 ;;
14 ;; This program is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18 ;;
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program; if not, write to the Free Software
21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
22
23
24 ;;;; Commentary:
25
26 ;;; Part of psgml.el
27
28 ;;; Menus for use with FSF Emacs 19
29
30
31 ;;;; Code:
32
33 (require 'psgml)
34 (require 'easymenu)
35
36 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
37 "*Max number of entries in Tags and Entities menus before they are split
38 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
149
150 ;;;; Key Commands
151
152 ;; Doesn't this work in Lucid? ***
153 (define-key sgml-mode-map [?\M-\C-\ ] 'sgml-mark-element)
154
155 (define-key sgml-mode-map [S-mouse-1] 'sgml-tags-menu)
156
157
158 ;;;; Pop Up Menus
159
160 (defun sgml-popup-menu (event title entries)
161 "Display a popup menu.
162 ENTRIES is a list where every element has the form (STRING . VALUE) or
163 STRING."
164 (x-popup-menu
165 event
166 (let ((menus (list (cons title entries))))
167 (cond ((> (length entries)
168 sgml-max-menu-size)
169 (setq menus
170 (loop for i from 1 while entries
171 collect
172 (let ((submenu
173 (subseq entries 0 (min (length entries)
174 sgml-max-menu-size))))
175 (setq entries (nthcdr sgml-max-menu-size
176 entries))
177 (cons
178 (format "%s '%s'-'%s'"
179 title
180 (sgml-range-indicator (caar submenu))
181 (sgml-range-indicator (caar (last submenu))))
182 submenu))))))
183 (cons title menus))))
184
185 (defun sgml-range-indicator (string)
186 (substring string
187 0
188 (min (length string) sgml-range-indicator-max-length)))
189
190 (defun sgml-popup-multi-menu (event title menus)
191 "Display a popup menu.
192 MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
193 ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated
194 if the item is selected."
195 (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level
196 ; menu even if there is only one entry
197 ; on the first level
198 (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
255
256 ;;;; Insert with properties
257
258 (defvar sgml-write-protect-intagible
259 (not (boundp 'emacs-minor-version)))
260
261 (defun sgml-insert (props format &rest args)
262 (let ((start (point)))
263 (insert (apply (function format)
264 format
265 args))
266 (when (and sgml-write-protect-intagible
267 (getf props 'intangible))
268 (setf (getf props 'read-only) t))
269 (add-text-properties start (point) props)))
270
271
272 ;;;; Set face of markup
273
274 (defun sgml-set-face-for (start end type)
275 (let ((current (overlays-at start))
276 (face (cdr (assq type sgml-markup-faces)))
277 (pos start)
278 o)
279 (while current
280 (cond ((and (null o)
281 (eq type (overlay-get (car current) 'sgml-type)))
282 (setq o (car current)))
283 ((overlay-get (car current) 'sgml-type)
284 (delete-overlay (car current))))
285 (setq current (cdr current)))
286 (while (< (setq pos (next-overlay-change pos))
287 end)
288 (setq current (overlays-at pos))
289 (while current
290 (when (overlay-get (car current) 'sgml-type)
291 (delete-overlay (car current)))
292 (setq current (cdr current))))
293 (cond (o
294 (move-overlay o start end)
295 (if (null (overlay-get o 'face))
296 (overlay-put o 'face face)))
297 (face
298 (setq o (make-overlay start end))
299 (overlay-put o 'sgml-type type)
300 (overlay-put o 'face face)))))
301
302 (defun sgml-set-face-after-change (start end &optional pre-len)
303 (when sgml-set-face
304 (loop for o in (overlays-at start)
305 do (cond
306 ((not (overlay-get o 'sgml-type)))
307 ((= start (overlay-start o))
308 (move-overlay o end (overlay-end o)))))))
309
310 (defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
311
312 (defun sgml-clear-faces ()
313 (interactive)
314 (loop for o being the overlays
315 if (overlay-get o 'sgml-type)
316 do (delete-overlay o)))
317
318
319 ;;;; Provide
320
321 (provide 'psgml-other)
322
323 ;;; psgml-other.el ends here