Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 0293115a14e9
children ec9a17fef872
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
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.
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 (eval-and-compile 32 (eval-and-compile
33 (require 'w3-sysdp) 33 (unless (string-match "XEmacs" emacs-version)
34 (require 'w3-sysdp))
34 (require 'cl)) 35 (require 'cl))
35 36
36 (require 'disp-table) 37 (require 'disp-table)
37 (if (not (fboundp '<<)) (fset '<< 'lsh)) 38 (if (not (fboundp '<<)) (fset '<< 'lsh))
38 (if (not (fboundp '&)) (fset '& 'logand)) 39 (if (not (fboundp '&)) (fset '& 'logand))
293 w2)))) 294 w2))))
294 295
295 (defun font-spatial-to-canonical (spec &optional device) 296 (defun font-spatial-to-canonical (spec &optional device)
296 "Convert SPEC (in inches, millimeters, points, or picas) into points" 297 "Convert SPEC (in inches, millimeters, points, or picas) into points"
297 ;; 1 in = 6 pa = 25.4 mm = 72 pt 298 ;; 1 in = 6 pa = 25.4 mm = 72 pt
298 (if (numberp spec) 299 (cond
299 spec 300 ((numberp spec)
301 spec)
302 ((null spec)
303 nil)
304 (t
300 (let ((num nil) 305 (let ((num nil)
301 (type nil) 306 (type nil)
302 ;; If for any reason we get null for any of this, default 307 ;; If for any reason we get null for any of this, default
303 ;; to 1024x768 resolution on a 17" screen 308 ;; to 1024x768 resolution on a 17" screen
304 (pix-width (float (or (device-pixel-width device) 1024))) 309 (pix-width (float (or (device-pixel-width device) 1024)))
337 ((string= type "cm") 342 ((string= type "cm")
338 (setq retval (* num 10 (/ 72.0 25.4)))) 343 (setq retval (* num 10 (/ 72.0 25.4))))
339 (t 344 (t
340 (setq retval num)) 345 (setq retval num))
341 ) 346 )
342 retval))) 347 retval))))
343 348
344 349
345 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
346 ;;; The main interface routines - constructors and accessor functions 351 ;;; The main interface routines - constructors and accessor functions
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464 pixelsize - pointsize - resx - resy - spacing - avgwidth - 469 pixelsize - pointsize - resx - resy - spacing - avgwidth -
465 registry - encoding "\\'" 470 registry - encoding "\\'"
466 )))) 471 ))))
467 472
468 (defun x-font-create-object (fontname &optional device) 473 (defun x-font-create-object (fontname &optional device)
469 (if (or (not (stringp fontname)) 474 (let ((case-fold-search t))
470 (not (string-match font-x-font-regexp fontname))) 475 (if (or (not (stringp fontname))
471 (make-font) 476 (not (string-match font-x-font-regexp fontname)))
472 (let ((family nil) 477 (make-font)
473 (style nil) 478 (let ((family nil)
474 (size nil) 479 (style nil)
475 (weight (match-string 1 fontname)) 480 (size nil)
476 (slant (match-string 2 fontname)) 481 (weight (match-string 1 fontname))
477 (swidth (match-string 3 fontname)) 482 (slant (match-string 2 fontname))
478 (adstyle (match-string 4 fontname)) 483 (swidth (match-string 3 fontname))
479 (pxsize (match-string 5 fontname)) 484 (adstyle (match-string 4 fontname))
480 (ptsize (match-string 6 fontname)) 485 (pxsize (match-string 5 fontname))
481 (retval nil) 486 (ptsize (match-string 6 fontname))
482 (case-fold-search t) 487 (retval nil)
483 ) 488 (case-fold-search t)
484 (if (not (string-match x-font-regexp-foundry-and-family fontname)) 489 )
485 nil 490 (if (not (string-match x-font-regexp-foundry-and-family fontname))
486 (setq family (list (downcase (match-string 1 fontname))))) 491 nil
487 (if (string= "*" weight) (setq weight nil)) 492 (setq family (list (downcase (match-string 1 fontname)))))
488 (if (string= "*" slant) (setq slant nil)) 493 (if (string= "*" weight) (setq weight nil))
489 (if (string= "*" swidth) (setq swidth nil)) 494 (if (string= "*" slant) (setq slant nil))
490 (if (string= "*" adstyle) (setq adstyle nil)) 495 (if (string= "*" swidth) (setq swidth nil))
491 (if (string= "*" pxsize) (setq pxsize nil)) 496 (if (string= "*" adstyle) (setq adstyle nil))
492 (if (string= "*" ptsize) (setq ptsize nil)) 497 (if (string= "*" pxsize) (setq pxsize nil))
493 (if ptsize (setq size (/ (string-to-int ptsize) 10))) 498 (if (string= "*" ptsize) (setq ptsize nil))
494 (if (and (not size) pxsize) (setq size (concat pxsize "px"))) 499 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
495 (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) 500 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
496 (if (and adstyle (not (equal adstyle ""))) 501 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
497 (setq family (append family (list (downcase adstyle))))) 502 (if (and adstyle (not (equal adstyle "")))
498 (setq retval (make-font :family family 503 (setq family (append family (list (downcase adstyle)))))
499 :weight weight 504 (setq retval (make-font :family family
500 :size size)) 505 :weight weight
501 (set-font-bold-p retval (eq :bold weight)) 506 :size size))
502 (cond 507 (set-font-bold-p retval (eq :bold weight))
503 ((null slant) nil) 508 (cond
504 ((member slant '("i" "I")) 509 ((null slant) nil)
505 (set-font-italic-p retval t)) 510 ((member slant '("i" "I"))
506 ((member slant '("o" "O")) 511 (set-font-italic-p retval t))
507 (set-font-oblique-p retval t))) 512 ((member slant '("o" "O"))
508 retval))) 513 (set-font-oblique-p retval t)))
514 retval))))
509 515
510 (defun x-font-families-for-device (&optional device no-resetp) 516 (defun x-font-families-for-device (&optional device no-resetp)
511 (condition-case () 517 (condition-case ()
512 (require 'x-font-menu) 518 (require 'x-font-menu)
513 (error nil)) 519 (error nil))
563 (if (and (not (or (font-family fontobj) 569 (if (and (not (or (font-family fontobj)
564 (font-weight fontobj) 570 (font-weight fontobj)
565 (font-size fontobj) 571 (font-size fontobj)
566 (font-registry fontobj) 572 (font-registry fontobj)
567 (font-encoding fontobj))) 573 (font-encoding fontobj)))
568 (not (font-bold-p fontobj)) 574 (= (font-style fontobj) 0))
569 (not (font-italic-p fontobj))
570 (not (font-oblique-p fontobj)))
571 (face-font 'default) 575 (face-font 'default)
572 (or device (setq device (selected-device))) 576 (or device (setq device (selected-device)))
573 (let ((family (or (font-family fontobj) 577 (let ((family (or (font-family fontobj)
574 (font-default-family-for-device device) 578 (font-default-family-for-device device)
575 (x-font-families-for-device device))) 579 (x-font-families-for-device device)))