Changeset 10221 in project


Ignore:
Timestamp:
03/31/08 18:51:14 (12 years ago)
Author:
elf
Message:

almost there

File:
1 edited

Legend:

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

    r10220 r10221  
    2929(eval-when (compile)
    3030    (declare
    31         (uses library extras srfi-1 srfi-13 posix)
     31        (uses library extras eval srfi-1 srfi-13 posix)
    3232        (bound-to-procedure
     33            unix-test:isatty?
    3334            unix-test:errarg
    3435            unix-test:testarg1
     
    6061            unix-test:base
    6162            )
    62         (export
    63             unix-test
    64             )
     63;        (export
     64;            unix-test
     65;            )
    6566        (emit-exports "unix-test.exports")
    6667        (inline)
     
    7677    ))
    7778
     79(eval-when (load eval)
     80    (eval `(define-macro (unix-test l)
     81              `(unix-test:base ',l))))
     82;(eval-when (load eval)
     83    ;(define-macro (unix-text l)
     84    ;    `(unix-test:base ',l)))
     85;    (eval '(define-macro (unix-text l)
     86;               `(unix-test:base ',l))))
     87
     88
     89
     90;;; C directive for terminal type
     91
     92
     93(cond-expand
     94    (windows
     95        (foreign-declare "#define UTEST_ISTTY(p) C_SCHEME_FALSE")
     96    )
     97    (else
     98        (foreign-declare "#include <unistd.h>")
     99        (foreign-declare "#define UTEST_ISTTY(p) C_mk_bool(isatty(C_unfix(p)))")
     100    ))
     101
     102(define unix-test:isatty?
     103    (foreign-lambda bool "UTEST_ISATTY" integer))
     104
    78105
    79106
     
    196223;; (unix-test:resolve VAL)
    197224;; resolve a clause element into a value
    198 (define-inline (unix-test:resolve v)
     225(define (unix-test:resolve v)
    199226    (if (list? v)
    200227        (unix-test:subclause v)
     
    463490            ((readable read-perm)
    464491                (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)))
     492                (unix-test:loop1-m file-read-access? l identity))
    480493            ((writeable writable write-perm)
    481494                (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)))
     495                (unix-test:loop1-m file-write-access? l identity))
    497496            ((executable searchable exec-perm search-perm)
    498497                (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)))
     498                (unix-test:loop1-m file-execute-access? l identity))
    514499            ((userowned user-owned user-is-owner owned-by-user)
    515500                (unix-test:check-string1+ l)
     
    520505                (let ((gid   (current-effective-group-id)))
    521506                    (unix-test:loop1-m (cute fx= gid <>) l file-owner)))
    522             ((terminal term
    523         ((terminal)
    524             (test-files-testarg1 (car l) l)
    525             (test-files-testtype (car l) port? "port" l)
    526             (test-files-loop1 terminal-port? (cdr l)))
    527         ((canonical)
    528             )
    529         ((size)
    530             )
    531         (else
    532             (error 'test-files
    533                    (conc "operation not recognised - '" l "'")))))
    534 
     507            ((terminal term term-port)
     508                (unix-test:testarg1+ l)
     509                (unix-test:testtype (conjoin integer? exact? positive?) "fd" l)
     510                (unix-test:loop1 unix-test:isatty? l))
     511            (else
     512                (##sys#signal-hook #:type-error 'unix-test
     513                    "bad argument type - not a recognised test clause"
     514                    (list l))))))
     515
     516;(define-macro (unix-test:help l)
     517;    `(unix-test:base ,l))
     518
     519;; (unix-test CLAUSE)
     520;; finally, the one exported function
     521;(define-macro (unix-test l)
     522;    `(unix-test:base ',l))
     523;(eval-when (load eval)
     524;    (eval `(define-macro (unix-test l) `(unix-test:help ',l))))
     525
Note: See TracChangeset for help on using the changeset viewer.