|
0
|
1 ;;;; psgml-info.el
|
|
2
|
2 ;;; Last edited: Wed Mar 20 21:24:16 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
|
|
|
3 ;;; $Id: psgml-info.el,v 1.1.1.2 1996/12/18 03:47:14 steve Exp $
|
|
0
|
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
|
|
2
|
100 (sgml-add-last-unique (sgml-and-node-next (car agenda)) states)
|
|
|
101 (loop for dfa in (sgml-and-node-dfas (car agenda)) do
|
|
0
|
102 (sgml-add-last-unique dfa states))))
|
|
|
103 (setq agenda (cdr agenda)))
|
|
2
|
104 (setq res (sort (set-difference
|
|
|
105 (union res (sgml-eltype-includes eltype))
|
|
|
106 (sgml-eltype-excludes eltype))
|
|
|
107 (function string-lessp)))
|
|
0
|
108 (setf (sgml-eltype-appdata eltype 're-cache) res)
|
|
|
109 res)))))
|
|
|
110
|
|
|
111
|
|
|
112 ;;;; List elements
|
|
|
113
|
|
|
114 (defun sgml-list-elements ()
|
|
|
115 "List the elements and their attributes in the current DTD."
|
|
|
116 (interactive)
|
|
|
117 (message "Creating table...")
|
|
|
118 (sgml-display-table
|
|
|
119 (sgml-map-element-types
|
|
|
120 (function
|
|
|
121 (lambda (eltype)
|
|
|
122 (cons (sgml-eltype-name eltype)
|
|
|
123 (mapcar (function sgml-attdecl-name)
|
|
|
124 (sgml-eltype-attlist eltype))))))
|
|
|
125 "Elements" "Element" "Attribute"))
|
|
|
126
|
|
|
127
|
|
|
128 ;;;; List attributes
|
|
|
129
|
|
|
130 (defun sgml-list-attributes ()
|
|
|
131 "List the attributes and in which elements they occur."
|
|
|
132 (interactive)
|
|
|
133 (let ((attributes nil))
|
|
|
134 (message "Creating table...")
|
|
|
135 (sgml-map-element-types
|
|
|
136 (function
|
|
|
137 (lambda (eltype)
|
|
|
138 (loop for a in (sgml-eltype-attlist eltype) do
|
|
|
139 (setq attributes
|
|
|
140 (sgml-add-to-table (sgml-attdecl-name a)
|
|
|
141 (sgml-eltype-name eltype)
|
|
|
142 attributes))))))
|
|
|
143 (sgml-display-table attributes
|
|
|
144 "Attributes" "Attribute" "Element")))
|
|
|
145
|
|
|
146
|
|
|
147
|
|
|
148
|
|
|
149 ;;;; List terminals
|
|
|
150
|
|
|
151 (defun sgml-list-terminals ()
|
|
|
152 "List the elements that can have data in their content."
|
|
|
153 (interactive)
|
|
|
154 (message "Creating table...")
|
|
|
155 (let ((data-models (list sgml-cdata sgml-rcdata sgml-any)))
|
|
|
156 (sgml-display-table
|
|
|
157 (delq nil
|
|
|
158 (sgml-map-element-types
|
|
|
159 (function
|
|
|
160 (lambda (eltype)
|
|
|
161 (if (or (sgml-eltype-mixed eltype)
|
|
|
162 (memq (sgml-eltype-model eltype) data-models))
|
|
|
163 (list (sgml-eltype-name eltype)
|
|
|
164 (symbol-name
|
|
|
165 (if (sgml-model-group-p (sgml-eltype-model eltype))
|
|
|
166 'mixed
|
|
|
167 (sgml-eltype-model eltype)))))))))
|
|
|
168 "Terminals" "Element" "Content")))
|
|
|
169
|
|
|
170
|
|
|
171 ;;;; Element cross reference list
|
|
|
172
|
|
|
173 (defun sgml-list-content-elements ()
|
|
|
174 "List all element types and the element types that can occur in its content."
|
|
|
175 (interactive)
|
|
|
176 (message "Creating table...")
|
|
|
177 (sgml-display-table
|
|
|
178 (sgml-map-element-types
|
|
|
179 (function
|
|
|
180 (lambda (eltype)
|
|
|
181 (cons (sgml-eltype-name eltype)
|
|
|
182 (mapcar (function sgml-eltype-name)
|
|
|
183 (sgml-eltype-refrenced-elements eltype))))))
|
|
|
184 "Elements refrenced by elements"
|
|
|
185 "Element" "Content"))
|
|
|
186
|
|
|
187 (defun sgml-list-occur-in-elements ()
|
|
|
188 "List all element types and where it can occur."
|
|
|
189 (interactive)
|
|
|
190 (message "Creating table...")
|
|
|
191 (let ((cross nil))
|
|
|
192 (sgml-map-element-types
|
|
|
193 (function
|
|
|
194 (lambda (eltype)
|
|
|
195 (loop for ref in (sgml-eltype-refrenced-elements eltype)
|
|
|
196 do (setq cross (sgml-add-to-table ref
|
|
|
197 (sgml-eltype-name eltype)
|
|
|
198 cross))))))
|
|
|
199 (sgml-display-table
|
|
|
200 cross
|
|
|
201 "Cross referenced element types" "Element" "Can occur in")))
|
|
|
202
|
|
|
203
|
|
|
204 ;;;; Display table
|
|
|
205
|
|
|
206 (defun sgml-display-table (table title col-title1 col-title2
|
|
|
207 &optional width nosort)
|
|
|
208 (or width
|
|
|
209 (setq width sgml-attr-col))
|
|
|
210 (let ((buf (get-buffer-create (format "*%s*" title))))
|
|
|
211 (message "Preparing display...")
|
|
|
212 (set-buffer buf)
|
|
|
213 (erase-buffer)
|
|
|
214 (insert col-title1)
|
|
|
215 (indent-to width)
|
|
|
216 (insert col-title2 "\n")
|
|
|
217 (insert-char ?= (length col-title1))
|
|
|
218 (indent-to width)
|
|
|
219 (insert-char ?= (length col-title2))
|
|
|
220 (insert "\n")
|
|
|
221 (unless nosort
|
|
|
222 (setq table (sort table (function (lambda (a b)
|
|
|
223 (string< (car a) (car b)))))))
|
|
|
224 (loop for e in table do
|
|
|
225 (insert (format "%s" (car e)))
|
|
|
226 (loop for name in (if nosort
|
|
|
227 (cdr e)
|
|
|
228 (sort (cdr e) (function string-lessp)))
|
|
|
229 do
|
|
|
230 (when (> (+ (length name) (current-column))
|
|
|
231 fill-column)
|
|
|
232 (insert "\n"))
|
|
|
233 (when (< (current-column) sgml-attr-col)
|
|
|
234 (indent-to width))
|
|
|
235 (insert name " "))
|
|
|
236 (insert "\n"))
|
|
|
237 (goto-char (point-min))
|
|
|
238 (display-buffer buf)
|
|
|
239 (message nil)))
|
|
|
240
|
|
|
241
|
|
|
242 ;;;; Describe entity
|
|
|
243
|
|
|
244 (defun sgml-describe-entity (name)
|
|
|
245 "Describe the properties of an entity as declared in the current DTD."
|
|
|
246 (interactive
|
|
|
247 (let (default input)
|
|
|
248 (sgml-need-dtd)
|
|
|
249 (save-excursion
|
|
|
250 (sgml-with-parser-syntax
|
|
|
251 (unless (sgml-parse-delim "ERO")
|
|
|
252 (skip-chars-backward "^&\"'= \t\n"))
|
|
|
253 (setq default (or (sgml-parse-name t) ""))))
|
|
|
254 (setq input (completing-read
|
|
|
255 (format "Entity name (%s): " default)
|
|
|
256 (sgml-entity-completion-table
|
|
|
257 (sgml-dtd-entities
|
|
|
258 (sgml-pstate-dtd sgml-buffer-parse-state)))))
|
|
|
259 (list
|
|
|
260 (if (equal "" input) default input))))
|
|
|
261
|
|
|
262 (with-output-to-temp-buffer "*Help*"
|
|
|
263 (let ((entity (sgml-lookup-entity name
|
|
|
264 (sgml-dtd-entities
|
|
|
265 (sgml-pstate-dtd
|
|
|
266 sgml-buffer-parse-state)))))
|
|
|
267 (or entity (error "Undefined entity"))
|
|
|
268 (princ (format "Entity %s is %s\n"
|
|
|
269 name
|
|
|
270 (cond ((null entity)
|
|
|
271 "undefined")
|
|
|
272 (t
|
|
|
273 (format "a %s entity"
|
|
|
274 (sgml-entity-type entity))))))
|
|
|
275 (when entity
|
|
|
276 (let ((text (sgml-entity-text entity)))
|
|
|
277 (cond ((stringp text)
|
|
|
278 (princ "Defined to be:\n")
|
|
|
279 (princ text))
|
|
|
280 (t
|
|
|
281 (princ "With external identifier ")
|
|
|
282 (princ (if (car text) "PUBLIC" "SYSTEM"))
|
|
|
283 (when (car text)
|
|
|
284 (princ (format " '%s'" (car text))))
|
|
|
285 (when (cdr text)
|
|
|
286 (princ (format " '%s'" (cdr text)))))))))))
|
|
|
287
|
|
|
288
|
|
|
289
|
|
|
290 ;;;; Describe element type
|
|
|
291
|
|
|
292 (defun sgml-describe-element-type (et-name)
|
|
|
293 "Describe the properties of an element type as declared in the current DTD."
|
|
|
294 (interactive
|
|
|
295 (let (default input)
|
|
|
296 (sgml-need-dtd)
|
|
|
297 (save-excursion
|
|
|
298 (sgml-with-parser-syntax
|
|
|
299 (unless (sgml-parse-delim "STAGO")
|
|
|
300 (skip-syntax-backward "w_"))
|
|
|
301 (setq default (sgml-parse-name))
|
|
|
302 (unless (and default
|
|
|
303 (sgml-eltype-defined (sgml-lookup-eltype default)))
|
|
|
304 (setq default nil))))
|
|
|
305 (setq input (sgml-read-element-type (if default
|
|
|
306 (format "Element type (%s): "
|
|
|
307 default)
|
|
|
308 "Element type: ")
|
|
|
309 sgml-dtd-info
|
|
|
310 default))
|
|
|
311
|
|
|
312 (list
|
|
|
313 (sgml-eltype-name input))))
|
|
|
314
|
|
|
315 (sgml-need-dtd)
|
|
|
316 (let ((et (sgml-lookup-eltype et-name)))
|
|
|
317 (with-output-to-temp-buffer "*Help*"
|
|
|
318 (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et)))
|
|
|
319 (princ (format " Start-tag is %s.\n End-tag is %s.\n"
|
|
|
320 (if (sgml-eltype-stag-optional et)
|
|
|
321 "optional" "required")
|
|
|
322 (if (sgml-eltype-etag-optional et)
|
|
|
323 "optional" "required")))
|
|
|
324 (princ "\nATTRIBUTES:\n")
|
|
|
325 (loop for attdecl in (sgml-eltype-attlist et) do
|
|
|
326 (let ((name (sgml-attdecl-name attdecl))
|
|
|
327 (dval (sgml-attdecl-declared-value attdecl))
|
|
|
328 (defl (sgml-attdecl-default-value attdecl)))
|
|
|
329 (when (listp dval)
|
|
|
330 (setq dval (concat (if (eq (first dval)
|
|
|
331 'notation)
|
|
|
332 "#NOTATION (" "(")
|
|
|
333 (mapconcat (function identity)
|
|
|
334 (second dval)
|
|
|
335 "|")
|
|
|
336 ")")))
|
|
|
337 (cond ((sgml-default-value-type-p 'fixed defl)
|
|
|
338 (setq defl (format "#FIXED '%s'"
|
|
|
339 (sgml-default-value-attval defl))))
|
|
|
340 ((symbolp defl)
|
|
|
341 (setq defl (upcase (format "#%s" defl))))
|
|
|
342 (t
|
|
|
343 (setq defl (format "'%s'"
|
|
|
344 (sgml-default-value-attval defl)))))
|
|
|
345 (princ (format " %-9s %-30s %s\n" name dval defl))))
|
|
|
346 ;; ----
|
|
|
347 (let ((s (sgml-eltype-shortmap et)))
|
|
|
348 (when s
|
|
|
349 (princ (format "\nUSEMAP: %s\n" s))))
|
|
|
350 ;; ----
|
|
|
351 (princ "\nOCCURS IN:\n\n")
|
|
2
|
352 (let ((occurs-in ()))
|
|
|
353 (sgml-map-eltypes
|
|
|
354 (function (lambda (cand)
|
|
|
355 (when (memq et (sgml-eltype-refrenced-elements cand))
|
|
|
356 (push cand occurs-in))))
|
|
|
357 (sgml-pstate-dtd sgml-buffer-parse-state))
|
|
|
358
|
|
|
359 (loop with col = 0
|
|
|
360 for occur-et in (sort occurs-in (function string-lessp))
|
|
|
361 for name = (sgml-eltype-name occur-et)
|
|
|
362 do
|
|
|
363 (when (and (> col 0) (> (+ col (length name) 1) fill-column))
|
|
|
364 (princ "\n")
|
|
|
365 (setq col 0))
|
|
|
366 (princ " ") (princ name)
|
|
|
367 (incf col (length name))
|
|
|
368 (incf col 1))))))
|
|
0
|
369
|
|
|
370
|
|
|
371 ;;;; Print general info about the DTD.
|
|
|
372
|
|
|
373 (defun sgml-general-dtd-info ()
|
|
|
374 "Display information about the current DTD."
|
|
|
375 (interactive)
|
|
|
376 (sgml-need-dtd)
|
|
|
377 (let ((elements 0)
|
|
|
378 (entities 0)
|
|
|
379 (parameters 0)
|
|
|
380 (fmt "%20s %s\n")
|
|
|
381 (hdr "")
|
|
|
382 )
|
|
|
383 (sgml-map-eltypes (function (lambda (e) (incf elements)))
|
|
|
384 sgml-dtd-info)
|
|
|
385 (sgml-map-entities (function (lambda (e) (incf entities)))
|
|
|
386 (sgml-dtd-entities sgml-dtd-info))
|
|
|
387 (sgml-map-entities (function (lambda (e) (incf parameters)))
|
|
|
388 (sgml-dtd-parameters sgml-dtd-info))
|
|
|
389
|
|
|
390 (with-output-to-temp-buffer "*Help*"
|
|
|
391 (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info)))
|
|
|
392 (when (sgml-dtd-merged sgml-dtd-info)
|
|
|
393 (princ (format fmt "Compiled DTD:"
|
|
|
394 (car (sgml-dtd-merged sgml-dtd-info)))))
|
|
|
395 (princ (format fmt "Element types:" (format "%d" elements)))
|
|
|
396 (princ (format fmt "Entities:" (format "%d" entities)))
|
|
|
397 (princ (format fmt "Parameter entities:" (format "%d" parameters)))
|
|
|
398
|
|
|
399 (setq hdr "Files used:")
|
|
|
400 (loop for x in (sgml-dtd-dependencies sgml-dtd-info)
|
|
|
401 if (stringp x)
|
|
|
402 do (princ (format fmt hdr x))
|
|
|
403 (setq hdr ""))
|
|
|
404
|
|
|
405 (setq hdr "Undef parameters:")
|
|
|
406 (sgml-map-entities
|
|
|
407 (function (lambda (entity)
|
|
|
408 (when (sgml-entity-marked-undefined-p entity)
|
|
|
409 (princ (format fmt hdr (sgml-entity-name entity)))
|
|
|
410 (setq hdr ""))))
|
|
|
411 (sgml-dtd-parameters sgml-dtd-info)))))
|
|
|
412
|
|
|
413 ;;; psgml-info.el ends here
|
