Refactoring some utils.

This commit is contained in:
Alex Shinn 2015-04-24 16:32:06 +09:00
parent 78d68de282
commit b40f5284fc
3 changed files with 59 additions and 78 deletions

View file

@ -3,24 +3,6 @@
;; This code was written by Alex Shinn in 2014 and placed in the
;; Public Domain. All warranties are disclaimed.
(define (find-in-path file . o)
(any (lambda (dir)
(let ((path (make-path dir file)))
(and (file-exists? path) path)))
(if (pair? o)
(car o)
(string-split (get-environment-variable "PATH") #\:))))
(define (find-sexp-in-path file dirs . o)
(let ((pred (if (pair? o) (car o) (lambda (x) #t))))
(any (lambda (dir)
(let ((path (make-path dir file)))
(and (file-exists? path)
(guard (exn (else #f))
(let ((x (call-with-input-file path read)))
(and (pred x) x))))))
dirs)))
(define known-implementations
'((chibi "chibi-scheme")
(chicken "chicken")
@ -72,52 +54,6 @@
(define (conf-for-implementation cfg impl)
(conf-specialize cfg 'implementation impl))
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out)))
(define (write-to-string x)
(call-with-output-string (lambda (out) (write x out))))
(define (resource->bytevector uri)
(let ((uri (if (uri? uri) uri (string->path-uri 'http uri))))
(if (uri-host uri)
(call-with-input-url uri port->bytevector)
(file->bytevector (uri-path uri)))))
(define (file->sexp-list file)
(call-with-input-file file
(lambda (in)
(let lp ((res '()))
(let ((x (read in)))
(if (eof-object? x)
(reverse res)
(lp (cons x res))))))))
(define (version-split str)
(if str
(map (lambda (x) (or (string->number x) x))
(string-split str #\.))
'()))
(define (version-compare a b)
(define (less? x y)
(cond ((number? x) (if (number? y) (< x y) 1))
((number? y) -1)
(else (string<? x y))))
(let lp ((as (version-split a))
(bs (version-split b)))
(cond
((null? as) (if (null? bs) -1 0))
((null? bs) 1)
((less? (car as) (car bs)) -1)
((less? (car bs) (car as)) 1)
(else (lp (cdr as) (cdr bs))))))
(define (version>? a b) (> (version-compare a b) 0))
(define (version>=? a b) (>= (version-compare a b) 0))
;; Hack to evaluate an expression in a separate process with a larger
;; default heap. The expression and result must be serializable with
;; write, and imports should be an argument list for environment.

View file

@ -1,10 +1,50 @@
;;> Copies the file \var{from} to \var{to}.
(define (find-in-path file . o)
(any (lambda (dir)
(let ((path (make-path dir file)))
(and (file-exists? path) path)))
(if (pair? o)
(car o)
(string-split (get-environment-variable "PATH") #\:))))
(define (copy-file from to)
(let ((in (open-binary-input-file from))
(out (open-binary-output-file to)))
(let lp ()
(let ((n (read-u8 in)))
(cond ((eof-object? n) (close-input-port in) (close-output-port out))
(else (write-u8 n out) (lp)))))))
(define (find-sexp-in-path file dirs . o)
(let ((pred (if (pair? o) (car o) (lambda (x) #t))))
(any (lambda (dir)
(let ((path (make-path dir file)))
(and (file-exists? path)
(guard (exn (else #f))
(let ((x (call-with-input-file path read)))
(and (pred x) x))))))
dirs)))
(define (write-to-string x)
(call-with-output-string (lambda (out) (write x out))))
(define (resource->bytevector uri)
(let ((uri (if (uri? uri) uri (string->path-uri 'http uri))))
(if (uri-host uri)
(call-with-input-url uri port->bytevector)
(file->bytevector (uri-path uri)))))
(define (version-split str)
(if str
(map (lambda (x) (or (string->number x) x))
(string-split str #\.))
'()))
(define (version-compare a b)
(define (less? x y)
(cond ((number? x) (if (number? y) (< x y) 1))
((number? y) -1)
(else (string<? x y))))
(let lp ((as (version-split a))
(bs (version-split b)))
(cond
((null? as) (if (null? bs) -1 0))
((null? bs) 1)
((less? (car as) (car bs)) -1)
((less? (car bs) (car as)) 1)
(else (lp (cdr as) (cdr bs))))))
(define (version>? a b) (> (version-compare a b) 0))
(define (version>=? a b) (>= (version-compare a b) 0))

View file

@ -1,12 +1,17 @@
(define-library (chibi snow utils)
(export copy-file)
(export find-in-path find-sexp-in-path
write-to-string resource->bytevector
version-split version-compare version>? version>=?)
(import (scheme base)
(scheme file)
(scheme time)
(srfi 33)
(chibi filesystem)
(scheme read)
(scheme write)
(scheme process-context)
(srfi 1)
(chibi io)
(chibi net http)
(chibi pathname)
(chibi process)
(chibi snow interface))
(chibi string)
(chibi uri))
(include "utils.scm"))