Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-style.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 ;;; w3-style.el,v --- Emacs-W3 binding style sheet mechanism
2 ;; Author: wmperry
3 ;; Created: 1996/05/31 21:34:16
4 ;; Version: 1.82
5 ;; Keywords: faces, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; A style sheet mechanism for emacs-w3
29 ;;;
30 ;;; This will eventually be able to under DSSSL[-lite] as well as the
31 ;;; experimental W3C mechanism
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 (require 'font)
34 (require 'w3-keyword)
35 (require 'cl)
36
37 (defvar w3-style-css-syntax-table
38 (copy-syntax-table mm-parse-args-syntax-table)
39 "The syntax table for parsing stylesheets")
40
41 (defvar w3-style-ie-compatibility nil
42 "*Whether we want to do Internet Explorer 3.0 compatible parsing of
43 CSS stylesheets.")
44
45 (defun w3-style-css-parse-args (st &optional nd defines)
46 ;; Return an assoc list of attribute/value pairs from a CSS style entry
47 (let (
48 name ; From name=
49 value ; its value
50 results ; Assoc list of results
51 name-pos ; Start of XXXX= position
52 val-pos ; Start of value position
53 )
54 (save-excursion
55 (if (stringp st)
56 (progn
57 (set-buffer (get-buffer-create " *w3-style-temp*"))
58 (set-syntax-table w3-style-css-syntax-table)
59 (erase-buffer)
60 (insert st)
61 (setq st (point-min)
62 nd (point-max)))
63 (set-syntax-table w3-style-css-syntax-table))
64 (save-restriction
65 (if (< nd st)
66 (narrow-to-region nd nd)
67 (narrow-to-region st nd))
68 (goto-char (point-min))
69 (while (not (eobp))
70 (skip-chars-forward ";, \n\t")
71 (setq name-pos (point))
72 (skip-chars-forward "^ \n\t:=,;")
73 (downcase-region name-pos (point))
74 (setq name (buffer-substring name-pos (point)))
75 (skip-chars-forward " \t\n")
76 (if (not (eq (char-after (point)) ?:)) ; There is no value
77 (setq value nil)
78 (skip-chars-forward " \t\n:")
79 (setq val-pos (point)
80 value
81 (cond
82 ((or (= (or (char-after val-pos) 0) ?\")
83 (= (or (char-after val-pos) 0) ?'))
84 (buffer-substring (1+ val-pos)
85 (condition-case ()
86 (prog2
87 (forward-sexp 1)
88 (1- (point))
89 (skip-chars-forward "\""))
90 (error
91 (skip-chars-forward "^ \t\n")
92 (point)))))
93 (t
94 (buffer-substring val-pos
95 (progn
96 (if w3-style-ie-compatibility
97 (skip-chars-forward "^;")
98 (skip-chars-forward "^,;"))
99 (skip-chars-backward " \t")
100 (point)))))))
101 (setq results (cons (cons name value) results))
102 (skip-chars-forward ";, \n\t"))
103 results))))
104
105 (defvar w3-style-css-define-table nil)
106
107 (defun w3-style-css-handle-define ()
108 (let ((name nil)
109 (save-pos (point))
110 (retval nil))
111 (skip-chars-forward "^ \t\r\n") ; Past the name token
112 (downcase-region save-pos (point))
113 (setq name (buffer-substring save-pos (point)))
114 (skip-chars-forward "= \t\r")
115 (setq save-pos (point))
116 (skip-chars-forward "^;")
117 (setq retval (cons name (buffer-substring save-pos (point))))
118 (skip-chars-forward " \t\r\n")
119 retval))
120
121 (defun w3-style-css-handle-import ()
122 (let ((url nil)
123 (save-pos (point)))
124 (if (looking-at "'\"")
125 (condition-case ()
126 (forward-sexp 1)
127 (error (skip-chars-forward "^ \t\r\n;")))
128 (skip-chars-forward "^ \t\r\n;"))
129 (setq url (url-expand-file-name (buffer-substring save-pos (point))))
130 (skip-chars-forward "\"; \t\r\n")
131 (setq save-pos (point))
132 (let ((url-working-buffer (url-generate-new-buffer-name " *styleimport*"))
133 (url-mime-accept-string
134 "text/css ; level=2")
135 (sheet nil))
136 (save-excursion
137 (set-buffer (get-buffer-create url-working-buffer))
138 (setq url-be-asynchronous nil)
139 (url-retrieve url)
140 (w3-style-css-clean)
141 (setq sheet (buffer-string))
142 (kill-buffer (current-buffer)))
143 (insert sheet)
144 (goto-char save-pos))))
145
146 (defun w3-style-css-clean ()
147 ;; Nuke comments, etc.
148 (goto-char (point-min))
149 (let ((save-pos nil))
150 (while (search-forward "/*" nil t)
151 (setq save-pos (- (point) 2))
152 (delete-region save-pos
153 (if (search-forward "*/" nil t)
154 (point)
155 (end-of-line)
156 (point)))))
157 (goto-char (point-min))
158 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
159 (w3-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
160 (w3-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
161 (goto-char (point-min)))
162
163 (defun w3-style-css-applies-to (st nd)
164 (let ((results nil)
165 (save-pos nil))
166 (narrow-to-region st nd)
167 (goto-char st)
168 (skip-chars-forward " \t\r\n")
169 (while (not (eobp))
170 (setq save-pos (point))
171 (skip-chars-forward "^,")
172 (skip-chars-backward " \r\t\n")
173 (setq results (cons (buffer-substring save-pos (point)) results))
174 (skip-chars-forward ", \t\r\n"))
175 (widen)
176 results))
177
178 (defun w3-style-parse-css (fname &optional string inherit)
179 (let (
180 (url-mime-accept-string
181 "text/css ; level=2")
182 (save-pos nil)
183 (applies-to nil) ; List of tags to apply style to
184 (attrs nil) ; List of name/value pairs
185 (tag nil)
186 (att nil)
187 (cur nil)
188 (val nil)
189 (class nil)
190 (defines nil)
191 (device-type nil)
192 (active-device-types (list 'normal 'default
193 (if w3-running-FSF19 'emacs 'xemacs)))
194 (sheet inherit))
195 (let ((type (device-type)))
196 (cond
197 ((eq type 'tty)
198 (if (and (fboundp 'tty-color-list)
199 (/= 0 (length (tty-color-list))))
200 (setq active-device-types (cons 'ansi-tty active-device-types))
201 (setq active-device-types (cons 'tty active-device-types))))
202 ((eq 'color (device-class))
203 (setq active-device-types
204 (append
205 (list (intern (format "%dbit-color"
206 (device-bitplanes)))
207 (intern (format "%dbit"
208 (device-bitplanes)))
209 'color) active-device-types))
210 (if (= 24 (device-bitplanes))
211 (setq active-device-types (cons 'truecolor active-device-types))))
212 ((eq 'grayscale (device-class))
213 (setq active-device-types (append
214 (list (intern (format "%dbit-grayscale"
215 (device-bitplanes)))
216 'grayscale)
217 active-device-types)))
218 ((eq 'mono (device-class))
219 (setq active-device-types (append (list 'mono 'monochrome)
220 active-device-types)))
221 (t
222 (setq active-device-types (cons 'unknown active-device-types)))))
223
224 (save-excursion
225 (set-buffer (get-buffer-create
226 (url-generate-new-buffer-name " *style*")))
227 (set-syntax-table w3-style-css-syntax-table)
228 (erase-buffer)
229 (if fname (url-insert-file-contents fname))
230 (goto-char (point-max))
231 (if string (insert string))
232 (w3-style-css-clean)
233 (goto-char (point-min))
234 (while (not (eobp))
235 (setq save-pos (point))
236 (cond
237 ;; C++ style comments, and we are doing IE compatibility
238 ((and (looking-at "//") w3-style-ie-compatibility)
239 (end-of-line))
240 ;; Pre-Processor directives
241 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
242 (let ((directive nil))
243 (skip-chars-forward " @\t\r") ; Past any leading whitespace
244 (setq save-pos (point))
245 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
246 (downcase-region save-pos (point))
247 (setq directive (buffer-substring save-pos (point)))
248 (skip-chars-forward " \t\r") ; Past any trailing whitespace
249 (setq save-pos (point))
250 (cond
251 ((string= directive "define")
252 (let ((retval (w3-style-css-handle-define)))
253 (and defines
254 (setq defines (cons retval defines)))))
255 ((string= directive "import")
256 (w3-style-css-handle-import))
257 (t
258 (w3-warn 'style (format "Unknown directive: @%s" directive)
259 'warning)))))
260 ;; Giving us some output device information
261 ((looking-at "[ \t\r]*:\\([^:]+\\):")
262 (downcase-region (match-beginning 1) (match-end 1))
263 (setq device-type (intern (buffer-substring (match-beginning 1)
264 (match-end 1))))
265 (goto-char (match-end 0))
266 (if (not (memq device-type active-device-types))
267 ;; Not applicable to us... skip the info
268 (progn
269 (if (re-search-forward ":[^:]*:" nil t)
270 (goto-char (match-beginning 0))
271 (goto-char (point-max))))))
272 ;; Default is to treat it like a stylesheet declaration
273 (t
274 (skip-chars-forward "^{:")
275 (downcase-region save-pos (point))
276 (setq applies-to (w3-style-css-applies-to save-pos (point)))
277 (skip-chars-forward "^{")
278 (setq save-pos (point))
279 (forward-sexp 1)
280 (end-of-line)
281 (skip-chars-backward "\r}")
282 (subst-char-in-region save-pos (point) ?\n ? )
283 (subst-char-in-region save-pos (point) ?\r ? )
284 (setq attrs (w3-style-css-parse-args (1+ save-pos)
285 (point) defines))
286 (skip-chars-forward "}\r\n")
287 (while applies-to
288 (setq cur (car applies-to)
289 applies-to (cdr applies-to))
290 (cond
291 ((string-match "\\(.*\\)\\.\\(.*\\)" cur) ; Normal class
292 (setq tag (intern (downcase (match-string 1 cur)))
293 class (match-string 2 cur)))
294 ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class
295 (setq tag (intern (downcase (match-string 1 cur)))
296 class (match-string 2 cur)))
297 (t ; No class - global
298 (setq tag (intern (downcase cur))
299 class 'internal)))
300 (let ((loop attrs))
301 (while loop
302 (if (stringp (car (car loop)))
303 (setcar (car loop) (intern (car (car loop)))))
304 (setq att (car (car loop))
305 val (cdr (car loop))
306 loop (cdr loop))
307 (case att
308 ((align textalign text-align display white-space)
309 (setq val (intern (downcase val))))
310 ((indent left-margin right-margin top-margin bottom-margin)
311 (setq val (string-to-int val)))
312 (otherwise
313 nil))
314 (let* ((node-1 (assq tag sheet))
315 (node-2 (and node-1 (assoc class node-1)))
316 (node-3 (and node-2 (assq att node-2))))
317 (cond
318 ((not node-1) ; New top-level element
319 (setq sheet (cons (cons tag (list (cons class
320 (list
321 (cons att val)))))
322 sheet)))
323 ((and node-1 (not node-2)) ; New class for existing element
324 (setcdr node-1 (cons (cons class (list (cons att val)))
325 (cdr node-1))))
326 ((and node-2 (not node-3)) ; attribute/value on old class
327 (setcdr node-2 (cons (cons att val) (cdr node-2))))
328 (node-3 ; Replace existing attribute value
329 (setcdr node-3 val)))))))))
330 (skip-chars-forward " \t\r\n"))
331 (set-buffer-modified-p nil)
332 (kill-buffer (current-buffer)))
333 (cons sheet defines)))
334
335
336 (defvar w3-style-font-size-mappings
337 '(("xx-small" . 0)
338 ("x-small" . 1)
339 ("small" . 2)
340 ("medium" . 3)
341 ("large" . 4)
342 ("x-large" . 5)
343 ("xx-large" . 6)
344 )
345 "A list of font size mappings")
346
347 (defvar w3-style-font-weight-mappings
348 '(("-3" . :extra-light)
349 ("-2" . :light)
350 ("-1" . :demi-light)
351 ("0" . :medium)
352 ("1" . :normal)
353 ("2" . :demi-bold)
354 ("3" . :bold)
355 ("4" . :extrabold)
356 ("bold" . :bold)
357 ("demi-light" . :demi-light)
358 ("demi-bold" . :demi-bold)
359 ("extra-bold" . :extra-bold)
360 ("extra-light". :extra-light)
361 )
362 "A list of font weight mappings.")
363
364 (defun w3-style-font-size-for-index (index)
365 (if (stringp index)
366 (setq index (or
367 (cdr-safe (assoc (downcase index)
368 w3-style-font-size-mappings))
369 3)))
370 (setq index (- index 3))
371 (let ((scaler (if (> index 0)
372 1.44
373 0.695))
374 (size 12))
375 (setq index (abs index))
376 (while (/= index 0)
377 (setq size (* size scaler)
378 index (1- index)))
379 ;; This rounds to the nearest '10'
380 (format "%dpt" (* 10 (round (/ size 10))))))
381
382 (defun w3-generate-stylesheet-faces (sheet)
383 (let ((todo sheet)
384 (cur nil)
385 (cur-classes nil)
386 (node nil)
387 (voice nil)
388 (voice-person nil)
389 (voice-tone nil)
390 (fore nil)
391 (back nil)
392 (pixmap nil)
393 (font nil)
394 (family nil)
395 (decoration nil)
396 (style nil)
397 (size nil)
398 (index nil)
399 (shorthand nil)
400 (weight nil)
401 (break-style nil))
402 (while todo
403 (setq cur (car todo)
404 cur-classes (cdr cur)
405 todo (cdr todo))
406 (while cur-classes
407 (setq node (cdr (car cur-classes))
408 cur (car cur-classes)
409 cur-classes (cdr cur-classes)
410 fore (cdr-safe (assq 'color node))
411 back (cdr-safe (assq 'background node))
412 voice-person (cdr-safe (assq 'voice node))
413 voice-tone (cdr-safe (assq 'voice-tone node))
414 decoration (cdr-safe (assq 'text-decoration node))
415 pixmap (cdr-safe (assq 'backdrop node))
416 index (cdr-safe (assq 'font-size-index node))
417 size (or (and index (w3-style-font-size-for-index index))
418 (cdr-safe (assq 'font-size node)))
419 family (cdr-safe (assq 'font-family node))
420 weight (cdr-safe (assq 'font-weight node))
421 weight (or (cdr-safe (assoc weight
422 w3-style-font-weight-mappings))
423 weight)
424 style (cdr-safe (assq 'font-style node))
425 shorthand (cdr-safe (assq 'font node)))
426
427 (setq voice (if (or voice-person voice-tone)
428 (intern
429 (cond
430 ((and voice-person voice-tone)
431 (concat voice-person "-" voice-tone))
432 (voice-person voice-person)
433 (voice-tone
434 (concat "default-voice-" voice-tone))
435 (t
436 (error "IMPOSSIBLE"))))))
437
438 ;; Make sure all 'break' items get intern'd
439 (if (or style decoration)
440 (setq style (concat style decoration)))
441 (setq break-style (assq 'break node))
442 (if (and (cdr break-style) (stringp (cdr break-style)))
443 (setcdr break-style (intern (cdr break-style))))
444 (if shorthand
445 (let ((shorthand (split-string shorthand "[ \t]")))
446 (setq size (or (nth 0 shorthand) size)
447 family (or (nth 1 shorthand) size)
448 weight (or (nth 2 shorthand) weight)
449 weight (or (cdr-safe
450 (assoc weight
451 w3-style-font-weight-mappings))
452 weight)
453 style (or (nth 3 shorthand) style))))
454 (if style
455 (setq style (mapcar
456 (function
457 (lambda (x)
458 (while (string-match "-" x)
459 (setq x (concat
460 (substring x 0 (match-beginning 0))
461 (substring x (match-end 0) nil))))
462 (intern-soft
463 (concat "font-set-" (downcase x) "-p"))))
464 (delete "" (split-string style "[ \t&,]")))))
465 (if family (setq family (delete "" (split-string family "[ \t]"))))
466 (if (or family weight style size)
467 (progn
468 (setq font (make-font :family family :weight weight :size size))
469 (while style
470 (and (fboundp (car style))
471 (funcall (car style) font t))
472 (setq style (cdr style))))
473 (setq font nil))
474 (if voice (setcdr cur (cons (cons 'voice-spec voice) (cdr cur))))
475 (if font (setcdr cur (cons (cons 'font-spec font) (cdr cur))))
476 (if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur))))
477 (if back (setcdr cur (cons (cons 'background back) (cdr cur))))
478 )
479 )
480 )
481 )
482
483 (defun w3-handle-style (&optional args)
484 (let ((fname (or (cdr-safe (assq 'href args))
485 (cdr-safe (assq 'src args))
486 (cdr-safe (assq 'uri args))))
487 (type (downcase (or (cdr-safe (assq 'notation args))
488 "experimental")))
489 (url-working-buffer " *style*")
490 (base (cdr-safe (assq 'base args)))
491 (stylesheet nil)
492 (defines nil)
493 (cur-sheet w3-current-stylesheet)
494 (string (cdr-safe (assq 'data args))))
495 (if fname (setq fname (url-expand-file-name fname
496 (cdr-safe
497 (assoc base w3-base-alist)))))
498 (save-excursion
499 (set-buffer (get-buffer-create url-working-buffer))
500 (erase-buffer)
501 (setq url-be-asynchronous nil)
502 (cond
503 ((member type '("experimental" "arena" "w3c-style" "css"))
504 (let ((data (w3-style-parse-css fname string cur-sheet)))
505 (setq stylesheet (nth 0 data)
506 defines (nth 1 data))))
507 (t
508 (w3-warn 'html "Unknown stylesheet notation: %s" type))))
509 (setq w3-current-stylesheet stylesheet)
510 (if (and w3-current-stylesheet (fboundp 'make-face))
511 (w3-generate-stylesheet-faces w3-current-stylesheet))))
512
513 (defun w3-display-stylesheet (&optional sheet)
514 (interactive)
515 (if (not sheet) (setq sheet w3-current-stylesheet))
516 (with-output-to-temp-buffer "W3 Stylesheet"
517 (set-buffer standard-output)
518 (emacs-lisp-mode)
519 (require 'pp)
520 (pp sheet (current-buffer))))
521
522 (provide 'w3-style)