Mercurial > hg > xemacs-beta

comparison lisp/font-menu.el @ 444:576fb035e263 r21-2-37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-37
author cvs
date Mon, 13 Aug 2007 11:36:19 +0200
parents abe6d1db359e
children 1ccc32a20af4
comparison
equal deleted inserted replaced
443:a8296e22da4e 444:576fb035e263
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; General Public License for more details.
20 20
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the 22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
25 25
26 ;; This file contains the device-nospecific font menu stuff 26 ;; This file contains the device-nospecific font menu stuff
27 27
156 the last entry in the menu." 156 the last entry in the menu."
157 :group 'font-menu 157 :group 'font-menu
158 :type '(choice (string :tag "Format string") 158 :type '(choice (string :tag "Format string")
159 (function))) 159 (function)))
160 160
161 (defvar font-menu-preferred-resolution 161 (defvar font-menu-preferred-resolution
162 (make-specifier-and-init 'generic '((global ((mswindows) . ":") 162 (make-specifier-and-init 'generic '((global ((mswindows) . ":")
163 ((x) . "*-*"))) t) 163 ((x) . "*-*"))) t)
164 "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").") 164 "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").")
165 165
166 (defvar font-menu-size-scaling 166 (defvar font-menu-size-scaling
185 (defun reset-device-font-menus (&optional device debug) 185 (defun reset-device-font-menus (&optional device debug)
186 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. 186 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
187 This is run the first time that a font-menu is needed for each device. 187 This is run the first time that a font-menu is needed for each device.
188 If you don't like the lazy invocation of this function, you can add it to 188 If you don't like the lazy invocation of this function, you can add it to
189 `create-device-hook' and that will make the font menus respond more quickly 189 `create-device-hook' and that will make the font menus respond more quickly
190 when they are selected for the first time. If you add fonts to your system, 190 when they are selected for the first time. If you add fonts to your system,
191 or if you change your font path, you can call this to re-initialize the menus." 191 or if you change your font path, you can call this to re-initialize the menus."
192 (message "Getting list of fonts from server... ") 192 (message "Getting list of fonts from server... ")
193 (if (or noninteractive 193 (if (or noninteractive
194 (not (or device (setq device (selected-device))))) 194 (not (or device (setq device (selected-device)))))
195 nil 195 nil
354 (unless from-family 354 (unless from-family
355 (signal 'error '("couldn't parse font name for default face"))) 355 (signal 'error '("couldn't parse font name for default face")))
356 (when weight 356 (when weight
357 (signal 'error '("Setting weight currently not supported"))) 357 (signal 'error '("Setting weight currently not supported")))
358 (setq new-default-face-font 358 (setq new-default-face-font
359 (font-menu-load-font 359 (font-menu-load-font
360 (or family from-family) 360 (or family from-family)
361 (or weight from-weight) 361 (or weight from-weight)
362 (or size from-size) 362 (or size from-size)
363 from-slant 363 from-slant
364 (specifier-instance 364 (specifier-instance
396 :size (concat 396 :size (concat
397 (int-to-string 397 (int-to-string
398 (/ (or size from-size) 398 (/ (or size from-size)
399 (specifier-instance font-menu-size-scaling 399 (specifier-instance font-menu-size-scaling
400 (selected-device)))) 400 (selected-device))))
401 "pt"))) 401 "pt")))
402 (message "Font %s" (face-font-name 'default))))) 402 (message "Font %s" (face-font-name 'default)))))
403 403
404 404
405 (defun font-menu-change-face (face 405 (defun font-menu-change-face (face
406 from-family from-weight from-size 406 from-family from-weight from-size
407 to-family to-weight to-size) 407 to-family to-weight to-size)
408 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) 408 (or (symbolp face) (setq face (wrong-type-argument 'symbolp face)))
409 (let* ((dcache (device-fonts-cache)) 409 (let* ((dcache (device-fonts-cache))
410 (font-data (font-menu-font-data face dcache)) 410 (font-data (font-menu-font-data face dcache))
411 (face-family (aref font-data 1)) 411 (face-family (aref font-data 1))
412 (face-size (aref font-data 2)) 412 (face-size (aref font-data 2))
413 (face-weight (aref font-data 3)) 413 (face-weight (aref font-data 3))
420 ;; are changing, then change it to the new attribute along that 420 ;; are changing, then change it to the new attribute along that
421 ;; dimension. Also, the face must have its own global attribute. 421 ;; dimension. Also, the face must have its own global attribute.
422 ;; If its value is inherited, we don't touch it. If any of this 422 ;; If its value is inherited, we don't touch it. If any of this
423 ;; is not true, we leave it alone. 423 ;; is not true, we leave it alone.
424 (when (and (face-font face 'global) 424 (when (and (face-font face 'global)
425 (cond 425 (cond
426 (to-family (string-equal face-family from-family)) 426 (to-family (string-equal face-family from-family))
427 (to-weight (string-equal face-weight from-weight)) 427 (to-weight (string-equal face-weight from-weight))
428 (to-size (= face-size from-size)))) 428 (to-size (= face-size from-size))))
429 (set-face-font face 429 (set-face-font face
430 (font-menu-load-font (or to-family face-family) 430 (font-menu-load-font (or to-family face-family)
431 (or to-weight face-weight) 431 (or to-weight face-weight)
432 (or to-size face-size) 432 (or to-size face-size)
433 face-slant 433 face-slant
434 (specifier-instance 434 (specifier-instance
435 font-menu-preferred-resolution 435 font-menu-preferred-resolution
436 (selected-device))) 436 (selected-device)))
437 (and font-menu-this-frame-only-p 437 (and font-menu-this-frame-only-p
438 (selected-frame)))))) 438 (selected-frame))))))
439 439
440 (define-device-method font-menu-load-font) 440 (define-device-method font-menu-load-font)