130 lines
4.2 KiB
Racket
130 lines
4.2 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/file
|
|
racket/list
|
|
racket/path
|
|
racket/string)
|
|
|
|
(provide bool-value
|
|
int-value
|
|
string-value
|
|
split-addresses
|
|
relpath-string
|
|
filesystem-path
|
|
flac-path?
|
|
opus-path?
|
|
directory-file-paths
|
|
replace-path-extension
|
|
ensure-parent-directory!
|
|
alist-ref/default
|
|
alist-set)
|
|
|
|
(define (bool-value v [default #f])
|
|
(cond [(boolean? v) v]
|
|
[(number? v) (not (zero? v))]
|
|
[(string? v)
|
|
(define s (string-downcase (string-trim v)))
|
|
(cond [(member s '("#t" "true" "yes" "y" "1" "on")) #t]
|
|
[(member s '("#f" "false" "no" "n" "0" "off" "")) #f]
|
|
[else default])]
|
|
[else default]))
|
|
|
|
(define (int-value v [default 0])
|
|
(cond [(integer? v) v]
|
|
[(number? v) (inexact->exact (round v))]
|
|
[(string? v) (or (string->number (string-trim v)) default)]
|
|
[else default]))
|
|
|
|
(define (string-value v [default ""])
|
|
(cond [(string? v) v]
|
|
[(symbol? v) (symbol->string v)]
|
|
[(number? v) (number->string v)]
|
|
[(boolean? v) (if v "#t" "#f")]
|
|
[(not v) default]
|
|
[else (format "~a" v)]))
|
|
|
|
(define (split-addresses v)
|
|
(define s (string-value v ""))
|
|
(filter (lambda (x) (not (string=? x "")))
|
|
(map string-trim (regexp-split #px"[,;]" s))))
|
|
|
|
(define (windows-extended-path-string s)
|
|
(cond [(or (< (string-length s) 3)
|
|
(not (eq? (system-type 'os) 'windows))
|
|
(string-prefix? s "\\\\?\\"))
|
|
s]
|
|
[(and (>= (string-length s) 2)
|
|
(char=? (string-ref s 0) #\\)
|
|
(char=? (string-ref s 1) #\\))
|
|
(string-append "\\\\?\\UNC\\" (substring s 2))]
|
|
[(and (>= (string-length s) 3)
|
|
(char-alphabetic? (string-ref s 0))
|
|
(char=? (string-ref s 1) #\:)
|
|
(char=? (string-ref s 2) #\\))
|
|
(string-append "\\\\?\\" s)]
|
|
[else s]))
|
|
|
|
(define (filesystem-path p)
|
|
(define s (cond [(path? p) (path->string p)]
|
|
[(string? p) p]
|
|
[else (raise-argument-error 'filesystem-path "path-string? or path?" p)]))
|
|
(simple-form-path (string->path (windows-extended-path-string s))))
|
|
|
|
(define (relpath-string base p)
|
|
(path->string (find-relative-path (filesystem-path base) (filesystem-path p))))
|
|
|
|
(define (extension-ci=? p ext)
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(and (path? name)
|
|
(let ([e (path-get-extension name)])
|
|
(and e (string-ci=? (bytes->string/utf-8 e) ext))))))
|
|
|
|
(define (file-exists?/quiet p)
|
|
(with-handlers ([exn:fail? (lambda (_) #f)]) (file-exists? p)))
|
|
|
|
(define (flac-path? p)
|
|
(and (file-exists?/quiet p) (extension-ci=? p ".flac")))
|
|
|
|
(define (opus-path? p)
|
|
(and (file-exists?/quiet p) (extension-ci=? p ".opus")))
|
|
|
|
(define (regular-file-path? p)
|
|
(file-exists?/quiet p))
|
|
|
|
(define (directory-list/quiet dir)
|
|
(with-handlers ([exn:fail? (lambda (_) '())])
|
|
(directory-list dir #:build? #t)))
|
|
|
|
(define (directory-exists?/quiet p)
|
|
(with-handlers ([exn:fail? (lambda (_) #f)])
|
|
(directory-exists? p)))
|
|
|
|
(define (sort-paths paths)
|
|
(sort paths string<? #:key path->string))
|
|
|
|
(define (directory-file-paths base-dir)
|
|
;; Tolerant recursive walker for Windows UNC/long-path trees. A single
|
|
;; vanished or unreadable entry is skipped instead of aborting the scan.
|
|
(define root (filesystem-path base-dir))
|
|
(let loop ([dir root] [acc '()])
|
|
(for/fold ([acc acc]) ([p (in-list (sort-paths (directory-list/quiet dir)))])
|
|
(cond [(directory-exists?/quiet p) (loop p acc)]
|
|
[(file-exists?/quiet p) (cons p acc)]
|
|
[else acc]))))
|
|
|
|
(define (replace-path-extension p ext)
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(unless (path? name) (error 'replace-path-extension "path has no file name: ~a" p))
|
|
(build-path base (path-replace-extension name ext))))
|
|
|
|
(define (ensure-parent-directory! p)
|
|
(define-values (base name dir?) (split-path p))
|
|
(when (path? base) (make-directory* base)))
|
|
|
|
(define (alist-ref/default a k [default #f])
|
|
(define e (assoc k a))
|
|
(if e (cdr e) default))
|
|
|
|
(define (alist-set a k v)
|
|
(cons (cons k v) (filter (lambda (e) (not (equal? (car e) k))) a)))
|