|
0
|
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
|
