Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-info.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-info.el
2 ;;; Last edited: Mon Aug 7 23:00:54 1995 by lenst@katja.lysator.liu.se (Lennart Staflin)
3 ;;; $Id: psgml-info.el,v 1.1.1.1 1996/12/18 03:35:21 steve Exp $
4
5 ;; Copyright (C) 1994, 1995 Lennart Staflin
6
7 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
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 ;; This file is an addon to the PSGML package.
27
28 ;; This file contains some commands to print out information about the
29 ;; current DTD.
30
31 ;; sgml-list-elements
32 ;; Will list all elements and the attributes declared for the element.
33
34 ;; sgml-list-attributes
35 ;; Will list all attributes declared and the elements that use them.
36
37 ;; sgml-list-terminals
38 ;; Will list all elements that can contain data.
39
40 ;; sgml-list-occur-in-elements
41 ;; Will list all element types and where it can occur.
42
43 ;; sgml-list-content-elements
44 ;; Will list all element types and the element types that can occur
45 ;; in its content.
46
47 ;;;; Code:
48
49 (require 'psgml)
50 (require 'psgml-parse)
51
52 (defconst sgml-attr-col 18)
53
54
55 ;;;; Utility functions
56
57 (defsubst sgml-add-to-table (row-index elem table)
58 (let ((p (assoc row-index table)))
59 (cond ((null p)
60 (cons (list row-index elem) table))
61 (t
62 (nconc p (list elem))
63 table))))
64
65 (defsubst sgml-add-last-unique (x l)
66 (unless (memq x l)
67 (nconc l (list x))))
68
69 (defun sgml-map-element-types (func)
70 (sgml-need-dtd)
71 (sgml-map-eltypes func
72 (sgml-pstate-dtd sgml-buffer-parse-state)
73 t))
74
75 (defun sgml-eltype-refrenced-elements (eltype)
76 "List of element types referenced in the model of ELTYPE."
77 ;; Now with cache. Uses appdata prop re-cache.
78 (or
79 (sgml-eltype-appdata eltype 're-cache)
80 (let* ((res ; result list (eltypes)
81 nil)
82 (states ; list of states
83 (list (sgml-eltype-model eltype)))
84 (agenda ; point into states
85 states))
86 (cond
87 ((not (sgml-model-group-p (car states)))
88 nil)
89 (t
90 (while agenda
91 (cond
92 ((sgml-normal-state-p (car agenda))
93 (loop for m in (append (sgml-state-opts (car agenda))
94 (sgml-state-reqs (car agenda)))
95 do
96 (pushnew (sgml-move-token m) res)
97 (sgml-add-last-unique (sgml-move-dest m) states)))
98
99 (t ; &-node
100 (sgml-add-last-unique (sgml-&node-next (car agenda)) states)
101 (loop for dfa in (sgml-&node-dfas (car agenda)) do
102 (sgml-add-last-unique dfa states))))
103 (setq agenda (cdr agenda)))
104 (setf (sgml-eltype-appdata eltype 're-cache) res)
105 res)))))
106
107
108 ;;;; List elements
109
110 (defun sgml-list-elements ()
111 "List the elements and their attributes in the current DTD."
112 (interactive)
113 (message "Creating table...")
114 (sgml-display-table
115 (sgml-map-element-types
116 (function
117 (lambda (eltype)
118 (cons (sgml-eltype-name eltype)
119 (mapcar (function sgml-attdecl-name)
120 (sgml-eltype-attlist eltype))))))
121 "Elements" "Element" "Attribute"))
122
123
124 ;;;; List attributes
125
126 (defun sgml-list-attributes ()
127 "List the attributes and in which elements they occur."
128 (interactive)
129 (let ((attributes nil))
130 (message "Creating table...")
131 (sgml-map-element-types
132 (function
133 (lambda (eltype)
134 (loop for a in (sgml-eltype-attlist eltype) do
135 (setq attributes
136 (sgml-add-to-table (sgml-attdecl-name a)
137 (sgml-eltype-name eltype)
138 attributes))))))
139 (sgml-display-table attributes
140 "Attributes" "Attribute" "Element")))
141
142
143
144
145 ;;;; List terminals
146
147 (defun sgml-list-terminals ()
148 "List the elements that can have data in their content."
149 (interactive)
150 (message "Creating table...")
151 (let ((data-models (list sgml-cdata sgml-rcdata sgml-any)))
152 (sgml-display-table
153 (delq nil
154 (sgml-map-element-types
155 (function
156 (lambda (eltype)
157 (if (or (sgml-eltype-mixed eltype)
158 (memq (sgml-eltype-model eltype) data-models))
159 (list (sgml-eltype-name eltype)
160 (symbol-name
161 (if (sgml-model-group-p (sgml-eltype-model eltype))
162 'mixed
163 (sgml-eltype-model eltype)))))))))
164 "Terminals" "Element" "Content")))
165
166
167 ;;;; Element cross reference list
168
169 (defun sgml-list-content-elements ()
170 "List all element types and the element types that can occur in its content."
171 (interactive)
172 (message "Creating table...")
173 (sgml-display-table
174 (sgml-map-element-types
175 (function
176 (lambda (eltype)
177 (cons (sgml-eltype-name eltype)
178 (mapcar (function sgml-eltype-name)
179 (sgml-eltype-refrenced-elements eltype))))))
180 "Elements refrenced by elements"
181 "Element" "Content"))
182
183 (defun sgml-list-occur-in-elements ()
184 "List all element types and where it can occur."
185 (interactive)
186 (message "Creating table...")
187 (let ((cross nil))
188 (sgml-map-element-types
189 (function
190 (lambda (eltype)
191 (loop for ref in (sgml-eltype-refrenced-elements eltype)
192 do (setq cross (sgml-add-to-table ref
193 (sgml-eltype-name eltype)
194 cross))))))
195 (sgml-display-table
196 cross
197 "Cross referenced element types" "Element" "Can occur in")))
198
199
200 ;;;; Display table
201
202 (defun sgml-display-table (table title col-title1 col-title2
203 &optional width nosort)
204 (or width
205 (setq width sgml-attr-col))
206 (let ((buf (get-buffer-create (format "*%s*" title))))
207 (message "Preparing display...")
208 (set-buffer buf)
209 (erase-buffer)
210 (insert col-title1)
211 (indent-to width)
212 (insert col-title2 "\n")
213 (insert-char ?= (length col-title1))
214 (indent-to width)
215 (insert-char ?= (length col-title2))
216 (insert "\n")
217 (unless nosort
218 (setq table (sort table (function (lambda (a b)
219 (string< (car a) (car b)))))))
220 (loop for e in table do
221 (insert (format "%s" (car e)))
222 (loop for name in (if nosort
223 (cdr e)
224 (sort (cdr e) (function string-lessp)))
225 do
226 (when (> (+ (length name) (current-column))
227 fill-column)
228 (insert "\n"))
229 (when (< (current-column) sgml-attr-col)
230 (indent-to width))
231 (insert name " "))
232 (insert "\n"))
233 (goto-char (point-min))
234 (display-buffer buf)
235 (message nil)))
236
237
238 ;;;; Describe entity
239
240 (defun sgml-describe-entity (name)
241 "Describe the properties of an entity as declared in the current DTD."
242 (interactive
243 (let (default input)
244 (sgml-need-dtd)
245 (save-excursion
246 (sgml-with-parser-syntax
247 (unless (sgml-parse-delim "ERO")
248 (skip-chars-backward "^&\"'= \t\n"))
249 (setq default (or (sgml-parse-name t) ""))))
250 (setq input (completing-read
251 (format "Entity name (%s): " default)
252 (sgml-entity-completion-table
253 (sgml-dtd-entities
254 (sgml-pstate-dtd sgml-buffer-parse-state)))))
255 (list
256 (if (equal "" input) default input))))
257
258 (with-output-to-temp-buffer "*Help*"
259 (let ((entity (sgml-lookup-entity name
260 (sgml-dtd-entities
261 (sgml-pstate-dtd
262 sgml-buffer-parse-state)))))
263 (or entity (error "Undefined entity"))
264 (princ (format "Entity %s is %s\n"
265 name
266 (cond ((null entity)
267 "undefined")
268 (t
269 (format "a %s entity"
270 (sgml-entity-type entity))))))
271 (when entity
272 (let ((text (sgml-entity-text entity)))
273 (cond ((stringp text)
274 (princ "Defined to be:\n")
275 (princ text))
276 (t
277 (princ "With external identifier ")
278 (princ (if (car text) "PUBLIC" "SYSTEM"))
279 (when (car text)
280 (princ (format " '%s'" (car text))))
281 (when (cdr text)
282 (princ (format " '%s'" (cdr text)))))))))))
283
284
285
286 ;;;; Describe element type
287
288 (defun sgml-describe-element-type (et-name)
289 "Describe the properties of an element type as declared in the current DTD."
290 (interactive
291 (let (default input)
292 (sgml-need-dtd)
293 (save-excursion
294 (sgml-with-parser-syntax
295 (unless (sgml-parse-delim "STAGO")
296 (skip-syntax-backward "w_"))
297 (setq default (sgml-parse-name))
298 (unless (and default
299 (sgml-eltype-defined (sgml-lookup-eltype default)))
300 (setq default nil))))
301 (setq input (sgml-read-element-type (if default
302 (format "Element type (%s): "
303 default)
304 "Element type: ")
305 sgml-dtd-info
306 default))
307
308 (list
309 (sgml-eltype-name input))))
310
311 (sgml-need-dtd)
312 (let ((et (sgml-lookup-eltype et-name)))
313 (with-output-to-temp-buffer "*Help*"
314 (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et)))
315 (princ (format " Start-tag is %s.\n End-tag is %s.\n"
316 (if (sgml-eltype-stag-optional et)
317 "optional" "required")
318 (if (sgml-eltype-etag-optional et)
319 "optional" "required")))
320 (princ "\nATTRIBUTES:\n")
321 (loop for attdecl in (sgml-eltype-attlist et) do
322 (let ((name (sgml-attdecl-name attdecl))
323 (dval (sgml-attdecl-declared-value attdecl))
324 (defl (sgml-attdecl-default-value attdecl)))
325 (when (listp dval)
326 (setq dval (concat (if (eq (first dval)
327 'notation)
328 "#NOTATION (" "(")
329 (mapconcat (function identity)
330 (second dval)
331 "|")
332 ")")))
333 (cond ((sgml-default-value-type-p 'fixed defl)
334 (setq defl (format "#FIXED '%s'"
335 (sgml-default-value-attval defl))))
336 ((symbolp defl)
337 (setq defl (upcase (format "#%s" defl))))
338 (t
339 (setq defl (format "'%s'"
340 (sgml-default-value-attval defl)))))
341 (princ (format " %-9s %-30s %s\n" name dval defl))))
342 ;; ----
343 (let ((s (sgml-eltype-shortmap et)))
344 (when s
345 (princ (format "\nUSEMAP: %s\n" s))))
346 ;; ----
347 (princ "\nOCCURS IN:\n\n")
348 (sgml-map-eltypes
349 (function (lambda (cand)
350 (when (memq et (sgml-eltype-refrenced-elements cand))
351 (princ (format " %s" (sgml-eltype-name cand))))))
352 (sgml-pstate-dtd sgml-buffer-parse-state)))))
353
354
355 ;;;; Print general info about the DTD.
356
357 (defun sgml-general-dtd-info ()
358 "Display information about the current DTD."
359 (interactive)
360 (sgml-need-dtd)
361 (let ((elements 0)
362 (entities 0)
363 (parameters 0)
364 (fmt "%20s %s\n")
365 (hdr "")
366 )
367 (sgml-map-eltypes (function (lambda (e) (incf elements)))
368 sgml-dtd-info)
369 (sgml-map-entities (function (lambda (e) (incf entities)))
370 (sgml-dtd-entities sgml-dtd-info))
371 (sgml-map-entities (function (lambda (e) (incf parameters)))
372 (sgml-dtd-parameters sgml-dtd-info))
373
374 (with-output-to-temp-buffer "*Help*"
375 (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info)))
376 (when (sgml-dtd-merged sgml-dtd-info)
377 (princ (format fmt "Compiled DTD:"
378 (car (sgml-dtd-merged sgml-dtd-info)))))
379 (princ (format fmt "Element types:" (format "%d" elements)))
380 (princ (format fmt "Entities:" (format "%d" entities)))
381 (princ (format fmt "Parameter entities:" (format "%d" parameters)))
382
383 (setq hdr "Files used:")
384 (loop for x in (sgml-dtd-dependencies sgml-dtd-info)
385 if (stringp x)
386 do (princ (format fmt hdr x))
387 (setq hdr ""))
388
389 (setq hdr "Undef parameters:")
390 (sgml-map-entities
391 (function (lambda (entity)
392 (when (sgml-entity-marked-undefined-p entity)
393 (princ (format fmt hdr (sgml-entity-name entity)))
394 (setq hdr ""))))
395 (sgml-dtd-parameters sgml-dtd-info)))))
396
397 ;;; psgml-info.el ends here