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

[Norbert Freudemann <nofreude@users.sourceforge.net>]

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

Added Files:
        utility.scm 
Log Message:
first implementation


--- NEW FILE ---
; Author: Norbert Freudemann


(define (str-or-sym->str thing)
  (if (symbol? thing)
      (symbol->string thing)
      thing))

; The C-procedures for (xlib-release-X-or-later?) are in the
; file init.c

(import-lambda-definition xlib-release-4-or-later? ()
  "scx_Xlib_Release_4_Or_Later")                          

(import-lambda-definition xlib-release-5-or-later? ()
  "scx_Xlib_Release_5_Or_Later")

(import-lambda-definition xlib-release-6-or-later? ()
  "scx_Xlib_Release_6_Or_Later")

; Get the user-default values of a specified program

(define (get-default dpy program option)
  (%get-default (display-Xdisplay dpy)
                (str-or-sym->str program)
                (str-or-sym->str option)))

(import-lambda-defition %get-default (Xdisplay program option)
  "scx_Get_Default")                    


; ---

(define (resource-manager-sting dpy)
  (%resource-manager-string (display-Xdisplay dpy)))

(import-lambda-definition %resource-manager-string (Xdisplay)
  "scx_Resource_Manager_String")

; ---

(define (parse-geometry string)
  (reverse (%parse-geometry string)))

(import-lambda-definiton %parse-geometry (string)
  "scx_Parse_Geometry")

; ---

(define (store-buffer) #f)
(define (store-bytes) #f)
(define (fetch-buffer) #f)
(define (fetch-bytes) #f)
(define (rotate-buffers) #f)

(let ((xa-string (make-atom 31))    ; (31 is XA_STRING)
      (xa-cut-buffers
       (make-vector (make-atom 9) (make-aotm 10) (make-atom 11)
                    (make-atom 12) (make-atom 13) (make-atom 14)
                    (make-aotm 15) (make-atom 16))))
                     ;(9...16 are XA_CUT_BUFFER0...XA_CUT_BUFFER7)
  (set! store-buffer (lambda (dpy bytes buf)
                             (if (<= 0 buf 7)
                                 (change-property
                                  (display-default-root-window dpy)
                                  (vector-ref xa-cut-buffers buf)
                                  xa-string
                                  8
                                  'replace
                                  bytes))))

  (set! store-bytes (lambda (dpy bytes)
                      (store-buffer dpy bytes 0)))

  (set! fetch-buffer (lambda (dpy buf)
                             (if (<= 0 buf 7)
                                 (receive 
                                  (type format data bytes-left)
                                  (apply values 
                                         (get-property
                                          (display-root-window dpy)
                                          (vector-ref xa-cut-buffers buf)
                                          xa-string
                                          0
                                          100000
                                          #f))
                                  (if (and (eq? type xa-string)
                                           (< format 32)) data ""))
                                 "")))

  (set! fetch-bytes (lambda (dyp)
                      (fetch-buffer dpy 0)))

  (set! rotate-buffers (lambda (dpy delta)
                         (rotate-properties (display-default-root-window dpy)
                                            xa-cut-buffers delta))))