#lang scheme/base (require (prefix-in gen: "generate-ffi.ss") (prefix-in s: "lookup.ss") scheme/foreign) (unsafe!) (define ffi-stat (gen:access)) (define (stat i . flags) (let ((flags (apply vector flags))) (cond ((string? i) (ffi-stat (string->path i) flags)) ((path? i) (ffi-stat i flags)) ((port? i) (ffi-stat i flags)) (else (error "Don't know how to stat" i))))) (define (type-bits i) (arithmetic-shift (bitwise-and (stat i s:mode) #o777000) (- #o11))) (define (normal-file? bits) (= #o100 bits)) (define (directory? bits) (= #o40 (bitwise-and #o40 bits))) (define (link? bits) (= #o120 bits)) (define (fold-files proc init (very-top (build-path #f))) (let do-directory ((top very-top) (result init)) (let ((contents (map (λ (i) (build-path top i)) (directory-list top)))) (let do-list ((contents contents) (result result) (dirs null)) (if (null? contents) (foldl (λ (dir result) (do-directory dir result)) result dirs) (let* ((item (car contents)) (bits (type-bits item)) (result (proc item (cond ((normal-file? bits) 'file) ((directory? bits) 'directory) ((link? bits) 'link) (else 'other)) result))) (do-list (cdr contents) result (if (directory? bits) (cons item dirs) dirs)))))))) (define (main) (for-each (λ (n) (display n)(newline) (display (number->string (stat n s:mode) #o10))(newline) (let ((bits (type-bits n))) (display (number->string bits #o10)) (newline) (display (directory? bits)) (newline) (display (normal-file? bits))(newline))) '("main.ss" "feep.ss" "/tmp" "/usr" "/home/synx" "/dev/null" "/bin/bash" "faoeuuou"))) (provide main stat)