mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-12 04:11:18 -08:00
700 lines
26 KiB
Common Lisp
700 lines
26 KiB
Common Lisp
;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
|
||
|
||
;; RESOURCE - Lisp version of XLIB's Xrm resource manager
|
||
|
||
;;;
|
||
;;; TEXAS INSTRUMENTS INCORPORATED
|
||
;;; P.O. BOX 2909
|
||
;;; AUSTIN, TEXAS 78769
|
||
;;;
|
||
;;; Copyright (C) 1987 Texas Instruments Incorporated.
|
||
;;;
|
||
;;; Permission is granted to any individual or institution to use, copy, modify,
|
||
;;; and distribute this software, provided that this complete copyright and
|
||
;;; permission notice is maintained, intact, in all copies and supporting
|
||
;;; documentation.
|
||
;;;
|
||
;;; Texas Instruments Incorporated provides this software "as is" without
|
||
;;; express or implied warranty.
|
||
;;;
|
||
|
||
(in-package :xlib)
|
||
|
||
;; The C version of this uses a 64 entry hash table at each entry.
|
||
;; Small hash tables lose in Lisp, so we do linear searches on lists.
|
||
|
||
(defstruct (resource-database (:copier nil) (:predicate nil)
|
||
(:print-function print-resource-database)
|
||
(:constructor make-resource-database-internal)
|
||
#+explorer (:callable-constructors nil)
|
||
)
|
||
(name nil :type stringable :read-only t)
|
||
(value nil)
|
||
(tight nil :type list) ;; List of resource-database
|
||
(loose nil :type list) ;; List of resource-database
|
||
)
|
||
|
||
(defun print-resource-database (database stream depth)
|
||
(declare (type resource-database database)
|
||
(ignore depth))
|
||
(print-unreadable-object (database stream :type t)
|
||
(write-string (string (resource-database-name database)) stream)
|
||
(when (resource-database-value database)
|
||
(write-string " " stream)
|
||
(prin1 (resource-database-value database) stream))))
|
||
|
||
;; The value slot of the top-level resource-database structure is used for a
|
||
;; time-stamp.
|
||
|
||
(defun make-resource-database ()
|
||
;; Make a resource-database with initial timestamp of 0
|
||
(make-resource-database-internal :name "Top-Level" :value 0))
|
||
|
||
(defun resource-database-timestamp (database)
|
||
(declare (type resource-database database))
|
||
(resource-database-value database))
|
||
|
||
(defun incf-resource-database-timestamp (database)
|
||
;; Increment the timestamp
|
||
(declare (type resource-database database))
|
||
(let ((timestamp (resource-database-value database)))
|
||
(setf (resource-database-value database)
|
||
(if (= timestamp most-positive-fixnum)
|
||
most-negative-fixnum
|
||
(1+ timestamp)))))
|
||
|
||
;; DEBUG FUNCTION (not exported)
|
||
(defun print-db (entry &optional (level 0) type)
|
||
;; Debug function to print a resource database
|
||
(format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
|
||
level
|
||
(resource-database-name entry)
|
||
(eq type 'loose)
|
||
(resource-database-value entry))
|
||
(when (resource-database-tight entry)
|
||
(dolist (tight (resource-database-tight entry))
|
||
(print-db tight (+ 2 level) 'tight)))
|
||
(when (resource-database-loose entry)
|
||
(dolist (loose (resource-database-loose entry))
|
||
(print-db loose (+ 2 level) 'loose))))
|
||
|
||
;; DEBUG FUNCTION
|
||
#+comment
|
||
(defun print-search-table (table)
|
||
(terpri)
|
||
(dolist (dbase-list table)
|
||
(format t "~%~s" dbase-list)
|
||
(dolist (db dbase-list)
|
||
(print-db db)
|
||
(dolist (dblist table)
|
||
(unless (eq dblist dbase-list)
|
||
(when (member db dblist)
|
||
(format t " duplicate at ~s" db))))
|
||
)))
|
||
|
||
;;
|
||
;; If this is true, resource symbols will be compared in a case-insensitive
|
||
;; manner, and converting a resource string to a keyword will uppercaseify it.
|
||
;;
|
||
(defparameter *uppercase-resource-symbols* nil)
|
||
|
||
(defun resource-key (stringable)
|
||
;; Ensure STRINGABLE is a keyword.
|
||
(declare (type stringable stringable))
|
||
(etypecase stringable
|
||
(symbol
|
||
(if (keywordp (the symbol stringable))
|
||
stringable
|
||
(kintern (symbol-name (the symbol stringable)))))
|
||
(string
|
||
(if *uppercase-resource-symbols*
|
||
(setq stringable (#-allegro string-upcase #+allegro correct-case
|
||
(the string stringable))))
|
||
(kintern (the string stringable)))))
|
||
|
||
(defun stringable-equal (a b)
|
||
;; Compare two stringables.
|
||
;; Ignore case when comparing to a symbol.
|
||
(declare (type stringable a b))
|
||
(declare (clx-values generalized-boolean))
|
||
(etypecase a
|
||
(string
|
||
(etypecase b
|
||
(string
|
||
(string= (the string a) (the string b)))
|
||
(symbol
|
||
(if *uppercase-resource-symbols*
|
||
(string-equal (the string a)
|
||
(the string (symbol-name (the symbol b))))
|
||
(string= (the string a)
|
||
(the string (symbol-name (the symbol b))))))))
|
||
(symbol
|
||
(etypecase b
|
||
(string
|
||
(if *uppercase-resource-symbols*
|
||
(string-equal (the string (symbol-name (the symbol a)))
|
||
(the string b))
|
||
(string= (the string (symbol-name (the symbol a)))
|
||
(the string b))))
|
||
(symbol
|
||
(string= (the string (symbol-name (the symbol a)))
|
||
(the string (symbol-name (the symbol b)))))))))
|
||
|
||
|
||
;;;-----------------------------------------------------------------------------
|
||
;;; Add/delete resource
|
||
|
||
(defun add-resource (database name-list value)
|
||
;; name-list is a list of either strings or symbols. If a symbol,
|
||
;; case-insensitive comparisons will be used, if a string,
|
||
;; case-sensitive comparisons will be used. The symbol '* or
|
||
;; string "*" are used as wildcards, matching anything or nothing.
|
||
(declare (type resource-database database)
|
||
(type (clx-list stringable) name-list)
|
||
(type t value))
|
||
(unless value (error "Null resource values are ignored"))
|
||
(incf-resource-database-timestamp database)
|
||
(do* ((list name-list (cdr list))
|
||
(name (car list) (car list))
|
||
(node database)
|
||
(loose-p nil))
|
||
((endp list)
|
||
(setf (resource-database-value node) value))
|
||
;; Key is the first name that isn't *
|
||
(if (stringable-equal name "*")
|
||
(setq loose-p t)
|
||
;; find the entry associated with name
|
||
(progn
|
||
(do ((entry (if loose-p
|
||
(resource-database-loose node)
|
||
(resource-database-tight node))
|
||
(cdr entry)))
|
||
((endp entry)
|
||
;; Entry not found - create a new one
|
||
(setq entry (make-resource-database-internal :name name))
|
||
(if loose-p
|
||
(push entry (resource-database-loose node))
|
||
(push entry (resource-database-tight node)))
|
||
(setq node entry))
|
||
(when (stringable-equal name (resource-database-name (car entry)))
|
||
;; Found entry - use it
|
||
(return (setq node (car entry)))))
|
||
(setq loose-p nil)))))
|
||
|
||
|
||
(defun delete-resource (database name-list)
|
||
(declare (type resource-database database)
|
||
(type list name-list))
|
||
(incf-resource-database-timestamp database)
|
||
(delete-resource-internal database name-list))
|
||
|
||
(defun delete-resource-internal (database name-list)
|
||
(declare (type resource-database database)
|
||
(type (clx-list stringable) name-list))
|
||
(do* ((list name-list (cdr list))
|
||
(string (car list) (car list))
|
||
(node database)
|
||
(loose-p nil))
|
||
((endp list) nil)
|
||
;; Key is the first name that isn't *
|
||
(if (stringable-equal string "*")
|
||
(setq loose-p t)
|
||
;; find the entry associated with name
|
||
(progn
|
||
(do* ((first-entry (if loose-p
|
||
(resource-database-loose node)
|
||
(resource-database-tight node)))
|
||
(entry-list first-entry (cdr entry-list))
|
||
(entry (car entry-list) (car entry-list)))
|
||
((endp entry-list)
|
||
;; Entry not found - exit
|
||
(return-from delete-resource-internal nil))
|
||
(when (stringable-equal string (resource-database-name entry))
|
||
(when (cdr list) (delete-resource-internal entry (cdr list)))
|
||
(when (and (null (resource-database-loose entry))
|
||
(null (resource-database-tight entry)))
|
||
(if loose-p
|
||
(setf (resource-database-loose node)
|
||
(delete entry (resource-database-loose node)
|
||
:test #'eq :count 1))
|
||
(setf (resource-database-tight node)
|
||
(delete entry (resource-database-tight node)
|
||
:test #'eq :count 1))))
|
||
(return-from delete-resource-internal t)))
|
||
(setq loose-p nil)))))
|
||
|
||
;;;-----------------------------------------------------------------------------
|
||
;;; Get Resource
|
||
|
||
(defun get-resource (database value-name value-class full-name full-class)
|
||
;; Return the value of the resource in DATABASE whose partial name
|
||
;; most closely matches (append full-name (list value-name)) and
|
||
;; (append full-class (list value-class)).
|
||
(declare (type resource-database database)
|
||
(type stringable value-name value-class)
|
||
(type (clx-list stringable) full-name full-class))
|
||
(declare (clx-values value))
|
||
(let ((names (append full-name (list value-name)))
|
||
(classes (append full-class (list value-class))))
|
||
(let* ((result (get-entry (resource-database-tight database)
|
||
(resource-database-loose database)
|
||
names classes)))
|
||
(when result
|
||
(resource-database-value result)))))
|
||
|
||
(defun get-entry-lookup (table name names classes)
|
||
(declare (type list table names classes)
|
||
(symbol name))
|
||
(dolist (entry table)
|
||
(declare (type resource-database entry))
|
||
(when (stringable-equal name (resource-database-name entry))
|
||
(if (null (cdr names))
|
||
(return entry)
|
||
(let ((result (get-entry (resource-database-tight entry)
|
||
(resource-database-loose entry)
|
||
(cdr names) (cdr classes))))
|
||
(declare (type (or null resource-database) result))
|
||
(when result
|
||
(return result)
|
||
))))))
|
||
|
||
(defun get-entry (tight loose names classes &aux result)
|
||
(declare (type list tight loose names classes))
|
||
(let ((name (car names))
|
||
(class (car classes)))
|
||
(declare (type symbol name class))
|
||
(cond ((and tight
|
||
(get-entry-lookup tight name names classes)))
|
||
((and loose
|
||
(get-entry-lookup loose name names classes)))
|
||
((and tight
|
||
(not (stringable-equal name class))
|
||
(get-entry-lookup tight class names classes)))
|
||
((and loose
|
||
(not (stringable-equal name class))
|
||
(get-entry-lookup loose class names classes)))
|
||
(loose
|
||
(loop
|
||
(pop names) (pop classes)
|
||
(unless (and names classes) (return nil))
|
||
(setq name (car names)
|
||
class (car classes))
|
||
(when (setq result (get-entry-lookup loose name names classes))
|
||
(return result))
|
||
(when (and (not (stringable-equal name class))
|
||
(setq result
|
||
(get-entry-lookup loose class names classes)))
|
||
(return result))
|
||
)))))
|
||
|
||
|
||
;;;-----------------------------------------------------------------------------
|
||
;;; Get-resource with search-table
|
||
|
||
(defun get-search-resource (table name class)
|
||
;; (get-search-resource (get-search-table database full-name full-class)
|
||
;; value-name value-class)
|
||
;; is equivalent to
|
||
;; (get-resource database value-name value-class full-name full-class)
|
||
;; But since most of the work is done by get-search-table,
|
||
;; get-search-resource is MUCH faster when getting several resources with
|
||
;; the same full-name/full-class
|
||
(declare (type list table)
|
||
(type stringable name class))
|
||
(let ((do-class (and class (not (stringable-equal name class)))))
|
||
(dolist (dbase-list table)
|
||
(declare (type list dbase-list))
|
||
(dolist (dbase dbase-list)
|
||
(declare (type resource-database dbase))
|
||
(when (stringable-equal name (resource-database-name dbase))
|
||
(return-from get-search-resource
|
||
(resource-database-value dbase))))
|
||
(when do-class
|
||
(dolist (dbase dbase-list)
|
||
(declare (type resource-database dbase))
|
||
(when (stringable-equal class (resource-database-name dbase))
|
||
(return-from get-search-resource
|
||
(resource-database-value dbase))))))))
|
||
|
||
(defvar *get-table-result*)
|
||
|
||
(defun get-search-table (database full-name full-class)
|
||
;; Return a search table for use with get-search-resource.
|
||
(declare (type resource-database database)
|
||
(type (clx-list stringable) full-name full-class))
|
||
(declare (clx-values value))
|
||
(let* ((tight (resource-database-tight database))
|
||
(loose (resource-database-loose database))
|
||
(result (cons nil nil))
|
||
(*get-table-result* result))
|
||
(declare (type list tight loose)
|
||
(type cons result))
|
||
(when (or tight loose)
|
||
(when full-name
|
||
(get-tables tight loose full-name full-class))
|
||
|
||
;; Pick up bindings of the form (* name). These are the elements of
|
||
;; top-level loose without further tight/loose databases.
|
||
;;
|
||
;; (Hack: these bindings belong in ANY search table, so recomputing them
|
||
;; is a drag. True fix involves redesigning entire lookup
|
||
;; data-structure/algorithm.)
|
||
;;
|
||
(let ((universal-bindings
|
||
(remove nil loose :test-not #'eq
|
||
:key #'(lambda (database)
|
||
(or (resource-database-tight database)
|
||
(resource-database-loose database))))))
|
||
(when universal-bindings
|
||
(setf (cdr *get-table-result*) (list universal-bindings)))))
|
||
(cdr result)))
|
||
|
||
(defun get-tables-lookup (dbase name names classes)
|
||
(declare (type list dbase names classes)
|
||
(type symbol name))
|
||
(declare (optimize speed))
|
||
(dolist (entry dbase)
|
||
(declare (type resource-database entry))
|
||
(when (stringable-equal name (resource-database-name entry))
|
||
(let ((tight (resource-database-tight entry))
|
||
(loose (resource-database-loose entry)))
|
||
(declare (type list tight loose))
|
||
(when (or tight loose)
|
||
(if (cdr names)
|
||
(get-tables tight loose (cdr names) (cdr classes))
|
||
(when tight
|
||
(let ((result *get-table-result*))
|
||
;; Put tight at end of *get-table-result*
|
||
(setf (cdr result)
|
||
(setq *get-table-result* (cons tight nil))))))
|
||
(when loose
|
||
(let ((result *get-table-result*))
|
||
;; Put loose at end of *get-table-result*
|
||
(setf (cdr result)
|
||
(setq *get-table-result* (cons loose nil))))))))))
|
||
|
||
(defun get-tables (tight loose names classes)
|
||
(declare (type list tight loose names classes))
|
||
(let ((name (car names))
|
||
(class (car classes)))
|
||
(declare (type symbol name class))
|
||
(when tight
|
||
(get-tables-lookup tight name names classes))
|
||
(when loose
|
||
(get-tables-lookup loose name names classes))
|
||
(when (and tight (not (stringable-equal name class)))
|
||
(get-tables-lookup tight class names classes))
|
||
(when (and loose (not (stringable-equal name class)))
|
||
(get-tables-lookup loose class names classes))
|
||
(when loose
|
||
(loop
|
||
(pop names) (pop classes)
|
||
(unless (and names classes) (return nil))
|
||
(setq name (car names)
|
||
class (car classes))
|
||
(get-tables-lookup loose name names classes)
|
||
(unless (stringable-equal name class)
|
||
(get-tables-lookup loose class names classes))
|
||
))))
|
||
|
||
|
||
;;;-----------------------------------------------------------------------------
|
||
;;; Utility functions
|
||
|
||
(defun map-resource (database function &rest args)
|
||
;; Call FUNCTION on each resource in DATABASE.
|
||
;; FUNCTION is called with arguments (name-list value . args)
|
||
(declare (type resource-database database)
|
||
(type (function (list t &rest t) t) function)
|
||
#+clx-ansi-common-lisp
|
||
(dynamic-extent function)
|
||
#+(and lispm (not clx-ansi-common-lisp))
|
||
(sys:downward-funarg function)
|
||
(dynamic-extent args))
|
||
(declare (clx-values nil))
|
||
(labels ((map-resource-internal (database function args name)
|
||
(declare (type resource-database database)
|
||
(type (function (list t &rest t) t) function)
|
||
(type list name)
|
||
#+clx-ansi-common-lisp
|
||
(dynamic-extent function)
|
||
#+(and lispm (not clx-ansi-common-lisp))
|
||
(sys:downward-funarg function))
|
||
(let ((tight (resource-database-tight database))
|
||
(loose (resource-database-loose database)))
|
||
(declare (type list tight loose))
|
||
(dolist (resource tight)
|
||
(declare (type resource-database resource))
|
||
(let ((value (resource-database-value resource))
|
||
(name (append
|
||
name
|
||
(list (resource-database-name resource)))))
|
||
(if value
|
||
(apply function name value args)
|
||
(map-resource-internal resource function args name))))
|
||
(dolist (resource loose)
|
||
(declare (type resource-database resource))
|
||
(let ((value (resource-database-value resource))
|
||
(name (append
|
||
name
|
||
(list "*" (resource-database-name resource)))))
|
||
(if value
|
||
(apply function name value args)
|
||
(map-resource-internal resource function args name)))))))
|
||
(map-resource-internal database function args nil)))
|
||
|
||
(defun merge-resources (database with-database)
|
||
(declare (type resource-database database with-database))
|
||
(declare (clx-values resource-database))
|
||
(map-resource
|
||
database
|
||
#'(lambda (name value database)
|
||
(add-resource database name value))
|
||
with-database)
|
||
with-database)
|
||
|
||
(defun char-memq (key char)
|
||
;; Used as a test function for POSITION
|
||
(declare (type base-char char))
|
||
(member char key))
|
||
|
||
(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
|
||
;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
|
||
;; stream
|
||
(let ((abortp (gensym))
|
||
(streamp (gensym)))
|
||
`(let* ((,abortp t)
|
||
(,streamp (streamp pathname))
|
||
(,stream (if ,streamp pathname (open ,pathname ,@options))))
|
||
(unwind-protect
|
||
(multiple-value-prog1
|
||
(progn ,@body)
|
||
(setq ,abortp nil))
|
||
(unless ,streamp
|
||
(close stream :abort ,abortp))))))
|
||
|
||
(defun read-resources (database pathname &key key test test-not)
|
||
;; Merges resources from a file in standard X11 format with DATABASE.
|
||
;; KEY is a function used for converting value-strings, the default is
|
||
;; identity. TEST and TEST-NOT are predicates used for filtering
|
||
;; which resources to include in the database. They are called with
|
||
;; the name and results of the KEY function.
|
||
(declare (type resource-database database)
|
||
(type (or pathname string stream) pathname)
|
||
(type (or null (function (string) t)) key)
|
||
(type (or null (function (list t) generalized-boolean))
|
||
test test-not))
|
||
(declare (clx-values resource-database))
|
||
(resource-with-open-file (stream pathname)
|
||
(loop
|
||
(let ((string (read-line stream nil :eof)))
|
||
(declare (type (or string keyword) string))
|
||
(when (eq string :eof) (return database))
|
||
(let* ((end (length string))
|
||
(i (position '(#\tab #\space) string
|
||
:test-not #'char-memq :end end))
|
||
(term nil))
|
||
(declare (type array-index end)
|
||
(type (or null array-index) i term))
|
||
(when i ;; else blank line
|
||
(case (char string i)
|
||
(#\! nil) ;; Comment - skip
|
||
;;(#.(card8->char 0) nil) ;; terminator for C strings - skip
|
||
(#\# ;; Include
|
||
(setq term (position '(#\tab #\space) string :test #'char-memq
|
||
:start i :end end))
|
||
(when (string-equal string "#INCLUDE" :start1 i :end1 term)
|
||
(let ((path (merge-pathnames
|
||
(string-trim '(#\tab #\space #\")
|
||
(subseq string (1+ term)))
|
||
(truename stream))))
|
||
(read-resources database path
|
||
:key key :test test :test-not test-not))))
|
||
(otherwise
|
||
(multiple-value-bind (name-list value)
|
||
(parse-resource string i end)
|
||
(when name-list
|
||
(when key (setq value (funcall key value)))
|
||
(when
|
||
(cond (test (funcall test name-list value))
|
||
(test-not (not (funcall test-not name-list value)))
|
||
(t t))
|
||
(add-resource database name-list value))))))))))))
|
||
|
||
(defun parse-resource (string &optional (start 0) end)
|
||
;; Parse a resource specfication string into a list of names and a value
|
||
;; string
|
||
(declare (type string string)
|
||
(type array-index start)
|
||
(type (or null array-index) end))
|
||
(declare (clx-values name-list value))
|
||
(do ((i start)
|
||
(end (or end (length string)))
|
||
(term)
|
||
(name-list))
|
||
((>= i end))
|
||
(declare (type array-index end)
|
||
(type (or null array-index) i term))
|
||
(setq term (position '(#\. #\* #\:) string
|
||
:test #'char-memq :start i :end end))
|
||
(case (and term (char string term))
|
||
;; Name seperator
|
||
(#\. (when (> term i)
|
||
(push (subseq string i term) name-list)))
|
||
;; Wildcard seperator
|
||
(#\* (when (> term i)
|
||
(push (subseq string i term) name-list))
|
||
(push '* name-list))
|
||
;; Value separator
|
||
(#\:
|
||
(push (subseq string i term) name-list)
|
||
(return
|
||
(values
|
||
(nreverse name-list)
|
||
(string-trim '(#\tab #\space) (subseq string (1+ term))))))
|
||
(otherwise
|
||
(return
|
||
(values
|
||
(nreverse name-list)
|
||
(subseq string i term)))))
|
||
(setq i (1+ term))))
|
||
|
||
(defun write-resources (database pathname &key write test test-not)
|
||
;; Write resources to PATHNAME in the standard X11 format.
|
||
;; WRITE is a function used for writing values, the default is #'princ
|
||
;; TEST and TEST-NOT are predicates used for filtering which resources
|
||
;; to include in the database. They are called with the name and value.
|
||
(declare (type resource-database database)
|
||
(type (or pathname string stream) pathname)
|
||
(type (or null (function (string stream) t)) write)
|
||
(type (or null (function (list t) generalized-boolean))
|
||
test test-not))
|
||
(resource-with-open-file (stream pathname :direction :output)
|
||
(map-resource
|
||
database
|
||
#'(lambda (name-list value stream write test test-not)
|
||
(when
|
||
(cond (test (funcall test name-list value))
|
||
(test-not (not (funcall test-not name-list value)))
|
||
(t t))
|
||
(let ((previous (car name-list)))
|
||
(princ previous stream)
|
||
(dolist (name (cdr name-list))
|
||
(unless (or (stringable-equal name "*")
|
||
(stringable-equal previous "*"))
|
||
(write-char #\. stream))
|
||
(setq previous name)
|
||
(princ name stream)))
|
||
(write-string ": " stream)
|
||
(funcall write value stream)
|
||
(terpri stream)))
|
||
stream (or write #'princ) test test-not))
|
||
database)
|
||
|
||
(defun wm-resources (database window &key key test test-not)
|
||
;; Takes the resources associated with the RESOURCE_MANAGER property
|
||
;; of WINDOW (if any) and merges them with DATABASE.
|
||
;; KEY is a function used for converting value-strings, the default is
|
||
;; identity. TEST and TEST-NOT are predicates used for filtering
|
||
;; which resources to include in the database. They are called with
|
||
;; the name and results of the KEY function.
|
||
(declare (type resource-database database)
|
||
(type window window)
|
||
(type (or null (function (string) t)) key)
|
||
(type (or null (function (list t) generalized-boolean))
|
||
test test-not))
|
||
(declare (clx-values resource-database))
|
||
(let ((string (get-property window :RESOURCE_MANAGER :type :STRING
|
||
:result-type 'string
|
||
:transform #'xlib::card8->char)))
|
||
(when string
|
||
(with-input-from-string (stream string)
|
||
(read-resources database stream
|
||
:key key :test test :test-not test-not)))))
|
||
|
||
(defun set-wm-resources (database window &key write test test-not)
|
||
;; Sets the resources associated with the RESOURCE_MANAGER property
|
||
;; of WINDOW.
|
||
;; WRITE is a function used for writing values, the default is #'princ
|
||
;; TEST and TEST-NOT are predicates used for filtering which resources
|
||
;; to include in the database. They are called with the name and value.
|
||
(declare (type resource-database database)
|
||
(type window window)
|
||
(type (or null (function (string stream) t)) write)
|
||
(type (or null (function (list t) generalized-boolean))
|
||
test test-not))
|
||
(xlib::set-string-property
|
||
window :RESOURCE_MANAGER
|
||
(with-output-to-string (stream)
|
||
(write-resources database stream :write write
|
||
:test test :test-not test-not))))
|
||
|
||
(defun root-resources (screen &key database key test test-not)
|
||
"Returns a resource database containing the contents of the root window
|
||
RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
|
||
then its default screen is used. If an existing DATABASE is given, then
|
||
resource values are merged with the DATABASE and the modified DATABASE is
|
||
returned.
|
||
|
||
TEST and TEST-NOT are predicates for selecting which resources are
|
||
read. Arguments are a resource name list and a resource value. The KEY
|
||
function, if given, is called to convert a resource value string to the
|
||
value given to TEST or TEST-NOT."
|
||
|
||
(declare (type (or screen display) screen)
|
||
(type (or null resource-database) database)
|
||
(type (or null (function (string) t)) key)
|
||
(type (or null (function (list t) generalized-boolean)) test test-not)
|
||
(clx-values resource-database))
|
||
(let* ((screen (if (type? screen 'display)
|
||
(display-default-screen screen)
|
||
screen))
|
||
(window (screen-root screen))
|
||
(database (or database (make-resource-database))))
|
||
(wm-resources database window :key key :test test :test-not test-not)
|
||
database))
|
||
|
||
(defun set-root-resources (screen &key test test-not (write #'princ) database)
|
||
"Changes the contents of the root window RESOURCE_MANAGER property for the
|
||
given SCREEN. If SCREEN is a display, then its default screen is used.
|
||
|
||
TEST and TEST-NOT are predicates for selecting which resources from the
|
||
DATABASE are written. Arguments are a resource name list and a resource
|
||
value. The WRITE function is used to convert a resource value into a
|
||
string stored in the property."
|
||
|
||
(declare (type (or screen display) screen)
|
||
(type (or null resource-database) database)
|
||
(type (or null (function (list t) generalized-boolean)) test test-not)
|
||
(type (or null (function (string stream) t)) write)
|
||
(clx-values resource-database))
|
||
(let* ((screen (if (type? screen 'display)
|
||
(display-default-screen screen)
|
||
screen))
|
||
(window (screen-root screen)))
|
||
(set-wm-resources database window
|
||
:write write :test test :test-not test-not)
|
||
database))
|
||
|
||
(defsetf root-resources (screen &key test test-not (write #'princ))(database)
|
||
`(set-root-resources
|
||
,screen :test ,test :test-not ,test-not :write ,write :database ,database))
|
||
|
||
(defun initialize-resource-database (display)
|
||
;; This function is (supposed to be) equivalent to the Xlib initialization
|
||
;; code.
|
||
(declare (type display display))
|
||
(let ((rdb (make-resource-database))
|
||
(rootwin (screen-root (car (display-roots display)))))
|
||
;; First read the server defaults if present, otherwise from the default
|
||
;; resource file
|
||
(if (get-property rootwin :RESOURCE_MANAGER)
|
||
(xlib:wm-resources rdb rootwin)
|
||
(let ((path (default-resources-pathname)))
|
||
(when (and path (probe-file path))
|
||
(read-resources rdb path))))
|
||
;; Next read from the resources file
|
||
(let ((path (resources-pathname)))
|
||
(when (and path (probe-file path))
|
||
(read-resources rdb path)))
|
||
(setf (display-xdefaults display) rdb)))
|