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