1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: getenv-ccl.cl
6 ;;;; Purpose: cormanlisp version
7 ;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
8 ;;;; Date Started: Feb 2002
10 ;;;; *************************************************************************
14 (ct:defun-dll c-getenv ((lpname LPSTR)
17 :library-name "kernel32.dll"
19 :entry-name "GetEnvironmentVariableA"
20 :linkage-type :pascal)
23 (let ((nsizebuf (ct:malloc (sizeof :long)))
24 (buffer (ct:malloc 1))
25 (cname (ct:lisp-string-to-c-string name)))
26 (setf (ct:cref lpdword nsizebuf 0) 0)
27 (let* ((needed-size (c-getenv cname buffer nsizebuf))
28 (buffer1 (ct:malloc (1+ needed-size))))
29 (setf (ct:cref lpdword nsizebuf 0) needed-size)
30 (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
32 (ct:c-string-to-lisp-string buffer1))
34 (ct:free nsizebuf)))))
36 (defun cl:user-homedir-pathname (&optional host)
37 (cond ((or (stringp host)
39 (every #'stringp host))) nil)
40 ((or (eq host :unspecific)
42 (let ((homedrive (getenv "HOMEDRIVE"))
43 (homepath (getenv "HOMEPATH")))
45 (if (and (stringp homedrive)
47 (= (length homedrive) 2)
48 (> (length homepath) 0))
49 (concatenate 'string homedrive homepath "\\")
51 (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
54 (uffi:def-function ("getenv" c-getenv)
58 (defun my-getenv (key)
59 "Returns an environment variable, or NIL if it does not exist"
60 (check-type key string)
61 (uffi:with-cstring (key-native key)
62 (uffi:convert-from-cstring (c-getenv key-native))))
66 (flet ((print-results (str)
67 (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
68 (print-results "USER")
69 (print-results "_FOO_")))
74 (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
75 (util.test:test (and (stringp (my-getenv "USER"))
76 (< 0 (length (my-getenv "USER"))))
77 t :fail-info "Error retrieving getenv")