guile18/test-suite/tests/regexp.test

   1 ;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
   3 ;;;;
   4 ;;;;    Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-regexp)
  22   #:use-module (test-suite lib)
  23   #:use-module (ice-9 regex))
  24
  25 \f
  26 ;;; Run a regexp-substitute or regexp-substitute/global test, once
  27 ;;; providing a real port and once providing #f, requesting direct
  28 ;;; string output.
  29 (define (vary-port func expected . args)
  30   (pass-if "port is string port"
  31            (equal? expected
  32                    (call-with-output-string
  33                     (lambda (port)
  34                       (apply func port args)))))
  35   (pass-if "port is #f"
  36            (equal? expected
  37                    (apply func #f args))))
  38
  39 (define (object->string obj)
  40   (call-with-output-string
  41    (lambda (port)
  42      (write obj port))))
  43
  44 ;;;
  45 ;;; make-regexp
  46 ;;;
  47
  48 (with-test-prefix "make-regexp"
  49
  50   (pass-if-exception "no args" exception:wrong-num-args
  51     (make-regexp))
  52
  53   (pass-if-exception "bad pat arg" exception:wrong-type-arg
  54     (make-regexp 'blah))
  55
  56   ;; in guile prior to 1.6.5 make-regex didn't validate its flags args
  57   (pass-if-exception "bad arg 2" exception:wrong-type-arg
  58     (make-regexp "xyz" 'abc))
  59
  60   (pass-if-exception "bad arg 3" exception:wrong-type-arg
  61     (make-regexp "xyz" regexp/icase 'abc)))
  62
  63 ;;;
  64 ;;; match:string
  65 ;;;
  66
  67 (with-test-prefix "match:string"
  68
  69   (pass-if "foo"
  70     (string=? "foo" (match:string (string-match ".*" "foo"))))
  71
  72   (pass-if "foo offset 1"
  73     (string=? "foo" (match:string (string-match ".*" "foo" 1)))))
  74
  75 ;;;
  76 ;;; regexp-exec
  77 ;;;
  78
  79 (with-test-prefix "regexp-exec"
  80
  81   (pass-if-exception "non-integer offset" exception:wrong-type-arg
  82     (let ((re (make-regexp "ab+")))
  83       (regexp-exec re "aaaabbbb" 1.5 'bogus-flags-arg)))
  84
  85   (pass-if-exception "non-string input" exception:wrong-type-arg
  86     (let ((re (make-regexp "ab+")))
  87       (regexp-exec re 'not-a-string)))
  88
  89   (pass-if-exception "non-string input, with offset" exception:wrong-type-arg
  90     (let ((re (make-regexp "ab+")))
  91       (regexp-exec re 'not-a-string 5)))
  92
  93   ;; in guile 1.8.1 and earlier, a #\nul character in the input string was
  94   ;; only detected in a critical section, and the resulting error throw
  95   ;; abort()ed the program
  96   (pass-if-exception "nul in input" exception:string-contains-nul
  97     (let ((re (make-regexp "ab+")))
  98       (regexp-exec re (string #\a #\b (integer->char 0)))))
  99
 100   ;; in guile 1.8.1 and earlier, a bogus flags argument was only detected
 101   ;; inside a critical section, and the resulting error throw abort()ed the
 102   ;; program
 103   (pass-if-exception "non-integer flags" exception:wrong-type-arg
 104     (let ((re (make-regexp "ab+")))
 105       (regexp-exec re "aaaabbbb" 0 'bogus-flags-arg))))
 106
 107 ;;;
 108 ;;; fold-matches
 109 ;;;
 110
 111 (with-test-prefix "fold-matches"
 112
 113   (pass-if "without flags"
 114     (equal? '("hello")
 115             (fold-matches "^[a-z]+$" "hello" '()
 116                           (lambda (match result)
 117                             (cons (match:substring match)
 118                                   result)))))
 119
 120   (pass-if "with flags"
 121     ;; Prior to 1.8.6, passing an additional flag would not work.
 122     (null?
 123      (fold-matches "^[a-z]+$" "hello" '()
 124                    (lambda (match result)
 125                      (cons (match:substring match)
 126                            result))
 127                    (logior regexp/notbol regexp/noteol)))))
 128
 129
 130 ;;;
 131 ;;; regexp-quote
 132 ;;;
 133
 134 (with-test-prefix "regexp-quote"
 135
 136   (pass-if-exception "no args" exception:wrong-num-args
 137     (regexp-quote))
 138
 139   (pass-if-exception "bad string arg" exception:wrong-type-arg
 140     (regexp-quote 'blah))
 141
 142   (let ((lst `((regexp/basic    ,regexp/basic)
 143                (regexp/extended ,regexp/extended)))
 144         ;; string of all characters, except #\nul which doesn't work because
 145         ;; it's the usual end-of-string for the underlying C regexec()
 146         (allchars (list->string (map integer->char
 147                                      (cdr (iota char-code-limit))))))
 148     (for-each
 149      (lambda (elem)
 150        (let ((name (car  elem))
 151              (flag (cadr elem)))
 152
 153          (with-test-prefix name
 154
 155            ;; try on each individual character, except #\nul
 156            (do ((i 1 (1+ i)))
 157                ((>= i char-code-limit))
 158              (let* ((c (integer->char i))
 159                     (s (string c))
 160                     (q (regexp-quote s)))
 161                (pass-if (list "char" i c s q)
 162                  (let ((m (regexp-exec (make-regexp q flag) s)))
 163                    (and (= 0 (match:start m))
 164                         (= 1 (match:end m)))))))
 165
 166            ;; try on pattern "aX" where X is each character, except #\nul
 167            ;; this exposes things like "?" which are special only when they
 168            ;; follow a pattern to repeat or whatever ("a" in this case)
 169            (do ((i 1 (1+ i)))
 170                ((>= i char-code-limit))
 171              (let* ((c (integer->char i))
 172                     (s (string #\a c))
 173                     (q (regexp-quote s)))
 174                (pass-if (list "string \"aX\"" i c s q)
 175                  (let ((m (regexp-exec (make-regexp q flag) s)))
 176                    (and (= 0 (match:start m))
 177                         (= 2 (match:end m)))))))
 178
 179            (pass-if "string of all chars"
 180              (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
 181                                                 flag) allchars)))
 182                (and (= 0 (match:start m))
 183                     (= (string-length allchars) (match:end m))))))))
 184      lst)))
 185
 186 ;;;
 187 ;;; regexp-substitute
 188 ;;;
 189
 190 (with-test-prefix "regexp-substitute"
 191   (let ((match
 192          (string-match "patleft(sub1)patmid(sub2)patright"
 193                        "contleftpatleftsub1patmidsub2patrightcontright")))
 194     (define (try expected . args)
 195       (with-test-prefix (object->string args)
 196         (apply vary-port regexp-substitute expected match args)))
 197
 198     (try "")
 199     (try "string1" "string1")
 200     (try "string1string2" "string1" "string2")
 201     (try "patleftsub1patmidsub2patright" 0)
 202     (try "hi-patleftsub1patmidsub2patright-bye" "hi-" 0 "-bye")
 203     (try "sub1" 1)
 204     (try "hi-sub1-bye" "hi-" 1 "-bye")
 205     (try "hi-sub2-bye" "hi-" 2 "-bye")
 206     (try "contleft" 'pre)
 207     (try "contright" 'post)
 208     (try "contrightcontleft" 'post 'pre)
 209     (try "contrightcontleftcontrightcontleft" 'post 'pre 'post 'pre)
 210     (try "contrightsub2sub1contleft" 'post 2 1 'pre)
 211     (try "foosub1sub1sub1sub1bar" "foo" 1 1 1 1 "bar")))
 212
 213 (with-test-prefix "regexp-substitute/global"
 214
 215   (define (try expected . args)
 216     (with-test-prefix (object->string args)
 217       (apply vary-port regexp-substitute/global expected args)))
 218
 219   (try "hi" "a(x*)b" "ab" "hi")
 220   (try ""   "a(x*)b" "ab" 1)
 221   (try "xx" "a(x*)b" "axxb" 1)
 222   (try "xx" "a(x*)b" "_axxb_" 1)
 223   (try "pre" "a(x*)b" "preaxxbpost" 'pre)
 224   (try "post" "a(x*)b" "preaxxbpost" 'post)
 225   (try "string" "x" "string" 'pre "y" 'post)
 226   (try "4" "a(x*)b" "_axxb_" (lambda (m)
 227                                 (number->string (match:end m 1))))
 228
 229   (try "_aybycyd_" "x+" "_axbxxcxxxd_" 'pre "y" 'post)
 230
 231   ;; This should not go into an infinite loop, just because the regexp
 232   ;; can match the empty string.  This test also kind of beats on our
 233   ;; definition of where a null string can match.
 234   (try "y_yaybycydy_y" "x*" "_axbxxcxxxd_" 'pre "y" 'post)
 235
 236   ;; These kind of bother me.  The extension from regexp-substitute to
 237   ;; regexp-substitute/global is only natural if your item list
 238   ;; includes both pre and post.  If those are required, why bother
 239   ;; to include them at all?
 240   (try "4:7:12:_" "a(x*)b" "_axxbaxbaxxxb_"
 241        (lambda (m) (number->string (match:end m 1))) ":"
 242        'post)
 243   (try "4:10:19:_:19:10:4" "a(x*)b" "_axxbaxxxxbaxxxxxxxb_"
 244        (lambda (m) (number->string (match:end m 1))) ":"
 245        'post
 246        ":" (lambda (m) (number->string (match:end m 1))))
 247
 248   ;; Jan Nieuwenhuizen's bug, 2 Sep 1999
 249   (try "" "_" (make-string 500 #\_)
 250        'post))