NetNews Usenet Archive 1992 #20/NN_1992_20.iso/spool/comp/lang/lisp/2432

Text File | 1992-09-14 | 10.6 KB | 308 lines

Newsgroups: comp.lang.lisp
Path: sparky!uunet!zaphod.mps.ohio-state.edu!darwin.sura.net!Sirius.dfn.de!solaris.rz.tu-clausthal.de!news!artemis!dehning
From: [e-mail] (Oliver Dehning)
Subject: Re: (ed), CLX, and OpenWindows
Message-ID: <[e-mail]>
Sender: [e-mail] (News Service)
Reply-To: [e-mail]
Organization: Universitaet Hannover, Theoretische Nachrichtentechnik
References: <[e-mail]>
Date: Tue, 15 Sep 1992 06:45:21 GMT
Lines: 295

In article [e-mail], [e-mail] (Graham Williams) writes:
>In Lucid Common Lisp and CMU Common Lisp, for example, when running
>under X11 I have things configured to run the supplied X11 Window based
>editor when (ed) is called (both implemented, I presume, using CLX).  This
>works fine under straight X11R4.  Under OpenWindows, with the default
>usage of xauthority rather than xhost, I get the following
>authorization error:
>
>    Connection failure to X11.0 server unix display 0: Internal error
>    during connection authorization check
>
>    (xlib::x-error xlib:connection-failure :major-version 11
>    :minor-version ...)
>
>Short of asking OpenWindows not to use the xauthority security
>mechanism, how can I convince OpenWindows that the editor is
>authorised!

There is a patch to CLX from Simon Leinen <[e-mail]>:

---------- Cut here ------------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File Name:      clx-auth.lisp
;;; Description:  Reading X Authority Databases
;;; Author:      Simon Leinen ([e-mail])
;;; Date Created: 14-Feb-92
;;; RCS $Header$
;;; RCS $Log$
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;; Copyright (C) 1992 Ecole Polytechnique Federale de Lausanne
;;;
;;; 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.
;;;
;;; EPFL provides this software "as is" without express or implied
;;; warranty.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This replacement version of the CLX open-display function tries to
;;; retrieve the authorization data for the given display from a file.
;;; The name of the authorization file is given by the XAUTHORITY
;;; environment variable.  If this variable is not set, a file named
;;; ".Xauthority" under the user's home directory is scanned.  In
;;; connection with automatic cookie setup as with XDM, this change
;;; increases network transparency (and security).
;;;
;;; Tested on:
;;;    CMU CL 16e (Sun 4)
;;;    Allegro CL 4.1 (Sun 4) and 4.1BETA (SGI)
;;;    Lucid CL 4.0.2 (Sun 4)
;;;    Genera 8.0.2 (UX Ivory)
;;; [should work with other releases of these Lisps as well.]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "XLIB")

#-CLX-MIT-R5
(defvar *output-buffer-size* 8192)

(defun open-display (host  &rest options &key (display 0) protocol
             authorization-name authorization-data &allow-other-keys)
  ;; Changed by Simon Leinen <[e-mail]>:
  ;; If no authorization information is given, try to find it out.
  ;;
  (declare (type integer display)
       (dynamic-extent options))
  (declare (values display))
  (unless (or authorization-name authorization-data)
    (multiple-value-setq (authorization-name authorization-data)
      (get-authorization-key host display protocol)))
  ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
  (let* ((stream (open-x-stream host display protocol))
     (disp (apply #'make-buffer
              *output-buffer-size*
              'make-display-internal
              :host host
              :display display
              :output-stream stream
              :input-stream stream
              :allow-other-keys t
              options))
     (ok-p nil))
    (unwind-protect
    (progn
      (display-connect disp
               :authorization-name authorization-name
               :authorization-data authorization-data)
      (initialize-resource-allocator disp)
      (initialize-predefined-atoms disp)
      (initialize-extensions disp)
      (setq ok-p t))
      (unless ok-p (close-display disp :abort t)))
    disp))

(defun get-authorization-key (host display protocol)
  (let ((auth-file (authority-file-name)))
    (if (not (probe-file auth-file))
    (values nil nil)
      (let ((display-number-as-string (prin1-to-string display)))
    (ecase protocol
      ((:tcp nil)
       (let ((host-address (host-address host :internet)))
         (with-open-file (auth auth-file)
           (loop
           (multiple-value-bind (address number name data)
               (read-xauth-entry auth)
             (unless address
               (return nil))
             (when (and (equal host-address address)
                (string= number display-number-as-string))
               (return (values name data)))))))))))))

(defun authority-file-name ()
  (let ((xauthority (getenv "XAUTHORITY")))
    (or xauthority
    #-Genera
    (make-pathname
     :name ".Xauthority"
     :type nil
     :defaults (user-homedir-pathname))
    #+Genera
    (make-pathname
     :name ""
     :type "Xauthority"
     :defaults (user-homedir-pathname)))))

(defun getenv (name)
  #+Allegro (sys:getenv name)
  #+Lucid (lcl:environment-variable name)
  #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
  #-(or Allegro Lucid CMU)
  nil)

(defun read-xauth-entry (stream)
  (let ((family (net-read-short stream nil)))
    (and family
     (let* ((address (net-read-short-length-string stream))
        (number (net-read-short-length-string stream))
        (name (net-read-short-length-string stream))
        (data (net-read-short-length-string stream)))
       (values (decode-address family address) number name data)))))

(defun decode-address (family address)
  (ecase family
    ((0)
     (list :internet (char-int (schar address 0))
       (char-int (schar address 1))
       (char-int (schar address 2))
       (char-int (schar address 3))))
    ((256)
     ;; is it ok to return address as a string?
     (list :unix address))))

(defun net-read-short (stream &optional (errorp t) (eof-value nil))
  (let ((high-byte-char (read-char stream errorp nil)))
    (if (not high-byte-char)
    eof-value
    (+ (* (char-int high-byte-char) 256)
       (char-int (read-char stream))))))

(defun net-read-short-length-string (stream)
  (let ((length (net-read-short stream)))
    (let ((string (make-string length)))
      (dotimes (k length)
    (setf (schar string k) (read-char stream)))
      string)))

#+Allegro
(defun host-address (host &optional (family :internet))
  (labels ((no-host-error ()
         (error "Unknown host ~S" host))
       (no-address-error ()
         (error "Host ~S has no ~S address" host family)))
    (let ((hostent (ipc::gethostbyname host)))
      (unwind-protect
       (progn
         (when (zerop hostent)
           (no-host-error))
         (ecase family
           ((:internet)
        (unless (= (ipc::hostent-addrtype hostent) 2)
          (no-address-error))
        (assert (= (ipc::hostent-length hostent) 4))
        (let ((addr (ipc::hostent-addr hostent)))
           (when (or (member comp::.target.
                     '(:hp :sgi4d :sony :dec3100)
                     :test #'eq)
                 (probe-file "/lib/ld.so"))
             ;; BSD 4.3 based systems require an extra indirection
             (setq addr (si:memref-int addr 0 0 :unsigned-long)))
          (list :internet
            (si:memref-int addr 0 0 :unsigned-byte)
            (si:memref-int addr 1 0 :unsigned-byte)
            (si:memref-int addr 2 0 :unsigned-byte)
            (si:memref-int addr 3 0 :unsigned-byte))))))
    (ff:free-cstruct hostent)))))

#+CMU
(defun host-address (host &optional (family :internet))
  (labels ((no-host-error ()
         (error "Unknown host ~S" host))
       (no-address-error ()
         (error "Host ~S has no ~S address" host family)))
    (let ((hostent (ext:lookup-host-entry host)))
      (when (not hostent)
    (no-host-error))
      (ecase family
    ((:internet)
     (unless (= (ext::host-entry-addr-type hostent) 2)
       (no-address-error))
     (let ((addr (first (ext::host-entry-addr-list hostent))))
       (list :internet
         (ldb (byte 8 24) addr)
         (ldb (byte 8 16) addr)
         (ldb (byte 8  8) addr)
         (ldb (byte 8  0) addr))))))))

#+Lucid
(progn

(lcl:def-foreign-struct sockaddr-in
            (family :type :signed-16bit)
            (port :type :unsigned-16bit)
            (addr :type (:array :unsigned-8bit (4)))
            (zero :type (:array :signed-8bit (8))))

(lcl:def-foreign-struct hostent
            (h_name :type (:pointer :char))
            (h_aliases :type (:pointer (:pointer :char)))
            (h_addrtype :type :signed-32bit)
            (h_length :type :signed-32bit)
            (h_addr_list :type (:pointer (:array (:pointer :char) (1)))))

(lcl:def-foreign-function
 (libc-gethostbyname (:return-type (:pointer hostent))
             (:name "_gethostbyname")
             (:language :c))
 (name (:pointer :character)))

(defun malloc-foreign-string (string)
  (check-type string string)
  (let ((foreign-string
     (lcl:malloc-foreign-pointer
      :type
      `(:pointer (:array :character (,(1+ (length string))))))))
    (setf (lcl:foreign-string-value foreign-string) string)
    (setf (lcl:foreign-pointer-type foreign-string)
      '(:pointer :character))
    foreign-string))

(defun host-address (name &optional (family :internet))
  (check-type name string)
  (let ((foreign-name (malloc-foreign-string name)))
    (unwind-protect
    (let ((hostent (libc-gethostbyname foreign-name)))
      (if (zerop (lcl:foreign-pointer-address hostent))
          nil
        (case (hostent-h_addrtype hostent)
           ((2) ;AF_INET
            (and (eq family :internet)
             (cons :internet
                   (make-ip-address
                (lcl:foreign-aref
                 (hostent-h_addr_list hostent)
                 0)))))
           (otherwise nil))))
      (lcl:free-foreign-pointer foreign-name))))

(defun make-ip-address (foreign-char-pointer)
  (setf (lcl:foreign-pointer-type foreign-char-pointer)
    '(:pointer (:array :unsigned-8bit (4))))
  (list (lcl:foreign-aref foreign-char-pointer 0)
    (lcl:foreign-aref foreign-char-pointer 1)
    (lcl:foreign-aref foreign-char-pointer 2)
    (lcl:foreign-aref foreign-char-pointer 3)))

);; #+Lucid

---------- Cut here ------------------------------------



 Oliver Dehning
______________________________________________________________________________
Dipl.-Ing. Oliver Dehning               |Universitaet Hannover
RFC:[e-mail]                   |Theoretische Nachrichtentechnik
X400:c=de;a=dbp;p=uni-hannover;ou=tnt;s=dehning|Appelstr. 9A
PSI: 4551104302::dehning               |D W3000 Hannover 1
FAX: [phone]  PHONE: [phone] |Federal Republic of Germany