source: project/release/3/unix-test/unix-test.scm @ 10221

Last change on this file since 10221 was 10221, checked in by elf, 12 years ago

almost there

File size: 18.0 KB
Line 
1;;;; egg:       unix-test
2;;;; file:      unix-test.scm
3;;;; author:    elf <elf@ephemeral.net>
4;;;; date:      31 Mar 2008
5;;;; licence:   BSD (see LICENCE)
6;;;; dialect:   r5rs
7;;;; requires:  srfi-1, srfi-13, posix
8;;;; version:   1.0
9;;;; purpose:   test(1) equivalency
10;;;;
11;;;; history:   1.0  20080331 (elf) Initial release
12;;;;
13
14
15
16
17;;; chicken library loading
18
19
20(use srfi-1)     ; list library
21(use srfi-13)    ; string library
22(use posix)      ; POSIX bindings
23
24
25
26;;; chicken compile-time directives
27
28
29(eval-when (compile)
30    (declare
31        (uses library extras eval srfi-1 srfi-13 posix)
32        (bound-to-procedure
33            unix-test:isatty?
34            unix-test:errarg
35            unix-test:testarg1
36            unix-test:testarg1+
37            unix-test:testarg2+
38            unix-test:errtype
39            unix-test:testtype
40            unix-test:testtype-car
41            unix-test:testtype-l
42            unix-test:testtype-list
43            unix-test:testtype-string
44            unix-test:testtype-real
45            unix-test:check-list1
46            unix-test:check-list1+
47            unix-test:check-string1
48            unix-test:check-string1+
49            unix-test:check-string2+
50            unix-test:check-real2+
51            unix-test:resolve
52            unix-test:loop1
53            unix-test:loop1-m
54            unix-test:loop2-static
55            unix-test:loop2-static-m
56            unix-test:loop2-pair
57            unix-test:loop2-pair-m
58            unix-test:loop2-sublist
59            unix-test:loop2-sublist-m
60            unix-test:subclause
61            unix-test:base
62            )
63;        (export
64;            unix-test
65;            )
66        (emit-exports "unix-test.exports")
67        (inline)
68        (inline-limit 100)
69        (lambda-lift)
70        (disable-interrupts)
71        (no-bound-checks)
72        (no-procedure-checks)
73        (standard-bindings)
74        (extended-bindings)
75        (usual-integrations)
76        (run-time-macros)
77    ))
78
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
105
106
107;;; inline check/error procedures
108
109
110;; (unix-test:errarg CLAUSE-ID EXPECTED-ARGS CLAUSE)
111;; throw an arity error
112(define-inline (unix-test:errarg cid expct l)
113    (##sys#signal-hook #:arity-error
114        (##sys#string->symbol (##sys#string-append "unix-test:"
115                                                   (##sys#symbol->string cid)))
116        (string-append "bad argument count - received "
117                       (##sys#number->string (fx- (length l) 1))
118                       " but expected " expct)
119        (list l)))
120
121;; (unix-test:testarg1 CLAUSE)
122;; ensure that there is exactly one argument to clause
123(define-inline (unix-test:testarg1 l)
124    (and (or (null? (cdr l))
125             (not (null? (cddr l))))
126         (unix-test:errarg (car l) "1" l)))
127
128;; (unix-test:testarg1+ CLAUSE)
129;; ensure that there is at least one argument to clause
130(define-inline (unix-test:testarg1+ l)
131    (and (null? (cdr l))
132         (unix-test:errarg (car l) "1+" l)))
133
134;; (unix-test:testarg2+ CLAUSE)
135;; ensure that there are at least two arguments to clause
136(define-inline (unix-test:testarg2+ l)
137    (and (or (null? (cdr l))
138             (null? (cddr l)))
139         (unix-test:errarg (car l) "2+" l)))
140
141;; (unix-test:errtype CLAUSE-ID EXPECTED CLAUSE)
142;; throw a type error
143(define-inline (unix-test:errtype cid expct l)
144    (##sys#signal-hook #:type-error 
145        (##sys#string->symbol (##sys#string-append "unix-test:"
146                                                   (##sys#symbol->string cid)))
147        (##sys#string-append "bad argument type - not resolving to " expct)
148        (list l)))
149
150;; (unix-test:testtype PRED TYPESTR CLAUSE)
151;; ensure each element of clause satisfies the predicate
152(define-inline (unix-test:testtype pred tstr l)
153    (or (every pred (cdr l))
154        (unix-test:errtype (car l) tstr l)))
155
156;; (unix-test:testtype-car PRED CSYM)
157;; predicate : either satisfy pred or be a list with car a member of csym
158(define-inline (unix-test:testtype-car pred csym)
159    (lambda (x)
160        (or (pred x)
161            (and (pair? x)
162                 (list? x)
163                 (any (cute eq? (car x) <>) csym)))))
164
165;; (unix-test:testtype-l PRED CSYM TYPESTR CLAUSE)
166;; ensure each element of clause satisfies pred or is a list with car of csym
167(define-inline (unix-test:testtype-l pred csym tstr l)
168    (unix-test:testtype (unix-test:testtype-car pred csym) tstr l))
169
170;; (unix-test:testtype-list CLAUSE)
171;; ensure each element of clause is a proper list
172(define-inline (unix-test:testtype-list l)
173    (unix-test:testtype (conjoin pair? list?) "list" l))
174
175;; (unix-test:testtype-string CLAUSE)
176;; ensure each element of clause can resolve to a string
177(define-inline (unix-test:testtype-string l)
178    (unix-test:testtype-l string? '(path append) "string" l))
179
180;; (unix-test:testtype-real CLAUSE)
181;; ensure each element of clause can resolve to a real number
182(define-inline (unix-test:testtype-real l)
183    (unix-test:testtype-l real? '(size length) "number" l))
184
185
186
187;;; inline combined check procedures
188
189
190;; all of these take in a clause, check arity (determined by last 1 or 2 chars)
191;; and perform the typechecking.  these are convenience procedures to keep
192;; my hands from wearing into nothing.
193
194(define-inline (unix-test:check-list1 l)
195    (unix-test:testarg1 l)
196    (unix-test:testtype-list l))
197
198(define-inline (unix-test:check-list1+ l)
199    (unix-test:testarg1+ l)
200    (unix-test:testtype-list l))
201
202(define-inline (unix-test:check-string1 l)
203    (unix-test:testarg1 l)
204    (unix-test:testtype-string l))
205
206(define-inline (unix-test:check-string1+ l)
207    (unix-test:testarg1+ l)
208    (unix-test:testtype-string l))
209
210(define-inline (unix-test:check-string2+ l)
211    (unix-test:testarg2+ l)
212    (unix-test:testtype-string l))
213
214(define-inline (unix-test:check-real2+ l)
215    (unix-test:testarg2+ l)
216    (unix-test:testtype-real l))
217
218
219
220;;; inline loop procedures
221
222
223;; (unix-test:resolve VAL)
224;; resolve a clause element into a value
225(define (unix-test:resolve v)
226    (if (list? v)
227        (unix-test:subclause v)
228        v))
229
230;; (unix-test:loop1 PROC LIST)
231;; apply single-arg proc to each element of list
232;; this is for non-comparison tests (eg file-type satisfaction)
233(define-inline (unix-test:loop1 proc l)
234    (and (every (lambda (x) (proc (unix-test:resolve x))) (cdr l))
235         #t))
236
237;; (unix-test:loop1-m PROC LIST MOD)
238;; apply single-arg proc to each element of list
239;; mod is applied to each element before proc
240(define-inline (unix-test:loop1-m proc l pmod)
241    (and (every
242             (lambda (x)
243                 (let ((t   (unix-test:resolve x)))
244                     (and (file-exists? t)
245                          (proc (pmod t)))))
246             (cdr l))
247         #t))
248
249;; (unix-test:loop2-static PROC LIST)
250;; apply two-arg proc to first list element with every other element of list
251;; this is for comparison tests with a constant value
252(define-inline (unix-test:loop2-static proc l)
253    (let ((v   (unix-test:resolve (cadr l))))
254        (and (every (lambda (x) (proc v (unix-test:resolve x))) (cddr l))
255             #t)))
256
257;; (unix-test:loop2-static-m PROC LIST MOD)
258;; apply two-arg proc to first list element with every other element of list
259;; mod is applied to each element before applying proc
260(define-inline (unix-test:loop2-static-m proc l pmod)
261    (let ((v   (unix-test:resolve (cadr l))))
262        (and (file-exists? v)
263             (set! v (pmod v))
264             (every
265                 (lambda (x)
266                     (let ((t   (unix-test:resolve x)))
267                         (and (file-exists? t)
268                              (proc v (pmod t)))))
269                 (cddr l))
270             #t)))
271
272;; (unix-test:loop2-pair PROC LIST)
273;; apply two-arg proc to each successive pair of values
274;; (eg, for input of '(1 2 3 4), apply proc to 1 2, 2 3, and 3 4)
275;; this is for order comparison tests
276(define-inline (unix-test:loop2-pair proc l)
277    (let loop ((v   (unix-test:resolve (cadr l)))
278               (l   (cddr l)))
279        (or (null? l)
280            (let ((t   (unix-test:resolve (car l))))
281                (and (proc v t)
282                     (loop t (cdr l)))))))
283
284;; (unix-test:loop2-pair-m PROC LIST MOD)
285;; apply two-arg proc to each successive pair of values
286;; mod is applied to each element before applying proc
287(define-inline (unix-test:loop2-pair-m proc l pmod)
288    (let ((v   (unix-test:resolve (cadr l))))
289        (and (file-exists? v)
290             (let loop ((v   (pmod v))
291                        (l   (cddr l)))
292                 (or (null? l)
293                     (let ((t   (unix-test:resolve (car l))))
294                         (and (file-exists? t)
295                              (set! t (pmod t))
296                              (proc v t)
297                              (loop t (cdr l)))))))))
298
299;; (unix-test:loop2-sublist PROC LIST)
300;; apply two-arg proc to each sublist of list
301;; (eg, for input of '(1 2 3 4), apply proc to 1 (2 3 4), 2 (3 4), and 3 (4))
302;; this is for inequality tests
303(define-inline (unix-test:loop2-sublist proc l)
304    (let loop ((v   (unix-test:resolve (cadr l)))
305               (l   (map unix-test:resolve (cddr l))))
306        (or (null? l)
307            (and (every (cute proc v <>) l)
308                 (loop (car l) (cdr l))))))
309
310;; (unix-test:loop2-sublist-m PROC LIST MOD)
311;; apply two-arg proc to each sublist of list
312;; mod is applied to each element before applying proc
313(define-inline (unix-test:loop2-sublist-m proc l pmod)
314    (let ((l   (map unix-test:resolve (cdr l))))
315        (and (every file-exists? l)
316             (let loop ((v   (pmod (car l)))
317                        (l   (map pmod (cdr l))))
318                 (or (null? l)
319                     (and (every (cute proc v <>) l)
320                          (loop (car l) (cdr l))))))))
321
322
323
324;;; unix-test
325
326
327;; (unix-test:subclause CLAUSE)
328;; dispatcher for clauses valid only within other clauses
329(define (unix-test:subclause l)
330    (case (car l)
331        ((size)
332            ;; file size - input: string  output: integer
333            (unix-test:check-string1 l)
334            (let ((t   (unix-test:resolve (cadr l))))
335                (if (and (file-exists? t) (regular-file? t))
336                    (file-size t)
337                    -1)))
338        ((length)
339            ;; string length - input: string  output: integer
340            (unix-test:check-string1 l)
341            (string-length (unix-test:resolve (cadr l))))
342        ((path)
343            ;; canonical path - input: string  output: string
344            (unix-test:check-string1 l)
345            (canonical-path (unix-test:resolve (cadr l))))
346        ((append)
347            ;; string append - input: string+  output: string
348            (unix-test:check-string1+ l)
349            (string-join (map unix-test:resolve (cdr l)) ""))
350        (else
351            ;; we should never get here
352            (##sys#error "we should not be here" l))))
353
354;; (unix-test:base CLAUSES)
355;; the big honkin dispatcher for tests
356(define (unix-test:base l)
357    (or (list? l)
358        (##sys#signal-hook #:type-error 'unix-test
359            "bad argument type - not a proper list"
360            (list l)))
361    (if (null? l)
362        #f
363        (case (car l)
364            ((not)
365                (unix-test:check-list1 l)
366                (not (unix-test:base (cadr l))))
367            ((and)
368                (unix-test:check-list1+ l)
369                (and (every unix-test:base (cdr l))
370                     #t))
371            ((or)
372                (unix-test:check-list1+ l)
373                (and (any unix-test:base (cdr l))
374                     #t))
375            ((length=0)
376                (unix-test:check-string1+ l)
377                (unix-test:loop1 string-null? l))
378            ((length>0)
379                (unix-test:check-string1+ l)
380                (unix-test:loop1 (compose not string-null?) l))
381            ((string=)
382                (unix-test:check-string2+ l)
383                (unix-test:loop2-static string=? l))
384            ((string!=)
385                (unix-test:check-string2+ l)
386                (unix-test:loop2-sublist (compose not string=?) l))
387            ((string<)
388                (unix-test:check-string2+ l)
389                (unix-test:loop2-pair string<? l))
390            ((string<=)
391                (unix-test:check-string2+ l)
392                (unix-test:loop2-pair string<=? l))
393            ((string>=)
394                (unix-test:check-string2+ l)
395                (unix-test:loop2-pair string>=? l))
396            ((string>)
397                (unix-test:check-string2+ l)
398                (unix-test:loop2-pair string>? l))
399            ((num=)
400                (unix-test:check-real2+ l)
401                (unix-test:loop2-static = l))
402            ((num!=)
403                (unix-test:check-real2+ l)
404                (unix-test:loop2-sublist (compose not =) l))
405            ((num<)
406                (unix-test:check-real2+ l)
407                (unix-test:loop2-pair < l))
408            ((num<=)
409                (unix-test:check-real2+ l)
410                (unix-test:loop2-pair <= l))
411            ((num>=)
412                (unix-test:check-real2+ l)
413                (unix-test:loop2-pair >= l))
414            ((num>)
415                (unix-test:check-real2+ l)
416                (unix-test:loop2-pair > l))
417            ((equal equals same)
418                (unix-test:check-string2+ l)
419                (unix-test:loop2-static-m
420                    (lambda (v x)
421                        (and (= (vector-ref v 0) (vector-ref x 0))
422                             (= (vector-ref v 9) (vector-ref x 9))))
423                    l
424                    file-stat))
425            ((newer)
426                (unix-test:check-string2+ l)
427                (unix-test:loop2-pair-m > l file-modification-time))
428            ((older)
429                (unix-test:check-string2+ l)
430                (unix-test:loop2-pair-m < l file-modification-time))
431            ((exists exist)
432                (unix-test:check-string1+ l)
433                (unix-test:loop1 file-exists? l))
434            ((blockdev block-dev)
435                (unix-test:check-string1+ l)
436                (unix-test:loop1-m stat-block-device? l identity))
437            ((chardev char-dev)
438                (unix-test:check-string1+ l)
439                (unix-test:loop1-m stat-char-device? l identity))
440            ((directory dir)
441                (unix-test:check-string1+ l)
442                (unix-test:loop1-m stat-directory? l identity))
443            ((regfile regular regular-file reg-file reg)
444                (unix-test:check-string1+ l)
445                (unix-test:loop1-m stat-regular? l identity))
446            ((symlink sym-link)
447                (unix-test:check-string1+ l)
448                (unix-test:loop1-m stat-symlink? l identity))
449            ((pipe fifo)
450                (unix-test:check-string1+ l)
451                (unix-test:loop1-m stat-fifo? l identity))
452            ((socket)
453                (unix-test:check-string1+ l)
454                (unix-test:loop1-m stat-socket? l identity))
455            ((setuid set-uid)
456                (unix-test:check-string1+ l)
457                (unix-test:loop1-m
458                    (lambda (x) (fx> (bitwise-and perm/isuid x) 0))
459                    l
460                    file-permissions))
461            ((setgid set-gid)
462                (unix-test:check-string1+ l)
463                (unix-test:loop1-m
464                    (lambda (x) (fx> (bitwise-and perm/isgid x) 0))
465                    l
466                    file-permissions))
467            ((stickybit sticky-bit sticky)
468                (unix-test:check-string1+ l)
469                (unix-test:loop1-m
470                    (lambda (x)
471                        (fx> (bitwise-and perm/isvtx x) 0))
472                    l
473                    file-permissions))
474            ((size=0)
475                (unix-test:check-string1+ l)
476                (unix-test:loop1
477                    (lambda (x)
478                        (and (file-exists? x)
479                             (regular-file? x)
480                             (fx= (file-size x) 0)))
481                    l))
482            ((size>0)
483                (unix-test:check-string1+ l)
484                (unix-test:loop1
485                    (lambda (x)
486                        (and (file-exists? x)
487                             (regular-file? x)
488                             (fx> (file-size x) 0)))
489                    l))
490            ((readable read-perm)
491                (unix-test:check-string1+ l)
492                (unix-test:loop1-m file-read-access? l identity))
493            ((writeable writable write-perm)
494                (unix-test:check-string1+ l)
495                (unix-test:loop1-m file-write-access? l identity))
496            ((executable searchable exec-perm search-perm)
497                (unix-test:check-string1+ l)
498                (unix-test:loop1-m file-execute-access? l identity))
499            ((userowned user-owned user-is-owner owned-by-user)
500                (unix-test:check-string1+ l)
501                (let ((uid   (current-effective-user-id)))
502                    (unix-test:loop1-m (cute fx= uid <>) l file-owner)))
503            ((groupowned group-owned group-is-owner owned-by-group)
504                (unix-test:check-string1+ l)
505                (let ((gid   (current-effective-group-id)))
506                    (unix-test:loop1-m (cute fx= gid <>) l file-owner)))
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 TracBrowser for help on using the repository browser.