136 lines
5.2 KiB
Scheme
136 lines
5.2 KiB
Scheme
#!r6rs
|
|
;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us>
|
|
;;;
|
|
;;; Permission to use, copy, modify, and distribute this software for
|
|
;;; any purpose with or without fee is hereby granted, provided that the
|
|
;;; above copyright notice and this permission notice appear in all
|
|
;;; copies.
|
|
;;;
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
|
|
;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
|
|
;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
|
|
;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
|
|
;;; PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
(library (srfi :98 os-environment-variables)
|
|
(export get-environment-variables
|
|
(rename (getenv get-environment-variable)))
|
|
(import (rnrs) (rnrs mutable-strings)
|
|
(only (chezscheme) getenv string-copy! foreign-ref foreign-entry
|
|
foreign-procedure machine-type load-shared-object ftype-sizeof))
|
|
|
|
(define (get-environment-variables)
|
|
(read-environ (get-environ-pointer)))
|
|
|
|
(define-record-type text-buffer (nongenerative)
|
|
(fields (mutable b) (mutable i))
|
|
(protocol (lambda (new) (lambda () (new (make-string 20) 0)))))
|
|
|
|
(define extend-buffer!
|
|
(let ()
|
|
(define (finish tb b i c)
|
|
(string-set! b i c)
|
|
(text-buffer-i-set! tb (fx+ i 1)))
|
|
(lambda (tb c)
|
|
(let ([b (text-buffer-b tb)]
|
|
[i (text-buffer-i tb)])
|
|
(if (fx=? i (string-length b))
|
|
(let ([new-b (make-string (* i i))])
|
|
(string-copy! b 0 new-b 0 i)
|
|
(text-buffer-b-set! tb new-b)
|
|
(finish tb new-b i c))
|
|
(finish tb b i c))))))
|
|
|
|
(define extract-and-clear-buffer!
|
|
(lambda (tb)
|
|
(let ([i (text-buffer-i tb)])
|
|
(text-buffer-i-set! tb 0)
|
|
(substring (text-buffer-b tb) 0 i))))
|
|
|
|
(define read-entry
|
|
(let ()
|
|
(define (s0 ptr offset tb)
|
|
(let ([c (foreign-ref 'char ptr offset)])
|
|
(cond
|
|
[(char=? c #\nul)
|
|
(values (cons (extract-and-clear-buffer! tb) #f)
|
|
(fx+ offset (ftype-sizeof char)))]
|
|
[(char=? c #\=)
|
|
(s1 ptr (fx+ offset (ftype-sizeof char))
|
|
tb (extract-and-clear-buffer! tb))]
|
|
[else
|
|
(extend-buffer! tb c)
|
|
(s0 ptr (fx+ offset (ftype-sizeof char)) tb)])))
|
|
(define (s1 ptr offset tb key)
|
|
(let ([c (foreign-ref 'char ptr offset)])
|
|
(cond
|
|
[(char=? c #\nul)
|
|
(values (cons key (extract-and-clear-buffer! tb))
|
|
(fx+ offset (ftype-sizeof char)))]
|
|
[else
|
|
(extend-buffer! tb c)
|
|
(s1 ptr (fx+ offset (ftype-sizeof char)) tb key)])))
|
|
s0))
|
|
|
|
(define read-environ
|
|
(if (memq (machine-type) '(i3nt a6nt ti3nt ta6nt))
|
|
(lambda (ptr)
|
|
(let ([tb (make-text-buffer)])
|
|
(let loop ([offset 0] [ls '()])
|
|
(let ([c (foreign-ref 'char ptr offset)])
|
|
(if (char=? c #\nul)
|
|
ls
|
|
(let-values ([(entry offset) (read-entry ptr offset tb)])
|
|
(loop offset (cons entry ls))))))))
|
|
(lambda (ptr)
|
|
(let ([tb (make-text-buffer)])
|
|
(let loop ([offset 0] [ls '()])
|
|
(let ([entry-ptr (foreign-ref 'void* ptr offset)])
|
|
(if (= entry-ptr 0)
|
|
ls
|
|
(let-values ([(entry char-offset)
|
|
(read-entry entry-ptr 0 tb)])
|
|
(loop (fx+ offset (ftype-sizeof void*))
|
|
(cons entry ls))))))))))
|
|
|
|
(define get-environ-pointer
|
|
(case (machine-type)
|
|
[(i3nt a6nt ti3nt ta6nt)
|
|
(load-shared-object "msvcrt.dll")
|
|
(load-shared-object "kernel32.dll")
|
|
(foreign-procedure "GetEnvironmentStrings" () void*)]
|
|
[(i3osx a6osx ti3osx ta6osx tarm64osx)
|
|
(load-shared-object "libc.dylib")
|
|
(let ([p (foreign-procedure "_NSGetEnviron" () void*)])
|
|
(lambda ()
|
|
(let ([ptr-to-ptr (p)])
|
|
(if (= ptr-to-ptr 0)
|
|
0
|
|
(foreign-ref 'void* ptr-to-ptr 0)))))]
|
|
[(i3le a6le ti3le ta6le arm32le ppc32le)
|
|
(load-shared-object "libc.so.6")
|
|
(lambda ()
|
|
(let ([ptr-to-ptr (foreign-entry "environ")])
|
|
(if (= ptr-to-ptr 0)
|
|
0
|
|
(foreign-ref 'void* ptr-to-ptr 0))))]
|
|
[(i3ob a6ob ti3ob ta6ob i3nb a6nb ti3nb ta6nb)
|
|
(load-shared-object "libc.so")
|
|
(lambda ()
|
|
(let ([ptr-to-ptr (foreign-entry "environ")])
|
|
(if (= ptr-to-ptr 0)
|
|
0
|
|
(foreign-ref 'void* ptr-to-ptr 0))))]
|
|
[(ta6fb a6fb)
|
|
(load-shared-object "libc.so.7")
|
|
(lambda ()
|
|
(let ([ptr-to-ptr (foreign-entry "environ")])
|
|
(if (= ptr-to-ptr 0)
|
|
0
|
|
(foreign-ref 'void* ptr-to-ptr 0))))]
|
|
[else (error 'get-environment-variables
|
|
"currently unsupoorted on ~s" (machine-type))])))
|