From 600bfb3764c55f78bf4e25016113fde17ec11506 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 2 Oct 2021 12:30:40 +0300 Subject: [PATCH] Allocate clusters and build directory entries --- tar2fat.scm | 189 ++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 163 insertions(+), 26 deletions(-) diff --git a/tar2fat.scm b/tar2fat.scm index 0df0fce..40bf467 100644 --- a/tar2fat.scm +++ b/tar2fat.scm @@ -1,3 +1,9 @@ +(define (filter p list) + (let loop ((newlist '()) (list list)) + (if (null? list) (reverse newlist) + (loop (if (p (car list)) (cons (car list) newlist) newlist) + (cdr list))))) + (define (find p list) (cond ((null? list) #f) ((p (car list)) (car list)) @@ -9,6 +15,22 @@ (if (null? (cdr list)) (reverse newlist) (loop (cons (car list) newlist) (cdr list)))))) +(define (bytevector-concatenate bytevectors) + (fold (lambda (part whole) (bytevector-append whole part)) + (bytevector) bytevectors)) + +(define (string-index str char) + (let loop ((i 0)) + (cond ((= i (string-length str)) #f) + ((char=? char (string-ref str i)) i) + (else (loop (+ i 1)))))) + +(define (string-every? p str) + (let loop ((i 0)) + (or (= i (string-length str)) + (and (p (string-ref str i)) + (loop (+ i 1)))))) + (define (string-prefix? fix str) (let ((fixlen (string-length fix)) (strlen (string-length str))) @@ -19,36 +41,68 @@ (define (string-drop str n) (string-copy str n (string-length str))) +(define (string-pad str n char) + (let ((lack (- n (string-length str)))) + (if (<= lack 0) str (string-append str (make-string lack char))))) + +(define (u8 u) + (bytevector u)) + +(define (u16l u) + (bytevector (bitwise-and #xff u) + (bitwise-and #xff (arithmetic-shift u -8)))) + +(define (u32l u) + (bytevector (bitwise-and #xff u) + (bitwise-and #xff (arithmetic-shift u -8)) + (bitwise-and #xff (arithmetic-shift u -16)) + (bitwise-and #xff (arithmetic-shift u -24)))) + ;; +(define bytes/sector 512) ; Do not change. +(define sectors/cluster 8) + (define-record-type fat-directory (make-fat-directory* name entries) fat-directory? (name fat-directory-name) - (entries fat-directory-entries fat-directory-set-entries!)) + (entries fat-directory-entries fat-directory-set-entries!) + (first-cluster fat-directory-first-cluster + fat-directory-set-first-cluster!)) (define-record-type fat-file (make-fat-file name contents) fat-file? (name fat-file-name) - (contents fat-file-contents)) + (contents fat-file-contents) + (first-cluster fat-file-first-cluster fat-file-set-first-cluster!)) (define-record-type drive (make-drive* number root-directory) drive? (number drive-number) + (first-sector drive-first-sector) + (sector-count drive-sector-count drive-set-sector-count!) + (max-space drive-max-space) + (free-space drive-free-space) (root-directory drive-root-directory)) -(define first-drive-letter #\C) -(define last-drive-letter #\F) +(define first-drive-letter #\c) +(define last-drive-letter #\f) (define max-drives - (- (char->integer last-drive-letter) (char->integer first-drive-letter))) + (+ 1 (- (char->integer last-drive-letter) + (char->integer first-drive-letter)))) (define drives (make-vector max-drives #f)) +(define (get-used-drives) + (filter drive? (vector->list drives))) + (define (drive-letter drive) - (integer->char (+ (char->integer first-drive-letter) (drive-number drive)))) + (string (integer->char (+ (char->integer first-drive-letter) + (drive-number drive))))) (define (drive-by-letter letter) (let ((number (- (char->integer letter) first-drive-letter))) @@ -122,6 +176,12 @@ (else (error "Can't decide if entry is file or directory"))))))) +(define (fat-file-size file) + (bytevector-length (fat-file-contents file))) + +(define (fat-file-clusters file) + (ceiling (/ (fat-file-size file) (* bytes/sector sectors/cluster)))) + (define (tar-read-entry) (define (bytevector-every? match? bytes) @@ -199,23 +259,7 @@ (loop a (+ b 1) parts)))))) parts)) -(define (dump-drive letter) - (define (emit nest str) - (write-string (make-string (* 2 nest) #\space)) - (write-string str) - (newline)) - (define (dump-directory-entries nest directory) - (for-each (lambda (entry) - (emit nest (fat-directory-entry-name entry)) - (when (fat-directory? entry) - (dump-directory-entries (+ nest 1) entry))) - (fat-directory-entries directory))) - (let ((drive (get-drive letter))) - (when drive - (emit 0 letter) - (dump-directory-entries 1 (drive-root-directory drive))))) - -(define (handle-entry entry) +(define (input-entry entry) (let ((path (tar-split-path (cdr (assq 'path entry))))) (when (null? path) (error "blank path in tar file")) @@ -237,12 +281,105 @@ (make-fat-file name (cdr (assq 'contents entry))))))))))))) -(define (main) +(define (input) (let loop () (let ((entry (tar-read-entry))) (unless (eof-object? entry) - (handle-entry entry) + (input-entry entry) (loop))))) +(define (build-file-allocation-table drive) + (let ((next-free-cluster 0)) + (define (allocate-clusters! n) + (set! next-free-cluster (+ next-free-cluster n))) + (let allocate-tree ((directory (drive-root-directory drive))) + (for-each (lambda (entry) + (cond ((fat-directory? entry) + (fat-directory-set-first-cluster! + entry next-free-cluster) + (let ((entries (fat-directory-entries entry))) + (allocate-clusters! (* 32 (length entries))))) + ((fat-file? entry) + (fat-file-set-first-cluster! entry next-free-cluster) + (allocate-clusters! (fat-file-clusters entry))) + (else + (error "What?" entry)))) + (fat-directory-entries directory)) + (for-each allocate-tree + (filter fat-directory? (fat-directory-entries directory)))))) + +(define (ascii-alphanumeric? char) + (or (char<=? #\0 char #\9) + (char<=? #\A char #\Z) + (char<=? #\a char #\z))) + +(define (valid-fat-filename-stem? str) + (and (<= (string-length str) 8) + (string-every? ascii-alphanumeric? str))) + +(define (valid-fat-filename-extension? str) + (and (<= (string-length str) 3) + (string-every? ascii-alphanumeric? str))) + +(define (encode-8.3-filename str) + (let* ((dot (string-index str #\.)) + (stem (if dot (string-copy str 0 dot) str)) + (ext (if dot (string-copy str (+ dot 1) (string-length str)) ""))) + (unless (valid-fat-filename-stem? stem) + (error "stem" stem)) + (unless (valid-fat-filename-extension? ext) + (error "ext" dot ext stem)) + (if (and (valid-fat-filename-stem? stem) + (valid-fat-filename-extension? ext)) + (string->utf8 (string-append (string-pad stem 8 #\space) + (string-pad ext 3 #\space))) + (error "Bad 8.3 filename" str)))) + +(define (encode-directory-entry entry) + (let ((attributes (bitwise-ior #x20 (if (fat-directory? entry) #x10 0)))) + (bytevector-append + (encode-8.3-filename (fat-directory-entry-name entry)) + (u8 attributes) + (u8 0) ; misc non-portable info + (u8 0) ; misc non-portable info + (u16l 0) ; create time-of-day + (u16l 0) ; create date + (u16l 0) ; access date + (u16l 0) ; misc non-portable info + (u16l 0) ; modify time-of-day + (u16l 0) ; modify date + (u16l (if (fat-file? entry) (fat-file-first-cluster entry) 0)) + (u32l (if (fat-file? entry) (fat-file-size entry) 0))))) + +(define (write-tree directory) + (write-bytevector + (bytevector-concatenate + (map encode-directory-entry + (fat-directory-entries directory)))) + (for-each write-tree + (filter fat-directory? (fat-directory-entries directory)))) + +(define (write-drive drive) + (write-tree (drive-root-directory drive))) + +(define (display-drive drive) + (define (emit nest str) + (write-string (make-string (* 2 nest) #\space)) + (write-string str) + (newline)) + (define (dump-directory-entries nest directory) + (for-each (lambda (entry) + (emit nest (fat-directory-entry-name entry)) + (when (fat-directory? entry) + (dump-directory-entries (+ nest 1) entry))) + (fat-directory-entries directory))) + (emit 0 (drive-letter drive)) + (dump-directory-entries 1 (drive-root-directory drive))) + +(define (main) + (input) + (for-each build-file-allocation-table (get-used-drives)) + (for-each display-drive (get-used-drives)) + (for-each write-drive (get-used-drives))) + (main) -(dump-drive "c")