This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/6.ss
2022-07-29 15:12:07 +02:00

506 lines
18 KiB
Scheme

;;; 6.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(begin
(define with-output-to-string
(lambda (th)
(unless (procedure? th)
($oops 'with-output-to-string "~s is not a procedure" th))
(parameterize ([current-output-port (open-output-string)])
(th)
(get-output-string (current-output-port)))))
(define with-input-from-string
(lambda (s th)
(unless (string? s)
($oops 'with-input-from-string "~s is not a string" s))
(unless (procedure? th)
($oops 'with-input-from-string "~s is not a procedure" th))
(let ([p (open-input-string s)])
(call-with-values
(lambda () (parameterize ([current-input-port p]) (th)))
(lambda v (apply values v))))))
(let ()
(define getwd
(if (foreign-entry? "(cs)s_getwd")
(foreign-procedure "(cs)s_getwd" () string)
(lambda ()
(let ([p (process "exec /bin/pwd")])
(let ([ip (car p)] [op (open-output-string)])
(let f ()
(let ([c (read-char ip)])
(if (or (eof-object? c) (char=? c #\newline))
(begin
(close-output-port (cadr p))
(close-input-port ip)
(get-output-string op))
(begin (write-char c op) (f))))))))))
(define chdir
(foreign-procedure "(cs)s_chdir"
(string)
integer-32))
(define $cd
(case-lambda
[(who) (or (getwd) ($oops who "cannot determine current directory"))]
[(dir who)
(unless (string? dir) ($oops who "~s is not a string" dir))
(unless (= (chdir dir) 0)
($oops who "cannot set current directory to ~s" dir))]))
(set-who! current-directory
(case-lambda
[() ($cd who)]
[(dir) ($cd dir who)]))
(set-who! cd
(case-lambda
[() ($cd who)]
[(dir) ($cd dir who)])))
(let ()
(define who 'mkdir)
(define fp (foreign-procedure "(cs)mkdir" (string uptr) ptr))
(define (do-mkdir path mode)
(unless (string? path) ($oops who "~s is not a string" path))
(unless (fixnum? mode) ($oops who "~s is not a fixnum" mode))
(let ([x (fp path mode)])
(cond
[(eqv? x #t) (void)]
[(string? x)
($oops/c who
(make-i/o-filename-error path)
"cannot create ~s: ~(~a~)" path x)]
[else
($oops/c who
(make-i/o-filename-error path)
"cannot create ~s" path)])))
(set! mkdir
(case-lambda
[(path) (do-mkdir path #o777)]
[(path mode) (do-mkdir path mode)])))
(define-who chmod
(let ([fp (foreign-procedure "(cs)chmod" (string fixnum) ptr)])
(lambda (path mode)
(unless (string? path) ($oops who "~s is not a string" path))
(unless (fixnum? mode) ($oops who "~s is not a fixnum" mode))
(let ([x (fp path mode)])
(cond
[(eqv? x #t) (void)]
[(string? x)
($oops/c who
(make-i/o-filename-error path)
"cannot modify ~s: ~(~a~)" path x)]
[else
($oops/c who
(make-i/o-filename-error path)
"cannot modify ~s" path)])))))
(define-who get-mode
(let ([fp (foreign-procedure "(cs)getmod" (string boolean) ptr)])
(rec get-mode
(case-lambda
[(path) (get-mode path #t)]
[(path follow?)
(define (err x)
(if (string? x)
($oops/c who
(make-i/o-filename-error path)
"failed for ~s: ~(~a~)" path x)
($oops/c who
(make-i/o-filename-error path)
"failed for ~s" path)))
(unless (string? path) ($oops who "~s is not a string" path))
(let ([x (fp path follow?)])
(if (fixnum? x)
x
(err x)))]))))
(let ()
(define file-x-time
(lambda (who path-fp fd-fp file follow?)
(define (path-err path x)
(if (string? x)
($oops/c who
(make-i/o-filename-error path)
"failed for ~s: ~(~a~)" path x)
($oops/c who
(make-i/o-filename-error path)
"failed for ~s" path)))
(unless (or (string? file) (and (port? file) (file-port? file)))
($oops who "~s is not a string or file port" file))
(if (string? file)
(let ([x (path-fp file follow?)])
(if (pair? x)
(make-time 'time-utc (cdr x) (car x))
(path-err file x)))
(let ([x (fd-fp (port-file-descriptor file))])
(cond
[(pair? x) (make-time 'time-utc (cdr x) (car x))]
[(string? x) ($oops who "failed for ~s: ~(~a~)" file x)]
[else ($oops who "failed for ~s" file)])))))
(define-syntax define-file-x-time
(syntax-rules ()
[(_ name path-name fd-name)
(set-who! name
(let ([path-fp (foreign-procedure path-name (string boolean) ptr)]
[fd-fp (foreign-procedure fd-name (fixnum) ptr)])
(case-lambda
[(file) (file-x-time who path-fp fd-fp file #t)]
[(file follow?) (file-x-time who path-fp fd-fp file follow?)])))]))
(define-file-x-time file-access-time "(cs)path_atime" "(cs)fd_atime")
(define-file-x-time file-change-time "(cs)path_ctime" "(cs)fd_atime")
(define-file-x-time file-modification-time "(cs)path_mtime" "(cs)fd_mtime"))
(define directory-separator
(lambda ()
(#2%directory-separator)))
(define directory-separator?
(lambda (c)
(unless (char? c)
($oops 'directory-separator? "~s is not a character" c))
(#3%directory-separator? c)))
(define-who directory-list
(let ([dl (if-feature windows
(let ([wl (foreign-procedure "(cs)find_files" (string) scheme-object)])
(lambda (path)
(let ([n (string-length path)])
(unless (and (fx> n 0)
(let nostars? ([i 0])
(or (fx= i n)
(and (not (char=? (string-ref path i) #\*))
(nostars? (fx+ i 1))))))
($oops who "invalid directory name ~s" path))
(wl (if (memv (string-ref path (fx- n 1)) '(#\\ #\/ #\:))
(string-append path "*")
(string-append path "\\*"))))))
(foreign-procedure "(cs)directory_list" (string) scheme-object))])
(lambda (path)
(unless (string? path) ($oops who "~s is not a string" path))
(let ([bv* (dl path)])
(if (string? bv*)
($oops/c who
(make-i/o-filename-error path)
"failed for ~a: ~(~a~)" path bv*)
(remp (lambda (s)
(let ([n (string-length s)])
(or (and (fx= n 1) (char=? (string-ref s 0) #\.))
(and (fx= n 2)
(char=? (string-ref s 0) #\.)
(char=? (string-ref s 1) #\.)))))
(map (if-feature windows
(lambda (bv) (utf16->string bv 'little #t))
utf8->string)
bv*)))))))
(define-who file-exists?
(let ([fp (foreign-procedure "(cs)file_existsp" (string boolean) boolean)])
(rec file-exists?
(case-lambda
[(path) (file-exists? path #t)]
[(path follow?)
(unless (string? path) ($oops who "~s is not a string" path))
(fp path follow?)]))))
(define-who #(r6rs: file-exists?)
(lambda (path)
(#2%file-exists? path #t)))
(define-who file-regular?
(let ([fp (foreign-procedure "(cs)file_regularp" (string boolean) boolean)])
(rec file-regular?
(case-lambda
[(path) (file-regular? path #t)]
[(path follow?)
(unless (string? path) ($oops who "~s is not a string" path))
(fp path follow?)]))))
(define-who file-directory?
(let ([fp (foreign-procedure "(cs)file_directoryp" (string boolean) boolean)])
(rec file-directory?
(case-lambda
[(path) (file-directory? path #t)]
[(path follow?)
(unless (string? path) ($oops who "~s is not a string" path))
(fp path follow?)]))))
(define-who file-symbolic-link?
(let ([fp (foreign-procedure "(cs)file_symbolic_linkp" (string) boolean)])
(lambda (path)
(unless (string? path) ($oops who "~s is not a string" path))
(fp path))))
(let ()
(define fp-delete-file
(foreign-procedure "(cs)delete_file"
(string)
scheme-object))
(define fp-delete-directory
(foreign-procedure "(cs)delete_directory"
(string)
scheme-object))
(define (do-delete who fp path error?)
(unless (string? path)
($oops who "~s is not a string" path))
(let ([x (fp path)])
(if error?
(cond
[(eqv? x #t) (void)]
[(string? x)
($oops/c who
(make-i/o-filename-error path)
"failed for ~a: ~(~a~)" path x)]
[else
($oops/c who
(make-i/o-filename-error path)
"failed for ~a" path)])
(eq? x #t))))
(set-who! delete-file
(case-lambda
[(path) (do-delete who fp-delete-file path #f)]
[(path error?) (do-delete who fp-delete-file path error?)]))
(set-who! #(r6rs: delete-file) ; implicit rec
(lambda (path)
(do-delete who fp-delete-file path #t)))
(set-who! delete-directory
(case-lambda
[(path) (do-delete who fp-delete-directory path #f)]
[(path error?) (do-delete who fp-delete-directory path error?)])))
(let ()
(define fp (foreign-procedure "(cs)rename_file" (string string) ptr))
(set-who! rename-file
(lambda (path1 path2)
(unless (string? path1)
($oops who "~s is not a string" path1))
(unless (string? path2)
($oops who "~s is not a string" path2))
(let ([x (fp path1 path2)])
(cond
[(eqv? x #t) (void)]
[(string? x)
($oops/c who
(condition
(make-i/o-filename-error path1)
(make-i/o-filename-error path2))
"cannot rename ~s to ~s: ~(~a~)" path1 path2 x)]
[else
($oops/c who
(condition
(make-i/o-filename-error path1)
(make-i/o-filename-error path2))
"cannot rename ~s to ~s" path1 path2)])))))
;;; path procedures
(let ()
(define windows? (if-feature windows #t #f))
(define directory-separator-predicate
(lambda (s)
(if (and windows?
(string? s)
(let ([n (string-length s)])
(and (fx>= n 4)
(char=? (string-ref s 0) #\\)
(char=? (string-ref s 1) #\\)
(char=? (string-ref s 2) #\?)
(char=? (string-ref s 3) #\\))))
(lambda (c) (char=? c #\\))
directory-separator?)))
(define path-base
(lambda (s n)
(cond
[(and windows?
(fx>= n 2)
(char=? (string-ref s 1) #\:)
(let ([c (string-ref s 0)])
(or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
(if (and (fx>= n 3) (directory-separator? (string-ref s 2))) 3 2)]
[(and windows?
(fx>= n 4)
(char=? (string-ref s 0) #\\)
(char=? (string-ref s 1) #\\)
(char=? (string-ref s 2) #\?)
(char=? (string-ref s 3) #\\))
(cond
[(and (fx>= n 6)
(char=? (string-ref s 5) #\:)
(let ([c (string-ref s 4)])
(or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
(if (and (fx>= n 7) (char=? (string-ref s 6) #\\)) 7 6)]
[(and windows?
(fx>= n 8)
(char-ci=? (string-ref s 4) #\U)
(char-ci=? (string-ref s 5) #\N)
(char-ci=? (string-ref s 6) #\C)
(char=? (string-ref s 7) #\\))
(let loop ([i (if (and (fx>= n 9) (char=? (string-ref s 8) #\\)) 9 8)])
(if (or (fx= i n) (char=? (string-ref s i) #\\))
i
(loop (fx+ i 1))))]
[else 4])]
[(and windows?
(fx>= n 2)
(directory-separator? (string-ref s 0))
(directory-separator? (string-ref s 1)))
(let loop ([i 2])
(if (or (fx= i n) (directory-separator? (string-ref s i)))
i
(loop (fx+ i 1))))]
[(and (fx>= n 1) (directory-separator? (string-ref s 0))) 1]
[(and (fx>= n 1) (char=? (string-ref s 0) #\.))
(if (or (fx= n 1) (directory-separator? (string-ref s 1)))
1
(if (and (char=? (string-ref s 1) #\.)
(or (fx= n 2) (directory-separator? (string-ref s 2))))
2
0))]
[(and (fx>= n 1) (char=? (string-ref s 0) #\~))
(if (or (fx= n 1) (directory-separator? (string-ref s 1)))
1
(let loop ([i 2])
(if (or (fx= i n) (directory-separator? (string-ref s i)))
i
(loop (fx+ i 1)))))]
[else 0])))
(set-who! path-absolute?
(lambda (s)
(unless (string? s) ($oops who "~s is not a string" s))
(let ([n (string-length s)])
(or (and (fx>= n 1) (directory-separator? (string-ref s 0)))
(and (fx>= n 1) (char=? (string-ref s 0) #\~))
(and windows?
(fx>= n 3)
(char=? (string-ref s 1) #\:)
(let ([c (string-ref s 0)])
(or (char<=? #\a c #\z) (char<=? #\A c #\Z)))
(directory-separator? (string-ref s 2)))))))
(set-who! path-extension
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(let loop ([i n])
(let ([i (fx- i 1)])
(if (or (fx< i base) (directory-separator? (string-ref s i)))
""
(if (char=? (string-ref s i) #\.)
(if (and (fx= i (fx- n 1))
(or (fx= i base)
(directory-separator? (string-ref s (fx- i 1)))
(and (char=? (string-ref s (fx- i 1)) #\.)
(or (fx= (fx- i 1) base)
(directory-separator? (string-ref s (fx- i 2)))))))
""
(substring s (fx+ i 1) n))
(loop i))))))))
(set-who! path-root
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(let loop ([i n])
(let ([i (fx- i 1)])
(if (or (fx< i base) (directory-separator? (string-ref s i)))
s
(if (char=? (string-ref s i) #\.)
(if (and (fx= i (fx- n 1))
(or (fx= i base)
(directory-separator? (string-ref s (fx- i 1)))
(and (char=? (string-ref s (fx- i 1)) #\.)
(or (fx= (fx- i 1) base)
(directory-separator? (string-ref s (fx- i 2)))))))
s
(substring s 0 i))
(loop i))))))))
(set-who! path-last
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(let loop ([i n])
(cond
[(fx= i base) (if (fx= base 0) s (substring s base n))]
[(directory-separator? (string-ref s (fx- i 1))) (substring s i n)]
[else (loop (fx- i 1))])))))
(set-who! path-parent
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(define (skip-sep-backward s i base)
(let ([i (fx- i 1)])
(if (or (fx= i base) (not (directory-separator? (string-ref s (fx- i 1)))))
i
(skip-sep-backward s i base))))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(let loop ([i n])
(cond
[(fx= i base) (substring s 0 base)]
[(directory-separator? (string-ref s (fx- i 1)))
(substring s 0 (skip-sep-backward s i base))]
[else (loop (fx- i 1))])))))
(set-who! path-first
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(if (fx= base 0)
(let loop ([i 0])
(cond
[(fx= i n) ""]
[(directory-separator? (string-ref s i)) (substring s 0 i)]
[else (loop (fx+ i 1))]))
(if (fx= base n) s (substring s 0 base))))))
(set-who! path-rest
(lambda (s)
(define directory-separator? (directory-separator-predicate s))
(define (skip-sep s i n)
(if (or (fx= i n) (not (directory-separator? (string-ref s i))))
i
(skip-sep s (fx+ i 1) n)))
(unless (string? s) ($oops who "~s is not a string" s))
(let* ([n (string-length s)] [base (path-base s n)])
(if (fx= base 0)
(let loop ([i 0])
(cond
[(fx= i n) s]
[(directory-separator? (string-ref s i))
(substring s (skip-sep s (fx+ i 1) n) n)]
[else (loop (fx+ i 1))]))
(substring s (skip-sep s base n) n)))))
)
)