#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do x-list-extensions)' -s $0 "$@" # -*- scheme -*-
!#
;;; x-list-extensions --- list extensions and info about them

;; Copyright (C) 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: x-list-extensions [--name-only] [--details]
;;
;; Write extension info to stdout in the format:
;;
;;   OP EV ER  NAME
;;
;; where OP, EV, and ER are hexadecimal values (CARD8, 00 through ff)
;; representing the extension's major opcode, first-event and first-error.
;; If an extension is not "present", show "-- -- --" instead of OP, EV, ER.
;; Likewise, if an extension has no allocated first-event or first-error,
;; show "--" in its place.
;;
;; Optional arg ‘--name-only’ means omit OP, EV, ER info.
;; Optional arg ‘--details’ means show version (and/or other info)
;; if available, following the name, in parentheses.

;;; Code:

(define-module (ttn-do x-list-extensions)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (fso))
  #:use-module ((ttn-do zzz x-protocol) #:select ((-x . zx-x)))
  #:use-module ((ttn-do zzz x-umbrages) #:select (connection)))

(define (list-extensions q)
  (zx-x 'names (q 'ListExtensions)))

(define ((describe name-only? details? q) name)
  (or name-only?
      (let ((info (q 'QueryExtension #:name name)))
        (define (get name)
          (let ((s (number->string (zx-x name info) 16)))
            (cond ((string=? "0" s) "--")
                  ((= 1 (string-length s)) (string-append "0" s))
                  (else s))))
        (if (zero? (zx-x 'present info))
            (fso "-- -- --")
            (fso "~A ~A ~A"
                 (get 'major-opcode)
                 (get 'first-event)
                 (get 'first-error)))
        (fso "  ")))
  (fso "~A" name)
  (and details?
       (case (string->symbol name)
         ((DAMAGE)
          (let ((alist (q '(DAMAGE QueryVersion)
                          #:client-major-version 9
                          #:client-minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((DPMS)
          (let ((alist (q '(DPMS Capable))))
            (fso " (capable? ~A)"
                 (let ((raw (zx-x 'capable alist)))
                   (cond ((not raw) 'mu)
                         ((positive? raw) 'yes)
                         (else 'no))))))
         ((GLX)
          (let ((alist (q '(GLX QueryVersion))))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((MIT-SCREEN-SAVER)
          (let ((alist (q '(MIT-SCREEN-SAVER QueryVersion)
                          #:client-major-version 9
                          #:client-minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'server-major-version alist)
                 (zx-x 'server-minor-version alist))))
         ((MIT-SHM)
          (let ((alist (q '(MIT-SHM QueryVersion))))
            (fso " (~A.~A uid ~A gid ~A pixmap-format ~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist)
                 (zx-x 'uid alist)
                 (zx-x 'gid alist)
                 (zx-x 'pixmap-format alist))))
         ((RANDR)
          (let ((alist (q '(RANDR QueryVersion)
                          #:major-version 9
                          #:minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((RECORD)
          (let ((alist (q '(RECORD QueryVersion)
                          #:major-version 9
                          #:minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((RENDER)
          (let ((alist (q '(RENDER QueryVersion)
                          #:client-major-version 9
                          #:client-minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((SHAPE)
          (let ((alist (q '(SHAPE QueryVersion))))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((X-Resource)
          (let ((alist (q '(X-Resource QueryVersion))))
            (fso " (~A.~A)"
                 (zx-x 'server-major alist)
                 (zx-x 'server-minor alist))))
         ((XC-MISC)
          (let ((alist (q '(XC-MISC GetVersion)
                          #:client-major-version 9
                          #:client-minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'server-major-version alist)
                 (zx-x 'server-minor-version alist))))
         ((XFIXES)
          (let ((alist (q '(XFIXES QueryVersion)
                          #:client-major-version 9
                          #:client-minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((XFree86-DRI)
          (let ((alist (q '(XFree86-DRI QueryVersion))))
            (fso " (~A.~A.~A)"
                 (zx-x 'dri-major-version alist)
                 (zx-x 'dri-minor-version alist)
                 (zx-x 'dri-minor-patch alist))))
         ((XTEST)
          (let ((alist (q '(XTEST GetVersion)
                          #:major-version 9
                          #:minor-version 9)))
            (fso " (~A.~A)"
                 (zx-x 'major-version alist)
                 (zx-x 'minor-version alist))))
         ((XVideo)
          (let ((alist (q '(XVideo QueryExtension))))
            (fso " (~A.~A)"
                 (zx-x 'major alist)
                 (zx-x 'minor alist))))))
  (newline))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (let ((qop (qop<-args args '((name-only) (details)))))
    (let* ((conn (connection))
           (q (conn #:q)))
      (array-for-each (describe (qop 'name-only)
                                (qop 'details)
                                q)
                      (list-extensions q))
      (conn #:bye))))

;;; x-list-extensions ends here