Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-style.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 9ee227acff29
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;; w3-style.el,v --- Emacs-W3 binding style sheet mechanism 1 ;;; w3-style.el --- Emacs-W3 binding style sheet mechanism
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/05/31 21:34:16 3 ;; Created: 1996/08/12 03:10:30
4 ;; Version: 1.82 4 ;; Version: 1.13
5 ;; Keywords: faces, hypermedia 5 ;; Keywords: faces, hypermedia
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; 9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply. 10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;; 11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify 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 13 ;;; it under the terms of the GNU General Public License as published by
137 (set-buffer (get-buffer-create url-working-buffer)) 137 (set-buffer (get-buffer-create url-working-buffer))
138 (setq url-be-asynchronous nil) 138 (setq url-be-asynchronous nil)
139 (url-retrieve url) 139 (url-retrieve url)
140 (w3-style-css-clean) 140 (w3-style-css-clean)
141 (setq sheet (buffer-string)) 141 (setq sheet (buffer-string))
142 (set-buffer-modified-p nil)
142 (kill-buffer (current-buffer))) 143 (kill-buffer (current-buffer)))
143 (insert sheet) 144 (insert sheet)
144 (goto-char save-pos)))) 145 (goto-char save-pos))))
145 146
146 (defun w3-style-css-clean () 147 (defun w3-style-css-clean ()
173 (setq results (cons (buffer-substring save-pos (point)) results)) 174 (setq results (cons (buffer-substring save-pos (point)) results))
174 (skip-chars-forward ", \t\r\n")) 175 (skip-chars-forward ", \t\r\n"))
175 (widen) 176 (widen)
176 results)) 177 results))
177 178
179 (defun w3-style-active-device-types (&optional device)
180 (let ((types (list 'normal 'default (if w3-running-xemacs 'xemacs 'emacs)))
181 (type (device-type device)))
182 (cond
183 ((featurep 'emacspeak)
184 (setq types (cons 'speech types)))
185 ((eq type 'tty)
186 (if (and (fboundp 'tty-color-list)
187 (/= 0 (length (tty-color-list))))
188 (setq types (cons 'ansi-tty types))
189 (setq types (cons 'tty types))))
190 ((eq 'color (device-class))
191 (if (not (device-bitplanes))
192 (setq types (cons 'color types))
193 (setq types
194 (append
195 (list (intern (format "%dbit-color"
196 (device-bitplanes)))
197 (intern (format "%dbit"
198 (device-bitplanes)))
199 'color) types))
200 (if (= 24 (device-bitplanes))
201 (setq types (cons 'truecolor types)))))
202 ((eq 'grayscale (device-class))
203 (setq types (append (list (intern (format "%dbit-grayscale"
204 (device-bitplanes)))
205 'grayscale)
206 types)))
207 ((eq 'mono (device-class))
208 (setq types (append (list 'mono 'monochrome) types)))
209 (t
210 (setq types (cons 'unknown types))))
211 types))
212
178 (defun w3-style-parse-css (fname &optional string inherit) 213 (defun w3-style-parse-css (fname &optional string inherit)
179 (let ( 214 (let (
180 (url-mime-accept-string 215 (url-mime-accept-string
181 "text/css ; level=2") 216 "text/css ; level=2")
182 (save-pos nil) 217 (save-pos nil)
187 (cur nil) 222 (cur nil)
188 (val nil) 223 (val nil)
189 (class nil) 224 (class nil)
190 (defines nil) 225 (defines nil)
191 (device-type nil) 226 (device-type nil)
192 (active-device-types (list 'normal 'default 227 (active-device-types (w3-style-active-device-types (selected-device)))
193 (if w3-running-FSF19 'emacs 'xemacs)))
194 (sheet inherit)) 228 (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 229 (save-excursion
225 (set-buffer (get-buffer-create 230 (set-buffer (get-buffer-create
226 (url-generate-new-buffer-name " *style*"))) 231 (url-generate-new-buffer-name " *style*")))
227 (set-syntax-table w3-style-css-syntax-table) 232 (set-syntax-table w3-style-css-syntax-table)
228 (erase-buffer) 233 (erase-buffer)
232 (w3-style-css-clean) 237 (w3-style-css-clean)
233 (goto-char (point-min)) 238 (goto-char (point-min))
234 (while (not (eobp)) 239 (while (not (eobp))
235 (setq save-pos (point)) 240 (setq save-pos (point))
236 (cond 241 (cond
242 ;; *sigh* SGML comments are being used to 'hide' data inlined
243 ;; with the <style> tag from older browsers.
244 ((or (looking-at "<!--+") ; begin
245 (looking-at "--+>")) ; end
246 (goto-char (match-end 0)))
237 ;; C++ style comments, and we are doing IE compatibility 247 ;; C++ style comments, and we are doing IE compatibility
238 ((and (looking-at "//") w3-style-ie-compatibility) 248 ((and (looking-at "//") w3-style-ie-compatibility)
239 (end-of-line)) 249 (end-of-line))
240 ;; Pre-Processor directives 250 ;; Pre-Processor directives
241 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)") 251 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
256 (w3-style-css-handle-import)) 266 (w3-style-css-handle-import))
257 (t 267 (t
258 (w3-warn 'style (format "Unknown directive: @%s" directive) 268 (w3-warn 'style (format "Unknown directive: @%s" directive)
259 'warning))))) 269 'warning)))))
260 ;; Giving us some output device information 270 ;; Giving us some output device information
261 ((looking-at "[ \t\r]*:\\([^:]+\\):") 271 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
262 (downcase-region (match-beginning 1) (match-end 1)) 272 (downcase-region (match-beginning 1) (match-end 1))
263 (setq device-type (intern (buffer-substring (match-beginning 1) 273 (setq device-type (intern (buffer-substring (match-beginning 1)
264 (match-end 1)))) 274 (match-end 1))))
265 (goto-char (match-end 0)) 275 (goto-char (match-end 0))
266 (if (not (memq device-type active-device-types)) 276 (if (not (memq device-type active-device-types))
267 ;; Not applicable to us... skip the info 277 ;; Not applicable to us... skip the info
268 (progn 278 (progn
269 (if (re-search-forward ":[^:]*:" nil t) 279 (if (re-search-forward ":[^:{ ]*:" nil t)
270 (goto-char (match-beginning 0)) 280 (goto-char (match-beginning 0))
271 (goto-char (point-max)))))) 281 (goto-char (point-max))))))
272 ;; Default is to treat it like a stylesheet declaration 282 ;; Default is to treat it like a stylesheet declaration
273 (t 283 (t
274 (skip-chars-forward "^{:") 284 (skip-chars-forward "^{")
275 (downcase-region save-pos (point)) 285 ;;(downcase-region save-pos (point))
276 (setq applies-to (w3-style-css-applies-to save-pos (point))) 286 (setq applies-to (w3-style-css-applies-to save-pos (point)))
277 (skip-chars-forward "^{") 287 (skip-chars-forward "^{")
278 (setq save-pos (point)) 288 (setq save-pos (point))
279 (forward-sexp 1) 289 (forward-sexp 1)
280 (end-of-line) 290 (end-of-line)
286 (skip-chars-forward "}\r\n") 296 (skip-chars-forward "}\r\n")
287 (while applies-to 297 (while applies-to
288 (setq cur (car applies-to) 298 (setq cur (car applies-to)
289 applies-to (cdr applies-to)) 299 applies-to (cdr applies-to))
290 (cond 300 (cond
291 ((string-match "\\(.*\\)\\.\\(.*\\)" cur) ; Normal class 301 ((string-match "\\([^.]*\\)\\.\\(.*\\)" cur) ; Normal class
292 (setq tag (intern (downcase (match-string 1 cur))) 302 (setq tag (intern (downcase (match-string 1 cur)))
293 class (match-string 2 cur))) 303 class (match-string 2 cur)))
294 ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class 304 ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class
295 (setq tag (intern (downcase (match-string 1 cur))) 305 (setq tag (intern (downcase (match-string 1 cur)))
296 class (match-string 2 cur))) 306 class (match-string 2 cur)))
377 (setq size (* size scaler) 387 (setq size (* size scaler)
378 index (1- index))) 388 index (1- index)))
379 ;; This rounds to the nearest '10' 389 ;; This rounds to the nearest '10'
380 (format "%dpt" (* 10 (round (/ size 10)))))) 390 (format "%dpt" (* 10 (round (/ size 10))))))
381 391
392 (defsubst w3-style-speech-normalize-number (num)
393 (if num (% (abs (read num)) 9)))
394
395 (defun w3-generate-stylesheet-voices (sheet)
396 (let ((todo sheet)
397 cur cur-classes
398 node family gain
399 left right pitch
400 pitch-range stress
401 richness voice
402 )
403 (while todo
404 (setq cur (car todo)
405 cur-classes (cdr cur)
406 todo (cdr todo))
407 (while cur-classes
408 (setq node (cdr (car cur-classes))
409 cur (car cur-classes)
410 cur-classes (cdr cur-classes)
411 family (cdr-safe (assq 'voice-family node))
412 family (if family (intern (downcase family)))
413 gain (w3-style-speech-normalize-number
414 (cdr-safe (assq 'gain node)))
415 left (w3-style-speech-normalize-number
416 (cdr-safe (assq 'left-volume node)))
417 right (w3-style-speech-normalize-number
418 (cdr-safe (assq 'right-volume node)))
419 pitch (w3-style-speech-normalize-number
420 (cdr-safe (assq 'pitch node)))
421 pitch-range (w3-style-speech-normalize-number
422 (cdr-safe (assq 'pitch-range node)))
423 stress (w3-style-speech-normalize-number
424 (cdr-safe (assq 'stress node)))
425 richness (w3-style-speech-normalize-number
426 (cdr-safe (assq 'richness node))))
427 (if (or family gain left right pitch pitch-range stress richness)
428 (setq voice (dtk-personality-from-speech-style
429 (make-dtk-speech-style :family (or family 'paul)
430 :gain (or gain 5)
431 :left-volume (or left 5)
432 :right-volume (or right 5)
433 :average-pitch (or pitch 5)
434 :pitch-range (or pitch-range 5)
435 :stress (or stress 5)
436 :richness (or richness 5))))
437 (setq voice nil))
438 (if voice (setcdr cur (cons (cons 'voice-spec voice) (cdr cur))))
439 )
440 )
441 )
442 )
443
444 (defun w3-style-post-process-stylesheet (sheet)
445 (w3-generate-stylesheet-faces sheet)
446 (if (featurep 'emacspeak)
447 (w3-generate-stylesheet-voices w3-user-stylesheet)))
448
449 (defun w3-style-css-split-font-shorthand (font)
450 ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
451 (let (weight size height family)
452 (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
453 (error "Malformed font shorthand: %s" font))
454 (setq weight (if (/= 0 (match-beginning 0))
455 (substring font 0 (match-beginning 0)))
456 size (match-string 1 font)
457 font (substring font (match-end 0) nil))
458 (if (string-match " */ *\\([^ ]+\\) *" font)
459 ;; they specified a line-height as well
460 (setq height (match-string 1 font)
461 family (substring font (match-end 0) nil))
462 (setq family (url-strip-leading-spaces font)))
463 (list weight size height family)))
464
382 (defun w3-generate-stylesheet-faces (sheet) 465 (defun w3-generate-stylesheet-faces (sheet)
383 (let ((todo sheet) 466 (let ((todo sheet)
384 (cur nil) 467 (cur nil)
385 (cur-classes nil) 468 (cur-classes nil)
386 (node nil) 469 (node nil)
387 (voice nil)
388 (voice-person nil)
389 (voice-tone nil)
390 (fore nil) 470 (fore nil)
391 (back nil) 471 (back nil)
392 (pixmap nil) 472 (pixmap nil)
393 (font nil) 473 (font nil)
394 (family nil) 474 (family nil)
407 (setq node (cdr (car cur-classes)) 487 (setq node (cdr (car cur-classes))
408 cur (car cur-classes) 488 cur (car cur-classes)
409 cur-classes (cdr cur-classes) 489 cur-classes (cdr cur-classes)
410 fore (cdr-safe (assq 'color node)) 490 fore (cdr-safe (assq 'color node))
411 back (cdr-safe (assq 'background node)) 491 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)) 492 decoration (cdr-safe (assq 'text-decoration node))
415 pixmap (cdr-safe (assq 'backdrop node)) 493 pixmap (cdr-safe (assq 'backdrop node))
416 index (cdr-safe (assq 'font-size-index node)) 494 index (cdr-safe (assq 'font-size-index node))
417 size (or (and index (w3-style-font-size-for-index index)) 495 size (or (and index (w3-style-font-size-for-index index))
418 (cdr-safe (assq 'font-size node))) 496 (cdr-safe (assq 'font-size node)))
422 w3-style-font-weight-mappings)) 500 w3-style-font-weight-mappings))
423 weight) 501 weight)
424 style (cdr-safe (assq 'font-style node)) 502 style (cdr-safe (assq 'font-style node))
425 shorthand (cdr-safe (assq 'font node))) 503 shorthand (cdr-safe (assq 'font node)))
426 504
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 505 ;; Make sure all 'break' items get intern'd
439 (if (or style decoration) 506 (if (or style decoration)
440 (setq style (concat style decoration))) 507 (setq style (concat style decoration)))
441 (setq break-style (assq 'break node)) 508 (setq break-style (assq 'break node))
442 (if (and (cdr break-style) (stringp (cdr break-style))) 509 (if (and (cdr break-style) (stringp (cdr break-style)))
443 (setcdr break-style (intern (cdr break-style)))) 510 (setcdr break-style (intern (cdr break-style))))
444 (if shorthand 511 (if shorthand
445 (let ((shorthand (split-string shorthand "[ \t]"))) 512 (progn
446 (setq size (or (nth 0 shorthand) size) 513 (setq shorthand (w3-style-css-split-font-shorthand shorthand))
447 family (or (nth 1 shorthand) size) 514 (setq weight (or (nth 0 shorthand) weight)
448 weight (or (nth 2 shorthand) weight) 515 size (or (nth 1 shorthand) size)
516 family (or (nth 3 shorthand) family)
449 weight (or (cdr-safe 517 weight (or (cdr-safe
450 (assoc weight 518 (assoc weight
451 w3-style-font-weight-mappings)) 519 w3-style-font-weight-mappings))
452 weight) 520 weight))))
453 style (or (nth 3 shorthand) style))))
454 (if style 521 (if style
455 (setq style (mapcar 522 (setq style (mapcar
456 (function 523 (function
457 (lambda (x) 524 (lambda (x)
458 (while (string-match "-" x) 525 (while (string-match "-" x)
460 (substring x 0 (match-beginning 0)) 527 (substring x 0 (match-beginning 0))
461 (substring x (match-end 0) nil)))) 528 (substring x (match-end 0) nil))))
462 (intern-soft 529 (intern-soft
463 (concat "font-set-" (downcase x) "-p")))) 530 (concat "font-set-" (downcase x) "-p"))))
464 (delete "" (split-string style "[ \t&,]"))))) 531 (delete "" (split-string style "[ \t&,]")))))
465 (if family (setq family (delete "" (split-string family "[ \t]")))) 532 (if family (setq family (delete "" (split-string family ","))))
466 (if (or family weight style size) 533 (if (or family weight style size)
467 (progn 534 (progn
468 (setq font (make-font :family family :weight weight :size size)) 535 (setq font (make-font :family family :weight weight :size size))
469 (while style 536 (while style
470 (and (fboundp (car style)) 537 (and (fboundp (car style))
471 (funcall (car style) font t)) 538 (funcall (car style) font t))
472 (setq style (cdr style)))) 539 (setq style (cdr style))))
473 (setq font nil)) 540 (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)))) 541 (if font (setcdr cur (cons (cons 'font-spec font) (cdr cur))))
476 (if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur)))) 542 (if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur))))
477 (if back (setcdr cur (cons (cons 'background back) (cdr cur)))) 543 (if back (setcdr cur (cons (cons 'background back) (cdr cur))))
478 ) 544 )
479 ) 545 )
505 (setq stylesheet (nth 0 data) 571 (setq stylesheet (nth 0 data)
506 defines (nth 1 data)))) 572 defines (nth 1 data))))
507 (t 573 (t
508 (w3-warn 'html "Unknown stylesheet notation: %s" type)))) 574 (w3-warn 'html "Unknown stylesheet notation: %s" type))))
509 (setq w3-current-stylesheet stylesheet) 575 (setq w3-current-stylesheet stylesheet)
510 (if (and w3-current-stylesheet (fboundp 'make-face)) 576 (w3-style-post-process-stylesheet w3-current-stylesheet)))
511 (w3-generate-stylesheet-faces w3-current-stylesheet))))
512 577
513 (defun w3-display-stylesheet (&optional sheet) 578 (defun w3-display-stylesheet (&optional sheet)
514 (interactive) 579 (interactive)
515 (if (not sheet) (setq sheet w3-current-stylesheet)) 580 (if (not sheet) (setq sheet w3-current-stylesheet))
516 (with-output-to-temp-buffer "W3 Stylesheet" 581 (with-output-to-temp-buffer "W3 Stylesheet"