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

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

ignore me still, but almost there.

File size: 19.2 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 srfi-1 srfi-13 posix)
32        (bound-to-procedure
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
61            )
62        (export
63            unix-test
64            )
65        (emit-exports "unix-test.exports")
66        (inline)
67        (inline-limit 100)
68        (lambda-lift)
69        (disable-interrupts)
70        (no-bound-checks)
71        (no-procedure-checks)
72        (standard-bindings)
73        (extended-bindings)
74        (usual-integrations)
75        (run-time-macros)
76    ))
77
78
79
80;;; inline check/error procedures
81
82
83;; (unix-test:errarg CLAUSE-ID EXPECTED-ARGS CLAUSE)
84;; throw an arity error
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)
95;; ensure that there is exactly one argument to clause
96(define-inline (unix-test:testarg1 l)
97    (and (or (null? (cdr l))
98             (not (null? (cddr l))))
99         (unix-test:errarg (car l) "1" l)))
100
101;; (unix-test:testarg1+ CLAUSE)
102;; ensure that there is at least one argument to clause
103(define-inline (unix-test:testarg1+ l)
104    (and (null? (cdr l))
105         (unix-test:errarg (car l) "1+" l)))
106
107;; (unix-test:testarg2+ CLAUSE)
108;; ensure that there are at least two arguments to clause
109(define-inline (unix-test:testarg2+ l)
110    (and (or (null? (cdr l))
111             (null? (cddr l)))
112         (unix-test:errarg (car l) "2+" l)))
113
114;; (unix-test:errtype CLAUSE-ID EXPECTED CLAUSE)
115;; throw a type error
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)
126    (or (every pred (cdr 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))
190
191
192
193;;; inline loop procedures
194
195
196;; (unix-test:resolve VAL)
197;; resolve a clause element into a value
198(define-inline (unix-test:resolve v)
199    (if (list? v)
200        (unix-test:subclause v)
201        v))
202
203;; (unix-test:loop1 PROC LIST)
204;; apply single-arg proc to each element of list
205;; this is for non-comparison tests (eg file-type satisfaction)
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)
214    (and (every
215             (lambda (x)
216                 (let ((t   (unix-test:resolve x)))
217                     (and (file-exists? t)
218                          (proc (pmod t)))))
219             (cdr l))
220         #t))
221
222;; (unix-test:loop2-static PROC LIST)
223;; apply two-arg proc to first list element with every other element of list
224;; this is for comparison tests with a constant value
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)
248;; this is for order comparison tests
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))))
254                (and (proc v t)
255                     (loop t (cdr l)))))))
256
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))
275;; this is for inequality tests
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)
330    (or (list? l)
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
393                    (lambda (v x)
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
443                    (lambda (x)
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
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
Note: See TracBrowser for help on using the repository browser.