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