home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / std-func.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  7KB  |  261 lines
  1. ;; std-func.gwm --- Standard functions used by most GWM profiles
  2. ;;
  3. ;; --------------------------------------------------------------------- 
  4. ;; 
  5. ;; Note from Anders Holst (aho@sans.kth.se):
  6. ;; This file is not really written by me, I just cut it out from
  7. ;; ".profile.gwm" since its functions are used by most profiles, and
  8. ;; its a pity to duplicate. I use it for the VTWM profile.
  9. ;; 
  10.  
  11.  
  12. ;;=============================================================================
  13. ;;                    X resource management for the standard profile
  14. ;;=============================================================================
  15. ;;
  16.  
  17. (defun std-resource-get args
  18.   (with (resource-class (# 0 args) resource-name (# 1 args) Name () Class ())
  19.     (: Name (+ -screen-name '.
  20.     window-client-class '.
  21.     (make-string-usable-for-resource-key-non-nil window-client-name) '.
  22.     (make-string-usable-for-resource-key-non-nil window-name) '.
  23.     screen-type '.
  24.     window-machine-name '.
  25.     (if resource-name resource-name resource-class)
  26.     ))
  27.     (: Class (+ "S.any.any.any.any.any.any" resource-class))
  28.     (resource-get Name Class)
  29. ))
  30.  
  31. ;; puts resource:
  32. ;; (std-resource-put resource-name
  33. ;;                   [screen-type] clientclass[name[windnowname[machine]]]]
  34. ;;                   value)
  35.  
  36. (defun std-resource-put (Resource args)
  37.   (with (Client-desc () Value () Screen () Name ())
  38.     (if (= 3 (length args))
  39.       (progn
  40.     (: Client-desc (# 1 args))
  41.     (: Value (# 2 args))
  42.     (: Screen (# 0 args))
  43.       )
  44.       (progn
  45.     (: Client-desc (# 0 args))
  46.     (: Value (# 1 args))
  47.     ))
  48.     (: Name (std-resource-expand Client-desc Screen Resource))
  49. ;;    (? "resource-put " Name " " Value "\n")
  50.     (resource-put Name Value)
  51. ))
  52.  
  53. ;; expands class[.name[.wname[.machine]]] visual Resource
  54. ;; into ScreenNumber.class.name.wname.visual.machine.Resource
  55.  
  56. (defun std-resource-expand (desc visual resource)
  57.   (if (match "[*]" desc)
  58.     (+ -screen-name
  59.       (if (match "^[*]" desc) () '.)
  60.       desc
  61.       (if (match "[*]$" desc) () '.)
  62.       resource)
  63.     (with (tmp (match
  64.       "^\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)$"
  65.       desc 1 2 3 4
  66.       ))
  67.       (make-resource-string -screen-name (# 0 tmp) (# 1 tmp) (# 2 tmp)
  68.     visual (# 3 tmp) 'any resource
  69. ))))
  70.  
  71. ;; appends list elements with '.', collapsing consecutive void (or any) 
  72. ;; elements into *
  73.  
  74. (defun make-resource-string l
  75.   (with (star () first t l2 
  76.       (mapfor elt l
  77.     (if (or (= "any" elt) (not elt))
  78.       (if star
  79.         ""
  80.         (progn
  81.           (setq star t)
  82.           "*"
  83.         )
  84.       )
  85.       (progn
  86.         (setq star ())
  87.         (if first (progn (setq first ()) elt)
  88.         (+ "." elt)
  89.     )))))
  90.     (eval (+ '(+) l2))
  91. ))
  92.   
  93.  
  94. ;(trace-func std-resource-put)
  95.  
  96. ;; customisation of decos by context
  97. ;; (customize deco screen application context...)
  98.  
  99. (defun customize-usage (string)
  100.   (? "USAGE: (customize deco screen application context...),\n"
  101.     "error was: " string "\n"
  102.     (exit customize)
  103. ))
  104.  
  105. (defunq customize args
  106.   (tag customize
  107.     (with (Deco (# 0 args)
  108.     Screen (# 1 args)
  109.     Application (# 2 args)
  110.     Context (if (and (=  4 (length args)) (= 'list (type (# 3 args))))
  111.       (# 3 args)
  112.       (sublist 3 (length args) args)
  113.     )
  114.     l (length Context)
  115.     i 1
  116.       )
  117.       (while (< i l)
  118.     (## i Context (eval (# i Context)))
  119.     (setq i (+ 2 i))
  120.       )
  121.       (std-resource-put Deco (list Screen Application Context))
  122. )))
  123.   
  124. ;; recursively evaluates till we obtain a context
  125.  
  126. (defun get-context (name)
  127.   (do-get-context name 0)
  128. )
  129.  
  130. (defun do-get-context (name level)
  131.   (if (> level max-autoload-evaluation) name
  132.     (progn
  133.       (setq name
  134.     (if (# (type name) string-types)
  135.       (progn            ; atoms:
  136.         (if (= 'string (type name))
  137.           (: name (atom name)))    ; string->atom to test if defined
  138.         (if (boundp name)
  139.           (eval name)        ; defined: eval
  140.           (progn
  141.         (load name)        ; undefined, load and returns itself
  142.         name
  143.       )))
  144.       (# (type name) func-types)    ; function: called without args
  145.       (eval (list name))
  146.       (= (type name) 'list)
  147.       (if (= (% (length name) 2) 0) ; if even list, its a context
  148.         name
  149.         (= 1 (length name))        ; if one element, return it
  150.         (# 0 name)
  151.         (eval name)            ; if odd list, eval
  152.       )
  153.       (eval name)            ; others: eval
  154.       ))
  155.       (if (or (not name)
  156.       (and (= (type name) 'list)(= (% (length name) 2) 0)))
  157.     name
  158.     (do-get-context name (+ 1 level)
  159. )))))
  160.  
  161.  
  162.  
  163. ;;=============================================================================
  164. ;;                    user-callable resource settings
  165. ;;=============================================================================
  166.  
  167. (defname '-screen-name screen.)
  168. (for screen (list-of-screens)
  169.   (: -screen-name (+ "S" (itoa screen)))
  170.   (std-resource-put 'GwmWindow (list screen-type ()))
  171.   (std-resource-put 'GwmIconWindow (list screen-type ()))
  172.   (std-resource-put 'GwmIconPixmap (list screen-type ()))
  173.   (std-resource-put 'GwmPlacement (list screen-type ()))
  174.   (std-resource-put 'GwmIconPlacement (list screen-type ()))
  175. )
  176.  
  177. (: string-types '(string t atom t pointer t active t))
  178. (: func-types '(expr t fexpr t subr t fsubr t))
  179.  
  180. (setq max-autoload-evaluation 10)
  181.  
  182. ;(defun autoload-description (name)
  183. ;  (with (level 0) 
  184. ;    (do-autoload-description name level)
  185. ;))
  186.  
  187. ;; recursively evaluates or load description to obtain a wl_client
  188.  
  189. (defun do-autoload-description (name level)
  190.   (if (> level max-autoload-evaluation) name
  191.     (progn
  192.       (setq name
  193.     (if (# (type name) string-types)
  194.       (progn            ; atoms:
  195.         (if (= 'string (type name))
  196.           (: name (atom name)))    ; string->atom to test if defined
  197.         (if (boundp name)
  198.           (eval name)        ; defined: eval
  199.           (progn
  200.         (load name)        ; undefined, load and returns itself
  201.         name
  202.       )))
  203.       (# (type name) func-types)    ; function: called without args
  204.       (eval (list name))
  205.       (eval name)            ; others: evalb
  206.       ))
  207.       (if (= 'client (type name)) name
  208.     (do-autoload-description name (+ 1 level)
  209. ))))))
  210.  
  211. (defun autoload-description (name)
  212.   (do-autoload-description name 0)
  213. )
  214.  
  215. (defunq set-window args (std-resource-put 'GwmWindow args))
  216.  
  217. (defunq set-icon-window args (std-resource-put 'GwmIconWindow args))
  218.  
  219. (defunq set-icon args
  220.   (## (- (length args) 1) args (expand-pixmap (# (- (length args) 1) args)))
  221.   (std-resource-put 'GwmIconPixmap args)
  222. )
  223.  
  224. (defun expand-pixmap (obj)
  225.     (if (and obj (# (type obj) string-types))
  226.     (pixmap-make obj)
  227.     (eval obj)))    
  228.  
  229. (defunq set-placement args (std-resource-put 'GwmPlacement args))
  230.  
  231. (defunq set-icon-placement args (std-resource-put 'GwmIconPlacement args))
  232.  
  233.  
  234. ; per-screen data setting
  235. ; =======================
  236.  
  237. (defunq defname-in-screen-to args
  238.     (with (value (eval (# 0 args))
  239.          vars (sublist 1 (length args) args))
  240.       (for var vars
  241.            (defname var screen. value))))
  242.  
  243. (defunq set-color (name value)
  244.   (if (not (= screen. (namespace-of name)))
  245.     (progn
  246.       (defname name screen.)
  247.       (for screen (list-of-screens)
  248.     (set name (color-make value)))
  249. )))
  250.  
  251. (defunq set-pixmap args
  252.   (with (name (# 0 args)
  253.       pixmap-make-call (# 0 args 'pixmap-make))
  254.     (if (not (= screen. (namespace-of name)))
  255.       (progn
  256.     (defname name screen.)
  257.     (for screen (list-of-screens)
  258.       (set name (eval pixmap-make-call)))
  259. ))))
  260.  
  261.