Changeset 10220 in project


Ignore:
Timestamp:
03/31/08 17:33:10 (12 years ago)
Author:
elf
Message:

ignore me still, but almost there.

Location:
release/3/unix-test
Files:
3 moved

Legend:

Unmodified
Added
Removed
  • release/3/unix-test/unix-test.meta

    r10218 r10220  
    1 ;;;; egg:       file-test
    2 ;;;; file:      file-test.meta
     1;;;; egg:       unix-test
     2;;;; file:      unix-test.meta
    33;;;; author:    elf <elf@ephemeral.net>
    4 ;;;; date:      18 Mar 2008
     4;;;; date:      31 Mar 2008
    55;;;; licence:   BSD (see LICENCE)
    66;;;; dialect:   r5rs
    77;;;; requires:  chicken build tools
    88;;;; version:   1.0
    9 ;;;; purpose:   chicken-setup metadata for file-test
     9;;;; purpose:   chicken-setup metadata for unix-test
    1010;;;;
    11 ;;;; history:   1.0  20080318 (elf) Initial release
     11;;;; history:   1.0  20080331 (elf) Initial release
    1212;;;;
    1313
     
    1515
    1616
    17 ((egg       "file-test.egg")
    18  (files     "file-test.scm" "file-test.setup" "file-test.html")
     17((egg       "unix-test.egg")
     18 (files     "unix-test.scm" "unix-test.setup" "unix-test.html")
    1919 (category  os)
    2020 (synopsis  "test(1) equivalence procedures")
    2121 (eggdoc    "doc.scm")
    2222 (author    "elf")
    23  (hidden)
    2423 (license   "BSD"))
    2524
  • release/3/unix-test/unix-test.scm

    r10218 r10220  
    1 ;;;; egg:       file-test
    2 ;;;; file:      file-test.scm
     1;;;; egg:       unix-test
     2;;;; file:      unix-test.scm
    33;;;; author:    elf <elf@ephemeral.net>
    4 ;;;; date:      18 Mar 2008
     4;;;; date:      31 Mar 2008
    55;;;; licence:   BSD (see LICENCE)
    66;;;; dialect:   r5rs
     
    99;;;; purpose:   test(1) equivalency
    1010;;;;
    11 ;;;; history:   1.0  20080318 (elf) Initial release
     11;;;; history:   1.0  20080331 (elf) Initial release
    1212;;;;
    1313
     
    3131        (uses library extras srfi-1 srfi-13 posix)
    3232        (bound-to-procedure
    33             file-test-errarg
    34             file-test-errarg1
    35             file-test-errarg1+
    36             file-test-errarg2+
    37             file-test-errtype
    38             file-test-testtype
    39             file-test-testcar
    40             file-test-testtype-l
    41             file-test-loop1
    42             file-test-loop2n
    43             file-test-loop2d
    44             file-test-loop2r
    45             file-test-base
     33            unix-test:errarg
     34            unix-test:testarg1
     35            unix-test:testarg1+
     36            unix-test:testarg2+
     37            unix-test:errtype
     38            unix-test:testtype
     39            unix-test:testtype-car
     40            unix-test:testtype-l
     41            unix-test:testtype-list
     42            unix-test:testtype-string
     43            unix-test:testtype-real
     44            unix-test:check-list1
     45            unix-test:check-list1+
     46            unix-test:check-string1
     47            unix-test:check-string1+
     48            unix-test:check-string2+
     49            unix-test:check-real2+
     50            unix-test:resolve
     51            unix-test:loop1
     52            unix-test:loop1-m
     53            unix-test:loop2-static
     54            unix-test:loop2-static-m
     55            unix-test:loop2-pair
     56            unix-test:loop2-pair-m
     57            unix-test:loop2-sublist
     58            unix-test:loop2-sublist-m
     59            unix-test:subclause
     60            unix-test:base
    4661            )
    4762        (export
    48             file-test
     63            unix-test
    4964            )
    50         (emit-exports "file-test.exports")
     65        (emit-exports "unix-test.exports")
    5166        (inline)
    5267        (inline-limit 100)
     
    6681
    6782
    68 ;; (file-test-errarg CLAUSE-ID EXPECTED-ARGS CLAUSE)
     83;; (unix-test:errarg CLAUSE-ID EXPECTED-ARGS CLAUSE)
    6984;; throw an arity error
    70 (define-inline (file-test-errarg cid expct l)
    71     (error 'file-test
    72            (conc "wrong number of args to " cid " clause : got "
    73                  (length (cdr l)) ", "
    74                  "expected " expct " - '" l "'")))
    75 
    76 ;; (file-test-testarg1 CLAUSE)
     85(define-inline (unix-test:errarg cid expct l)
     86    (##sys#signal-hook #:arity-error
     87        (##sys#string->symbol (##sys#string-append "unix-test:"
     88                                                   (##sys#symbol->string cid)))
     89        (string-append "bad argument count - received "
     90                       (##sys#number->string (fx- (length l) 1))
     91                       " but expected " expct)
     92        (list l)))
     93
     94;; (unix-test:testarg1 CLAUSE)
    7795;; ensure that there is exactly one argument to clause
    78 (define-inline (file-test-testarg1 l)
     96(define-inline (unix-test:testarg1 l)
    7997    (and (or (null? (cdr l))
    8098             (not (null? (cddr l))))
    81          (file-test-errarg (car l) "1" l)))
    82 
    83 ;; (file-test-testarg1+ CLAUSE)
     99         (unix-test:errarg (car l) "1" l)))
     100
     101;; (unix-test:testarg1+ CLAUSE)
    84102;; ensure that there is at least one argument to clause
    85 (define-inline (file-test-testarg1+ l)
     103(define-inline (unix-test:testarg1+ l)
    86104    (and (null? (cdr l))
    87          (file-test-errarg (car l) "1+" l)))
    88 
    89 ;; (file-test-testarg2+ CLAUSE)
     105         (unix-test:errarg (car l) "1+" l)))
     106
     107;; (unix-test:testarg2+ CLAUSE)
    90108;; ensure that there are at least two arguments to clause
    91 (define-inline (file-test-testarg2+ l)
     109(define-inline (unix-test:testarg2+ l)
    92110    (and (or (null? (cdr l))
    93111             (null? (cddr l)))
    94          (file-test-errarg (car l) "2+" l)))
    95 
    96 ;; (file-test-errtype CLAUSE-ID EXPECTED CLAUSE)
     112         (unix-test:errarg (car l) "2+" l)))
     113
     114;; (unix-test:errtype CLAUSE-ID EXPECTED CLAUSE)
    97115;; throw a type error
    98 (define-inline (file-test-errtype cid expct l)
    99     (error 'file-test
    100            (conc "wrong type to " cid " clause : expected "
    101                  expct " - '" l "'")))
    102 
    103 ;; (file-test-testtype PRED TYPESTR CLAUSE)
    104 ;; ensures each element of clause satisfies the predicate
    105 (define-inline (file-test-testtype pred tstr l)
     116(define-inline (unix-test:errtype cid expct l)
     117    (##sys#signal-hook #:type-error
     118        (##sys#string->symbol (##sys#string-append "unix-test:"
     119                                                   (##sys#symbol->string cid)))
     120        (##sys#string-append "bad argument type - not resolving to " expct)
     121        (list l)))
     122
     123;; (unix-test:testtype PRED TYPESTR CLAUSE)
     124;; ensure each element of clause satisfies the predicate
     125(define-inline (unix-test:testtype pred tstr l)
    106126    (or (every pred (cdr l))
    107         (file-test-errtype (car l) tstr l)))
    108 
    109 ;; (file-test-testcar CSYM ELEM)
    110 ;; ensures that csym is the car of elem
    111 (define-inline (file-test-testcar csym e)
    112     (and (pair? e)
    113          (list? e)
    114          (eq? csym (car e))))
    115 
    116 ;; (file-test-testtype-l PRED CSYM TYPESTR CLAUSE)
    117 ;; ensures each element of clause satisfies pred or is a list with car of csym
    118 (define-inline (file-test-testtype-l pred csym tstr l)
    119     (or (every (disjoin pred (cute file-test-testcar csym <>)) (cdr l))
    120         (file-test-errtype (car l)
    121                            (string-append tstr " or " csym " clause")
    122                            l)))
     127        (unix-test:errtype (car l) tstr l)))
     128
     129;; (unix-test:testtype-car PRED CSYM)
     130;; predicate : either satisfy pred or be a list with car a member of csym
     131(define-inline (unix-test:testtype-car pred csym)
     132    (lambda (x)
     133        (or (pred x)
     134            (and (pair? x)
     135                 (list? x)
     136                 (any (cute eq? (car x) <>) csym)))))
     137
     138;; (unix-test:testtype-l PRED CSYM TYPESTR CLAUSE)
     139;; ensure each element of clause satisfies pred or is a list with car of csym
     140(define-inline (unix-test:testtype-l pred csym tstr l)
     141    (unix-test:testtype (unix-test:testtype-car pred csym) tstr l))
     142
     143;; (unix-test:testtype-list CLAUSE)
     144;; ensure each element of clause is a proper list
     145(define-inline (unix-test:testtype-list l)
     146    (unix-test:testtype (conjoin pair? list?) "list" l))
     147
     148;; (unix-test:testtype-string CLAUSE)
     149;; ensure each element of clause can resolve to a string
     150(define-inline (unix-test:testtype-string l)
     151    (unix-test:testtype-l string? '(path append) "string" l))
     152
     153;; (unix-test:testtype-real CLAUSE)
     154;; ensure each element of clause can resolve to a real number
     155(define-inline (unix-test:testtype-real l)
     156    (unix-test:testtype-l real? '(size length) "number" l))
     157
     158
     159
     160;;; inline combined check procedures
     161
     162
     163;; all of these take in a clause, check arity (determined by last 1 or 2 chars)
     164;; and perform the typechecking.  these are convenience procedures to keep
     165;; my hands from wearing into nothing.
     166
     167(define-inline (unix-test:check-list1 l)
     168    (unix-test:testarg1 l)
     169    (unix-test:testtype-list l))
     170
     171(define-inline (unix-test:check-list1+ l)
     172    (unix-test:testarg1+ l)
     173    (unix-test:testtype-list l))
     174
     175(define-inline (unix-test:check-string1 l)
     176    (unix-test:testarg1 l)
     177    (unix-test:testtype-string l))
     178
     179(define-inline (unix-test:check-string1+ l)
     180    (unix-test:testarg1+ l)
     181    (unix-test:testtype-string l))
     182
     183(define-inline (unix-test:check-string2+ l)
     184    (unix-test:testarg2+ l)
     185    (unix-test:testtype-string l))
     186
     187(define-inline (unix-test:check-real2+ l)
     188    (unix-test:testarg2+ l)
     189    (unix-test:testtype-real l))
    123190
    124191
     
    127194
    128195
    129 ;; (file-test-resolve VAL)
    130 ;; resolves a clause element into a value
    131 (define-inline (file-test-resolve v)
     196;; (unix-test:resolve VAL)
     197;; resolve a clause element into a value
     198(define-inline (unix-test:resolve v)
    132199    (if (list? v)
    133         (file-test-base v)
     200        (unix-test:subclause v)
    134201        v))
    135202
    136 ;; (file-test-loop1 PROC LIST)
    137 ;; runs single-arg proc over each element of list
     203;; (unix-test:loop1 PROC LIST)
     204;; apply single-arg proc to each element of list
    138205;; this is for non-comparison tests (eg file-type satisfaction)
    139 (define-inline (file-test-loop1 proc l)
     206(define-inline (unix-test:loop1 proc l)
     207    (and (every (lambda (x) (proc (unix-test:resolve x))) (cdr l))
     208         #t))
     209
     210;; (unix-test:loop1-m PROC LIST MOD)
     211;; apply single-arg proc to each element of list
     212;; mod is applied to each element before proc
     213(define-inline (unix-test:loop1-m proc l pmod)
    140214    (and (every
    141              (lambda (x) (proc (file-test-resolve x)))
    142              l)
     215             (lambda (x)
     216                 (let ((t   (unix-test:resolve x)))
     217                     (and (file-exists? t)
     218                          (proc (pmod t)))))
     219             (cdr l))
    143220         #t))
    144221
    145 ;; (file-test-loop2n PROC VAL LIST)
    146 ;; runs two-arg proc over each element of list with val
     222;; (unix-test:loop2-static PROC LIST)
     223;; apply two-arg proc to first list element with every other element of list
    147224;; this is for comparison tests with a constant value
    148 (define-inline (file-test-loop2n proc v l)
    149     (and (every
    150              (lambda (x) (proc v (file-test-resolve x)))
    151              l)
    152          #t))
    153 
    154 ;; (file-test-loop2d PROC LIST)
    155 ;; runs two-arg proc over each car cadr pair in list excepting the terminal '()
     225(define-inline (unix-test:loop2-static proc l)
     226    (let ((v   (unix-test:resolve (cadr l))))
     227        (and (every (lambda (x) (proc v (unix-test:resolve x))) (cddr l))
     228             #t)))
     229
     230;; (unix-test:loop2-static-m PROC LIST MOD)
     231;; apply two-arg proc to first list element with every other element of list
     232;; mod is applied to each element before applying proc
     233(define-inline (unix-test:loop2-static-m proc l pmod)
     234    (let ((v   (unix-test:resolve (cadr l))))
     235        (and (file-exists? v)
     236             (set! v (pmod v))
     237             (every
     238                 (lambda (x)
     239                     (let ((t   (unix-test:resolve x)))
     240                         (and (file-exists? t)
     241                              (proc v (pmod t)))))
     242                 (cddr l))
     243             #t)))
     244
     245;; (unix-test:loop2-pair PROC LIST)
     246;; apply two-arg proc to each successive pair of values
     247;; (eg, for input of '(1 2 3 4), apply proc to 1 2, 2 3, and 3 4)
    156248;; this is for order comparison tests
    157 (define-inline (file-test-loop2d proc l)
    158     (let loop ((v   (file-test-resolve (car l)))
    159                (l   (cdr l)))
    160         (if (null? l)
    161             #t
    162             (let ((t   (file-test-resolve (cadr l))))
     249(define-inline (unix-test:loop2-pair proc l)
     250    (let loop ((v   (unix-test:resolve (cadr l)))
     251               (l   (cddr l)))
     252        (or (null? l)
     253            (let ((t   (unix-test:resolve (car l))))
    163254                (and (proc v t)
    164255                     (loop t (cdr l)))))))
    165256
    166 ;; (file-test-loop2r PROC LIST)
    167 ;; runs two-arg proc over each car cdr pair in list (every sublist)
     257;; (unix-test:loop2-pair-m PROC LIST MOD)
     258;; apply two-arg proc to each successive pair of values
     259;; mod is applied to each element before applying proc
     260(define-inline (unix-test:loop2-pair-m proc l pmod)
     261    (let ((v   (unix-test:resolve (cadr l))))
     262        (and (file-exists? v)
     263             (let loop ((v   (pmod v))
     264                        (l   (cddr l)))
     265                 (or (null? l)
     266                     (let ((t   (unix-test:resolve (car l))))
     267                         (and (file-exists? t)
     268                              (set! t (pmod t))
     269                              (proc v t)
     270                              (loop t (cdr l)))))))))
     271
     272;; (unix-test:loop2-sublist PROC LIST)
     273;; apply two-arg proc to each sublist of list
     274;; (eg, for input of '(1 2 3 4), apply proc to 1 (2 3 4), 2 (3 4), and 3 (4))
    168275;; this is for inequality tests
    169 (define-inline (file-test-loop2r proc l)
    170     (call-with-current-continuation
    171         (lambda (k)
    172             (pair-fold
    173                 (lambda (x p)
    174                     (or (null? (cdr x))
    175                         (every (cute proc (car x) <>) (cdr x))
    176                         (k #f)))
    177                 #t
    178                 (map file-test-resolve l)))))
    179 
    180 
    181 
    182 ;;; file-test
    183 
    184 
    185 ;; (file-test-base CLAUSES)
    186 ;;
    187 (define (test-files l)
     276(define-inline (unix-test:loop2-sublist proc l)
     277    (let loop ((v   (unix-test:resolve (cadr l)))
     278               (l   (map unix-test:resolve (cddr l))))
     279        (or (null? l)
     280            (and (every (cute proc v <>) l)
     281                 (loop (car l) (cdr l))))))
     282
     283;; (unix-test:loop2-sublist-m PROC LIST MOD)
     284;; apply two-arg proc to each sublist of list
     285;; mod is applied to each element before applying proc
     286(define-inline (unix-test:loop2-sublist-m proc l pmod)
     287    (let ((l   (map unix-test:resolve (cdr l))))
     288        (and (every file-exists? l)
     289             (let loop ((v   (pmod (car l)))
     290                        (l   (map pmod (cdr l))))
     291                 (or (null? l)
     292                     (and (every (cute proc v <>) l)
     293                          (loop (car l) (cdr l))))))))
     294
     295
     296
     297;;; unix-test
     298
     299
     300;; (unix-test:subclause CLAUSE)
     301;; dispatcher for clauses valid only within other clauses
     302(define (unix-test:subclause l)
     303    (case (car l)
     304        ((size)
     305            ;; file size - input: string  output: integer
     306            (unix-test:check-string1 l)
     307            (let ((t   (unix-test:resolve (cadr l))))
     308                (if (and (file-exists? t) (regular-file? t))
     309                    (file-size t)
     310                    -1)))
     311        ((length)
     312            ;; string length - input: string  output: integer
     313            (unix-test:check-string1 l)
     314            (string-length (unix-test:resolve (cadr l))))
     315        ((path)
     316            ;; canonical path - input: string  output: string
     317            (unix-test:check-string1 l)
     318            (canonical-path (unix-test:resolve (cadr l))))
     319        ((append)
     320            ;; string append - input: string+  output: string
     321            (unix-test:check-string1+ l)
     322            (string-join (map unix-test:resolve (cdr l)) ""))
     323        (else
     324            ;; we should never get here
     325            (##sys#error "we should not be here" l))))
     326
     327;; (unix-test:base CLAUSES)
     328;; the big honkin dispatcher for tests
     329(define (unix-test:base l)
    188330    (or (list? l)
    189         (error 'test-files (conc "not a list - '" l "'")))
    190     (case (car l)
    191         ((not)
    192             (test-files-testarg1 '! l)
    193             (test-files-loop1 not (cdr l)))
    194         ((and)
    195             (test-files-testarg1 'a l)
    196             (test-files-testtype 'a list? "list" l)
    197             (if (every test-files (cdr l))
    198                 #t
    199                 #f))
    200         ((or)
    201             (test-files-testarg1 'o l)
    202             (test-files-testtype 'o list? "list" l)
    203             (if (any test-files (cdr l))
    204                 #t
    205                 #f))
    206         ((string=0 string>0)
    207             (test-files-testarg1 (car l) l)
    208             (test-files-testtype (car l) string? "string" l)
    209             (test-files-loop1
    210                 (if (eq? 'z (car l))
    211                     string-null?
    212                     (compose not string-null?))
    213                 (cdr l)))
    214         ((string=)
    215             (test-files-testarg2 (car l) l)
    216             (test-files-testtype (car l) string? "string" l)
    217             (test-files-loop2n string=? (cadr l) (cddr l)))
    218         ((string!=)
    219             (test-files-testarg2 (car l) l)
    220             (test-files-testtype (car l) string? "string" l)
    221             (test-files-loop2r
    222                 (lambda (s l)
    223                     (not (any (cut string=? s <>) l)))
    224                 (cdr l)))
    225         ((num=)
    226             (test-files-testarg2 (car l) l)
    227             (test-files-testtype (car l) integer? "integer" l)
    228             (test-files-loop2n = (cadr l) (cddr l)))
    229         ((num!=)
    230             (test-files-testarg2 (car l) l)
    231             (test-files-testtype (car l) integer? "integer" l)
    232             (test-files-loop2r
    233                 (lambda (i l)
    234                     (not (any (cut = i <>) l)))
    235                 (cdr l)))
    236         ((num< num<= num> num>=)
    237             (test-files-testarg2 (car l) l)
    238             (test-files-testtype (car l) integer? "integer" l)
    239             (test-files-loop2d
    240                 (case (car l)
    241                     ((ge)    >=)
    242                     ((gt)    >)
    243                     ((le)    <=)
    244                     ((lt)    <))
    245                 (cdr l)))
    246         ((equal)
    247             (test-files-testarg2 'ef l)
    248             (test-files-testtype 'ef string? "string" l)
    249             (if (file-exists? (cadr l))
    250                 (test-files-loop2n
     331        (##sys#signal-hook #:type-error 'unix-test
     332            "bad argument type - not a proper list"
     333            (list l)))
     334    (if (null? l)
     335        #f
     336        (case (car l)
     337            ((not)
     338                (unix-test:check-list1 l)
     339                (not (unix-test:base (cadr l))))
     340            ((and)
     341                (unix-test:check-list1+ l)
     342                (and (every unix-test:base (cdr l))
     343                     #t))
     344            ((or)
     345                (unix-test:check-list1+ l)
     346                (and (any unix-test:base (cdr l))
     347                     #t))
     348            ((length=0)
     349                (unix-test:check-string1+ l)
     350                (unix-test:loop1 string-null? l))
     351            ((length>0)
     352                (unix-test:check-string1+ l)
     353                (unix-test:loop1 (compose not string-null?) l))
     354            ((string=)
     355                (unix-test:check-string2+ l)
     356                (unix-test:loop2-static string=? l))
     357            ((string!=)
     358                (unix-test:check-string2+ l)
     359                (unix-test:loop2-sublist (compose not string=?) l))
     360            ((string<)
     361                (unix-test:check-string2+ l)
     362                (unix-test:loop2-pair string<? l))
     363            ((string<=)
     364                (unix-test:check-string2+ l)
     365                (unix-test:loop2-pair string<=? l))
     366            ((string>=)
     367                (unix-test:check-string2+ l)
     368                (unix-test:loop2-pair string>=? l))
     369            ((string>)
     370                (unix-test:check-string2+ l)
     371                (unix-test:loop2-pair string>? l))
     372            ((num=)
     373                (unix-test:check-real2+ l)
     374                (unix-test:loop2-static = l))
     375            ((num!=)
     376                (unix-test:check-real2+ l)
     377                (unix-test:loop2-sublist (compose not =) l))
     378            ((num<)
     379                (unix-test:check-real2+ l)
     380                (unix-test:loop2-pair < l))
     381            ((num<=)
     382                (unix-test:check-real2+ l)
     383                (unix-test:loop2-pair <= l))
     384            ((num>=)
     385                (unix-test:check-real2+ l)
     386                (unix-test:loop2-pair >= l))
     387            ((num>)
     388                (unix-test:check-real2+ l)
     389                (unix-test:loop2-pair > l))
     390            ((equal equals same)
     391                (unix-test:check-string2+ l)
     392                (unix-test:loop2-static-m
    251393                    (lambda (v x)
    252                         (if (file-exists? x)
    253                             (let ((t   (file-stat x)))
    254                                 (and (= (vector-ref v 0) (vector-ref t 0))
    255                                      (= (vector-ref v 9) (vector-ref t 9))))
    256                             #f))
    257                     (file-stat (cadr l))
    258                     (cddr l))
    259                 #f))
    260         ((newer older)
    261             (test-files-testarg2 (car l) l)
    262             (test-files-testtype (car l) string? "string" l)
    263             (if (every file-exists? (cdr l))
    264                 (test-files-loop2d
    265                     (if (eq? 'nt (car l))
    266                         >
    267                         <)
    268                     (map file-modification-time (cdr l)))
    269                 #f))
    270         ((exists exist)
    271             (test-files-testarg1 'e l)
    272             (test-files-testtype 'e string? "string" l)
    273             (test-files-loop1 file-exists? (cdr l)))
    274         ((blockdev chardev directory regular symlink pipe socket)
    275             (test-files-testarg1 (car l) l)
    276             (test-files-testtype (car l) string? "string" l)
    277             (if (every file-exists? (cdr l))
    278                 (test-files-loop1
    279                     (case (car l)
    280                         ((b)      stat-block-device?)
    281                         ((c)      stat-char-device?)
    282                         ((d)      stat-directory?)
    283                         ((f)      stat-regular?)
    284                         ((h L)    stat-symlink?)
    285                         ((p)      stat-fifo?)
    286                         ((S)      stat-socket?))
    287                     (cdr l))
    288                 #f))
    289         ((setgid stickybit setuid)
    290             (test-files-testarg1 (car l) l)
    291             (test-files-testtype (car l) string? "string" l)
    292             (if (every file-exists? (cdr l))
    293                 (test-files-loop2n
    294                     (lambda (v x)
    295                         (> (bitwise-and (file-permissions x) v) 0))
    296                     (case (car l)
    297                         ((g)    perm/isgid)
    298                         ((k)    perm/isvtx)
    299                         ((u)    perm/isuid))
    300                     (cdr l))
    301                 #f))
    302         ((size>0)
    303             (test-files-testarg1 's l)
    304             (test-files-testtype 's string? "string" l)
    305             (if (every file-exists? (cdr l))
    306                 (test-files-loop1
     394                        (and (= (vector-ref v 0) (vector-ref x 0))
     395                             (= (vector-ref v 9) (vector-ref x 9))))
     396                    l
     397                    file-stat))
     398            ((newer)
     399                (unix-test:check-string2+ l)
     400                (unix-test:loop2-pair-m > l file-modification-time))
     401            ((older)
     402                (unix-test:check-string2+ l)
     403                (unix-test:loop2-pair-m < l file-modification-time))
     404            ((exists exist)
     405                (unix-test:check-string1+ l)
     406                (unix-test:loop1 file-exists? l))
     407            ((blockdev block-dev)
     408                (unix-test:check-string1+ l)
     409                (unix-test:loop1-m stat-block-device? l identity))
     410            ((chardev char-dev)
     411                (unix-test:check-string1+ l)
     412                (unix-test:loop1-m stat-char-device? l identity))
     413            ((directory dir)
     414                (unix-test:check-string1+ l)
     415                (unix-test:loop1-m stat-directory? l identity))
     416            ((regfile regular regular-file reg-file reg)
     417                (unix-test:check-string1+ l)
     418                (unix-test:loop1-m stat-regular? l identity))
     419            ((symlink sym-link)
     420                (unix-test:check-string1+ l)
     421                (unix-test:loop1-m stat-symlink? l identity))
     422            ((pipe fifo)
     423                (unix-test:check-string1+ l)
     424                (unix-test:loop1-m stat-fifo? l identity))
     425            ((socket)
     426                (unix-test:check-string1+ l)
     427                (unix-test:loop1-m stat-socket? l identity))
     428            ((setuid set-uid)
     429                (unix-test:check-string1+ l)
     430                (unix-test:loop1-m
     431                    (lambda (x) (fx> (bitwise-and perm/isuid x) 0))
     432                    l
     433                    file-permissions))
     434            ((setgid set-gid)
     435                (unix-test:check-string1+ l)
     436                (unix-test:loop1-m
     437                    (lambda (x) (fx> (bitwise-and perm/isgid x) 0))
     438                    l
     439                    file-permissions))
     440            ((stickybit sticky-bit sticky)
     441                (unix-test:check-string1+ l)
     442                (unix-test:loop1-m
    307443                    (lambda (x)
    308                         (> (file-size x) 0))
    309                     (cdr l))
    310                 #f))
    311         ((readable writeable executable)
    312             (test-files-testarg1 (car l) l)
    313             (test-files-testtype (car l) string? "string" l)
    314             (if (every file-exists? (cdr l))
    315                 (test-files-loop2n
    316                     (lambda (v x)
    317                         (let ((t   (file-stat x)))
    318                             (if (= (vector-ref t 3) (vector-ref v 0))
    319                                 (> (bitwise-and (vector-ref t 1)
    320                                                 (vector-ref v 2))
    321                                    0)
    322                                 (if (= (vector-ref t 4) (vector-ref v 1))
    323                                     (> (bitwise-and (vector-ref t 1)
    324                                                     (vector-ref v 3))
    325                                        0)
    326                                     (> (bitwise-and (vector-ref t 1)
    327                                                     (vector-ref v 4))
    328                                        0)))))
    329                     (case (car l)
    330                         ((r)
    331                             (vector (current-effective-user-id)
    332                                     (current-effective-group-id)
    333                                     (+ perm/irusr perm/irgrp perm/iroth)
    334                                     (+ perm/irgrp perm/iroth)
    335                                     perm/iroth))
    336                         ((w)
    337                             (vector (current-effective-user-id)
    338                                     (current-effective-group-id)
    339                                     (+ perm/iwusr perm/iwgrp perm/iwoth)
    340                                     (+ perm/iwgrp perm/iwoth)
    341                                     perm/iwoth))
    342                         ((x)
    343                             (vector (current-effective-user-id)
    344                                     (current-effective-group-id)
    345                                     (+ perm/ixusr perm/ixgrp perm/ixoth)
    346                                     (+ perm/ixgrp perm/ixoth)
    347                                     perm/ixoth)))
    348                     (cdr l))
    349                 #f))
    350         ((groupowned userowned)
    351             (test-files-testarg1 (car l) l)
    352             (test-files-testtype (car l) string? "string" l)
    353             (if (every file-exists? (cdr l))
    354                 (test-files-loop2n
    355                     (lambda (i x)
    356                         (= (file-owner x) i))
    357                     (if (eq? 'G (car l))
    358                         (current-effective-group-id)
    359                         (current-effective-user-id))
    360                     (cdr l))
    361                 #f))
     444                        (fx> (bitwise-and perm/isvtx x) 0))
     445                    l
     446                    file-permissions))
     447            ((size=0)
     448                (unix-test:check-string1+ l)
     449                (unix-test:loop1
     450                    (lambda (x)
     451                        (and (file-exists? x)
     452                             (regular-file? x)
     453                             (fx= (file-size x) 0)))
     454                    l))
     455            ((size>0)
     456                (unix-test:check-string1+ l)
     457                (unix-test:loop1
     458                    (lambda (x)
     459                        (and (file-exists? x)
     460                             (regular-file? x)
     461                             (fx> (file-size x) 0)))
     462                    l))
     463            ((readable read-perm)
     464                (unix-test:check-string1+ l)
     465                (let ((uid   (current-effective-user-id))
     466                      (gid   (current-effective-group-id))
     467                      (usr   (bitwise-ior perm/irusr perm/irgrp perm/iroth))
     468                      (grp   (bitwise-ior perm/irgrp perm/iroth))
     469                      (oth   perm/iroth))
     470                    (unix-test:loop1-m
     471                        (lambda (x)
     472                            (fx> (bitwise-and
     473                                     (vector-ref x 1)
     474                                     (or (and (fx= uid (vector-ref x 3)) usr)
     475                                         (and (fx= gid (vector-ref x 4)) grp)
     476                                         oth))
     477                                 0))
     478                        l
     479                        file-stat)))
     480            ((writeable writable write-perm)
     481                (unix-test:check-string1+ l)
     482                (let ((uid   (current-effective-user-id))
     483                      (gid   (current-effective-group-id))
     484                      (usr   (bitwise-ior perm/iwusr perm/iwgrp perm/iwoth))
     485                      (grp   (bitwise-ior perm/iwgrp perm/iwoth))
     486                      (oth   perm/iwoth))
     487                    (unix-test:loop1-m
     488                        (lambda (x)
     489                            (fx> (bitwise-and
     490                                     (vector-ref x 1)
     491                                     (or (and (fx= uid (vector-ref x 3)) usr)
     492                                         (and (fx= gid (vector-ref x 4)) grp)
     493                                         oth))
     494                                 0))
     495                        l
     496                        file-stat)))
     497            ((executable searchable exec-perm search-perm)
     498                (unix-test:check-string1+ l)
     499                (let ((uid   (current-effective-user-id))
     500                      (gid   (current-effective-group-id))
     501                      (usr   (bitwise-ior perm/ixusr perm/ixgrp perm/ixoth))
     502                      (grp   (bitwise-ior perm/ixgrp perm/ixoth))
     503                      (oth   perm/ixoth))
     504                    (unix-test:loop1-m
     505                        (lambda (x)
     506                            (fx> (bitwise-and
     507                                     (vector-ref x 1)
     508                                     (or (and (fx= uid (vector-ref x 3)) usr)
     509                                         (and (fx= gid (vector-ref x 4)) grp)
     510                                         oth))
     511                                 0))
     512                        l
     513                        file-stat)))
     514            ((userowned user-owned user-is-owner owned-by-user)
     515                (unix-test:check-string1+ l)
     516                (let ((uid   (current-effective-user-id)))
     517                    (unix-test:loop1-m (cute fx= uid <>) l file-owner)))
     518            ((groupowned group-owned group-is-owner owned-by-group)
     519                (unix-test:check-string1+ l)
     520                (let ((gid   (current-effective-group-id)))
     521                    (unix-test:loop1-m (cute fx= gid <>) l file-owner)))
     522            ((terminal term
    362523        ((terminal)
    363524            (test-files-testarg1 (car l) l)
  • release/3/unix-test/unix-test.setup

    r10218 r10220  
    1 ;;;; egg:       file-test
    2 ;;;; file:      file-test.setup
     1;;;; egg:       unix-test
     2;;;; file:      unix-test.setup
    33;;;; author:    elf <elf@ephemeral.net>
    4 ;;;; date:      18 Mar 2008
     4;;;; date:      31 Mar 2008
    55;;;; licence:   BSD (see LICENCE)
    66;;;; dialect:   r5rs
    77;;;; requires:  chicken build tools
    88;;;; version:   1.0
    9 ;;;; purpose:   chicken-setup installation instructions for file-test
     9;;;; purpose:   chicken-setup installation instructions for unix-test
    1010;;;;
    11 ;;;; history:   1.0  20080318 (elf) Initial release
     11;;;; history:   1.0  20080331 (elf) Initial release
    1212;;;;
    1313
     
    1515
    1616
    17 (compile file-test.scm -O2 -s -G -d0 -x -no-trace -no-lambda-info)
     17(compile unix-test.scm -O2 -s -G -d0 -x -no-trace -no-lambda-info)
    1818
    1919
    2020
    2121(install-extension
    22     'file-test
    23     '("file-test.so" "file-test.exports" "file-test.html")
     22    'unix-test
     23    '("unix-test.so" "unix-test.exports" "unix-test.html")
    2424    '((version        1.0)
    25       (documentation  "file-test.html")
    26       (exports        "file-test.exports")))
     25      (documentation  "unix-test.html")
     26      (exports        "unix-test.exports")))
    2727
Note: See TracChangeset for help on using the changeset viewer.