Commit 6453d716 authored by Raymond Toy's avatar Raymond Toy

Fix #73: Update clx from upstream clx

parent d9487768
$Id: CHANGES,v 1.7 2009/06/17 18:22:45 rtoy Rel $
Details of changes since R5:
NOTE: this file is not updated any more. Changes since checking into
......
-*- Text -*-
$Id: NEWS,v 1.3 2009/06/17 18:22:45 rtoy Rel $
-- Changes in CLX 0.7.5, 2018-02-04 --
Various OpenMCL (CCL) issues fixed
Correct Decnet host parsing
Automated tests for "displays" and "core protocol"
Manual improvements with regard to inconsistencies with code
"RandR", "DRI2", "XC-MISC" and "Composite" extensions support
Thanks to Manuel Giraud, Daniel Kochmański, Tomasz Kurcz, Javier Olaechea, Luis Oliveira
-- Changes in CLX 0.7.4, 2017-08-18 --
Unit test framework fiasco has been added to the codebase.
Demos and tests are put in a separate system clx/demo and clx/tests.
Option `win-gravity' is fixed so it doesn't crash in some scenarios.
-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 ---
Support for Allegro CL (6.2 and later) (Mikel Evins)
......
$Id: README-R5,v 1.2 2009/06/17 18:22:45 rtoy Rel $
Original CLX README, retained for historical information
---
......
# CLX
CLX is an X11 client library for Common Lisp. The code was originally
taken from a CMUCL distribution, was modified somewhat in order to
make it compile and run under SBCL, then a selection of patches were
added from other CLXes around the net.
# Features
- SHAPE extension support (Gilbert Baumann)
- XFREE86-VIDMODE extension support (Iban Hatchondo)
- experimental RENDER extension support
(Gilbert Baumann and Christian Sunesson)
- X authority support that works with ssh forwarding (Eric Marsden via CMUCL)
- OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan)
- various bug fixes (Iban Hatchondo and a cast of several)
- a manual in texinfo format (Shawn Betts, Gilbert Baumann)
# Supported versions
CLX should work with SBCL, CCL, ECL and CLISP. If it doesn't please submit an
[issue](https://github.com/sharplispers/clx/issues/new) along with the version
information of your implementation.
Allegro Common Lisp users should use clx version maintained by Franz Inc., which can
be found at [https://github.com/franzinc/clx](https://github.com/franzinc/clx)
# Building using quicklisp
```lisp
(ql:quickload 'clx)
```
To load demos and tests as well:
```lisp
(ql:quickload 'clx/demo)
```
or if you want to use the latest version from git, clone this repository to
your local-project and use `quickload` as described above
```shell
cd ~/quicklisp/local-projects/
git clone git://github.com/sharplispers/clx.git
```
# Building using ASDF
If you don't have quicklisp installed you can use ASDF to load CLX. To do so clone this repository to either:
* `~/common-lisp`
* `~/.local/share/common-lisp/source/.`
where ASDF will look for system definitions by default
and then on the lisp REPL type
```lisp
(require 'asdf)
(asdf:load-system 'clx)
```
If you want to load clx from another location you have to first tell ASDF to
look in that directory by adding the directory to ASDF's central registry on every session.
```lisp
(require 'asdf)
(push "/path/to/the/clx/directory/" asdf:*central-registry*) ; Mind the trailing slash, it is important.
(asdf:load-system 'clx)
```
or you can configure ASDF to look in your directory as described in the [ASDF Manual](https://common-lisp.net/project/asdf/asdf.html#Configuring-ASDF-to-find-your-systems)
To load demo and test files as well:
```lisp
(asdf:load-system 'clx/demo)
```
# Demos
To test CLX (and get a small amount of Lisp advocacy), try loading the file
"demo/menu", and then executing the function xlib::just-say-lisp.
```lisp
(load "clx/demo/menu")
(xlib::just-say-lisp)
```
Note: If you're new to Lisp, be advised that despite the examples in
demo/, it's generally /not/ considered good style to switch to the
:xlib package and write your code in it. Spend some time with a
language reference to familiarize yourself with USE-PACKAGE, or
better yet, the USE option to DEFPACKAGE.
# Documentation
An up to date version of the manual can be found at [sharplispers.github.io/clx](https://sharplispers.github.io/clx/)
#Bug reports, new features, patches
Please use github to track issues:
# Contributing
To contribute submit a [pull request](https://github.com/sharplispers/clx/pulls)
To report bugs, request features, etc please use the [github issue tracker](https://github.com/sharplispers/clx/issues)
---
Heavy lifting by <Raymond.Wiker at fast.no>
ASDFized version by Daniel Barlow <dan at metacircles.com>
and Christophe Rhodes <csr21 at cam.ac.uk>
The sharplispers group on github have recently (November 2011)
"adopted" clx and maintain the version that lives at:
https://github.com/sharplispers/clx
#!/bin/bash
set -o errexit -o nounset
if [ "$TRAVIS_BRANCH" != "master" ]
then
echo "This commit was made against the $TRAVIS_BRANCH and not the master! No deploy!"
exit 0
fi
rev=$(git rev-parse --short HEAD)
mkdir -p stage/_book
command -v texi2any >/dev/null 2>&1 || { echo >&2 "texi2any is required but it's not installed. Aborting."; exit 1; }
texi2any --html manual/clx.texinfo --css-ref=style.css -o stage/_book
cp manual/style.css stage/_book
cd stage/_book
git init
git config user.name "Documentation Bot"
git config user.email "Bender@future.com"
git remote add upstream "https://$GH_TOKEN@github.com/sharplispers/clx.git"
git fetch upstream
git reset upstream/gh-pages
touch .
git add -A .
git commit -m "rebuild pages at ${rev}"
git push -q upstream HEAD:gh-pages
......@@ -23,29 +23,33 @@
(defpackage :clx-system (:use :cl :asdf))
(in-package :clx-system)
(pushnew :clx-ansi-common-lisp *features*)
(defclass clx-source-file (cl-source-file) ())
(defclass xrender-source-file (clx-source-file) ())
;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of
;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-)
(defclass example-source-file (cl-source-file) ())
(defclass legacy-file (static-file) ())
(defsystem CLX
:depends-on (#+sbcl sb-bsd-sockets)
:version "0.7.2"
(defsystem #:clx
:description "An implementation of the X Window System protocol in Lisp."
:author "Texas Instruments Incorporated.
Franz Inc, Berkeley, Ca.
Independent FOSS developers"
:maintainer "sharplispers"
:license "MIT"
:depends-on (#+(or ecl sbcl) sb-bsd-sockets)
:version "0.7.5"
:serial t
:default-component-class clx-source-file
:in-order-to ((test-op (test-op "clx/test")))
:components
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl allegro) (:file "dependent")
#-(or openmcl allegro lispworks) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
#+lispworks (:file "dep-lispworks")
(:file "macros")
(:file "bufmac")
(:file "buffer")
......@@ -64,8 +68,7 @@
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
(:module "extensions"
:components
((:file "shape")
(:file "big-requests")
......@@ -76,34 +79,15 @@
(:file "dpms")
(:file "xtest")
(:file "screensaver")
(:file "xinerama")))
(:module demo
:default-component-class example-source-file
:components
((:file "bezier")
;; KLUDGE: this requires "bezier" for proper operation,
;; but we don't declare that dependency here, because
;; asdf doesn't load example files anyway.
(:file "beziertest")
(:file "clclock")
(:file "clipboard")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
;; workaround the problem.
(:file "mandel")
(:file "menu")
(:file "zoid")))
(:module test
:default-component-class example-source-file
:components
((:file "image")
;; KLUDGE: again, this depends on "zoid"
(:file "trapezoid")))
(:file "randr")
(:file "xinerama")
(:file "dbe")
(:file "xc-misc")
(:file "dri2")
(:file "composite")))
(:static-file "NEWS")
(:static-file "CHANGES")
(:static-file "README")
(:static-file "README.md")
(:static-file "README-R5")
(:legacy-file "exclMakefile")
(:legacy-file "exclREADME")
......@@ -114,10 +98,10 @@
(:legacy-file "defsystem" :pathname "defsystem.lisp")
(:legacy-file "provide" :pathname "provide.lisp")
(:legacy-file "cmudep" :pathname "cmudep.lisp")
(:module manual
(:module "manual"
;; TODO: teach asdf how to process texinfo files
:components ((:static-file "clx.texinfo")))
(:module debug
(:module "debug"
:default-component-class legacy-file
:components
((:file "debug" :pathname "debug.lisp")
......@@ -127,10 +111,36 @@
(:file "trace" :pathname "trace.lisp")
(:file "util" :pathname "util.lisp")))))
(defmethod perform ((o load-op) (f example-source-file))
;; do nothing. We want to compile them when CLX is compiled, but
;; not load them when CLX is loaded.
t)
(defsystem #:clx/demo
:depends-on ("clx")
:components
((:module "demo"
:components
((:file "bezier")
(:file "beziertest" :depends-on ("bezier"))
(:file "clclock")
(:file "clipboard")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
;; workaround the problem.
(:file "mandel")
(:file "menu")
(:file "zoid")
(:file "image")
(:file "trapezoid" :depends-on ("zoid"))))))
(defsystem #:clx/test
:depends-on ("clx" "fiasco")
:perform (test-op (o s)
(uiop:symbol-call :fiasco :run-tests :xlib-test))
:components
((:module "tests"
:components
((:file "package")
(:file "util")
(:file "core-protocol" :depends-on ("package" "util"))))))
#+sbcl
(defmethod perform :around ((o compile-op) (f xrender-source-file))
......@@ -142,39 +152,28 @@
#+sbcl
(defmethod perform :around ((o compile-op) (f clx-source-file))
;; our CLX library should compile without WARNINGs, and ideally
;; without STYLE-WARNINGs. Since it currently does, let's enforce
;; it here so that we can catch regressions easily.
(let ((on-warnings (operation-on-warnings o))
(on-failure (operation-on-failure o)))
(unwind-protect
(progn
(setf (operation-on-warnings o) :error
(operation-on-failure o) :error)
;; a variety of accessors, such as AREF-CARD32, are not
;; declared INLINE. Without this (non-ANSI)
;; static-type-inference behaviour, SBCL emits an extra 100
;; optimization notes (roughly one fifth of all of the
;; notes emitted). Since the internals are unlikely to
;; change much, and certainly the internals should stay in
;; sync, enabling this extension is a win. (Note that the
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t)
(sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
(sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (and sadx (sb-c::policy-quality-name-p sadx))
;; no way of setting it back short of yet more yukky stuff
(proclaim `(optimize (,sadx 3))))
(if sadx-var
(progv (list sadx-var) (list t)
(call-next-method))
(call-next-method))))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))
;; a variety of accessors, such as AREF-CARD32, are not
;; declared INLINE. Without this (non-ANSI)
;; static-type-inference behaviour, SBCL emits an extra 100
;; optimization notes (roughly one fifth of all of the
;; notes emitted). Since the internals are unlikely to
;; change much, and certainly the internals should stay in
;; sync, enabling this extension is a win. (Note that the
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t)
(sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
(sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (and sadx (sb-c::policy-quality-name-p sadx))
;; no way of setting it back short of yet more yukky stuff
(proclaim `(optimize (,sadx 3))))
(if sadx-var
(progv (list sadx-var) (list t)
(call-next-method))
(call-next-method))))
#+sbcl
(defmethod perform :around (o (f clx-source-file))
......
......@@ -20,9 +20,6 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: debug.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(export '(display-listen
......
......@@ -20,9 +20,6 @@
;;; Created 07/15/87 by LaMott G. OREN
#cmu
(ext:file-comment "$Id: describe.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(defparameter *request-parameters* (make-array (length *request-names*)))
......
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
;;; This code was intended for CLUE. --FMG
#+cmu
(ext:file-comment "$Id: event-test.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(defpackage "XTEST"
(:use :xlib :common-lisp)
)
(in-package "XTEST")
(in-package :xtest :use '(:xlib :lisp))
(defstruct event
key ; Event key
......
......@@ -18,9 +18,6 @@
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment "$Id: keytrans.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(defun list-missing-keysyms ()
......
......@@ -32,9 +32,6 @@
;;; Created 09/14/87 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: trace.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(eval-when (load eval)
......
......@@ -20,9 +20,6 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: util.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(export '(display-root
......
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; Tests image code by randomly reading, copying and then writing images to
;;; the exact same place on the screen. If everything works, just the borders
;;; of the image windows appear. If one of these image windows is garbled,
;;; then somewhere something is broken. Entry point is the function
;;; IMAGE-TEST
(in-package :xlib)
(export '(image-test))
(defvar *image-test-host* "")
(defvar *image-test-nimages* 25)
(defvar *image-test-copy* t)
(defvar *image-test-copy-random-subimage* t)
(defvar *image-test-put-random-subimage* t)
(defvar *image-test-get-image-result-type-choices*
'(image-x image-x image-xy image-z))
(defvar *image-test-get-image-image-x-format-choices*
'(:xy-pixmap :z-pixmap))
(defun image-test
(&key
(host *image-test-host*)
(nimages *image-test-nimages*)
(copy *image-test-copy*)
(copy-random-subimage *image-test-copy-random-subimage*)
(put-random-subimage *image-test-put-random-subimage*)
(get-image-result-type-choices
*image-test-get-image-result-type-choices*)
(get-image-image-x-format-choices
*image-test-get-image-image-x-format-choices*))
(declare (ignore host))
(let* ((display nil)
(abort t)
(images nil))
(loop
(setq images nil)
(unwind-protect
(progn
(setq display (open-default-display))
(let* ((screen (display-default-screen display))
(window (screen-root screen))
(gcontext (create-gcontext
:foreground (screen-white-pixel screen)
:background (screen-black-pixel screen)
:drawable window
:font (open-font display "fixed"))))
(dotimes (i nimages)
(let ((image (image-test-get-image
window
get-image-result-type-choices
get-image-image-x-format-choices)))
(format t "~&Image=~S~%" image)
(let ((copy (if copy
(image-test-copy-image
image
copy-random-subimage)
image)))
(format t "~&Copy=~S~%" copy)
(push (list image copy) images)
(image-test-put-image
screen gcontext copy
(concatenate
'string (image-info image) (image-info copy))
put-random-subimage))))
(unless (y-or-n-p "More ") (return))
(setq abort nil)))
(close-display (shiftf display nil) :abort abort))
(sleep 10))
(reverse images)))
(defun image-test-choose (list)
(nth (random (length list)) list))
(defun image-test-get-image (window result-type-choices image-x-format-choices)
(let* ((x (random (floor (drawable-width window) 3)))
(y (random (floor (drawable-height window) 3)))
(hw (floor (- (drawable-width window) x) 3))
(hh (floor (- (drawable-height window) y) 3))
(width (+ hw hw (random hw)))
(height (+ hh hh (random hh)))
(result-type (image-test-choose result-type-choices))
(format
(ecase result-type
(image-x (image-test-choose image-x-format-choices))
(image-xy :xy-pixmap)
(image-z :z-pixmap)))
(image (get-image window :x x :y y :width width :height height
:format format :result-type result-type)))
(setf (getf (image-plist image) :root-x) x)
(setf (getf (image-plist image) :root-y) y)
image))
(defun image-test-subimage-parameters (image random-subimage-p)
(if random-subimage-p
(let* ((x (random (floor (image-width image) 3)))
(y (random (floor (image-height image) 3)))
(hw (floor (- (image-width image) x) 3))
(hh (floor (- (image-height image) y) 3))
(width (+ hw hw (random hw)))
(height (+ hh hh (random hh))))
(values x y width height))
(values 0 0 (image-width image) (image-height image))))
(defun image-test-copy-image (image random-subimage-p)
(let ((result-type
(if (zerop (random 2))
(type-of image)
(etypecase image
(image-x (ecase (image-x-format image)
(:xy-pixmap 'image-xy)
(:z-pixmap 'image-z)))
((or image-xy image-z) 'image-x)))))
(multiple-value-bind (x y width height)
(image-test-subimage-parameters image random-subimage-p)
(incf (getf (image-plist image) :root-x) x)
(incf (getf (image-plist image) :root-y) y)
(copy-image image :x x :y y :width width :height height
:result-type result-type))))
(defun image-test-put-image (screen gcontext image info random-subimage-p)
(multiple-value-bind (src-x src-y width height)
(image-test-subimage-parameters image random-subimage-p)
(let* ((border-width 1)
(root-x (getf (image-plist image) :root-x))
(root-y (getf (image-plist image) :root-y))
(x (+ src-x root-x (- border-width)))
(y (+ src-y root-y (- border-width))))
(unless (or (zerop width) (zerop height))
(let ((window
(create-window
:parent (screen-root screen) :x x :y y
:width width :height height
:border-width border-width
:background (screen-white-pixel screen)
:override-redirect :on)))
(map-window window)
(display-finish-output (drawable-display window))
(put-image window gcontext image
:x 0 :y 0 :src-x src-x :src-y src-y
:width width :height height)
(draw-image-glyphs window gcontext 0 (1- height) info)
(display-finish-output (drawable-display window))
window)))))
(defun image-info (image)
(etypecase image
(image-x (ecase (image-x-format image)
(:xy-pixmap "XXY")
(:z-pixmap "XZ ")))
(image-xy "XY ")
(image-z "Z ")))
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX trapezoid Extension test program
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun zoid-test ()
;; Display the part picture in /extensions/test/datafile
(let* ((display (open-default-display))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(loop
(event-case (display :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES
(draw-filled-trapezoids window gc '(10 20 30 40 100 200))
(setf (gcontext-trapezoid-alignment gc) :y)
(draw-filled-trapezoids window gc #(10 20 30 40 100 200))
(with-gcontext (gc :trapezoid-alignment :x)
(draw-filled-trapezoids window gc '(40 50 60 70 140 240)))
(setf (gcontext-trapezoid-alignment gc) :x)
(draw-filled-trapezoids window gc #(40 50 60 70 80 90))
(with-gcontext (gc :trapezoid-alignment :y)
(draw-filled-trapezoids window gc #(40 50 60 70 140 240)))
(draw-glyphs window gc 10 10 "Press any key to exit")
;; Returning non-nil causes event-case to exit
t))
(key-press () (return-from zoid-test t))))
(close-display display))))
......@@ -1208,7 +1208,9 @@ Returns a list of (host display-number screen protocol)."
(slash-i (or (position #\/ name) -1))
(colon-i (position #\: name :start (1+ slash-i)))
(decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
(host (subseq name (1+ slash-i) colon-i))
(host (subseq name (1+ slash-i) (if decnet-colon-p
(1+ colon-i)
colon-i)))
(dot-i (and colon-i (position #\. name :start colon-i)))
(display (when colon-i
(parse-integer name
......
......@@ -1014,7 +1014,9 @@ Returns a list of (host display-number screen protocol)."
(slash-i (or (position #\/ name) -1))
(colon-i (position #\: name :start (1+ slash-i)))
(decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
(host (subseq name (1+ slash-i) colon-i))
(host (subseq name (1+ slash-i) (if decnet-colon-p
(1+ colon-i)
colon-i)))
(dot-i (and colon-i (position #\. name