Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-fs.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 ;;; fs.el --- Format a SGML-file according to a style file
2 ;; Copyright (C) 1995 Lennart Staflin
3
4 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
5 ;; Version: $Id: psgml-fs.el,v 1.1.1.1 1996/12/18 03:35:17 steve Exp $
6 ;; Keywords:
7 ;; Last edited: Mon Jan 8 22:12:00 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
8
9 ;;; This program is free software; you can redistribute it and/or modify
10 ;;; it under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 1, or (at your option)
12 ;;; 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 ;;; A copy of the GNU General Public License can be obtained from this
20 ;;; program's author (send electronic mail to lenst@lysator.liu.se) or from
21 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
22 ;;; 02139, USA.
23 ;;;
24 ;;; Commentary:
25
26 ;; The function `style-format' formats the SGML-file in the current buffer
27 ;; according to the style defined in the file `style.el' (or the file given
28 ;; by the variable `fs-style').
29
30 ;; To try it load this file and open the test file example.sgml. Then
31 ;; run the emacs command `M-x style-format'.
32
33 ;; The style file should contain a single Lisp list. The elements of
34 ;; this list, are them self lists, describe the style for an element type.
35 ;; The sublists begin with the generic identifier for the element types and
36 ;; the rest of the list are characteristic/value pairs.
37
38 ;; E.g. ("p" block t left 4 top 2)
39
40 ;; Defines the style for p-elements to be blocks with left margin 4 and
41 ;; at least to blank lines before the block.
42
43
44 ;;; Code:
45 (require 'psgml-api)
46
47 ;;;; Formatting parameters
48
49 (defvar fs-char
50 '((left . 0)
51 (first . nil)
52 (default-top . 0)
53 (default-bottom . 0)
54 (ignore-empty-para . nil)
55 (literal . nil)))
56
57 (defvar fs-special-styles
58 '(top bottom before after hang-from text)
59 "Style attribues that should not be entered in the characteristics table.")
60
61
62 ;;;; Formatting engine
63
64 (defun fs-char (p)
65 (cdr (assq p fs-char)))
66
67 (defvar fs-para-acc ""
68 "Accumulate text of paragraph")
69
70 (defvar fs-hang-from nil
71 "Hanging indent of current pargraph")
72
73 (defvar fs-first-indent nil)
74 (defvar fs-left-indent nil)
75
76 (defvar fs-vspace 0
77 "Vertical space after last paragraph")
78
79 (defun fs-addvspace (n)
80 (when (> n fs-vspace)
81 (princ (make-string (- n fs-vspace) ?\n))
82 (setq fs-vspace n)))
83
84
85 (defun fs-para ()
86 (when (if (fs-char 'ignore-epmty-para)
87 (string-match "[^\t\n ]" fs-para-acc)
88 fs-left-indent)
89 (assert fs-left-indent)
90 (fs-output-para fs-para-acc fs-first-indent fs-left-indent
91 fs-hang-from
92 (fs-char 'literal))
93 (setq fs-vspace 0
94 fs-hang-from nil))
95 (setq fs-para-acc ""
96 fs-first-indent nil
97 fs-left-indent nil))
98
99 (defun fs-paraform-data (data)
100 (unless fs-left-indent
101 (setq fs-left-indent (fs-char 'left)
102 fs-first-indent (fs-char 'first)))
103 (setq fs-para-acc (concat fs-para-acc data)))
104
105 (defun fs-output-para (text first-indent indent hang-from literal)
106 (sgml-push-to-string text)
107 (let ((indent-tabs-mode nil)
108 (fill-prefix (make-string indent ? )))
109 (cond
110 (literal
111 (goto-char (point-max))
112 (unless (bolp)
113 (insert ?\n))
114 (goto-char (point-min))
115 (while (not (eobp))
116 (insert fill-prefix)
117 (beginning-of-line 2)))
118 (t
119 (while (re-search-forward "[ \t\n\r]+" nil t)
120 (replace-match " "))
121 (goto-char (point-min))
122 (delete-horizontal-space)
123 (insert
124 (if hang-from
125 hang-from
126 (make-string (or first-indent indent) ? )))
127 (fill-region-as-paragraph (point-min) (point-max))
128 ))
129 (princ (buffer-string)))
130 (sgml-pop-entity))
131
132 (defun fs-element-content (e)
133 (let ((fs-para-acc ""))
134 (sgml-map-content e
135 (function fs-paraform-phrase)
136 (function fs-paraform-data)
137 nil
138 (function fs-paraform-entity))
139 fs-para-acc))
140
141 (defun fs-paraform-phrase (e)
142 (sgml-map-content e
143 (function fs-paraform-phrase)
144 (function fs-paraform-data)
145 nil
146 (function fs-paraform-entity)))
147
148 (defun fs-paraform-entity (entity)
149 (let ((entity-map (fs-char 'entity-map))
150 (text nil))
151 (when entity-map
152 (setq text
153 (loop for (name val) on entity-map by 'cddr
154 thereis (if (equal name (sgml-entity-name entity))
155 val))))
156 (unless text
157 (setq text (sgml-entity-text entity)))
158 (fs-paraform-data text)))
159
160 ;;;; Style driven engine
161
162 (defvar fs-style "psgml-style.el"
163 "*Style sheet to use for `style-format'.
164 The value can be the style-sheet list, or it can be a file name
165 \(string) of a file containing the style sheet or it can be the name
166 \(symbol) of a variable containing the style sheet." )
167
168 (defvar fs-cached-styles nil)
169
170 (defun fs-get-style (style)
171 (cond ((stringp style)
172 (sgml-cache-catalog style
173 'fs-cached-styles
174 (function (lambda ()
175 (read (current-buffer))))))
176 ((symbolp style)
177 (fs-get-style (symbol-value style)))
178 ((listp style)
179 style)
180 (t
181 (error "Illegal style value: %s" style))))
182
183 (defun fs-engine (e)
184 (fs-do-style e
185 (cdr (or (assoc (sgml-element-gi e) fs-style)
186 (assq t fs-style)))))
187
188 (defun fs-do-style (e style)
189 (let ((hang-from (getf style 'hang-from)))
190 (when hang-from
191 (setq fs-hang-from
192 (format "%s%s "
193 (make-string (fs-char 'left) ? )
194 (eval hang-from)))))
195 (let ((fs-char (nconc
196 (loop for st on style by 'cddr
197 unless (memq (car st) fs-special-styles)
198 collect (cons (car st)
199 (eval (cadr st))))
200 fs-char)))
201 (when (getf style 'block)
202 (fs-para)
203 (fs-addvspace (or (getf style 'top)
204 (fs-char 'default-top))))
205 (let ((before (getf style 'before)))
206 (when before
207 (fs-do-style e before)))
208 (cond ((getf style 'text)
209 (fs-paraform-data (eval (getf style 'text))))
210 (t
211 (sgml-map-content e
212 (function fs-engine)
213 (function fs-paraform-data)
214 nil
215 (function fs-paraform-entity))))
216 (let ((after (getf style 'after)))
217 (when after
218 (fs-do-style e after)))
219 (when (getf style 'block)
220 (fs-para)
221 (fs-addvspace (or (getf style 'bottom)
222 (fs-char 'default-bottom))))))
223
224 ;;;###autoload
225 (defun style-format ()
226 (interactive)
227 (setq fs-para-acc "")
228 (let ((fs-style (fs-get-style fs-style)))
229 (with-output-to-temp-buffer "*Formatted*"
230 (fs-engine (sgml-top-element))
231 (fs-para))))
232
233
234
235 ;;;; Helper functions for use in style sheet
236
237 (defun fs-attval (name)
238 (sgml-element-attval e name))
239
240
241 ;;; fs.el ends here