test-suite/tests/srfi-37.test

   1 ;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2007, 2008 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-srfi-37)
  20   #:use-module (test-suite lib)
  21   #:use-module (srfi srfi-37))
  22
  23 (with-test-prefix "SRFI-37"
  24
  25   (pass-if "empty calls with count-modified seeds"
  26     (equal? (list 21 42)
  27             (call-with-values
  28                 (lambda ()
  29                   (args-fold '("1" "3" "4") '()
  30                              (lambda (opt name arg seed seed2)
  31                                (values 1 2))
  32                              (lambda (op seed seed2)
  33                                (values (1+ seed) (+ 2 seed2)))
  34                              18 36))
  35               list)))
  36
  37   (pass-if "short opt params"
  38     (let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t) (no-operands #t))
  39       (args-fold '("-abcdoit" "-ad" "whatev")
  40                  (list (option '(#\a) #f #f (lambda (opt name arg)
  41                                               (set! a-set #t)
  42                                               (values)))
  43                        (option '(#\b) #f #f (lambda (opt name arg)
  44                                               (set! b-set #t)
  45                                               (values)))
  46                        (option '("cdoit" #\c) #f #t
  47                                (lambda (opt name arg)
  48                                  (set! c-val arg)
  49                                  (values)))
  50                        (option '(#\d) #f #t
  51                                (lambda (opt name arg)
  52                                  (set! d-val arg)
  53                                  (values))))
  54                  (lambda (opt name arg) (set! no-fail #f) (values))
  55                  (lambda (oper) (set! no-operands #f) (values)))
  56       (equal? '(#t #t "doit" "whatev" #t #t)
  57               (list a-set b-set c-val d-val no-fail no-operands))))
  58
  59   (pass-if "single unrecognized long-opt"
  60     (equal? "fake"
  61             (args-fold '("--fake" "-i2")
  62                        (list (option '(#\i) #t #f
  63                                      (lambda (opt name arg k) k)))
  64                        (lambda (opt name arg k) name)
  65                        (lambda (operand k) #f)
  66                        #f)))
  67
  68   (pass-if "long req'd/optional"
  69     (equal? '(#f "bsquare" "apple")
  70             (args-fold '("--x=pple" "--y=square" "--y")
  71                        (list (option '("x") #t #f
  72                                      (lambda (opt name arg k)
  73                                        (cons (string-append "a" arg) k)))
  74                              (option '("y") #f #t
  75                                      (lambda (opt name arg k)
  76                                        (cons (if arg
  77                                                  (string-append "b" arg)
  78                                                  #f) k))))
  79                        (lambda (opt name arg k) #f)
  80                        (lambda (opt name arg k) #f)
  81                        '())))
  82
  83   ;; this matches behavior of getopt_long in libc 2.4
  84   (pass-if "short options absorb special markers in the next arg"
  85     (let ((arg-proc (lambda (opt name arg k)
  86                       (acons name arg k))))
  87       (equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
  88               (args-fold '("-zx" "--" "-y" "-z" "--")
  89                          (list (option '(#\x) #f #t arg-proc)
  90                                (option '(#\z) #f #f arg-proc)
  91                                (option '(#\y) #t #f arg-proc))
  92                          (lambda (opt name arg k) #f)
  93                          (lambda (opt name arg k) #f)
  94                          '()))))
  95
  96   (pass-if "short options without arguments"
  97     ;; In Guile 1.8.4 and earlier, using short names of argument-less options
  98     ;; would lead to a stack overflow.
  99     (let ((arg-proc (lambda (opt name arg k)
 100                       (acons name arg k))))
 101       (equal? '((#\x . #f))
 102               (args-fold '("-x")
 103                          (list (option '(#\x) #f #f arg-proc))
 104                          (lambda (opt name arg k) #f)
 105                          (lambda (opt name arg k) #f)
 106                          '()))))
 107
 108 )