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
12 ;;;; *************************************************************************
16 (ct:defun-dll c-getenv ((lpname LPSTR)
19 :library-name "kernel32.dll"
21 :entry-name "GetEnvironmentVariableA"
22 :linkage-type :pascal)
25 (let ((nsizebuf (ct:malloc (sizeof :long)))
26 (buffer (ct:malloc 1))
27 (cname (ct:lisp-string-to-c-string name)))
28 (setf (ct:cref lpdword nsizebuf 0) 0)
29 (let* ((needed-size (c-getenv cname buffer nsizebuf))
30 (buffer1 (ct:malloc (1+ needed-size))))
31 (setf (ct:cref lpdword nsizebuf 0) needed-size)
32 (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
34 (ct:c-string-to-lisp-string buffer1))
36 (ct:free nsizebuf)))))
38 (defun cl:user-homedir-pathname (&optional host)
39 (cond ((or (stringp host)
41 (every #'stringp host))) nil)
42 ((or (eq host :unspecific)
44 (let ((homedrive (getenv "HOMEDRIVE"))
45 (homepath (getenv "HOMEPATH")))
47 (if (and (stringp homedrive)
49 (= (length homedrive) 2)
50 (> (length homepath) 0))
51 (concatenate 'string homedrive homepath "\\")
53 (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
56 (uffi:def-function ("getenv" c-getenv)
60 (defun my-getenv (key)
61 "Returns an environment variable, or NIL if it does not exist"
62 (check-type key string)
63 (uffi:with-cstring (key-native key)
64 (uffi:convert-from-cstring (c-getenv key-native))))
68 (flet ((print-results (str)
69 (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
70 (print-results "USER")
71 (print-results "_FOO_")))
76 (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
77 (util.test:test (and (stringp (my-getenv "USER"))
78 (< 0 (length (my-getenv "USER"))))
79 t :fail-info "Error retrieving getenv")