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 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; UFFI users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (ct:defun-dll c-getenv ((lpname LPSTR)
24 :library-name "kernel32.dll"
26 :entry-name "GetEnvironmentVariableA"
27 :linkage-type :pascal)
30 (let ((nsizebuf (ct:malloc (sizeof :long)))
31 (buffer (ct:malloc 1))
32 (cname (ct:lisp-string-to-c-string name)))
33 (setf (ct:cref lpdword nsizebuf 0) 0)
34 (let* ((needed-size (c-getenv cname buffer nsizebuf))
35 (buffer1 (ct:malloc (1+ needed-size))))
36 (setf (ct:cref lpdword nsizebuf 0) needed-size)
37 (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
39 (ct:c-string-to-lisp-string buffer1))
41 (ct:free nsizebuf)))))
43 (defun cl:user-homedir-pathname (&optional host)
44 (cond ((or (stringp host)
46 (every #'stringp host))) nil)
47 ((or (eq host :unspecific)
49 (let ((homedrive (getenv "HOMEDRIVE"))
50 (homepath (getenv "HOMEPATH")))
52 (if (and (stringp homedrive)
54 (= (length homedrive) 2)
55 (> (length homepath) 0))
56 (concatenate 'string homedrive homepath "\\")
58 (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
61 (uffi:def-function ("getenv" c-getenv)
65 (defun my-getenv (key)
66 "Returns an environment variable, or NIL if it does not exist"
67 (check-type key string)
68 (uffi:with-cstring (key-native key)
69 (uffi:convert-from-cstring (c-getenv key-native))))
73 (flet ((print-results (str)
74 (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
75 (print-results "USER")
76 (print-results "_FOO_")))
81 (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
82 (util.test:test (and (stringp (my-getenv "USER"))
83 (< 0 (length (my-getenv "USER"))))
84 t :fail-info "Error retrieving getenv")