78 lines
3.0 KiB
Scheme
78 lines
3.0 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide find-version)
|
|
|
|
(define (find-version base-path vers)
|
|
(let-values ([(dir name _) (split-path (bytes->path base-path))])
|
|
(let ([files (with-handlers ([exn:fail:filesystem? (lambda (exn) null)])
|
|
(directory-list dir))])
|
|
(and files
|
|
(let* ([p (path-element->bytes name)]
|
|
[len (bytes-length p)]
|
|
[candidate-versions
|
|
(filter
|
|
values
|
|
(map
|
|
(lambda (file)
|
|
(let ([s (path-element->bytes file)])
|
|
(and (len . < . (bytes-length s))
|
|
(regexp-match? #rx#"[.]ss$" s)
|
|
(bytes=? p (subbytes s 0 len))
|
|
(or (and (= (bytes-length s) (+ len 3))
|
|
null)
|
|
(let ([vers (subbytes s len (- (bytes-length s) 3))])
|
|
(and (regexp-match #rx#"^(-[0-9]+)+$" vers)
|
|
(map string->number
|
|
(cdr
|
|
(map bytes->string/latin-1
|
|
(regexp-split #rx#"-" vers))))))))))
|
|
files))]
|
|
[versions
|
|
(sort candidate-versions
|
|
(lambda (a b)
|
|
(let loop ([a a][b b])
|
|
(cond
|
|
[(null? a) #t]
|
|
[(null? b) #f]
|
|
[(> (car a) (car b)) #t]
|
|
[(< (car a) (car b)) #f]
|
|
[else (loop (cdr a) (cdr b))]))))])
|
|
(ormap (lambda (candidate-version)
|
|
(and (version-match? candidate-version vers)
|
|
candidate-version))
|
|
versions))))))
|
|
|
|
(define (version-match? cand vers)
|
|
(cond
|
|
[(null? vers) #t]
|
|
[(null? cand) #f]
|
|
[(eq? (car vers) 'and)
|
|
(andmap (lambda (v)
|
|
(version-match? cand v))
|
|
(cdr vers))]
|
|
[(eq? (car vers) 'or)
|
|
(ormap (lambda (v)
|
|
(version-match? cand v))
|
|
(cdr vers))]
|
|
[(eq? (car vers) 'not)
|
|
(not (version-match? (cadr vers)))]
|
|
[(sub-version-match? (car cand) (car vers))
|
|
(version-match? (cdr cand) (cdr vers))]
|
|
[else #f]))
|
|
|
|
(define (sub-version-match? cand subvers)
|
|
(cond
|
|
[(number? subvers) (= cand subvers)]
|
|
[else (case (car subvers)
|
|
[(>=) (>= cand (cadr subvers))]
|
|
[(<=) (<= cand (cadr subvers))]
|
|
[(and) (andmap (lambda (sv)
|
|
(sub-version-match? cand sv))
|
|
(cdr subvers))]
|
|
[(or) (ormap (lambda (sv)
|
|
(sub-version-match? cand sv))
|
|
(cdr subvers))]
|
|
[(not) (not (sub-version-match? cand (cadr subvers)))]
|
|
[else (error "bad subversion")])]))
|
|
|