;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/perl-tests.lisp,v 1.8 2009/09/17 19:17:36 edi Exp $

;;; The tests in this file test CL-PPCRE against testdata generated by
;;; the Perl program `perltest.pl' from the input file `testinput' in
;;; order to check compatibility with Perl and correctness of the
;;; regex engine.

;;; 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-test)

(defvar *tests-to-skip* '(662 790 1439)
  "Some tests we skip because the testdata is generated by a Perl
program and CL-PPCRE differs from Perl for these tests - on purpose.")

(defun create-string-from-input (input)
  "Converts INPUT to a string which can be used in TEST below.  The
input file `testdata' encodes strings containing non-printable
characters as lists where those characters are represented by their
character code."
  (etypecase input
    ((or null string) input)
    (list (string-list-to-simple-string
           (loop for element in input
                 if (stringp element)
                 collect element
                 else
                 collect (string (code-char element)))))))

(defun perl-test (&key (file-name 
                        (make-pathname :name "perltestdata"
                                       :type nil :version nil
                                       :defaults *this-file*)
                        file-name-provided-p)
                       (external-format '(:latin-1 :eol-style :lf))
                       verbose)
  "Loops through all test cases in FILE-NAME and prints a report if
VERBOSE is true.  EXTERNAL-FORMAT is the FLEXI-STREAMS external format
which is used to read the file.  Returns a true value if all tests
succeeded.

For the syntax of the tests in FILE-NAME refer to the source code of
this function and to the Perl script perltest.pl which generates such
test files."
  (declare #.*standard-optimize-settings*)
  (with-open-file (binary-stream file-name :element-type 'flex:octet)
    (let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
          ;; the standard Perl tests don't need full Unicode support
          (*regex-char-code-limit* (if file-name-provided-p *regex-char-code-limit* 256))
          ;; we need this for the standard test suite or otherwise we
          ;; might get stack overflows
          (*optimize-char-classes* (if file-name-provided-p *optimize-char-classes* :charmap))
          ;; we only check for correctness and don't care about speed
          ;; that match (but rather about space constraints of the
          ;; trial versions)
          (*use-bmh-matchers* (if file-name-provided-p *use-bmh-matchers* nil))
          ;; some tests in the Perl suite explicitly check for this
          (*allow-quoting* (if file-name-provided-p *allow-quoting* t)))
      (do-tests ((format nil "Running tests in file ~S" (file-namestring file-name))
                 (not verbose))
        (let ((input-line (or (read stream nil) (done)))
              errors)
          (destructuring-bind (counter
                               info-string%
                               regex%
                               case-insensitive-mode
                               multi-line-mode
                               single-line-mode
                               extended-mode
                               target%
                               perl-error
                               expected-result%
                               expected-registers)
              input-line
            (destructuring-bind (info-string regex target expected-result)
                (mapcar 'create-string-from-input
                        (list info-string% regex% target% expected-result%))
              (setq expected-registers (mapcar 'create-string-from-input expected-registers))
              (unless (find counter *tests-to-skip* :test #'=)
                (when verbose
                  (format t "~&~4D: ~S" counter info-string))                  
                (let ((scanner
                       (handler-bind ((error (lambda (condition)
                                               (declare (ignore condition))
                                               (when perl-error
                                                 ;; we expected an
                                                 ;; error, so we can
                                                 ;; signal success
                                                 (return-from test-block)))))
                         (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))))
                  (block test-block
                    (multiple-value-bind (start end reg-starts reg-ends)                        
                        (scan scanner target)
                      (cond (perl-error
                             (push (format nil "expected an error but got a result.")
                                   errors))
                            (t
                             (when (not (eq start expected-result))
                               (if start
                                 (let ((result (subseq target start end)))
                                   (unless (string= result expected-result)
                                     (push (format nil "expected ~S but got ~S."
                                                   expected-result result)
                                           errors))
                                   (setq reg-starts (coerce reg-starts 'list)
                                         reg-ends (coerce reg-ends 'list))
                                   (loop for i from 0
                                         for expected-register in expected-registers
                                         for reg-start = (nth i reg-starts)
                                         for reg-end = (nth i reg-ends)
                                         for register = (if (and reg-start reg-end)
                                                          (subseq target reg-start reg-end)
                                                          nil)
                                         unless (string= expected-register register)
                                         do (push (format nil "\\~A: expected ~S but got ~S."
                                                          (1+ i) expected-register register)
                                                  errors)))
                                 (push (format nil "expected ~S but got ~S."
                                               expected-result start)
                                       errors))))))
                    errors))))))))))
