;;; -*-Scheme-*-
;;;
-;;; $Id: xterm.scm,v 1.47 1995/09/15 19:28:51 cph Exp $
+;;; $Id: xterm.scm,v 1.48 1995/09/27 16:24:07 cph Exp $
;;;
;;; Copyright (c) 1989-95 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
(define-primitives
- (x-open-display 1)
+ (x-change-property 7)
(x-close-all-displays 0)
(x-close-display 1)
(x-close-window 1)
+ (x-convert-selection 6)
+ (x-delete-property 3)
(x-display-descriptor 1)
(x-display-flush 1)
(x-display-process-events 2)
(x-display-sync 2)
+ (x-get-atom-name 2)
+ (x-get-selection-owner 2)
+ (x-get-window-property 7)
+ (x-intern-atom 3)
+ (x-max-request-size 1)
+ (x-open-display 1)
+ (x-select-input 3)
+ (x-send-selection-notify 6)
+ (x-set-selection-owner 4)
+ (x-window-andc-event-mask 2)
(x-window-beep 1)
(x-window-display 1)
(x-window-flush 1)
+ (x-window-id 1)
(x-window-map 1)
+ (x-window-or-event-mask 2)
(x-window-raise 1)
(x-window-set-event-mask 2)
(x-window-set-icon-name 2)
(xterm-enable-cursor 2)
(xterm-erase-cursor 1)
(xterm-map-x-coordinate 2)
- (xterm-map-y-coordinate 2)
(xterm-map-x-size 2)
+ (xterm-map-y-coordinate 2)
(xterm-map-y-size 2)
(xterm-open-window 3)
(xterm-reconfigure 3)
(xterm-write-substring! 7)
(xterm-x-size 1)
(xterm-y-size 1))
-
+\f
;; These constants must match "microcode/x11base.c"
(define-integrable event:process-output -2)
(define-integrable event:process-status -3)
(define-integrable event-type:unmap 12)
(define-integrable event-type:take-focus 13)
(define-integrable event-type:visibility 14)
-(define-integrable number-of-event-types 15)
+(define-integrable event-type:selection-clear 15)
+(define-integrable event-type:selection-notify 16)
+(define-integrable event-type:selection-request 17)
+(define-integrable event-type:property-notify 18)
+(define-integrable number-of-event-types 19)
;; This mask contains button-down, button-up, configure, focus-in,
-;; key-press, expose, destroy, map, unmap, and visibility.
-(define-integrable event-mask #x5e57)
+;; key-press, expose, destroy, map, unmap, visibility,
+;; selection-clear, selection-notify, selection-request, and
+;; property-notify.
+(define-integrable event-mask #x7de57)
\f
(define-structure (xterm-screen-state
(constructor make-xterm-screen-state (xterm display))
((PROCESS-STATUS-CHANGE) event:process-status)
((INTERRUPT) (loop))
(else (read-event-1 display block?))))))))))
-
+\f
(define (preview-event-stream)
(set! previewer-registration
(permanently-register-input-thread-event
(if (not reading-event?)
(let ((event (x-display-process-events x-display-data 2)))
(if event
- (if (and signal-interrupts?
- (fix:= event-type:key-press (vector-ref event 0))
- (string-find-next-char (vector-ref event 2)
- #\BEL))
- (begin
- (clean-event-queue x-display-events)
- (signal-interrupt!))
- (enqueue!/unsafe x-display-events event))))))))
+ (preview-event event)))))))
unspecific)
-\f
+
+(define (wait-for-event interval predicate process-event)
+ (let ((timeout (+ (real-time-clock) interval)))
+ (fluid-let ((reading-event? #t))
+ (let loop ()
+ (let ((event (x-display-process-events x-display-data 2)))
+ (if event
+ (if (and (vector? event) (predicate event))
+ (or (process-event event) (loop))
+ (begin (preview-event event) (loop)))
+ (and (< (real-time-clock) timeout)
+ (loop))))))))
+
+(define (preview-event event)
+ (cond ((not (vector? event))
+ (enqueue!/unsafe x-display-events event))
+ ((and signal-interrupts?
+ (fix:= event-type:key-press (vector-ref event 0))
+ (string-find-next-char (vector-ref event 2) #\BEL))
+ (clean-event-queue x-display-events)
+ (signal-interrupt!))
+ ((vector-ref event-handlers (vector-ref event 0))
+ (enqueue!/unsafe x-display-events event))))
+
(define (clean-event-queue queue)
;; Flush keyboard and mouse events from the input queue. Other
;; events are harmless and must be processed regardless.
(cdr events)))
((null? events))
(enqueue!/unsafe queue (car events))))
-
+\f
(define (process-change-event event)
(cond ((fix:= event event:process-output) (accept-process-output))
((fix:= event event:process-status) (handle-process-status-changes))
(else (error "Illegal change event:" event))))
(define (process-special-event event)
- (let ((handler (vector-ref event-handlers (vector-ref event 0)))
- (screen (xterm->screen (vector-ref event 1))))
+ (let ((handler (vector-ref event-handlers (vector-ref event 0))))
(and handler
- screen
- (handler screen event))))
+ (if (vector-ref event 1)
+ (let ((screen (xterm->screen (vector-ref event 1))))
+ (and screen
+ (handler screen event)))
+ (handler #f event)))))
(define event-handlers
(make-vector number-of-event-types false))
(set! ignore-button-state 'IGNORE-BUTTON-UP)
#f)
(let ((xterm (screen-xterm screen)))
- (make-input-event 'BUTTON
- execute-button-command
- screen
- (make-down-button (vector-ref event 4))
- (xterm-map-x-coordinate xterm (vector-ref event 2))
- (xterm-map-y-coordinate xterm (vector-ref event 3)))))))
+ (make-input-event
+ 'BUTTON
+ execute-button-command
+ screen
+ (make-down-button (vector-ref event 4))
+ (xterm-map-x-coordinate xterm (vector-ref event 2))
+ (xterm-map-y-coordinate xterm (vector-ref event 3)))))))
(define-event-handler event-type:button-up
(lambda (screen event)
(set! ignore-button-state #f)
#f)
(let ((xterm (screen-xterm screen)))
- (make-input-event 'BUTTON
- execute-button-command
- screen
- (make-up-button (vector-ref event 4))
- (xterm-map-x-coordinate xterm (vector-ref event 2))
- (xterm-map-y-coordinate xterm (vector-ref event 3)))))))
+ (make-input-event
+ 'BUTTON
+ execute-button-command
+ screen
+ (make-up-button (vector-ref event 4))
+ (xterm-map-x-coordinate xterm (vector-ref event 2))
+ (xterm-map-y-coordinate xterm (vector-ref event 3)))))))
\f
(define-event-handler event-type:configure
(lambda (screen event)
(set! last-focus-time (vector-ref event 2))
(make-input-event 'SELECT-SCREEN select-screen screen)))
\f
+;;;; Atoms
+
+(define built-in-atoms
+ '#(#F
+ PRIMARY
+ SECONDARY
+ ARC
+ ATOM
+ BITMAP
+ CARDINAL
+ COLORMAP
+ CURSOR
+ CUT_BUFFER0
+ CUT_BUFFER1
+ CUT_BUFFER2
+ CUT_BUFFER3
+ CUT_BUFFER4
+ CUT_BUFFER5
+ CUT_BUFFER6
+ CUT_BUFFER7
+ DRAWABLE
+ FONT
+ INTEGER
+ PIXMAP
+ POINT
+ RECTANGLE
+ RESOURCE_MANAGER
+ RGB_COLOR_MAP
+ RGB_BEST_MAP
+ RGB_BLUE_MAP
+ RGB_DEFAULT_MAP
+ RGB_GRAY_MAP
+ RGB_GREEN_MAP
+ RGB_RED_MAP
+ STRING
+ VISUALID
+ WINDOW
+ WM_COMMAND
+ WM_HINTS
+ WM_CLIENT_MACHINE
+ WM_ICON_NAME
+ WM_ICON_SIZE
+ WM_NAME
+ WM_NORMAL_HINTS
+ WM_SIZE_HINTS
+ WM_ZOOM_HINTS
+ MIN_SPACE
+ NORM_SPACE
+ MAX_SPACE
+ END_SPACE
+ SUPERSCRIPT_X
+ SUPERSCRIPT_Y
+ SUBSCRIPT_X
+ SUBSCRIPT_Y
+ UNDERLINE_POSITION
+ UNDERLINE_THICKNESS
+ STRIKEOUT_ASCENT
+ STRIKEOUT_DESCENT
+ ITALIC_ANGLE
+ X_HEIGHT
+ QUAD_WIDTH
+ WEIGHT
+ POINT_SIZE
+ RESOLUTION
+ COPYRIGHT
+ NOTICE
+ FONT_NAME
+ FAMILY_NAME
+ FULL_NAME
+ CAP_HEIGHT
+ WM_CLASS
+ WM_TRANSIENT_FOR))
+\f
+(define (intern-atom display name soft?)
+ (or (hash-table/get built-in-atoms-table name #f)
+ (let ((table (car (display/cached-atoms-tables display))))
+ (or (hash-table/get table name #f)
+ (let ((atom
+ (x-intern-atom display
+ (string-upcase (symbol->string name))
+ soft?)))
+ (if (not (= atom 0))
+ (hash-table/put! table name atom))
+ atom)))))
+
+(define (get-atom-name display atom)
+ (if (< atom (vector-length built-in-atoms))
+ (vector-ref built-in-atoms atom)
+ (let ((table (cdr (display/cached-atoms-tables display))))
+ (or (hash-table/get table atom #f)
+ (let ((symbol
+ (let ((string (x-get-atom-name display atom)))
+ (if (not (string? string))
+ (error "X error (XGetAtomName):" string atom))
+ (intern string))))
+ (hash-table/put! table atom symbol)
+ symbol)))))
+
+(define built-in-atoms-table
+ (let ((n (vector-length built-in-atoms)))
+ (let ((table (make-eq-hash-table n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (hash-table/put! table (vector-ref built-in-atoms i) i))
+ table)))
+
+(define display/cached-atoms-tables
+ (let ((table (make-eq-hash-table)))
+ (lambda (display)
+ (or (hash-table/get table display #f)
+ (let ((result (cons (make-eq-hash-table) (make-eqv-hash-table))))
+ (hash-table/put! table display result)
+ result)))))
+\f
+;;;; Properties
+
+(define (get-xterm-property xterm property type delete?)
+ (get-window-property (x-window-display xterm)
+ (x-window-id xterm)
+ property
+ type
+ delete?))
+
+(define (get-window-property display window property type delete?)
+ (let ((property (intern-atom display property #f))
+ (type-atom (intern-atom display type #f)))
+ (let ((v (x-get-window-property display window property 0 0 #f type-atom)))
+ (and v
+ (vector-ref v 3)
+ (let ((data
+ (get-window-property-1 display window property delete?
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2))))
+ (if type
+ data
+ (cons (get-atom-name display (vector-ref v 0))
+ data)))))))
+
+(define (get-window-property-1 display window property delete?
+ type format bytes)
+ (let ((read-once
+ (lambda (offset bytes n delete?)
+ (let ((v
+ (x-get-window-property display window property
+ (quotient offset 4)
+ (integer-ceiling n 4)
+ delete? type)))
+ (if (not (and v
+ (= type (vector-ref v 0))
+ (= format (vector-ref v 1))
+ (= (- bytes n) (vector-ref v 2))
+ (vector-ref v 3)
+ (= n
+ (if (= format 8)
+ (string-length (vector-ref v 3))
+ (* (vector-length (vector-ref v 3))
+ (quotient format 8))))))
+ (error "Window property changed:" v))
+ (vector-ref v 3))))
+ (qb (* (property-quantum display) 4)))
+ (if (<= bytes qb)
+ (read-once 0 bytes bytes delete?)
+ (let ((b/w (quotient format 8)))
+ (let ((result
+ (if (= b/w 1)
+ (make-string bytes)
+ (make-vector (quotient bytes b/w))))
+ (move!
+ (if (= b/w 1)
+ substring-move-right!
+ subvector-move-right!)))
+ (let loop ((offset 0) (bytes bytes))
+ (if (<= bytes qb)
+ (move! (read-once offset bytes bytes delete?)
+ 0 (quotient bytes b/w)
+ result (quotient offset b/w))
+ (begin
+ (move! (read-once offset bytes qb #f) 0 (quotient qb b/w)
+ result (quotient offset b/w))
+ (loop (+ offset qb) (- bytes qb)))))
+ result)))))
+\f
+(define (put-window-property display window property type format data)
+ (let ((put-1
+ (let ((property (intern-atom display property #f))
+ (type (intern-atom display type #f)))
+ (lambda (mode data)
+ (let ((status
+ (x-change-property display window property type format
+ mode data)))
+ (cond ((= status x-status:success)
+ #t)
+ ((= status x-status:bad-alloc)
+ (x-delete-property display window property)
+ #f)
+ (else
+ (error "X error (XChangeProperty):" status)))))))
+ (qw (property-quantum display))
+ (i/w (quotient 32 format))
+ (subpart (if (= format 8) substring subvector))
+ (end (if (= format 8) (string-length data) (vector-length data)))
+ (mode:replace 0)
+ (mode:append 2))
+ (let loop ((start 0) (nw (integer-ceiling end i/w)) (mode mode:replace))
+ (if (<= nw qw)
+ (put-1 mode (if (= start 0) data (subpart data start end)))
+ (let ((end (+ start (* qw i/w))))
+ (and (put-1 mode (subpart data start end))
+ (loop end (- nw qw) mode:append)))))))
+
+(define-integrable (property-quantum display)
+ ;; The limit on the size of a property quantum is the maximum
+ ;; request size less the size of the largest header needed. The
+ ;; relevant packets are the GetProperty reply packet (header size 8)
+ ;; and the ChangeProperty request packet (header size 6). The magic
+ ;; number 8 is the larger of these two header sizes.
+ (fix:- (x-max-request-size display) 8))
+
+(define (delete-xterm-property xterm property)
+ (delete-window-property (x-window-display xterm)
+ (x-window-id xterm)
+ property))
+
+(define (delete-window-property display window property)
+ (x-delete-property display window (intern-atom display property #f)))
+
+(define-integrable x-status:success 0)
+(define-integrable x-status:bad-request 1)
+(define-integrable x-status:bad-value 2)
+(define-integrable x-status:bad-window 3)
+(define-integrable x-status:bad-pixmap 4)
+(define-integrable x-status:bad-atom 5)
+(define-integrable x-status:bad-cursor 6)
+(define-integrable x-status:bad-font 7)
+(define-integrable x-status:bad-match 8)
+(define-integrable x-status:bad-drawable 9)
+(define-integrable x-status:bad-access 10)
+(define-integrable x-status:bad-alloc 11)
+(define-integrable x-status:bad-color 12)
+(define-integrable x-status:bad-gc 13)
+(define-integrable x-status:bad-id-choice 14)
+(define-integrable x-status:bad-name 15)
+(define-integrable x-status:bad-length 16)
+(define-integrable x-status:bad-implementation 17)
+\f
+;;;; Selection Source
+
+(define (os/interprogram-cut string push?)
+ push?
+ (if (eq? x-display-type (current-display-type))
+ (let ((xterm (screen-xterm (selected-screen))))
+ (own-selection (x-window-display xterm)
+ 'PRIMARY
+ (x-window-id xterm)
+ last-focus-time
+ string))))
+
+(define (own-selection display selection window time value)
+ (and (eqv? window
+ (let ((selection (intern-atom display selection #f)))
+ (x-set-selection-owner display selection window time)
+ (x-get-selection-owner display selection)))
+ (begin
+ (hash-table/put! (display/selection-records display)
+ selection
+ (make-selection-record window time value))
+ #t)))
+
+(define display/selection-records
+ (let ((table (make-eq-hash-table)))
+ (lambda (display)
+ (or (hash-table/get table display #f)
+ (let ((result (make-eq-hash-table)))
+ (hash-table/put! table display result)
+ result)))))
+
+(define (display/selection-record display name time)
+ (let ((record (hash-table/get (display/selection-records display) name #f)))
+ (and record
+ (<= (selection-record/time record) time)
+ record)))
+
+(define (display/delete-selection-record! display name time)
+ (let ((records (display/selection-records display)))
+ (if (let ((record (hash-table/get records name #f)))
+ (and record
+ (<= (selection-record/time record) time)))
+ (hash-table/remove! records name))))
+
+(define-structure (selection-record (conc-name selection-record/))
+ (window #f read-only #t)
+ (time #f read-only #t)
+ (value #f read-only #t))
+\f
+(define-event-handler event-type:selection-request
+ (lambda (screen event)
+ screen
+ (let ((display x-display-data))
+ (let ((requestor (selection-request/requestor event))
+ (selection
+ (get-atom-name display (selection-request/selection event)))
+ (target
+ (get-atom-name display (selection-request/target event)))
+ (property
+ (get-atom-name display (selection-request/property event)))
+ (time (selection-request/time event)))
+ (let ((reply
+ (lambda (property)
+ (x-send-selection-notify display
+ requestor
+ (selection-request/selection event)
+ (selection-request/target event)
+ (intern-atom display property #f)
+ time)
+ (x-display-flush display))))
+ (if (let ((record (display/selection-record display selection time)))
+ (and record
+ property
+ (process-selection-request display requestor property
+ target time record #f)))
+ (reply property)
+ (reply #f)))))
+ #f))
+
+(define-structure (selection-request (type vector)
+ (initial-offset 2)
+ (conc-name selection-request/))
+ (requestor #f read-only #t)
+ (selection #f read-only #t)
+ (target #f read-only #t)
+ (property #f read-only #t)
+ (time #f read-only #t))
+
+(define-event-handler event-type:selection-clear
+ (lambda (screen event)
+ screen
+ (let ((display x-display-data))
+ (display/delete-selection-record!
+ display
+ (get-atom-name display (selection-clear/selection event))
+ (selection-clear/time event)))
+ #f))
+
+(define-structure (selection-clear (type vector)
+ (initial-offset 2)
+ (conc-name selection-clear/))
+ (selection #f read-only #t)
+ (time #f read-only #t))
+\f
+(define (process-selection-request display requestor property target time
+ record multiple?)
+ (let ((win
+ (lambda (format data)
+ (and (put-window-property display requestor property target format
+ data)
+ target))))
+ (case target
+ ((STRING)
+ (win 8 (selection-record/value record)))
+ ((TARGETS)
+ (win 32 (atoms->property-data '(STRING TIMESTAMP) display)))
+ ((TIMESTAMP)
+ (win 32 (timestamp->property-data (selection-record/time record))))
+ ((MULTIPLE)
+ (and multiple?
+ (let ((alist
+ (property-data->atom-alist
+ (or (get-window-property display requestor property
+ 'MULTIPLE #f)
+ (error "Missing MULTIPLE property:" property))
+ display)))
+ (for-each (lambda (entry)
+ (set-car! entry
+ (process-selection-request display
+ requestor
+ (cdr entry)
+ (car entry)
+ time
+ record
+ #t)))
+ alist)
+ (win 32 (atom-alist->property-data alist display)))))
+ (else #f))))
+
+(define (atoms->property-data names display)
+ (list->vector (map (lambda (name) (intern-atom display name #f)) names)))
+
+(define (timestamp->property-data time)
+ (vector time))
+
+(define (property-data->atom-alist data display)
+ (if (not (even? (vector-length data)))
+ (error:bad-range-argument data 'PROPERTY-DATA->ATOM-ALIST))
+ (let loop ((atoms
+ (map (lambda (atom) (get-atom-name display atom))
+ (vector->list data))))
+ (if (null? atoms)
+ '()
+ (cons (cons (car atoms) (cadr atoms))
+ (loop (cddr atoms))))))
+
+(define (atom-alist->property-data alist display)
+ (atoms->property-data (let loop ((alist alist))
+ (if (null? alist)
+ '()
+ (cons (caar alist)
+ (cons (cdar alist)
+ (loop (cdr alist))))))
+ display))
+\f
+;;;; Selection Sink
+
+(define (os/interprogram-paste)
+ (and (eq? x-display-type (current-display-type))
+ (xterm/interprogram-paste (screen-xterm (selected-screen)))))
+
+(define (xterm/interprogram-paste xterm)
+ (with-thread-events-blocked
+ (lambda ()
+ (let ((selection 'PRIMARY)
+ (property '_EDWIN_TMP_)
+ (time last-focus-time))
+ (cond ((display/selection-record (x-window-display xterm)
+ selection time)
+ => selection-record/value)
+ ((request-selection xterm selection 'STRING property time)
+ (receive-selection xterm property 'STRING time))
+ ((request-selection xterm selection 'C_STRING property time)
+ (receive-selection xterm property 'C_STRING time))
+ (else #f))))))
+
+(define (with-thread-events-blocked thunk)
+ (let ((block-events?))
+ (dynamic-wind (lambda ()
+ (set! block-events? (block-thread-events))
+ unspecific)
+ thunk
+ (lambda ()
+ (if (not block-events?) (unblock-thread-events))))))
+
+(define (request-selection xterm selection target property time)
+ (let ((display (x-window-display xterm))
+ (window (x-window-id xterm)))
+ (let ((selection (intern-atom display selection #f))
+ (target (intern-atom display target #f))
+ (property (intern-atom display property #f)))
+ (x-delete-property display window property)
+ (x-convert-selection display selection target property window time)
+ (x-display-flush display)
+ (eq? 'REQUEST-GRANTED
+ (wait-for-event x-selection-timeout
+ (lambda (event)
+ (fix:= event-type:selection-notify (vector-ref event 0)))
+ (lambda (event)
+ (and (= window (selection-notify/requestor event))
+ (= selection (selection-notify/selection event))
+ (= target (selection-notify/target event))
+ (= time (selection-notify/time event))
+ (if (= property (selection-notify/property event))
+ 'REQUEST-GRANTED
+ 'REQUEST-DENIED))))))))
+
+(define-structure (selection-notify (type vector)
+ (initial-offset 2)
+ (conc-name selection-notify/))
+ (requestor #f read-only #t)
+ (selection #f read-only #t)
+ (target #f read-only #t)
+ (property #f read-only #t)
+ (time #f read-only #t))
+\f
+(define (receive-selection xterm property target time)
+ (let ((value (get-xterm-property xterm property #f #t)))
+ (if (not value)
+ (error "Missing selection value."))
+ (if (eq? 'INCR (car value))
+ (receive-incremental-selection xterm property target time)
+ (and (eq? target (car value))
+ (cdr value)))))
+
+(define (receive-incremental-selection xterm property target time)
+ ;; I have been unable to get this to work, after a day of hacking,
+ ;; and I don't have any idea why it won't work. Given that this
+ ;; will only be used for selections of size exceeding ~230kb, I'm
+ ;; going to leave it broken. -- cph
+ (x-window-flush xterm)
+ (let loop ((time time) (accum '()))
+ (let ((time
+ (wait-for-window-property-change xterm property time
+ x-property-state:new-value)))
+ (if (not time)
+ (error "Timeout waiting for PROPERTY-NOTIFY event."))
+ (let ((value (get-xterm-property xterm property target #t)))
+ (if (not value)
+ (error "Missing property after PROPERTY-NOTIFY event."))
+ (if (string-null? value)
+ (apply string-append (reverse! accum))
+ (loop time (cons value accum)))))))
+
+(define (wait-for-window-property-change xterm property time state)
+ (wait-for-event x-selection-timeout
+ (lambda (event)
+ (fix:= event-type:property-notify (vector-ref event 0)))
+ (let ((property (intern-atom (x-window-display xterm) property #f))
+ (window (x-window-id xterm)))
+ (lambda (event)
+ (and (= window (property-notify/window event))
+ (= property (property-notify/property event))
+ (< time (property-notify/time event))
+ (= state (property-notify/state event))
+ (property-notify/time event))))))
+
+(define-structure (property-notify (type vector)
+ (initial-offset 2)
+ (conc-name property-notify/))
+ (window #f read-only #t)
+ (property #f read-only #t)
+ (time #f read-only #t)
+ (state #f read-only #t))
+
+(define-integrable x-property-state:new-value 0)
+(define-integrable x-property-state:delete 1)
+
+(define x-selection-timeout 5000)
+\f
+;;;; Initialization
+
(define reading-event?)
(define signal-interrupts?)
(define last-focus-time)
projects / mit-scheme.git / commitdiff