home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / tek-highlight-2.0 / tek-style-utils.el < prev    next >
Encoding:
Text File  |  1992-08-20  |  21.3 KB  |  604 lines
  1. ;;*****************************************************************************
  2. ;;
  3. ;; Filename:    tek-style-utils.el
  4. ;;
  5. ;; Copyright (C) 1992  Rod Whitby
  6. ;;
  7. ;; This program is free software;; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation;; either version 1, or (at your option)
  10. ;; any later version.
  11. ;;
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY;; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16. ;;
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with this program;; if not, write to the Free Software
  19. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. ;;
  21. ;; Modified by:        Rod Whitby, <rwhitby@research.canon.oz.au>
  22. ;; Author:        Ken Wood, <kwood@austek.oz.au>
  23. ;;
  24. ;; Description:    Set up some default fonts for highlighting etc, and
  25. ;;        define a function for building styles from default
  26. ;;        option values and X11 resource defaults.
  27. ;;
  28. ;; IMPORTANT:    Check that the variable tek-highlight-use-attributes is
  29. ;;        set correctly (see below) before attempting to use this
  30. ;;        package.
  31. ;;
  32. ;; When loaded, this package attempts to define 3 non-proportional fonts
  33. ;; which match the default minibuffer font in with and height: a non-bold
  34. ;; italic font, a bold italic font and a bold upright font.
  35. ;; 
  36. ;; A function for defining and modifying attribute styles based on X
  37. ;; resources is also provided for use by the other packages. You may
  38. ;; modify the these styles by setting X11 resources (usually in your
  39. ;; .Xdefaults file). Up to 9 options may be specified for each style.
  40. ;; Sensible defaults are used for any options that you do not specify.
  41. ;; The options are represented by the following X11 resources:
  42. ;; 
  43. ;;     Emacs.STYLE-NAME.style-font: Font.
  44. ;; 
  45. ;;     Emacs.STYLE-NAME.style-foreground: Foreground color.
  46. ;; 
  47. ;;     Emacs.STYLE-NAME.style-background: Background color.
  48. ;; 
  49. ;;     Emacs.STYLE-NAME.style-cursor-foreground: Cursor foreground color.
  50. ;; 
  51. ;;     Emacs.STYLE-NAME.style-cursor-background: Cursor background color.
  52. ;; 
  53. ;;     Emacs.STYLE-NAME.style-underline: Underline color.
  54. ;; 
  55. ;;     Emacs.STYLE-NAME.style-stipple: Stipple pattern.
  56. ;; 
  57. ;;     Emacs.STYLE-NAME.style-cursor-stipple: Stipple pattern.
  58. ;; 
  59. ;;     Emacs.STYLE-NAME.style-background-stipple: Stipple pattern.
  60. ;; 
  61. ;;     Emacs.STYLE-NAME.style-pixmap: Pixmap for graphic zones.
  62. ;; 
  63. ;; The values of STYLE-NAME currently used are:
  64. ;; 
  65. ;;     motion: Mouse drag regions.
  66. ;; 
  67. ;;     src-comment: Comments in source code.
  68. ;; 
  69. ;;     info: Info browser buttons.
  70. ;; 
  71. ;;     VM-from: From: lines in VM.
  72. ;; 
  73. ;;     VM-subject: Subject: lines in VM.
  74. ;; 
  75. ;;     gnus-from: From: lines in GNUS.
  76. ;; 
  77. ;;     gnus-subject: Subject: lines in GNUS.
  78. ;; 
  79. ;;     mh-e-from: From: lines in mh-e.
  80. ;; 
  81. ;;     mh-e-subject: Subject: lines in mh-e.
  82. ;; 
  83. ;;     manual-seealso: "See Also" sections in man pages.
  84. ;; 
  85. ;;     manual-usersupplied: User supplied options in man pages.
  86. ;; 
  87. ;;     manual-heading: Fixed options in man pages. These may be shown
  88. ;;     in the default font depending on your implementation of the
  89. ;;     "man" program.
  90. ;; 
  91. ;; The above X11 resources must be loaded before you start up epoch, in
  92. ;; order for them to take effect.
  93. ;;
  94. ;; Note: the stipple options have not been tested and I don't really understand
  95. ;; stipple patterns, so there may be some problems here.
  96. ;; 
  97. ;;*****************************************************************************
  98.  
  99. ;; $Id: tek-style-utils.el,v 1.9 1992/08/18 04:14:26 rwhitby Rel $
  100.  
  101. (provide 'tek-style-utils)
  102.  
  103. (defvar tek-highlight-use-attributes
  104.   (string-match "^Epoch 3" epoch::version)
  105.   "\
  106. If non-nil, then do highlighting as for Epoch version 3 - using
  107. attributes with the style attached to the attribute. Otherwise do it
  108. as for Epoch version 4 - using the style directly.")
  109.  
  110. ;; Select appropriate functions for adding and clearing buttons/zones
  111. (if tek-highlight-use-attributes
  112.     (progn
  113.       (fset 'add-zone 'add-button)
  114.       (fset 'clear-zones 'clear-buttons)))
  115.  
  116. (defvar tek-default-font nil
  117.   "\
  118. Default font used in the minibuffer. This font is the basis for a
  119. number of special fonts used for highlighting in various places.")
  120.  
  121. (defvar tek-italic-fixed-font nil
  122.   "\
  123. A non-bold italic or oblique fixed-width font, as similar as possible
  124. to the default minibuffer font, or nil if there are no such fonts.")
  125.  
  126. (defvar tek-italic-bold-fixed-font nil
  127.   "\
  128. A bold italic or oblique fixed-width font, as similar as possible to
  129. the default minibuffer font, or nil if there is no such font.")
  130.  
  131. (defvar tek-bold-fixed-font nil
  132.   "\
  133. A bold roman (upright) fixed-width font, as similar as possible to the
  134. default minibuffer font, or nil if there is no such font.")
  135.  
  136. (defvar tek-stipple '(32 2 "\125\125\125\125\252\252\252\252")
  137.   "\
  138. A default stipple pattern, designed to \"grey-out\" areas.")
  139.  
  140. ;;
  141. ;; Now, search for & load some commonly needed fonts.
  142. ;;
  143. (let (
  144.       ;; Variables to hold default font information
  145.       default-font-info
  146.       default-font-name
  147.       default-font-height
  148.       default-font-width
  149.       ;; String specifying the required font width.
  150.       font-width
  151.       ;;
  152.       ;; Variables to hold the possible values of style attributes to try
  153.       ;;
  154.       height-try-list
  155.       ;; List of font weights to try for bold fonts.
  156.       (bold-weight-try-list (list "-bold" "-demibold"))
  157.       ;; List of slant options to try for italic fonts.
  158.       (slant-try-list (list "-i" "-o"))
  159.       ;; List of spacing options to try.
  160.       (spacing-try-list (list "-m" "-c"))
  161.       )
  162.   ;; Get details of current default font for the minibuffer
  163.   (setq default-font-info (font nil (minibuf-screen)))
  164.   (setq default-font-name (car default-font-info))
  165.   (setq default-font-width (cadr default-font-info))
  166.   (setq default-font-height (cadr (cdr default-font-info)))
  167.   ;; Convert the font-width to a string, since it will be used
  168.   ;; directly. Width must be multiplied by 10 first.
  169.   (setq font-width
  170.     (concat "-" (int-to-string (* default-font-width 10))))
  171.   ;; Generate a list of font height strings to try for fixed-width fonts
  172.   ;; from the default font height.
  173.   (setq height-try-list
  174.     (list (concat "-" (int-to-string default-font-height))
  175.           (concat "-" (int-to-string (1+ default-font-height)))
  176.           (concat "-" (int-to-string (1- default-font-height)))))
  177.   ;;
  178.   ;; First of all, record the default font.
  179.   (setq tek-default-font default-font-name)
  180.   ;;
  181.   ;;
  182.   ;; Now, try to find an italic font similar to the minibuffer font.
  183.   ;; From most preferred to least preferred, we'd like the
  184.   ;; following options:
  185.   ;;    1) monospaced (m), then character spacing (c).
  186.   ;;     2) italic (i), then oblique (o).
  187.   ;;    3) same height, then 1 pixel taller, then 1 pixel shorter.
  188.   (if (not tek-italic-fixed-font)
  189.       (setq tek-italic-fixed-font
  190.         (let (
  191.           ;; Variable to hold the font name currently being tried
  192.           font-try-name
  193.           ;; Font finally selected, nil if none
  194.           (font-try-val nil)
  195.           ;; Loop variables
  196.           (current-height-list height-try-list)
  197.           current-slant-list
  198.           current-spacing-list
  199.           )
  200.           ;; Loop through the height options
  201.           (while (and (not font-try-val) current-height-list)
  202.         ;; Set up the list of slant options
  203.         (setq current-slant-list slant-try-list)
  204.         ;; Loop through the slant options
  205.         (while (and (not font-try-val) current-slant-list)
  206.           ;; Set up the list of spacing options
  207.           (setq current-spacing-list spacing-try-list)
  208.           ;; Loop through the spacing options
  209.           (while (and (not font-try-val) current-spacing-list)
  210.             (setq font-try-name
  211.               (concat "-*-*-medium"
  212.                   (car current-slant-list)
  213.                   "-*-*"
  214.                   (car current-height-list)
  215.                   "-*-*-*"
  216.                   (car current-spacing-list)
  217.                   font-width
  218.                   "-*-*"))
  219.             (setq font-try-val (get-font font-try-name))
  220.             ;; Remove the first element from the spacing list
  221.             (setq current-spacing-list (cdr current-spacing-list))
  222.             ) ;; end spacing loop
  223.           ;; Remove the first element from the slant list
  224.           (setq current-slant-list (cdr current-slant-list))
  225.           ) ;; end slant loop
  226.         ;; Remove the first element from the height list
  227.         (setq current-height-list (cdr current-height-list))
  228.         ) ;; end height try list
  229.           ;; Check to see if we found a suitable font and return it or nil.
  230.           (if font-try-val
  231.           font-try-name
  232.         nil))))
  233.   ;;
  234.   ;; Now, try to find a bold italic font similar to the minibuffer font.
  235.   ;; From most preferred to least preferred, we'd like the following
  236.   ;; options:
  237.   ;;    1) monospaced (m), then character spacing (c).
  238.   ;;    2) italic (i), then oblique (o).
  239.   ;;    3) bold, then demibold.
  240.   ;;    4) same height, then 1 pixel taller, then 1 pixel shorter.
  241.   (if (not tek-italic-bold-fixed-font)
  242.       (setq tek-italic-bold-fixed-font
  243.         (let (
  244.           ;; Variable to hold the font name currently being tried
  245.           font-try-name
  246.           ;; Font finally selected, nil if none
  247.           (font-try-val nil)
  248.           ;; Loop variables
  249.           (current-height-list height-try-list)
  250.           current-weight-list
  251.           current-slant-list
  252.           current-spacing-list
  253.           )
  254.           ;; Loop through the height options
  255.           (while (and (not font-try-val) current-height-list)
  256.         ;; Set up the list of weight options
  257.         (setq current-weight-list bold-weight-try-list)
  258.         ;; Loop through the weight options
  259.         (while (and (not font-try-val) current-weight-list)
  260.           ;; Set up the list of slant options
  261.           (setq current-slant-list slant-try-list)
  262.           ;; Loop through the slant options
  263.           (while (and (not font-try-val) current-slant-list)
  264.             ;; Set up the list of spacing options
  265.             (setq current-spacing-list spacing-try-list)
  266.             ;; Loop through the spacing options
  267.             (while (and (not font-try-val) current-spacing-list)
  268.               (setq font-try-name
  269.                 (concat "-*-*"
  270.                     (car current-weight-list)
  271.                     (car current-slant-list)
  272.                     "-*-*"
  273.                     (car current-height-list)
  274.                     "-*-*-*"
  275.                     (car current-spacing-list)
  276.                     font-width
  277.                     "-*-*"))
  278.               (setq font-try-val (get-font font-try-name))
  279.               ;; Remove the first element from the spacing list
  280.               (setq current-spacing-list (cdr current-spacing-list))
  281.               ) ;; end spacing loop
  282.             (setq font-try-val (get-font font-try-name))
  283.             ;; Remove the first element from the slant list
  284.             (setq current-slant-list (cdr current-slant-list))
  285.             ) ;; end slant loop
  286.           ;; Remove the first element from the weight list
  287.           (setq current-weight-list (cdr current-weight-list))
  288.           ) ;; end weight loop
  289.         ;; Remove the first element from the height list
  290.         (setq current-height-list (cdr current-height-list))
  291.         ) ;; end height try list
  292.           ;; Check to see if we found a suitable font and return it or nil.
  293.           (if font-try-val
  294.           font-try-name
  295.         nil))))
  296.   ;; Now, try to find a bold fixed font similar to the minibuffer font.
  297.   ;; From most preferred to least preferred, we'd like the following
  298.   ;; options:
  299.   ;;    1) monospaced (m), then character spacing (c).
  300.   ;;    2) bold, then demibold.
  301.   ;;    3) same height, then 1 pixel taller, then 1 pixel shorter.
  302.   (if (not tek-bold-fixed-font)
  303.       (setq tek-bold-fixed-font
  304.         (let (
  305.           ;; Variable to hold the font name currently being tried
  306.           font-try-name
  307.           ;; Font finally selected, nil if none
  308.           (font-try-val nil)
  309.           ;; Loop variables
  310.           (current-height-list height-try-list)
  311.           current-weight-list
  312.           current-spacing-list
  313.           )
  314.           ;; First of all, just try appending "bold" to the current font
  315.           ;; name. This will work with some aliases, such as "6x13".
  316.           (setq font-try-name (concat default-font-name "bold"))
  317.           (setq font-try-val (get-font font-try-name))
  318.           ;; If the above fails, loop through the normal options as usual.
  319.           ;; Loop through the height options
  320.           (while (and (not font-try-val) current-height-list)
  321.         ;; Set up the list of weight options
  322.         (setq current-weight-list bold-weight-try-list)
  323.         ;; Loop through the weight options
  324.         (while (and (not font-try-val) current-weight-list)
  325.           ;; Set up the list of spacing options
  326.           (setq current-spacing-list spacing-try-list)
  327.           ;; Loop through the spacing options
  328.           (while (and (not font-try-val) current-spacing-list)
  329.             (setq font-try-name
  330.               (concat "-*-*"
  331.                   (car current-weight-list)
  332.                   "-r-*-*"
  333.                   (car current-height-list)
  334.                   "-*-*-*"
  335.                   (car current-spacing-list)
  336.                   font-width
  337.                   "-*-*"))
  338.             (setq font-try-val (get-font font-try-name))
  339.             ;; Remove the first element from the spacing list
  340.             (setq current-spacing-list (cdr current-spacing-list))
  341.             ) ;; end spacing loop
  342.           ;; Remove the first element from the weight list
  343.           (setq current-weight-list (cdr current-weight-list))
  344.           ) ;; end weight loop
  345.         ;; Remove the first element from the height list
  346.         (setq current-height-list (cdr current-height-list))
  347.         ) ;; end height try list
  348.           ;; Check to see if we found a suitable font and return it or nil.
  349.           (if font-try-val
  350.           font-try-name
  351.         nil))))
  352.   )
  353.  
  354.  
  355. ;; Define the prefix to be use when looking for X resources
  356. (defvar tek-resource-prefix "Emacs"
  357.   "\
  358. String to be prepended to resource names prior to looking up their
  359. value.")
  360.  
  361. (defun tek-get-color (color)
  362.   ;; Return X-Cardinal for COLOR, which should be an X-Cardinal or
  363.   ;; string, including the special case "foreground" or "background"
  364.   ;; for the current value of (foreground) and (background).
  365.   ;; We could check what type of resource, but don't bother since this
  366.   ;; error will be caught when we try and use the alleged color.
  367.   (cond ((resourcep color)
  368.      color)
  369.     ((and (stringp color)
  370.           (equal "foreground" (downcase color)))
  371.      (foreground))
  372.     ((and (stringp color)
  373.           (equal "background" (downcase color)))
  374.      (background))
  375.     ((stringp color)
  376.      (get-color color))
  377.     (t
  378.      nil)))
  379.  
  380. (defun tek-get-font (font &optional offset)
  381.   ;; Return X-Font for FONT, which should be an X-Font, or a string containing
  382.   ;; an opaque font specification or a string containing a font name.
  383.   (cond ((resourcep font)
  384.      font)
  385.     ((and (stringp font)
  386.           (string-match "^opaque-\\([0-9]+\\)x\\([0-9]+\\)\\+\\([0-9]+\\)"
  387.                 font))
  388.       (epoch::define-opaque-font
  389.       font
  390.       (string-to-int (substring font (match-beginning 2) (match-end 2)))
  391.       (string-to-int (substring font (match-beginning 1) (match-end 1)))
  392.       (string-to-int (substring font (match-beginning 3) (match-end 3)))
  393.       ))
  394.     ((stringp font)
  395.      (get-font font))
  396.     (t
  397.      nil)))
  398.  
  399. (defun tek-get-bitmap (bitmap)
  400.   ;; Return X-Bitmap for BITMAP, which should be an X-Bitmap, or a string
  401.   ;; containing the path of a bitmap file, or list
  402.   ;; (WIDTH HEIGHT STRING).
  403.   (cond ((resourcep bitmap)
  404.      bitmap)
  405.     ((stringp bitmap)
  406.      ;; (epoch::read-bitmap-file pixmap)
  407.      nil)
  408.     ((listp bitmap)
  409.      (apply 'make-bitmap bitmap))
  410.     (t
  411.      nil)))
  412.  
  413. (defun tek-get-pixmap (pixmap)
  414.   ;; Return X-Pixmap for PIXMAP, which should be an X-Pixmap, or a string
  415.   ;; containing the path of a pixmap file, or a list
  416.   ;; (.. to be defined ..).
  417.   (cond ((resourcep pixmap)
  418.      pixmap)
  419.     ((stringp pixmap)
  420.      (epoch::read-pixmap-file pixmap))
  421.     ((listp pixmap)
  422.      ;; (apply 'make-pixmap pixmap)
  423.      nil)
  424.     (t
  425.      nil)))
  426.  
  427. ;; Define a function to initialise a style
  428. (defun tek-build-style (style-name
  429.             &optional package-style
  430.             &optional default-style-font
  431.             &optional default-style-foreground
  432.             &optional default-style-background
  433.             &optional default-style-cursor-foreground
  434.             &optional default-style-cursor-background
  435.             &optional default-style-underline
  436.             &optional default-style-stipple
  437.             &optional default-style-cursor-stipple
  438.             &optional default-style-background-stipple
  439.             &optional default-style-pixmap)
  440.   "\
  441. Return a style object, with values set as specified by the X11
  442. resources for STYLE-NAME, a string. If optional PACKAGE-STYLE is not
  443. given or nil, then create a new style.
  444.  
  445. There are 9 style fields which may be specified for the package: font,
  446. foreground, background, cursor-foreground, cursor-background,
  447. underline, stipple, cursor-stipple and background-stipple. The value
  448. of `tek-resource-prefix' is prepended to the package name,
  449. before looking up the value of the resource. Thus, the possible
  450. resources that may be specified are:
  451.  
  452. RESOURCE.STYLE-NAME.style-font
  453. RESOURCE.STYLE-NAME.style-foreground
  454. RESOURCE.STYLE-NAME.style-background
  455. RESOURCE.STYLE-NAME.style-cursor-foreground
  456. RESOURCE.STYLE-NAME.style-cursor-background
  457. RESOURCE.STYLE-NAME.style-underline
  458. RESOURCE.STYLE-NAME.style-stipple
  459. RESOURCE.STYLE-NAME.style-cursor-stipple
  460. RESOURCE.STYLE-NAME.style-background-stipple
  461. RESOURCE.STYLE-NAME.style-pixmap
  462.  
  463. See make-style and the style-* and set-style-* functions for details
  464. of style options.
  465.  
  466. This function also takes 9 optional arguments: FONT, FOREGROUND,
  467. BACKGROUND, CURSOR-FOREGROUND, CURSOR-BACKGROUND, UNDERLINE, STIPPLE,
  468. CURSOR-STIPPLE and BACKGROUND-STIPPLE. These are the default values to
  469. use no X11 resources for the package are defined. If any X11 resources
  470. are not defined, the default value will be used to specify that style
  471. option.
  472.  
  473. If any style option is not specified by either X11 resource and the
  474. corresponding default value is not specified or is nil, then that
  475. style field will not be set."
  476.   (let (
  477.     ;; Use a local variable for the package style.
  478.     (new-package-style package-style)
  479.     ;; Names of the specified X11 resources.
  480.     (font-resource-name
  481.      (concat tek-resource-prefix "."
  482.          style-name ".style-font"))
  483.     (foreground-resource-name
  484.      (concat tek-resource-prefix "."
  485.          style-name ".style-foreground"))
  486.     (background-resource-name
  487.      (concat tek-resource-prefix "."
  488.          style-name ".style-background"))
  489.     (cursor-foreground-resource-name
  490.      (concat tek-resource-prefix "."
  491.          style-name ".style-cursor-foreground"))
  492.     (cursor-background-resource-name
  493.      (concat tek-resource-prefix "."
  494.          style-name ".style-cursor-background"))
  495.     (underline-resource-name
  496.      (concat tek-resource-prefix "."
  497.          style-name ".style-underline"))
  498.     (stipple-resource-name
  499.      (concat tek-resource-prefix "."
  500.          style-name ".style-stipple"))
  501.     (cursor-stipple-resource-name
  502.      (concat tek-resource-prefix "."
  503.          style-name ".style-cursor-stipple"))
  504.     (background-stipple-resource-name
  505.      (concat tek-resource-prefix "."
  506.          style-name ".style-backgound-stipple"))
  507.     (pixmap-resource-name
  508.      (concat tek-resource-prefix "."
  509.          style-name ".style-pixmap"))
  510.     ;; Calculated style field values.
  511.     (package-font nil)
  512.     (package-foreground nil)
  513.     (package-background nil)
  514.     (package-cursor-foreground nil)
  515.     (package-cursor-background nil)
  516.     (package-underline nil)
  517.     (package-stipple nil)
  518.     (package-cursor-stipple nil)
  519.     (package-background-stipple nil)
  520.     (package-pixmap nil)
  521.     )
  522.     ;; Attempt to find the required settings in the X11 resources.
  523.     (setq package-font
  524.       (get-default font-resource-name))
  525.     (setq package-foreground
  526.       (get-default foreground-resource-name))
  527.     (setq package-background
  528.       (get-default background-resource-name))
  529.     (setq package-cursor-foreground
  530.       (get-default cursor-foreground-resource-name))
  531.     (setq package-cursor-background
  532.       (get-default cursor-background-resource-name))
  533.     (setq package-underline
  534.       (get-default underline-resource-name))
  535.     (setq package-stipple
  536.       (get-default stipple-resource-name))
  537.     (setq package-cursor-stipple
  538.       (get-default cursor-stipple-resource-name))
  539.     (setq package-background-stipple
  540.       (get-default background-stipple-resource-name))
  541.     (setq package-pixmap
  542.       (get-default pixmap-resource-name))
  543.     ;; If any of the X11 resources were not defined, use the defaults.
  544.     (if (not package-font)
  545.     (setq package-font default-style-font))
  546.     (if (not package-foreground)
  547.     (setq package-foreground default-style-foreground))
  548.     (if (not package-background)
  549.     (setq package-background default-style-background))
  550.     (if (not package-cursor-foreground)
  551.     (setq package-cursor-foreground default-style-cursor-foreground))
  552.     (if (not package-cursor-background)
  553.     (setq package-cursor-background default-style-cursor-background))
  554.     (if (not package-underline)
  555.     (setq package-underline default-style-underline))
  556.     (if (not package-stipple)
  557.     (setq package-stipple default-style-stipple))
  558.     (if (not package-cursor-stipple)
  559.     (setq package-cursor-stipple default-style-cursor-stipple))
  560.     (if (not package-background-stipple)
  561.     (setq package-background-stipple default-style-background-stipple))
  562.     (if (not package-pixmap)
  563.     (setq package-pixmap default-style-pixmap))
  564.     ;; Create a new style if necessary.
  565.     (if (not new-package-style)
  566.     (setq new-package-style (make-style)))
  567.     ;; Set each of the style fields if a value is defined for it.
  568.     (if package-font
  569.     (set-style-font new-package-style
  570.             (tek-get-font package-font)))
  571.     (if package-foreground
  572.     (set-style-foreground new-package-style
  573.                   (tek-get-color package-foreground)))
  574.     (if package-background
  575.     (set-style-background new-package-style
  576.                   (tek-get-color package-background)))
  577.     (if package-cursor-foreground
  578.     (set-style-cursor-foreground new-package-style
  579.                      (tek-get-color
  580.                       package-cursor-foreground)))
  581.     (if package-background
  582.     (set-style-background new-package-style
  583.                   (tek-get-color package-background)))
  584.     (if package-underline
  585.     (set-style-underline new-package-style
  586.                  (tek-get-color package-underline)))
  587.     (if package-stipple
  588.     (set-style-stipple new-package-style
  589.                (tek-get-bitmap package-stipple)))
  590.     (if package-cursor-stipple
  591.     (set-style-cursor-stipple new-package-style
  592.                   (tek-get-bitmap
  593.                    package-cursor-stipple)))
  594.     (if package-background-stipple
  595.     (set-style-background-stipple new-package-style
  596.                       (tek-get-bitmap
  597.                        package-background-stipple)))
  598.     (if package-pixmap
  599.     (set-style-pixmap new-package-style
  600.               (tek-get-pixmap package-pixmap)))
  601.     ;; return the style
  602.     new-package-style
  603.     ))
  604.