cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-frametrans.el

   1 ;;; xwem-frametrans.el --- Transparency frames support.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Thu Dec  2 10:35:14 MSK 2004
   7 ;; Keywords: xwem
   8 ;; X-CVS: $Id: xwem-frametrans.el,v 1.2 2005-04-04 19:54:12 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;; Not yet fully functional.  To start using it do:
  32 ;;
  33 ;;   (add-hook 'xwem-frame-creation-hook 'xwem-ft-mask-init)
  34 ;;
  35 ;; It will apply masking to every newly created frame.
  36 ;;
  37 ;; For masking on already exsting frame, do something like:
  38 ;;
  39 ;;   H-: (xwem-ft-mask-init (xwem-frame-selected))
  40
  41 ;;; Code:
  42 \f
  43
  44 (require 'xwem-load)
  45 (require 'xlib-xshape)
  46 (require 'xwem-frame)
  47
  48 (defstruct xwem-frame-ft
  49   frame
  50   mask
  51   gc
  52   bgc
  53   saved-height
  54   saved-width
  55
  56   plist)
  57
  58 (defmacro xwem-frame-ft-get-prop (xff prop)
  59   `(plist-get (xwem-frame-ft-plist ,xff) ,prop))
  60 (defmacro xwem-frame-ft-rem-prop (xff prop)
  61   `(setf (xwem-frame-ft-plist ,xff)
  62          (plist-remprop (xwem-frame-ft-plist ,xff) ,prop)))
  63 (defmacro xwem-frame-ft-set-prop (xff prop val)
  64   `(if ,val
  65        (setf (xwem-frame-ft-plist ,xff)
  66              (plist-put (xwem-frame-ft-plist ,xff) ,prop ,val))
  67      (xwem-frame-ft-rem-prop ,xff ,prop)))
  68
  69 \f
  70 ;;; Functions
  71 (define-xwem-deffered xwem-ft-fill-mask (frame)
  72   "Fill the FRAME with mask."
  73   (let* ((xff (and (xwem-frame-p frame)
  74                    (xwem-frame-get-prop frame 'xwem-frame-ft)))
  75          (mask (and xff (xwem-frame-ft-mask xff)))
  76          (xgc (and xff (xwem-frame-ft-gc xff)))
  77          (xmgc (and xff (xwem-frame-ft-bgc xff))))
  78 ;         (plist (and xff (xwem-frame-ft-plist xff))))
  79     (when (and (X-Pixmap-p mask)
  80                (X-Gc-p xgc)
  81                (X-Gc-p xmgc))
  82       (XFillRectangle (xwem-dpy) mask xgc 0 0
  83                       (xwem-frame-width frame) (xwem-frame-height frame))
  84       (xwem-win-map #'(lambda (w)
  85                         (XFillRectangle (xwem-dpy) mask xmgc
  86                                         (+ (xwem-win-x w)
  87                                            (xwem-win-border-width w))
  88                                         (+ (xwem-win-y w)
  89                                            (xwem-win-border-width w))
  90                                         (- (xwem-win-width w)
  91                                            (xwem-win-border-width w)
  92                                            (xwem-win-border-width w))
  93                                         (- (xwem-win-height w)
  94                                            (xwem-win-border-width w)
  95                                            (xwem-win-border-width w)))
  96                         (let ((cl (xwem-win-cl w))
  97                               clg)
  98                           (when (and (xwem-cl-p cl) (xwem-cl-active-p cl))
  99                             (setq clg (xwem-cl-xgeom cl))
 100                             (XFillRectangle (xwem-dpy) mask xgc
 101                                             (X-Geom-x clg)
 102                                             (X-Geom-y clg)
 103                                             (X-Geom-width-with-borders clg)
 104                                             (X-Geom-height-with-borders clg)))))
 105                     (xwem-frame-selwin frame))
 106       (X-XShapeMask (xwem-dpy) (xwem-frame-xwin frame)
 107                     X-XShape-Bounding X-XShapeSet 0 0 mask))))
 108
 109 (defun xwem-ft-mask-init (frame &optional ft-properties)
 110   "Initialize transparency mask for FRAME."
 111   (let* ((xpx (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)))
 112                              (xwem-frame-xwin frame) 1
 113                              (xwem-frame-width frame) (xwem-frame-height frame)))
 114          (gc xwem-misc-mask-fgc)
 115          (bgc xwem-misc-mask-bgc))
 116
 117     (XFillRectangle (xwem-dpy) xpx gc 0 0
 118                     (xwem-frame-width frame)
 119                     (xwem-frame-height frame))
 120     (xwem-frame-put-prop frame 'xwem-frame-ft
 121       (make-xwem-frame-ft :frame frame
 122                           :mask xpx
 123                           :gc gc
 124                           :bgc bgc
 125                           :saved-height (xwem-frame-height frame)
 126                           :saved-width (xwem-frame-width frame)
 127                           :plist ft-properties))
 128
 129     (xwem-ft-fill-mask frame)))
 130
 131 (define-xwem-deffered xwem-ft-mask-resize (frame)
 132   "Resize FRAME's transparency mask."
 133   (let ((xff (and (xwem-frame-p frame)
 134                   (xwem-frame-get-prop frame 'xwem-frame-ft))))
 135     (when xff
 136       (when (or (not (xwem-frame-ft-saved-height xff))
 137                 (not (xwem-frame-ft-saved-width xff))
 138                 (> (xwem-frame-width frame)
 139                    (xwem-frame-ft-saved-width xff))
 140                 (> (xwem-frame-height frame)
 141                    (xwem-frame-ft-saved-height xff)))
 142         ;; Recreate pixmap
 143         (XFreePixmap (xwem-dpy) (xwem-frame-ft-mask xff))
 144
 145         (setf (xwem-frame-ft-mask xff)
 146               (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy)
 147                                                        :id (X-Dpy-get-id (xwem-dpy)))
 148                              (xwem-frame-xwin frame) 1
 149                              (xwem-frame-width frame) (xwem-frame-height frame)))
 150         (setf (xwem-frame-ft-saved-width xff) (xwem-frame-width frame))
 151         (setf (xwem-frame-ft-saved-height xff) (xwem-frame-height frame))
 152         ))))
 153
 154 (defun xwem-ft-mask-deinit (frame)
 155   "Denitialize transparency mask for FRAME."
 156   (let* ((xff (and (xwem-frame-p frame)
 157                    (xwem-frame-get-prop frame 'xwem-frame-ft)))
 158          (xpx (xwem-frame-ft-mask xff)))
 159     (xwem-frame-rem-prop frame 'xwem-frame-ft)
 160     (XFreePixmap (xwem-dpy) xpx)
 161     (X-XShapeMask (xwem-dpy) (xwem-frame-xwin frame)
 162                   X-XShape-Bounding X-XShapeSet 0 0 nil)))
 163
 164 (defun xwem-frame-set-transparency (frame prop val)
 165   "Set frame transparency."
 166   (xwem-frame-put-prop frame prop val)
 167
 168   (if val
 169       (xwem-ft-mask-init frame)
 170     (xwem-ft-mask-deinit frame)))
 171
 172 (defun xwem-frame-get-transparency (frame prop)
 173   "Return FRAME's transparency."
 174   (xwem-frame-get-prop frame prop))
 175
 176 ;;;; Commands
 177 ;;;###autoload(autoload 'xwem-frame-transparency "xwem-frametrans" nil t)
 178 (define-xwem-command xwem-frame-transparency (frame &optional toggle)
 179   "Toggle transparency for FRAME.
 180 If TOGGLE is positive number - enable.
 181 If TOGGLE is negative number - disable."
 182   (xwem-interactive (list (xwem-frame-selected)
 183                           xwem-prefix-arg))
 184
 185   (xwem-frame-set-property
 186    frame 'transparency
 187    (if (null toggle)
 188        (not (xwem-frame-property frame 'transparency))
 189      (> (prefix-numeric-value toggle) 0))))
 190
 191 \f
 192 (provide 'xwem-frametrans)
 193
 194 ;; On-load actions:
 195 (add-hook 'xwem-frame-resize-hook 'xwem-ft-mask-resize)
 196
 197 (defadvice xwem-win-set-cl (after trans-frame activate)
 198   "Fill frame when window changes its client."
 199   (xwem-ft-fill-mask (xwem-win-frame (ad-get-arg 0))))
 200
 201 (defadvice xwem-win-redraw-win-1 (after trans-frame activate)
 202   "Fill frame transparency mask."
 203   (xwem-ft-fill-mask (xwem-win-frame (ad-get-arg 0))))
 204
 205 (define-xwem-frame-property transparency
 206   "Make frame to be transparent."
 207   :type 'boolean
 208   :set 'xwem-frame-set-transparency
 209   :get 'xwem-frame-get-transparency)
 210
 211 ;;; xwem-frametrans.el ends here