Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 821dec489c24
children 360340f9fd5f
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/30 00:58:33 3 ;; Created: 1997/02/08 00:56:14
4 ;; Version: 1.29 4 ;; Version: 1.33
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; The emacsen compatibility package - load it up before anything else 30 ;;; The emacsen compatibility package - load it up before anything else
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (require 'cl)
33
32 (eval-and-compile 34 (eval-and-compile
33 (require 'w3-sysdp) 35 (if (not (and (string-match "XEmacs" emacs-version)
34 (require 'cl)) 36 (or (> emacs-major-version 19)
37 (>= emacs-minor-version 14))))
38 (require 'w3-sysdp)))
35 39
36 (require 'disp-table) 40 (require 'disp-table)
37 (if (not (fboundp '<<)) (fset '<< 'lsh)) 41 (if (not (fboundp '<<)) (fset '<< 'lsh))
38 (if (not (fboundp '&)) (fset '& 'logand)) 42 (if (not (fboundp '&)) (fset '& 'logand))
39 (if (not (fboundp '|)) (fset '| 'logior)) 43 (if (not (fboundp '|)) (fset '| 'logior))
293 w2)))) 297 w2))))
294 298
295 (defun font-spatial-to-canonical (spec &optional device) 299 (defun font-spatial-to-canonical (spec &optional device)
296 "Convert SPEC (in inches, millimeters, points, or picas) into points" 300 "Convert SPEC (in inches, millimeters, points, or picas) into points"
297 ;; 1 in = 6 pa = 25.4 mm = 72 pt 301 ;; 1 in = 6 pa = 25.4 mm = 72 pt
298 (if (numberp spec) 302 (cond
299 spec 303 ((numberp spec)
304 spec)
305 ((null spec)
306 nil)
307 (t
300 (let ((num nil) 308 (let ((num nil)
301 (type nil) 309 (type nil)
302 ;; If for any reason we get null for any of this, default 310 ;; If for any reason we get null for any of this, default
303 ;; to 1024x768 resolution on a 17" screen 311 ;; to 1024x768 resolution on a 17" screen
304 (pix-width (float (or (device-pixel-width device) 1024))) 312 (pix-width (float (or (device-pixel-width device) 1024)))
337 ((string= type "cm") 345 ((string= type "cm")
338 (setq retval (* num 10 (/ 72.0 25.4)))) 346 (setq retval (* num 10 (/ 72.0 25.4))))
339 (t 347 (t
340 (setq retval num)) 348 (setq retval num))
341 ) 349 )
342 retval))) 350 retval))))
343 351
344 352
345 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
346 ;;; The main interface routines - constructors and accessor functions 354 ;;; The main interface routines - constructors and accessor functions
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464 pixelsize - pointsize - resx - resy - spacing - avgwidth - 472 pixelsize - pointsize - resx - resy - spacing - avgwidth -
465 registry - encoding "\\'" 473 registry - encoding "\\'"
466 )))) 474 ))))
467 475
468 (defun x-font-create-object (fontname &optional device) 476 (defun x-font-create-object (fontname &optional device)
469 (if (or (not (stringp fontname)) 477 (let ((case-fold-search t))
470 (not (string-match font-x-font-regexp fontname))) 478 (if (or (not (stringp fontname))
471 (make-font) 479 (not (string-match font-x-font-regexp fontname)))
472 (let ((family nil) 480 (make-font)
473 (style nil) 481 (let ((family nil)
474 (size nil) 482 (style nil)
475 (weight (match-string 1 fontname)) 483 (size nil)
476 (slant (match-string 2 fontname)) 484 (weight (match-string 1 fontname))
477 (swidth (match-string 3 fontname)) 485 (slant (match-string 2 fontname))
478 (adstyle (match-string 4 fontname)) 486 (swidth (match-string 3 fontname))
479 (pxsize (match-string 5 fontname)) 487 (adstyle (match-string 4 fontname))
480 (ptsize (match-string 6 fontname)) 488 (pxsize (match-string 5 fontname))
481 (retval nil) 489 (ptsize (match-string 6 fontname))
482 (case-fold-search t) 490 (retval nil)
483 ) 491 (case-fold-search t)
484 (if (not (string-match x-font-regexp-foundry-and-family fontname)) 492 )
485 nil 493 (if (not (string-match x-font-regexp-foundry-and-family fontname))
486 (setq family (list (downcase (match-string 1 fontname))))) 494 nil
487 (if (string= "*" weight) (setq weight nil)) 495 (setq family (list (downcase (match-string 1 fontname)))))
488 (if (string= "*" slant) (setq slant nil)) 496 (if (string= "*" weight) (setq weight nil))
489 (if (string= "*" swidth) (setq swidth nil)) 497 (if (string= "*" slant) (setq slant nil))
490 (if (string= "*" adstyle) (setq adstyle nil)) 498 (if (string= "*" swidth) (setq swidth nil))
491 (if (string= "*" pxsize) (setq pxsize nil)) 499 (if (string= "*" adstyle) (setq adstyle nil))
492 (if (string= "*" ptsize) (setq ptsize nil)) 500 (if (string= "*" pxsize) (setq pxsize nil))
493 (if ptsize (setq size (/ (string-to-int ptsize) 10))) 501 (if (string= "*" ptsize) (setq ptsize nil))
494 (if (and (not size) pxsize) (setq size (concat pxsize "px"))) 502 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
495 (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) 503 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
496 (if (and adstyle (not (equal adstyle ""))) 504 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
497 (setq family (append family (list (downcase adstyle))))) 505 (if (and adstyle (not (equal adstyle "")))
498 (setq retval (make-font :family family 506 (setq family (append family (list (downcase adstyle)))))
499 :weight weight 507 (setq retval (make-font :family family
500 :size size)) 508 :weight weight
501 (set-font-bold-p retval (eq :bold weight)) 509 :size size))
502 (cond 510 (set-font-bold-p retval (eq :bold weight))
503 ((null slant) nil) 511 (cond
504 ((member slant '("i" "I")) 512 ((null slant) nil)
505 (set-font-italic-p retval t)) 513 ((member slant '("i" "I"))
506 ((member slant '("o" "O")) 514 (set-font-italic-p retval t))
507 (set-font-oblique-p retval t))) 515 ((member slant '("o" "O"))
508 retval))) 516 (set-font-oblique-p retval t)))
517 retval))))
509 518
510 (defun x-font-families-for-device (&optional device no-resetp) 519 (defun x-font-families-for-device (&optional device no-resetp)
511 (condition-case () 520 (condition-case ()
512 (require 'x-font-menu) 521 (require 'x-font-menu)
513 (error nil)) 522 (error nil))
563 (if (and (not (or (font-family fontobj) 572 (if (and (not (or (font-family fontobj)
564 (font-weight fontobj) 573 (font-weight fontobj)
565 (font-size fontobj) 574 (font-size fontobj)
566 (font-registry fontobj) 575 (font-registry fontobj)
567 (font-encoding fontobj))) 576 (font-encoding fontobj)))
568 (not (font-bold-p fontobj)) 577 (= (font-style fontobj) 0))
569 (not (font-italic-p fontobj))
570 (not (font-oblique-p fontobj)))
571 (face-font 'default) 578 (face-font 'default)
572 (or device (setq device (selected-device))) 579 (or device (setq device (selected-device)))
573 (let ((family (or (font-family fontobj) 580 (let ((family (or (font-family fontobj)
574 (font-default-family-for-device device) 581 (font-default-family-for-device device)
575 (x-font-families-for-device device))) 582 (x-font-families-for-device device)))