151 lines
8.2 KiB
Common Lisp
151 lines
8.2 KiB
Common Lisp
;;; -*- 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* '(636 638 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))
|
|
(block inner-test-block
|
|
(let ((scanner
|
|
(handler-bind ((error (lambda (condition)
|
|
(declare (ignore condition))
|
|
(when perl-error
|
|
;; we expected an
|
|
;; error, so we can
|
|
;; signal success
|
|
(return-from inner-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))))
|
|
(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))))))))))
|