[Scsh-checkins] CVS: scx/scheme/xlib cursor-type.scm,NONE,1.1 cursor.scm,NONE,1.1

[David Frese <frese@users.sourceforge.net>]

Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv1823

Added Files:
        cursor-type.scm cursor.scm 
Log Message:
added support for the cursor functions.


--- NEW FILE ---
(define-record-type cursor :cursor
  (really-make-cursor tag Xcursor display) 
  cursor? 
  (tag cursor-tag cursor-set-tag!)
  (Xcursor real-cursor-Xcursor cursor-set-Xcursor!)
  (display cursor-display cursor-set-display!))

(define (cursor-Xcursor cursor)
  (if (none-resource? cursor)
      0
      (real-cursor-Xcursor cursor)))

(define (make-cursor Xcursor display finalize?)
  (if (= 0 Xcursor)
      none-resource
      (let ((maybe-cursor (cursor-list-find Xcursor)))
        (if maybe-cursor
            maybe-cursor
            (let ((cursor (really-make-cursor #f Xcursor display)))
              (add-finalizer! cursor cursor-list-delete!)
              (if finalize?
                  (add-finalizer! cursor free-cursor))
              (cursor-list-set! Xcursor cursor)
              cursor)))))

;; ...

(define (free-cursor cursor)
  (let ((Xdisplay (display-Xdisplay (cursor-display cursor)))
        (Xcursor (cursor-Xcursor cursor)))
    (if (integer? Xcursor)
        (begin
          (%free-cursor Xdisplay Xcursor)
          (cursor-set-Xcursor! cursor 'already-destroyed)))))

(import-lambda-definition %free-cursor (Xdisplay Xcursor)
  "Free_Cursor")

;; All cursor records need to be saved in a weak-list, to have only one record
;; for the same Xlib cursor-structure in the heap.

(define *weak-cursor-list* (make-integer-table))

(define (cursor-list-find Xcursor)
  (let ((r (table-ref *weak-cursor-list* Xcursor)))
    (if r 
        (weak-pointer-ref r)
        r)))

(define (cursor-list-set! Xcursor cursor)
  (let ((p (make-weak-pointer cursor)))
    (table-set! *weak-cursor-list* Xcursor p)))

(define (cursor-list-delete! cursor)
  (table-set! *weak-cursor-list* 
              (cursor-Xcursor cursor) #f))
--- NEW FILE ---
(define (create-pixmap-cursor src mask x y foreground background)
  (let ((display (pixmap-display src)))
    (make-cursor (%create-pixmap-cursor (display-Xdisplay display)
                                        (pixmap-Xpixmap src)
                                        (pixmap-Xpixmap mask)
                                        x y
                                        (color-Xcolor foreground)
                                        (color-Xcolor background))
                 display
                 #t)))

(define create-cursor create-pixmap-cursor) ;; for compatibility with elk

(import-lambda-definition %create-pixmap-cursor (Xdisplay src mask x y f b)
  "scx_Create_Pixmap_Cursor")

(define (create-glyph-cursor src src-char mask mask-char foreground background)
  (let ((display (pixmap-display src)))
    (make-cursor (%create-glyph-cursor (display-Xdisplay display)
                                       (pixmap-Xpixmap src)
                                       src-char
                                       (pixmap-Xpixmap mask)
                                       mask-char
                                       (color-Xcolor foreground)
                                       (color-Xcolor background))
                 display
                 #t)))

(import-lambda-definition %create-glyph-cursor 
                          (Xdisplay src srcc mask maskc f b)
  "scx_Create_Glyph_Cursor")

(define (create-font-cursor display src-char)
  (let ((font (load-font display "cursor")))
    (create-glyph-cursor font src-char
                         font (+ 1 src-char)
                         (make-color 0 0 0)
                         (make-color 1 1 1))
    ;; elk protects that with unwind-protect, and calls unload-font to free 
    ;; the font, but we free it anyway on garbage-collection...(??)
    ;;(unload-font font)
    ))

(define (recolor-cursor cursor foreground background)
  (%recolor-cursor (display-Xdisplay (cursor-display cursor))
                   (cursor-Xcursor cursor)
                   foreground background))

(import-lambda-definition %recolor-cursor (Xdisplay Xcursor f b)
  "scx_Recolor_Cursor")