Update to current dev version
git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-ppcre@3581 4281704c-cde7-0310-8518-8e2dc76b1ff0
This commit is contained in:
Edi Weitz
150
test/perl-tests.lisp
Normal file
150
test/perl-tests.lisp
Normal file
@ -0,0 +1,150 @@
|
||||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/perl-tests.lisp,v 1.7 2008/07/22 23:02:04 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-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)
|
||||
|
||||
(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))))))))))
|
||||
Reference in New Issue
Block a user