;;; -*- mode: lisp -*-
;;; 
;;; (c) copyright 2005 by Nicolas Sceaux (nicolas.sceaux@free.fr)
;;; 

(defpackage #:climacs-regex-tests
  (:use :cl :climacs-buffer :climacs-base :climacs-ppcre :climacs-regex)
  (:export #:test))

(in-package :climacs-regex-tests)

;;; This is adapted from the CL-PPCRE test suite: ppcre-test.lisp

;;; Copyright (c) 2002-2005, 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.

(defun create-string-from-input (input)
  (cond ((or (null input)
             (stringp input))
         input)
        (t
         (climacs-ppcre::string-list-to-simple-string
          (loop for element in input
             if (stringp element)
             collect element
             else
             collect (string (code-char element)))))))

(defun buffer-substring (buffer start end)
  (coerce (buffer-sequence buffer start end) 'string))

(defun test (&key (file-name 
                   (merge-pathnames
                    (parse-namestring "climacs-ppcre/testdata")
                    (make-pathname :type nil :version nil
                                   :defaults common-lisp-user::*climacs-directory*))
                   file-name-provided-p))
  "Loop through all test cases in FILE-NAME and print report."
  (with-open-file (stream file-name
                   #+(or :allegro :clisp :scl)
                   :external-format
                   #+(or :allegro :clisp :scl)
                   (if file-name-provided-p
                       :default
                       #+:allegro :iso-8859-1
                       #+:clisp charset:iso-8859-1
                       #+:scl :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 full
                                          ;; Unicode support
                                          255)
       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))
                (buffer (make-instance 'standard-buffer))
                (ex-result (create-string-from-input ex-result))
                (ex-subs (mapcar #'create-string-from-input ex-subs))
                (errors '()))
            (insert-buffer-sequence buffer 0 (create-string-from-input string))
            ;; provide some visual feedback for slow CL
            ;; implementations; suggested by JP Massar
            (incf testcount)
            (when (zerop (mod testcount 10))
              (format t ".")
              (force-output))
            (when (zerop (mod testcount 100))
              (terpri))
            (handler-case
                (let* ((*use-bmh-matchers* 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 buffer)
                    (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 (buffer-substring buffer 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)
                                                    (buffer-substring buffer 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)))))))
              (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)))
                  (t nil))))
    (values)))
