scheme/scwm-minimal.scm

   1 ;;;; $Id: scwm-minimal.scm,v 1.1 2000-01-07 06:33:26 tell Exp $
   2 ;;;; Copyright (C) 1997-1999 Maciej Stachowiak and Greg J. Badros
   3 ;;;; This file gets compiled directly into scwm
   4 ;;;; Scwm will eval these commands before reading
   5 ;;;; any other .scm file
   6 ;;;; In a sense, these are compiled-in primitives implemented in scheme
   7 ;;;; (these can get overridden later, of course)
   8
   9
  10 (define-public guile-version (+ (string->number (major-version))
  11                                 (/ (string->number (minor-version)) 10)))
  12
  13 ;; Turn off buffering so that we can see messages as
  14 ;; they are displayed (an issue in >= guile-1.3.2)
  15 (if (> guile-version 1.3)
  16     (setvbuf (current-output-port) _IONBF))
  17
  18 ;; Make quit an alias for scwm-quit
  19 (define quit scwm-quit)
  20 (undefine scwm-quit)
  21
  22 (define FIXED-FONT (make-font "fixed"))
  23
  24 ;;; Make some colors
  25
  26 ;;; Set some global options
  27 (set-not-menu-foreground! "black")
  28 (set-not-menu-background! "gray")
  29
  30
  31 (set-highlight-foreground! "black")
  32 (set-highlight-background! "gray")
  33 (set-icon-font! FIXED-FONT)
  34 (set-title-font! FIXED-FONT)
  35 (set-title-justify! 'center)
  36
  37 ;; temporary definitions for bootstrapping, use winops.scm to
  38 ;; redefine properly.
  39 (define hack-interactive-move rubber-band-move)
  40 (define hack-interactive-resize rubber-band-resize)
  41
  42
  43 ;;; Some functions for decoration bindings
  44 (define (resize-or-raise)
  45   "Perform a resize, raise, or lower based on the mouse-event-type.
  46 To be bound to a window decoration: click does `raise-window',
  47 motion does `interactive-resize', and double-click does
  48 `lower-window'."
  49   (case (mouse-event-type)
  50     ((click) (raise-window))
  51     ((motion) (hack-interactive-resize))
  52     ((double-click) (lower-window))))
  53
  54 (define (move-or-raise)
  55   "Perform a move, raise, or lower based on the mouse-event-type.
  56 To be bound to a window decoration: click does `raise-window',
  57 motion does `interactive-move', and double-click does
  58 `lower-window'."
  59   (case (mouse-event-type)
  60     ((click) (raise-window))
  61     ((motion) (hack-interactive-move))
  62     ((double-click) (lower-window))))
  63
  64 ;;; Initialize the decoration bindings to
  65 ;;; permit at least some useful behaviour
  66 (bind-mouse 'frame-corners 1 resize-or-raise)
  67
  68 (bind-mouse '(title frame-sides) 1 move-or-raise)
  69
  70 (bind-mouse 'icon 1 deiconify-window)
  71
  72 (let ((default-menu (make-menu
  73                      (list
  74                       (make-menuitem "Default Menu" #f)
  75                       (make-menuitem "Exit SCWM" quit))
  76                      (make-color "gray") (make-color "black")
  77                      (make-color "slate gray") FIXED-FONT)))
  78   (bind-mouse 'root 1 (lambda () (popup-menu default-menu))))
  79
  80 ;; GJB:FIXME:: Here I trade flexibility
  81 ;; for safety.  If this ever becomes an issue
  82 ;; we should consider exposing the X-grab-server, X-ungrab-server
  83 ;; primitives
  84 (define (with-grabbed-server thunk)
  85   "Execute THUNK with the X server grabbed."
  86   #f)
  87
  88 (let ((xgs X-grab-server)
  89       (xugs X-ungrab-server))
  90   (set! with-grabbed-server (lambda (thunk)
  91                               (dynamic-wind xgs thunk xugs))))
  92
  93 ;; now undefine the dangerous primitives
  94 (undefine X-grab-server)
  95 (undefine X-ungrab-server)
  96
  97 ;; END gross hack
  98
  99 (if (not (defined? 'run-hook))
 100     ;; GJB:FIXME:MS: I'd like a backtrace when a hook fails
 101     (define-public (run-hook hook-list . args)
 102       "Runs the procedures in HOOK-LIST, each getting ARGS as their arguments.
 103 If any error, the others still run.  The procedures are executed in the
 104 order in which they appear in HOOK-LIST"
 105       (for-each (lambda (p)
 106                   (catch #t
 107                          (lambda () (apply p args))
 108                          (lambda args
 109                            (display "Error running hook: ")
 110                            (write p)
 111                            (newline))))
 112                 hook-list)))
 113
 114
 115 (if (not (defined? 'reset-hook!))
 116     (defmacro-public reset-hook! (hook)
 117       `(set! ,hook ())))
 118
 119 (if (not (defined? 'make-hook))
 120     (begin
 121       ;; guile-1.3
 122       (define-public (make-hook . n) ())
 123       (define-public hook? list?))
 124     ;; guile-1.3.2 and later
 125     (define-public (hook? h)
 126       (and (pair? h) (eq? (car h) 'hook))))
 127
 128 (define-public (append-hook! hook proc)
 129   "Add PROC to HOOK at the end of the list."
 130   (add-hook! hook proc #t))
 131
 132 ;; GJB:FIXME:: this should not be public,
 133 ;; but I leave it public for now for easier debugging --07/03/99 gjb
 134 (define-public *scwm-modules* '())
 135
 136 (define-public (scwm-module-loaded? module)
 137   "Return #t iff MODULE has been loaded."
 138   (let ((entry (assoc module *scwm-modules*)))
 139     (and entry (null? (cdr entry)))))
 140
 141 ;;; GJB:FIXME:G1.3.2:  This might work in guile-1.3.2
 142 ;;  (environment-bound? module-environment name))
 143
 144
 145 (define (use-scwm-module-note-success module)
 146   (let ((entry (assoc module *scwm-modules*)))
 147     (if (not entry)
 148         (set! *scwm-modules* (cons (cons module '()) *scwm-modules*))
 149         (let ((eval-after-load-proc (cdr entry)))
 150           (if (not (null? eval-after-load-proc))
 151               (let ((answer (eval-after-load-proc)))
 152                 (set-cdr! entry '())
 153                 answer))))))
 154
 155 (define-public (eval-after-load module proc)
 156   "Run PROC after MODULE is loaded.
 157 Run PROC immediately if MODULE has already been loaded."
 158   (if (scwm-module-loaded? module)
 159       (proc)
 160       (set! *scwm-modules* (cons (cons module proc) *scwm-modules*))))
 161
 162 (define (process-use-scwm-module module)
 163   (if (symbol? module)
 164       (set! module (append '(app scwm) (list module))))
 165   (catch #t
 166          (lambda ()
 167            (process-use-modules (list module))
 168            (use-scwm-module-note-success module)
 169            (run-hook load-processing-hook -1)
 170            module)
 171          (lambda (key . args)
 172            (display "Error loading module: ")
 173            (display module) (newline)
 174            (catch #t
 175                   (lambda ()
 176                     (apply handle-system-error (cons key args))
 177                     (backtrace))
 178                   (lambda (key . args) #t))
 179            #f)))
 180
 181 (define-public (process-use-scwm-modules module-list)
 182   "Returns a list of all the modules loaded in successfully.
 183 Modules that failed to load have #f in their place in the
 184 list instead of the module."
 185   (map process-use-scwm-module (reverse module-list)))
 186
 187 (defmacro use-scwm-modules modules
 188   `(process-use-scwm-modules ',modules))
 189
 190 (X-property-set! 'root-window "_WIN_WM_NAME" "scwm")
 191 (X-property-set! 'root-window "_WIN_WM_VERSION" (scwm-version))