clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/cl-ppcre/parser.lisp

@@ -0,0 +1,319 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-ppcre/parser.lisp,v 1.31 2009/09/17 19:17:31 edi Exp $
+
+;;; The parser will - with the help of the lexer - parse a regex
+;;; string and convert it into a "parse tree" (see docs for details
+;;; about the syntax of these trees).  Note that the lexer might
+;;; return illegal parse trees.  It is assumed that the conversion
+;;; process later on will track them down.
+
+;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-ppcre)
+
+(defun group (lexer)
+  "Parses and consumes a <group>.
+The productions are: <group> -> \"\(\"<regex>\")\"
+                                \"\(?:\"<regex>\")\"
+                                \"\(?>\"<regex>\")\"
+                                \"\(?<flags>:\"<regex>\")\"
+                                \"\(?=\"<regex>\")\"
+                                \"\(?!\"<regex>\")\"
+                                \"\(?<=\"<regex>\")\"
+                                \"\(?<!\"<regex>\")\"
+                                \"\(?\(\"<num>\")\"<regex>\")\"
+                                \"\(?\(\"<regex>\")\"<regex>\")\"
+                                \"\(?<name>\"<regex>\")\" \(when *ALLOW-NAMED-REGISTERS* is T)
+                                <legal-token>
+where <flags> is parsed by the lexer function MAYBE-PARSE-FLAGS.
+Will return <parse-tree> or \(<grouping-type> <parse-tree>) where
+<grouping-type> is one of six keywords - see source for details."
+  (declare #.*standard-optimize-settings*)
+  (multiple-value-bind (open-token flags)
+      (get-token lexer)
+    (cond ((eq open-token :open-paren-paren)
+            ;; special case for conditional regular expressions; note
+            ;; that at this point we accept a couple of illegal
+            ;; combinations which'll be sorted out later by the
+            ;; converter
+            (let* ((open-paren-pos (car (lexer-last-pos lexer)))
+                   ;; check if what follows "(?(" is a number
+                   (number (try-number lexer :no-whitespace-p t))
+                   ;; make changes to extended-mode-p local
+                   (*extended-mode-p* *extended-mode-p*))
+              (declare (fixnum open-paren-pos))
+              (cond (number
+                      ;; condition is a number (i.e. refers to a
+                      ;; back-reference)
+                      (let* ((inner-close-token (get-token lexer))
+                             (reg-expr (reg-expr lexer))
+                             (close-token (get-token lexer)))
+                        (unless (eq inner-close-token :close-paren)
+                          (signal-syntax-error* (+ open-paren-pos 2)
+                                                "Opening paren has no matching closing paren."))
+                        (unless (eq close-token :close-paren)
+                          (signal-syntax-error* open-paren-pos
+                                                "Opening paren has no matching closing paren."))
+                        (list :branch number reg-expr)))
+                    (t
+                      ;; condition must be a full regex (actually a
+                      ;; look-behind or look-ahead); and here comes a
+                      ;; terrible kludge: instead of being cleanly
+                      ;; separated from the lexer, the parser pushes
+                      ;; back the lexer by one position, thereby
+                      ;; landing in the middle of the 'token' "(?(" -
+                      ;; yuck!!
+                      (decf (lexer-pos lexer))
+                      (let* ((inner-reg-expr (group lexer))
+                             (reg-expr (reg-expr lexer))
+                             (close-token (get-token lexer)))
+                        (unless (eq close-token :close-paren)
+                          (signal-syntax-error* open-paren-pos
+                                                "Opening paren has no matching closing paren."))
+                        (list :branch inner-reg-expr reg-expr))))))
+          ((member open-token '(:open-paren
+                                :open-paren-colon
+                                :open-paren-greater
+                                :open-paren-equal
+                                :open-paren-exclamation
+                                :open-paren-less-equal
+                                :open-paren-less-exclamation
+                                :open-paren-less-letter)
+                   :test #'eq)
+            ;; make changes to extended-mode-p local
+            (let ((*extended-mode-p* *extended-mode-p*))
+              ;; we saw one of the six token representing opening
+              ;; parentheses
+              (let* ((open-paren-pos (car (lexer-last-pos lexer)))
+                     (register-name (when (eq open-token :open-paren-less-letter)
+                                      (parse-register-name-aux lexer)))
+                     (reg-expr (reg-expr lexer))
+                     (close-token (get-token lexer)))
+                (when (or (eq open-token :open-paren)
+                          (eq open-token :open-paren-less-letter))
+                  ;; if this is the "("<regex>")" or "(?"<name>""<regex>")" production we have to
+                  ;; increment the register counter of the lexer
+                  (incf (lexer-reg lexer)))
+                (unless (eq close-token :close-paren)
+                  ;; the token following <regex> must be the closing
+                  ;; parenthesis or this is a syntax error
+                  (signal-syntax-error* open-paren-pos
+                                        "Opening paren has no matching closing paren."))
+                (if flags
+                  ;; if the lexer has returned a list of flags this must
+                  ;; have been the "(?:"<regex>")" production
+                  (cons :group (nconc flags (list reg-expr)))
+                  (if (eq open-token :open-paren-less-letter)
+                      (list :named-register
+                            ;; every string was reversed, so we have to
+                            ;; reverse it back to get the name
+                            (nreverse register-name)
+                            reg-expr)
+                      (list (case open-token
+                              ((:open-paren)
+                               :register)
+                              ((:open-paren-colon)
+                               :group)
+                              ((:open-paren-greater)
+                               :standalone)
+                              ((:open-paren-equal)
+                               :positive-lookahead)
+                              ((:open-paren-exclamation)
+                               :negative-lookahead)
+                              ((:open-paren-less-equal)
+                               :positive-lookbehind)
+                              ((:open-paren-less-exclamation)
+                               :negative-lookbehind))
+                            reg-expr))))))
+          (t
+           ;; this is the <legal-token> production; <legal-token> is
+           ;; any token which passes START-OF-SUBEXPR-P (otherwise
+           ;; parsing had already stopped in the SEQ method)
+           open-token))))
+
+(defun greedy-quant (lexer)
+  "Parses and consumes a <greedy-quant>.
+The productions are: <greedy-quant> -> <group> | <group><quantifier>
+where <quantifier> is parsed by the lexer function GET-QUANTIFIER.
+Will return <parse-tree> or (:GREEDY-REPETITION <min> <max> <parse-tree>)."
+  (declare #.*standard-optimize-settings*)
+  (let* ((group (group lexer))
+         (token (get-quantifier lexer)))
+    (if token
+      ;; if GET-QUANTIFIER returned a non-NIL value it's the
+      ;; two-element list (<min> <max>)
+      (list :greedy-repetition (first token) (second token) group)
+      group)))
+
+(defun quant (lexer)
+  "Parses and consumes a <quant>.
+The productions are: <quant> -> <greedy-quant> | <greedy-quant>\"?\".
+Will return the <parse-tree> returned by GREEDY-QUANT and optionally
+change :GREEDY-REPETITION to :NON-GREEDY-REPETITION."
+  (declare #.*standard-optimize-settings*)
+  (let* ((greedy-quant (greedy-quant lexer))
+         (pos (lexer-pos lexer))
+         (next-char (next-char lexer)))
+    (when next-char
+      (if (char= next-char #\?)
+        (setf (car greedy-quant) :non-greedy-repetition)
+        (setf (lexer-pos lexer) pos)))
+    greedy-quant))
+
+(defun seq (lexer)
+  "Parses and consumes a <seq>.
+The productions are: <seq> -> <quant> | <quant><seq>.
+Will return <parse-tree> or (:SEQUENCE <parse-tree> <parse-tree>)."
+  (declare #.*standard-optimize-settings*)
+  (flet ((make-array-from-two-chars (char1 char2)
+           (let ((string (make-array 2
+                                     :element-type 'character
+                                     :fill-pointer t
+                                     :adjustable t)))
+             (setf (aref string 0) char1)
+             (setf (aref string 1) char2)
+             string)))
+    ;; Note that we're calling START-OF-SUBEXPR-P before we actually try
+    ;; to parse a <seq> or <quant> in order to catch empty regular
+    ;; expressions
+    (if (start-of-subexpr-p lexer)
+      (let ((quant (quant lexer)))
+        (if (start-of-subexpr-p lexer)
+          (let* ((seq (seq lexer))
+                 (quant-is-char-p (characterp quant))
+                 (seq-is-sequence-p (and (consp seq)
+                                         (eq (first seq) :sequence))))
+            (cond ((and quant-is-char-p
+                        (characterp seq))
+                    (make-array-from-two-chars seq quant))
+                  ((and quant-is-char-p
+                        (stringp seq))
+                    (vector-push-extend quant seq)
+                    seq)
+                  ((and quant-is-char-p
+                        seq-is-sequence-p
+                        (characterp (second seq)))
+                    (cond ((cddr seq)
+                            (setf (cdr seq)
+                                    (cons
+                                     (make-array-from-two-chars (second seq)
+                                                                quant)
+                                     (cddr seq)))
+                            seq)
+                          (t (make-array-from-two-chars (second seq) quant))))
+                  ((and quant-is-char-p
+                        seq-is-sequence-p
+                        (stringp (second seq)))
+                    (cond ((cddr seq)
+                            (setf (cdr seq)
+                                    (cons
+                                     (progn
+                                       (vector-push-extend quant (second seq))
+                                       (second seq))
+                                     (cddr seq)))
+                            seq)
+                          (t 
+                            (vector-push-extend quant (second seq))
+                            (second seq))))
+                  (seq-is-sequence-p
+                    ;; if <seq> is also a :SEQUENCE parse tree we merge
+                    ;; both lists into one to avoid unnecessary consing
+                    (setf (cdr seq)
+                            (cons quant (cdr seq)))
+                    seq)
+                  (t (list :sequence quant seq))))
+          quant))
+      :void)))
+  
+(defun reg-expr (lexer)
+  "Parses and consumes a <regex>, a complete regular expression.
+The productions are: <regex> -> <seq> | <seq>\"|\"<regex>.
+Will return <parse-tree> or (:ALTERNATION <parse-tree> <parse-tree>)."
+  (declare #.*standard-optimize-settings*)
+  (let ((pos (lexer-pos lexer)))
+    (case (next-char lexer)
+      ((nil)
+        ;; if we didn't get any token we return :VOID which stands for
+        ;; "empty regular expression"
+        :void)
+      ((#\|)
+        ;; now check whether the expression started with a vertical
+        ;; bar, i.e. <seq> - the left alternation - is empty
+        (list :alternation :void (reg-expr lexer)))
+      (otherwise
+        ;; otherwise un-read the character we just saw and parse a
+        ;; <seq> plus the character following it
+        (setf (lexer-pos lexer) pos)
+        (let* ((seq (seq lexer))
+               (pos (lexer-pos lexer)))
+          (case (next-char lexer)
+            ((nil)
+              ;; no further character, just a <seq>
+              seq)
+            ((#\|)
+              ;; if the character was a vertical bar, this is an
+              ;; alternation and we have the second production
+              (let ((reg-expr (reg-expr lexer)))
+                (cond ((and (consp reg-expr)
+                            (eq (first reg-expr) :alternation))
+                        ;; again we try to merge as above in SEQ
+                        (setf (cdr reg-expr)
+                                (cons seq (cdr reg-expr)))
+                        reg-expr)
+                      (t (list :alternation seq reg-expr)))))
+            (otherwise
+              ;; a character which is not a vertical bar - this is
+              ;; either a syntax error or we're inside of a group and
+              ;; the next character is a closing parenthesis; so we
+              ;; just un-read the character and let another function
+              ;; take care of it
+              (setf (lexer-pos lexer) pos)
+              seq)))))))
+
+(defun reverse-strings (parse-tree)
+  "Recursively walks through PARSE-TREE and destructively reverses all
+strings in it."
+  (declare #.*standard-optimize-settings*)
+  (cond ((stringp parse-tree)
+          (nreverse parse-tree))
+        ((consp parse-tree)
+          (loop for parse-tree-rest on parse-tree
+                while parse-tree-rest
+                do (setf (car parse-tree-rest)
+                           (reverse-strings (car parse-tree-rest))))
+          parse-tree)
+        (t parse-tree)))
+
+(defun parse-string (string)
+  "Translate the regex string STRING into a parse tree."
+  (declare #.*standard-optimize-settings*)
+  (let* ((lexer (make-lexer string))
+         (parse-tree (reverse-strings (reg-expr lexer))))
+    ;; check whether we've consumed the whole regex string
+    (if (end-of-string-p lexer)
+      parse-tree
+      (signal-syntax-error* (lexer-pos lexer) "Expected end of string."))))

data/lib/clucumber/vendor/cl-ppcre/ppcre-tests.lisp

@@ -0,0 +1,269 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-ppcre/ppcre-tests.lisp,v 1.36 2008/06/25 14:04:28 edi Exp $
+
+;;; Copyright (c) 2002-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:cl-ppcre-test)
+
+(defparameter *cl-ppcre-test-base-directory*
+  (make-pathname :name nil :type nil :version nil
+                 :defaults (parse-namestring *load-truename*)))
+
+(defun full-gc ()
+  "Start a full garbage collection."
+  ;; what are the corresponding values for MCL and OpenMCL?
+  #+:allegro (excl:gc t)
+  #+(or :cmu :scl) (ext:gc :full t)
+  #+:ecl (si:gc t)
+  #+:clisp (ext:gc)
+  #+:cormanlisp (loop for i from 0 to 3 do (cormanlisp:gc i))
+  #+:lispworks4 (hcl:mark-and-sweep 3)
+  #+:lispworks5 (hcl:gc-generation #+:lispworks-32bit 3 #+:lispworks-64bit :blocking-gen-num)
+  #+:sbcl (sb-ext:gc :full t))
+
+;; warning: ugly code ahead!!
+;; this is just a quick hack for testing purposes
+
+(defun time-regex (factor regex string
+                          &key case-insensitive-mode
+                               multi-line-mode
+                               single-line-mode
+                               extended-mode)
+  (declare #.ppcre::*standard-optimize-settings*)
+  "Auxiliary function used by TEST to benchmark a regex scanner
+against Perl timings."
+  (declare (type string string))
+  (let* ((scanner (create-scanner regex
+                                  :case-insensitive-mode case-insensitive-mode
+                                  :multi-line-mode multi-line-mode
+                                  :single-line-mode single-line-mode
+                                  :extended-mode extended-mode))
+         ;; make sure GC doesn't invalidate our benchmarking
+         (dummy (full-gc))
+         (start (get-internal-real-time)))
+    (declare (ignore dummy))
+    (dotimes (i factor)
+      (funcall scanner string 0 (length string)))
+    (float (/ (- (get-internal-real-time) start) internal-time-units-per-second))))
+
+#+(or scl
+      lispworks
+      (and sbcl sb-thread))
+(defun threaded-scan (scanner target-string &key (threads 10) (repetitions 5000))
+  (declare #.ppcre::*standard-optimize-settings*)
+  "Auxiliary function used by TEST to check whether SCANNER is thread-safe."
+  (full-gc)
+  (let ((collector (make-array threads))
+        (counter 0))
+    (loop for i below threads
+          do (let* ((j i)
+                    (fn
+                      (lambda ()
+                        (let ((r (random repetitions)))
+                          (loop for k below repetitions
+                                if (= k r)
+                                  do (setf (aref collector j)
+                                             (let ((result
+                                                     (multiple-value-list
+                                                       (cl-ppcre:scan scanner target-string))))
+                                               (unless (cdr result)
+                                                 (setq result '(nil nil #() #())))
+                                               result))
+                                else
+                                  do (cl-ppcre:scan scanner target-string))
+                          (incf counter)))))
+               #+scl (thread:thread-create fn)
+               #+lispworks (mp:process-run-function "" nil fn)
+               #+(and sbcl sb-thread) (sb-thread:make-thread fn)))
+    (loop while (< counter threads)
+          do (sleep .1))
+    (destructuring-bind (first-start first-end first-reg-starts first-reg-ends)
+        (aref collector 0)
+      (loop for (start end reg-starts reg-ends) across collector
+            if (or (not (eql first-start start))
+                   (not (eql first-end end))
+                   (/= (length first-reg-starts) (length reg-starts))
+                   (/= (length first-reg-ends) (length reg-ends))
+                   (loop for first-reg-start across first-reg-starts
+                         for reg-start across reg-starts
+                         thereis (not (eql first-reg-start reg-start)))
+                   (loop for first-reg-end across first-reg-ends
+                         for reg-end across reg-ends
+                         thereis (not (eql first-reg-end reg-end))))
+            do (return (format nil "~&Inconsistent results during multi-threading"))))))
+
+(defun create-string-from-input (input)
+  (cond ((or (null input)
+             (stringp input))
+          input)
+        (t
+          (cl-ppcre::string-list-to-simple-string
+           (loop for element in input
+                 if (stringp element)
+                 collect element
+                 else
+                 collect (string (code-char element)))))))
+
+(defun test (&key (file-name 
+                   (make-pathname :name "testdata"
+                                  :type nil :version nil
+                                  :defaults *cl-ppcre-test-base-directory*)
+                   file-name-provided-p)
+                  threaded)
+  (declare #.ppcre::*standard-optimize-settings*)
+  (declare (ignorable threaded))
+  "Loop through all test cases in FILE-NAME and print report. Only in
+LispWorks and SCL: If THREADED is true, also test whether the scanners
+work multi-threaded."
+  (with-open-file (stream file-name
+                          #+(or :allegro :clisp :scl :sbcl)
+                          :external-format
+                          #+(or :allegro :clisp :scl :sbcl)
+                          (if file-name-provided-p
+                            :default
+                            #+(or :allegro :scl :sbcl) :iso-8859-1
+                            #+:clisp charset:iso-8859-1))
+    (loop with testcount of-type fixnum = 0
+          with *regex-char-code-limit* = (if file-name-provided-p
+                                           *regex-char-code-limit*
+                                           ;; the standard test suite
+                                           ;; doesn't need Unicode
+                                           ;; support
+                                           256)
+          with *allow-quoting* = (if file-name-provided-p
+                                   *allow-quoting*
+                                   t)
+          for input-line = (read stream nil nil)
+          for (counter info-string regex
+                       case-insensitive-mode multi-line-mode
+                       single-line-mode extended-mode
+                       string perl-error factor
+                       perl-time ex-result ex-subs) = input-line
+          while input-line
+          do (let ((info-string (create-string-from-input info-string))
+                   (regex (create-string-from-input regex))
+                   (string (create-string-from-input string))
+                   (ex-result (create-string-from-input ex-result))
+                   (ex-subs (mapcar #'create-string-from-input ex-subs))
+                   (errors '()))
+               ;; provide some visual feedback for slow CL
+               ;; implementations; suggested by JP Massar
+               (incf testcount)
+               #+(or scl
+                     lispworks
+                     (and sbcl sb-thread))
+               (when threaded
+                 (format t "Test #~A (ID ~A)~%" testcount counter)
+                 (force-output))
+               (unless #-(or scl
+                             lispworks
+                             (and sbcl sb-thread))
+                       nil
+                       #+(or scl
+                             lispworks
+                             (and sbcl sb-thread))
+                       threaded
+                 (when (zerop (mod testcount 10))
+                   (format t ".")
+                   (force-output))
+                 (when (zerop (mod testcount 100))
+                   (terpri)))
+               (handler-case
+                 (let* ((*use-bmh-matchers* (if (and (> factor 1) (plusp perl-time))
+                                              *use-bmh-matchers*
+                                              ;; if we only check for
+                                              ;; correctness we don't
+                                              ;; care about speed that
+                                              ;; match (but rather
+                                              ;; about space
+                                              ;; constraints of the
+                                              ;; trial versions)
+                                              nil))
+                        (scanner (create-scanner regex
+                                                :case-insensitive-mode case-insensitive-mode
+                                                :multi-line-mode multi-line-mode
+                                                :single-line-mode single-line-mode
+                                                :extended-mode extended-mode)))
+                   (multiple-value-bind (result1 result2 sub-starts sub-ends)
+                       (scan scanner string)
+                     (cond (perl-error
+                             (push (format nil
+                                           "~&expected an error but got a result")
+                                   errors))
+                           (t
+                             (when (not (eq result1 ex-result))
+                               (if result1
+                                 (let ((result (subseq string result1 result2)))
+                                   (unless (string= result ex-result)
+                                     (push (format nil
+                                                   "~&expected ~S but got ~S"
+                                                   ex-result result)
+                                           errors))
+                                   (setq sub-starts (coerce sub-starts 'list)
+                                         sub-ends (coerce sub-ends 'list))
+                                   (loop for i from 0
+                                         for ex-sub in ex-subs
+                                         for sub-start = (nth i sub-starts)
+                                         for sub-end = (nth i sub-ends)
+                                         for sub = (if (and sub-start sub-end)
+                                                     (subseq string sub-start sub-end)
+                                                     nil)
+                                         unless (string= ex-sub sub)
+                                           do (push (format nil
+                                                            "~&\\~A: expected ~S but got ~S"
+                                                            (1+ i) ex-sub sub) errors)))
+                                 (push (format nil
+                                               "~&expected ~S but got ~S"
+                                               ex-result result1)
+                                       errors)))))
+                     #+(or scl
+                           lispworks
+                           (and sbcl sb-thread))
+                     (when threaded
+                       (let ((thread-result (threaded-scan scanner string)))
+                         (when thread-result
+                         (push thread-result errors))))))
+                 (condition (msg)
+                   (unless perl-error
+                     (push (format nil "~&got an unexpected error: '~A'" msg)
+                           errors))))
+               (setq errors (nreverse errors))
+               (cond (errors
+                       (when (or (<= factor 1) (zerop perl-time))
+                         (format t "~&~4@A (~A):~{~&   ~A~}~%"
+                                 counter info-string errors)))
+                     ((and (> factor 1) (plusp perl-time))
+                       (let ((result (time-regex factor regex string
+                                                 :case-insensitive-mode case-insensitive-mode
+                                                 :multi-line-mode multi-line-mode
+                                                 :single-line-mode single-line-mode
+                                                 :extended-mode extended-mode)))
+                         (format t "~&~4@A: ~,4F (~A repetitions, Perl: ~,4F seconds, CL-PPCRE: ~,4F seconds)" counter
+                                 (float (/ result perl-time)) factor perl-time result)
+                         #+:cormanlisp (force-output *standard-output*)))
+                     (t nil))))
+    (values)))