From bdb966b22ea563a7dfa1f464a1b6cb6d8b5a712c Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 29 Apr 2003 14:08:02 +0000 Subject: [PATCH] r4703: *** empty log message *** --- debian/rules | 2 +- tests/Makefile | 6 +- tests/file-socket.lisp | 42 ------------ tests/getenv.lisp | 53 ++++++++++----- tests/gethostname.lisp | 26 ++----- tests/getshells.lisp | 47 ------------- tests/run-examples.lisp | 39 ----------- tests/test-examples.lisp | 43 ------------ tests/{c-test-fns.c => uffi-c-test-lib.c} | 2 +- .../{c-test-fns.lisp => uffi-c-test-lib.lisp} | 58 ++++------------ tests/union.lisp | 68 ++++--------------- uffi-tests.asd | 6 +- 12 files changed, 78 insertions(+), 314 deletions(-) delete mode 100644 tests/file-socket.lisp delete mode 100644 tests/getshells.lisp delete mode 100644 tests/run-examples.lisp delete mode 100644 tests/test-examples.lisp rename tests/{c-test-fns.c => uffi-c-test-lib.c} (95%) rename tests/{c-test-fns.lisp => uffi-c-test-lib.lisp} (62%) diff --git a/debian/rules b/debian/rules index c83af85..a96513c 100755 --- a/debian/rules +++ b/debian/rules @@ -61,7 +61,7 @@ install: build dh_installdirs -p $(debpkg-tests) $(clc-tests)/tests $(lib-dir) dh_install -p $(debpkg-tests) $(pkg-tests).asd $(clc-tests) dh_install -p $(debpkg-tests) "tests/*.lisp" $(clc-tests)/tests - dh_install -p $(debpkg-tests) "tests/c-test-fns.so" $(lib-dir) + dh_install -p $(debpkg-tests) "tests/uffi-c-test-lib.so" $(lib-dir) dh_link -p $(debpkg-tests) $(clc-tests)/$(pkg-tests).asd $(clc-systems)/$(pkg-tests).asd # Build architecture-independent files here. diff --git a/tests/Makefile b/tests/Makefile index 3a4d2e9..88fda03 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.19 2003/04/29 12:42:03 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.20 2003/04/29 14:08:02 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -21,7 +21,7 @@ include ../Makefile.common distclean: clean -base=c-test-fns +base=uffi-c-test-lib source=$(base).c object=$(base).o shared_lib=$(base).so @@ -32,7 +32,7 @@ all: $(shared_lib) linux: $(source) Makefile gcc -fPIC -DPIC -c $(source) -o $(object) gcc -shared $(object) -o $(shared_lib) - #gcc -shared -Wl,-soname,c-test-fns $(object) -o $(shared_lib) + #gcc -shared -Wl,-soname,uffi-c-test-lib $(object) -o $(shared_lib) rm $(object) mac: diff --git a/tests/file-socket.lisp b/tests/file-socket.lisp deleted file mode 100644 index 67fe886..0000000 --- a/tests/file-socket.lisp +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: file-socket.cl -;;;; Purpose: UFFI Example file to get a socket on a file -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Jul 2002 -;;;; -;;;; $Id: file-socket.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package :cl-user) - -;; Values for linux -(uffi:def-constant PF_UNIX 1) -(uffi:def-constant SOCK_STREAM 1) - -(uffi:def-function ("socket" c-socket) - ((family :int) - (type :int) - (protocol :int)) - :returning :int) - -(uffi:def-function ("connect" c-connect) - ((sockfd :int) - (serv-addr :void-pointer) - (addr-len :int)) - :returning :int) - -(defun connect-to-file-socket (filename) - (let ((socket (c-socket PF_UNIX SOCK_STREAM 0))) - (if (plusp socket) - (let ((stream (c-connect socket filename (length filename)))) - stream) - (error "Unable to create socket")))) diff --git a/tests/getenv.lisp b/tests/getenv.lisp index 17d2758..aae7317 100644 --- a/tests/getenv.lisp +++ b/tests/getenv.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: getenv.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ +;;;; $Id: getenv.lisp,v 1.2 2003/04/29 14:08:02 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,32 +16,49 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :cl-user) +(in-package :uffi-tests) (uffi:def-function ("getenv" c-getenv) ((name :cstring)) :returning :cstring) +(uffi:def-function ("setenv" c-setenv) + ((name :cstring) + (value :cstring) + (overwrite :int)) + :returning :int) + +(uffi:def-function ("unsetenv" c-unsetenv) + ((name :cstring)) + :returning :void) + (defun my-getenv (key) "Returns an environment variable, or NIL if it does not exist" (check-type key string) (uffi:with-cstring (key-native key) (uffi:convert-from-cstring (c-getenv key-native)))) - -#+examples-uffi -(progn - (flet ((print-results (str) - (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) - (print-results "USER") - (print-results "_FOO_"))) - - -#+test-uffi -(progn - (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") - (util.test:test (and (stringp (my-getenv "USER")) - (< 0 (length (my-getenv "USER")))) - t :fail-info "Error retrieving getenv") -) + +(defun my-setenv (key name &optional (overwrite t)) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (check-type name string) + (setq overwrite (if overwrite 1 0)) + (uffi:with-cstrings ((key-native key) + (name-native name)) + (c-setenv key-native name-native (if overwrite 1 0)))) + +(defun my-unsetenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstrings ((key-native key)) + (c-unsetenv key-native))) + +(deftest getenv.1 (my-getenv "__UFFI_FOO1__") nil) +(deftest setenv.1 (my-setenv "__UFFI_FOO1__" "UFFI-TEST") 0) +(deftest getenv.2 (my-getenv "__UFFI_FOO1__") "UFFI-TEST") +(deftest setenv.2 (my-unsetenv "__UFFI_FOO1__") nil) +(deftest getenv.3 (my-getenv "__UFFI_FOO1__") nil) + + diff --git a/tests/gethostname.lisp b/tests/gethostname.lisp index a6e1b0e..e973891 100644 --- a/tests/gethostname.lisp +++ b/tests/gethostname.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: gethostname.lisp,v 1.3 2002/12/02 13:21:43 kevin Exp $ +;;;; $Id: gethostname.lisp,v 1.4 2003/04/29 14:08:02 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :cl-user) +(in-package :uffi-tests) ;;; This example is inspired by the example on the CL-Cookbook web site @@ -44,23 +44,11 @@ (uffi:convert-from-foreign-string name) (error "gethostname() failed.")))) -#+examples-uffi -(progn - (format t "~&Hostname (technique 1): ~A" (gethostname)) - (format t "~&Hostname (technique 2): ~A" (gethostname2))) +(deftest gethostname.1 (stringp (gethostname)) t) +(deftest gethostname.2 (stringp (gethostname2)) t) +(deftest gethostname.3 (plusp (length (gethostname))) t) +(deftest gethostname.4 (plusp (length (gethostname2))) t) +(deftest gethostname.5 (gethostname) #.(gethostname2)) -#+test-uffi -(progn - (let ((hostname1 (gethostname)) - (hostname2 (gethostname2))) - - (util.test:test (and (stringp hostname1) (stringp hostname2)) t - :fail-info "gethostname not string") - (util.test:test (and (not (zerop (length hostname1))) - (not (zerop (length hostname2)))) t - :fail-info "gethostname length 0") - (util.test:test (string= hostname1 hostname1) t - :fail-info "gethostname techniques don't match")) - ) diff --git a/tests/getshells.lisp b/tests/getshells.lisp deleted file mode 100644 index 1b05d10..0000000 --- a/tests/getshells.lisp +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: getshells.cl -;;;; Purpose: UFFI Example file to get lisp of legal shells -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: getshells.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package :cl-user) - - -(uffi:def-function "setusershell" - nil - :returning :void) - -(uffi:def-function "endusershell" - nil - :returning :void) - -(uffi:def-function "getusershell" - nil - :returning :cstring) - -(defun getshells () - "Returns list of valid shells" - (setusershell) - (let (shells) - (do ((shell (uffi:convert-from-cstring (getusershell)) - (uffi:convert-from-cstring (getusershell)))) - ((null shell)) - (push shell shells)) - (endusershell) - (nreverse shells))) - -#+examples-uffi -(format t "~&Shells: ~S" (getshells)) - diff --git a/tests/run-examples.lisp b/tests/run-examples.lisp deleted file mode 100644 index 7e80a3f..0000000 --- a/tests/run-examples.lisp +++ /dev/null @@ -1,39 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: run-examples.cl -;;;; Purpose: Load and execute all examples for UFFI -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: run-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -#-uffi (asdf:oos 'asdf:load-op :uffi) - -(pushnew :examples-uffi cl:*features*) - -(flet ((load-test (name) - (load (make-pathname :defaults *load-truename* :name name)))) - (load-test "c-test-fns") - (load-test "arrays") - (load-test "union") - (load-test "strtol") - (load-test "atoifl") - (load-test "gettime") - (load-test "getenv") - (load-test "gethostname") - (load-test "getshells") - (load-test "compress")) - -(setq cl:*features* (remove :examples-uffi cl:*features*)) - - - diff --git a/tests/test-examples.lisp b/tests/test-examples.lisp deleted file mode 100644 index 5f780d4..0000000 --- a/tests/test-examples.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: test-examples.cl -;;;; Purpose: Load and execute all examples for UFFI -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: test-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -#-uffi (asdf:oos 'asdf:load-op :uffi) - -(unless (ignore-errors (find-package :util.test)) - (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*))) - -(defun do-tests () - (pushnew :test-uffi cl:*features*) - (util.test:with-tests (:name "UFFI-Tests") - (setq util.test:*break-on-test-failures* nil) - (flet ((load-test (name) - (load (make-pathname :name name :defaults *load-truename*)))) - (load-test "c-test-fns") - (load-test "arrays") - (load-test "union") - (load-test "strtol") - (load-test "atoifl") - (load-test "gettime") - (load-test "getenv") - (load-test "gethostname") - (load-test "getshells") - (load-test "compress")) - (setq cl:*features* (remove :test-uffi cl:*features*)))) - -(do-tests) - diff --git a/tests/c-test-fns.c b/tests/uffi-c-test-lib.c similarity index 95% rename from tests/c-test-fns.c rename to tests/uffi-c-test-lib.c index 20a5c2f..d8e9b49 100644 --- a/tests/c-test-fns.c +++ b/tests/uffi-c-test-lib.c @@ -6,7 +6,7 @@ * Programer: Kevin M. Rosenberg * Date Started: Mar 2002 * - * CVS Id: $Id: c-test-fns.c,v 1.5 2002/03/21 10:06:52 kevin Exp $ + * CVS Id: $Id: uffi-c-test-lib.c,v 1.1 2003/04/29 14:08:02 kevin Exp $ * * This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg * diff --git a/tests/c-test-fns.lisp b/tests/uffi-c-test-lib.lisp similarity index 62% rename from tests/c-test-fns.lisp rename to tests/uffi-c-test-lib.lisp index 4ff8fb9..20f4ccb 100644 --- a/tests/c-test-fns.lisp +++ b/tests/uffi-c-test-lib.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: c-test-fns.lisp,v 1.4 2002/11/18 04:53:31 kevin Exp $ +;;;; $Id: uffi-c-test-lib.lisp,v 1.1 2003/04/29 14:08:02 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,13 +16,14 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :cl-user) +(in-package :uffi-tests) (unless (uffi:load-foreign-library - (uffi:find-foreign-library "c-test-fns" - (list *load-truename* "/home/kevin/debian/src/uffi/examples/")) + (uffi:find-foreign-library "uffi-c-test-lib" + (list *load-truename* + "/usr/lib/")) :supporting-libraries '("c")) - (warn "Unable to load c-test-fns library")) + (warn "Unable to load uffi-c-test-lib library")) (uffi:def-function ("cs_to_upper" cs-to-upper) ((input (* :unsigned-char))) @@ -77,45 +78,10 @@ (half-double-vector +double-vec-length+ (system:vector-sap vec))) vec)) -#+examples-uffi -(format t "~&(string-to-upper \"this is a test\") => ~A" - (string-to-upper "this is a test")) +(deftest c-test.1 (string-to-upper "this is a test") "THIS IS A TEST") +(deftest c-test.2 (string-to-upper nil) nil) +(deftest c-test.3 (string-count-upper "This is a Test") 2) +(deftest c-test.4 (string-count-upper nil) -1) +(deftest c-test.5 (test-half-double-vector) + (0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)) -#+examples-uffi -(format t "~&(string-to-upper nil) => ~A" - (string-to-upper nil)) - -#+examples-uffi -(format t "~&(string-count-upper \"This is a Test\") => ~A" - (string-count-upper "This is a Test")) - -#+examples-uffi -(format t "~&(string-count-upper nil) => ~A" - (string-count-upper nil)) - -#+examples-uffi -(format t "~&Half vector: ~S" (test-half-double-vector)) - - - -#+test-uffi -(progn - (util.test:test (string= (string-to-upper "this is a test") "THIS IS A TEST") - t - :test #'eql - :fail-info "Error with string-to-upper") - (util.test:test (string-to-upper nil) nil - :fail-info "string-to-upper with nil failed") - (util.test:test (string-count-upper "This is a Test") - 2 - :test #'eql - :fail-info "Error with string-count-upper") - (util.test:test (string-count-upper nil) -1 - :test #'eql - :fail-info "string-count-upper with nil failed") - - (util.test:test (test-half-double-vector) - '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0) - :test #'equal - :fail-info "Error comparing half-double-vector") - ) diff --git a/tests/union.lisp b/tests/union.lisp index 2e186d8..aefbaaf 100644 --- a/tests/union.lisp +++ b/tests/union.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: union.lisp,v 1.3 2002/12/09 16:30:20 kevin Exp $ +;;;; $Id: union.lisp,v 1.4 2003/04/29 14:08:02 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :cl-user) +(in-package :uffi-tests) (uffi:def-union tunion1 (char :char) @@ -25,65 +25,25 @@ (sf :float) (df :double)) -(defun run-union-1 () - (let ((u (uffi:allocate-foreign-object 'tunion1))) - (setf (uffi:get-slot-value u 'tunion1 'uint) - ;; little endian - #-(or sparc sparc-v9 powerpc ppc big-endian) +(defvar *u* (uffi:allocate-foreign-object 'tunion1)) +(setf (uffi:get-slot-value *u* 'tunion1 'uint) + #-(or sparc sparc-v9 powerpc ppc) (+ (* 1 (char-code #\A)) (* 256 (char-code #\B)) (* 65536 (char-code #\C)) - (* 16777216 255)) - ;; big endian - #+(or sparc sparc-v9 powerpc ppc big-endian) + (* 16777216 128)) + #+(or sparc sparc-v9 powerpc ppc) (+ (* 16777216 (char-code #\A)) (* 65536 (char-code #\B)) (* 256 (char-code #\C)) - (* 1 255))) - (format *standard-output* "~&Should be #\A: ~S" - (uffi:ensure-char-character - (uffi:get-slot-value u 'tunion1 'char))) -;; (format *standard-output* "~&Should be negative number: ~D" -;; (uffi:get-slot-value u 'tunion1 'int)) - (format *standard-output* "~&Should be positive number: ~D" - (uffi:get-slot-value u 'tunion1 'uint)) - (uffi:free-foreign-object u)) - (values)) + (* 1 128))) -#+test-uffi -(defun test-union-1 () - (let ((u (uffi:allocate-foreign-object 'tunion1))) - (setf (uffi:get-slot-value u 'tunion1 'uint) - #-(or sparc sparc-v9 powerpc ppc) - (+ (* 1 (char-code #\A)) - (* 256 (char-code #\B)) - (* 65536 (char-code #\C)) - (* 16777216 128)) - #+(or sparc sparc-v9 powerpc ppc) - (+ (* 16777216 (char-code #\A)) - (* 65536 (char-code #\B)) - (* 256 (char-code #\C)) - (* 1 128))) ;set signed bit - (util.test:test (uffi:ensure-char-character - (uffi:get-slot-value u 'tunion1 'char)) - #\A - :test #'eql - :fail-info "Error with union character") - #-(or sparc sparc-v9 mcl) -;; (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int)) -;; t -;; :fail-info -;; "Error with negative int in union") - (util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint)) - t - :fail-info - "Error with unsigned int in union") - (uffi:free-foreign-object u)) - (values)) +(deftest union.1 (uffi:ensure-char-character + (uffi:get-slot-value *u* 'tunion1 'char)) #\A) -#+examples-uffi -(run-union-1) +#-(or sparc sparc-v9 mcl) +(deftest union.2 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t) -#+test-uffi -(test-union-1) +;; (uffi:free-foreign-object u)) + diff --git a/uffi-tests.asd b/uffi-tests.asd index 0bf6ab3..6ecea17 100644 --- a/uffi-tests.asd +++ b/uffi-tests.asd @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: uffi-tests.asd,v 1.3 2003/04/29 13:16:14 kevin Exp $ +;;;; $Id: uffi-tests.asd,v 1.4 2003/04/29 14:08:02 kevin Exp $ ;;;; ************************************************************************* (defpackage #:uffi-tests-system @@ -24,6 +24,10 @@ (:file "strtol" :depends-on ("package")) (:file "atoifl" :depends-on ("package")) (:file "compress" :depends-on ("package")) + (:file "getenv" :depends-on ("package")) + (:file "gethostname" :depends-on ("package")) + (:file "union" :depends-on ("package")) + (:file "uffi-c-test-lib" :depends-on ("package")) )))) (defmethod perform ((o test-op) (c (eql (find-system :uffi-tests)))) -- 2.34.1