File: slot.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (156 lines) | stat: -rw-r--r-- 4,949 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
#| nokogiri-slot.jl -- managing individual config items

   $Id: slot.jl,v 1.9 2003/01/12 20:30:47 jsh Exp $

   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>

   This file is part of sawfish.

   sawfish is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   sawfish is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with sawfish; see the file COPYING.  If not, write to
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#

(define-structure sawfish.ui.slot

    (export slot-name
	    slot-widget
	    slot-old-value
	    slot-gtk-widget
	    slot-doc slot-flags
	    slot-layout set-slot-layout
	    update-dependences
	    update-all-dependences
	    get-slot
	    slot-value
	    fetch-slots
	    custom-symbol-value)

    (open rep
	  gui.gtk-2.gtk
	  rep.system
	  rep.data.tables
	  rep.data.records
	  sawfish.gtk.widget
	  sawfish.ui.wm)

  (define-record-type :slot
    (create-slot name old-value flags)
    ;; [no predicate]
    (name slot-name)			;name of config item
    (widget slot-widget slot-widget-set) ;associated lisp widget
    (layout slot-layout set-slot-layout) ;gtk widget if the slot is displayed
    (old-value slot-old-value)		;original value of slot's config
    (doc slot-doc slot-doc-set)		;doc string (unless shown in widget)
    (flags slot-flags))

  (define-record-discloser :slot
    (lambda (x) (format nil "#<slot %s>" (slot-name x))))

  ;; hash table mapping names to slots
  (define slot-table (make-table symbol-hash eq))

  ;; hash table mapping slot name to list of slots depending on them
  (define dependence-table (make-table symbol-hash eq))

  (defvar *nokogiri-slot-changed-hook* '())

;;; slot creation, data structure mgmt

  (define (slot-dependences slot)
    (table-ref dependence-table (slot-name slot)))

  (define (update-dependences slot)
    (when (slot-dependences slot)
      (let ((value (slot-value slot)))
	(mapc (lambda (dep)
		(when (slot-layout dep)
		  (gtk-widget-set-sensitive (slot-layout dep) value)))
	      (slot-dependences slot)))))

  (define (update-all-dependences)
    (table-walk (lambda (dep slots)
		  (declare (unused slots))
		  (update-dependences (get-slot dep))) dependence-table))

  ;; called when the value of SLOT changes
  (define (slot-changed slot)
    (call-hook '*nokogiri-slot-changed-hook* (list slot))
    (update-dependences slot))

  (define (slot-gtk-widget slot) (widget-gtk-widget (slot-widget slot)))

  (define (make-slot #!key name value type doc depends widget-flags)
    (let ((slot (create-slot name value widget-flags)))
      (table-set slot-table (slot-name slot) slot)

      ;; install dependendences
      (when depends
	(table-set dependence-table depends
		   (cons slot (table-ref dependence-table depends))))

      ;; create the widget
      (let* ((callback (lambda () (slot-changed slot))))
	(if (widget-accepts-doc-string-p (or (car type) type))
	    (slot-widget-set slot (make-widget type callback doc))
	  (slot-doc-set slot doc)
	  (slot-widget-set slot (make-widget type callback))))
      (widget-set (slot-widget slot) (slot-old-value slot))

      slot))

  (define (get-slot name) (table-ref slot-table name))
  (define (slot-value slot) (widget-ref (slot-widget slot)))

  ;; Return a list of slots for variables NAMES. Will load the data
  ;; from the WM if not already cached
  (define (fetch-slots names)
    ;; don't want to request one slot at a time from wm..

    ;; SLOTS is a list of slots matching NAMES, or nil if the slot
    ;; hadn't been loaded. EXTRA is a list of slots to splice into
    ;; the nil spaces.
    (define (merge slots extra)
      (let loop ((rest slots))
	(if (null rest)
	    slots
	  (when (null (car rest))
	    (rplaca rest (apply make-slot (car extra)))
	    (setq extra (cdr extra)))
	  (loop (cdr rest)))))

    ;; find which slots still need to be loaded
    (let ((slots (mapcar get-slot names)))
      (let loop ((names-rest names)
		 (slots-rest slots)
		 (to-fetch '()))
	(if (null names-rest)
	    (if to-fetch
		;; load and merge the required slots
		(merge slots (wm-load-slots (nreverse to-fetch)))
	      slots)
	  (if (null (car slots-rest))
	      ;; slot not loaded yet
	      (loop (cdr names-rest)
		    (cdr slots-rest)
		    (cons (car names-rest) to-fetch))
	    (loop (cdr names-rest)
		  (cdr slots-rest)
		  to-fetch))))))

;;; misc

  (define (custom-symbol-value symbol)
    (let ((slot (or (get-slot symbol)
		    (error "Slot not loaded yet: %s" symbol))))
      (slot-value slot))))