← Back to branch summary

~ubuntu-branches/ubuntu/lucid/sawfish/lucid-updates

« back to all changes in this revision

Viewing changes to lisp/sawfish/gtk/widgets/font.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2005-02-23 16:16:46 UTC
  • mfrom: (1.2.1 upstream) (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050223161646-4id6qyw4h9lkvb0v
Tags: 1:1.3+cvs20050222-1
http://bugs.debian.org/295290
* New cvs release.
* Add an emacs initialisation script to load sawfish.el (Closes: #295290)
* Updated sawfish.el to 1.32

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/gtk/widgets/font.jl
1
1
#| nokogiri-widgets/font.jl -- font selection widget
2
2
 
3
 
   $Id: font.jl,v 1.4 2000/11/27 18:13:19 jsh Exp $
 
3
   $Id: font.jl.in,v 1.1 2003/08/16 18:35:38 jsh Exp $
4
4
 
5
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
6
6
 
24
24
(define-structure sawfish.gtk.widgets.font ()
25
25
 
26
26
    (open rep
27
 
          gui.gtk
28
 
          sawfish.gtk.widget)
29
 
 
30
 
  (defconst default-font "fixed")
 
27
          rep.system
 
28
          gui.gtk-2.gtk
 
29
          sawfish.gtk.widget
 
30
          sawfish.wm.util.font)
 
31
 
 
32
  ;; FIXME: this is broken, in that only if Xrender is present
 
33
  ;; does gdk use Xft. But, it's the best I can do..
 
34
  (define use-xft (let ((x (getenv "GDK_USE_XFT")))
 
35
                    (or (not x) (/= (string->number x) 0))))
 
36
 
 
37
  ;; defined by configure
 
38
  (define have-pango-xft (eq 'yes 'yes))
 
39
 
 
40
  (define default-font (if use-xft "Sans" "fixed"))
31
41
 
32
42
  (define (make-font-item changed-callback)
33
43
    (let* ((box (gtk-hbox-new nil box-spacing))
34
44
           (entry (gtk-entry-new))
35
45
           (button (gtk-button-new-with-label (_ "Browse..."))))
 
46
      (gtk-editable-set-editable entry nil)
36
47
      (gtk-box-pack-start box entry t t)
37
48
      (gtk-box-pack-start box button)
38
49
      (when changed-callback
39
 
        (gtk-signal-connect
 
50
        (g-signal-connect
40
51
         entry "changed" (make-signal-callback changed-callback)))
41
 
      (gtk-signal-connect
 
52
      (g-signal-connect
42
53
       button "clicked"
43
54
       (lambda ()
44
55
         (let ((fontsel (gtk-font-selection-dialog-new (_ "Select font"))))
45
56
           (gtk-font-selection-dialog-set-font-name
46
57
            fontsel (gtk-entry-get-text entry))
47
 
           (gtk-signal-connect
 
58
           (g-signal-connect
48
59
            (gtk-font-selection-dialog-ok-button fontsel) "clicked"
49
60
            (lambda ()
50
61
              (gtk-entry-set-text
51
62
               entry (gtk-font-selection-dialog-get-font-name fontsel))
52
63
              (gtk-widget-destroy fontsel)))
53
 
           (gtk-signal-connect
 
64
           (g-signal-connect
54
65
            (gtk-font-selection-dialog-cancel-button fontsel) "clicked"
55
66
            (lambda () (gtk-widget-destroy fontsel)))
56
 
           (gtk-signal-connect fontsel "delete_event"
 
67
           (g-signal-connect fontsel "delete_event"
57
68
                               (lambda () (gtk-widget-destroy fontsel)))
58
69
           (gtk-widget-show fontsel)
59
70
           (gtk-grab-add fontsel))))
61
72
      (lambda (op)
62
73
        (case op
63
74
          ((set) (lambda (x)
64
 
                   (gtk-entry-set-text entry (and (stringp x) x))))
 
75
                   (cond ((stringp x)
 
76
                          (gtk-entry-set-text entry x))
 
77
                         ((consp x)
 
78
                          (let ((face (cond
 
79
                                        ((string-equal (car x) "Xft")
 
80
                                         (xft-description->face (cdr x)))
 
81
                                        ((string-equal (car x) "xlfd")
 
82
                                         (xlfd-description->face (cdr x)))
 
83
                                        ((string-equal (car x) "pango")
 
84
                                         (pango-description->face (cdr x))))))
 
85
                            (when face
 
86
                              (gtk-entry-set-text
 
87
                               entry (face->pango-description face)))))
 
88
                         (t (gtk-entry-set-text entry default-font)))))
65
89
          ((clear) (lambda ()
66
90
                     (gtk-entry-set-text entry default-font)))
67
 
          ((ref) (lambda () (gtk-entry-get-text entry)))
 
91
          ((ref) (lambda ()
 
92
                   (let* ((pango-name (gtk-entry-get-text entry))
 
93
                          (face (pango-description->face pango-name)))
 
94
                     (cond ((not face) nil)
 
95
                           (use-xft
 
96
                            (if have-pango-xft
 
97
                                (cons "Pango" (face->pango-description face))
 
98
                              (cons "Xft" (face->xft-description face))))
 
99
                           (t (cons "xlfd" (face->xlfd-description face)))))))
68
100
          ((gtk-widget) box)
69
101
          ((validp) (lambda (x) (stringp x)))))))
70
102