Coverage report: /home/jsnell/.sbcl/site/cl-ppcre-1.2.13/ppcre-tests.lisp

KindCoveredAll%
expression148227 65.2
branch2328 82.1
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
2
 ;;; $Header: /usr/local/cvsrep/cl-ppcre/ppcre-tests.lisp,v 1.31 2005/08/23 12:23:13 edi Exp $
3
 
4
 ;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved.
5
 
6
 ;;; Redistribution and use in source and binary forms, with or without
7
 ;;; modification, are permitted provided that the following conditions
8
 ;;; are met:
9
 
10
 ;;;   * Redistributions of source code must retain the above copyright
11
 ;;;     notice, this list of conditions and the following disclaimer.
12
 
13
 ;;;   * Redistributions in binary form must reproduce the above
14
 ;;;     copyright notice, this list of conditions and the following
15
 ;;;     disclaimer in the documentation and/or other materials
16
 ;;;     provided with the distribution.
17
 
18
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
 
30
 (in-package #:cl-ppcre-test)
31
 
32
 (defparameter *cl-ppcre-test-base-directory*
33
   (make-pathname :name nil :type nil :version nil
34
                  :defaults (parse-namestring *load-truename*)))
35
 
36
 (defun full-gc ()
37
   "Start a full garbage collection."
38
   ;; what are the corresponding values for MCL and OpenMCL?
39
   #+:allegro (excl:gc t)
40
   #+(or :cmu :scl) (ext:gc :full t)
41
   #+:ecl (si:gc t)
42
   #+:clisp (ext:gc)
43
   #+:cormanlisp (loop for i from 0 to 3 do (cormanlisp:gc i))
44
   #+:lispworks (hcl:mark-and-sweep 3)
45
   #+:sbcl (sb-ext:gc :full t))
46
 
47
 ;; warning: ugly code ahead!!
48
 ;; this is just a quick hack for testing purposes
49
 
50
 (defun time-regex (factor regex string
51
                           &key case-insensitive-mode
52
                                multi-line-mode
53
                                single-line-mode
54
                                extended-mode)
55
   (declare #.*standard-optimize-settings*)
56
   "Auxiliary function used by TEST to benchmark a regex scanner
57
 against Perl timings."
58
   (declare (type string string))
59
   (let* ((scanner (create-scanner regex
60
                                   :case-insensitive-mode case-insensitive-mode
61
                                   :multi-line-mode multi-line-mode
62
                                   :single-line-mode single-line-mode
63
                                   :extended-mode extended-mode))
64
          ;; make sure GC doesn't invalidate our benchmarking
65
          (dummy (full-gc))
66
          (start (get-internal-real-time)))
67
     (declare (ignore dummy))
68
     (dotimes (i factor)
69
       (funcall scanner string 0 (length string)))
70
     (float (/ (- (get-internal-real-time) start) internal-time-units-per-second))))
71
 
72
 #+(or scl
73
       lispworks
74
       (and sbcl sb-thread))
75
 (defun threaded-scan (scanner target-string &key (threads 10) (repetitions 5000))
76
   (declare #.*standard-optimize-settings*)
77
   "Auxiliary function used by TEST to check whether SCANNER is thread-safe."
78
   (full-gc)
79
   (let ((collector (make-array threads))
80
         (counter 0))
81
     (loop for i below threads
82
           do (let* ((j i)
83
                     (fn
84
                       (lambda ()
85
                         (let ((r (random repetitions)))
86
                           (loop for k below repetitions
87
                                 if (= k r)
88
                                   do (setf (aref collector j)
89
                                              (let ((result
90
                                                      (multiple-value-list
91
                                                        (cl-ppcre:scan scanner target-string))))
92
                                                (unless (cdr result)
93
                                                  (setq result '(nil nil #() #())))
94
                                                result))
95
                                 else
96
                                   do (cl-ppcre:scan scanner target-string))
97
                           (incf counter)))))
98
                #+scl (thread:thread-create fn)
99
                #+lispworks (mp:process-run-function "" nil fn)
100
                #+(and sbcl sb-thread) (sb-thread:make-thread fn)))
101
     (loop while (< counter threads)
102
           do (sleep .1))
103
     (destructuring-bind (first-start first-end first-reg-starts first-reg-ends)
104
         (aref collector 0)
105
       (loop for (start end reg-starts reg-ends) across collector
106
             if (or (not (eql first-start start))
107
                    (not (eql first-end end))
108
                    (/= (length first-reg-starts) (length reg-starts))
109
                    (/= (length first-reg-ends) (length reg-ends))
110
                    (loop for first-reg-start across first-reg-starts
111
                          for reg-start across reg-starts
112
                          thereis (not (eql first-reg-start reg-start)))
113
                    (loop for first-reg-end across first-reg-ends
114
                          for reg-end across reg-ends
115
                          thereis (not (eql first-reg-end reg-end))))
116
             do (return (format nil "~&Inconsistent results during multi-threading"))))))
117
 
118
 (defun create-string-from-input (input)
119
   (cond ((or (null input)
120
              (stringp input))
121
           input)
122
         (t
123
           (cl-ppcre::string-list-to-simple-string
124
            (loop for element in input
125
                  if (stringp element)
126
                  collect element
127
                  else
128
                  collect (string (code-char element)))))))
129
 
130
 (defun test (&key (file-name 
131
                    (make-pathname :name "testdata"
132
                                   :type nil :version nil
133
                                   :defaults *cl-ppcre-test-base-directory*)
134
                    file-name-provided-p)
135
                   threaded)
136
   (declare #.*standard-optimize-settings*)
137
   (declare (ignorable threaded))
138
   "Loop through all test cases in FILE-NAME and print report. Only in
139
 LispWorks and SCL: If THREADED is true, also test whether the scanners
140
 work multi-threaded."
141
   (with-open-file (stream file-name
142
                           #+(or :allegro :clisp :scl :sbcl)
143
                           :external-format
144
                           #+(or :allegro :clisp :scl :sbcl)
145
                           (if file-name-provided-p
146
                             :default
147
                             #+(or :allegro :scl :sbcl) :iso-8859-1
148
                             #+:clisp charset:iso-8859-1))
149
     (loop with testcount of-type fixnum = 0
150
           with *regex-char-code-limit* = (if file-name-provided-p
151
                                            *regex-char-code-limit*
152
                                            ;; the standard test suite
153
                                            ;; doesn't need Unicode
154
                                            ;; support
155
                                            256)
156
           with *allow-quoting* = (if file-name-provided-p
157
                                    *allow-quoting*
158
                                    t)
159
           for input-line = (read stream nil nil)
160
           for (counter info-string regex
161
                        case-insensitive-mode multi-line-mode
162
                        single-line-mode extended-mode
163
                        string perl-error factor
164
                        perl-time ex-result ex-subs) = input-line
165
           while input-line
166
           do (let ((info-string (create-string-from-input info-string))
167
                    (regex (create-string-from-input regex))
168
                    (string (create-string-from-input string))
169
                    (ex-result (create-string-from-input ex-result))
170
                    (ex-subs (mapcar #'create-string-from-input ex-subs))
171
                    (errors '()))
172
                ;; provide some visual feedback for slow CL
173
                ;; implementations; suggested by JP Massar
174
                (incf testcount)
175
                #+(or scl
176
                      lispworks
177
                      (and sbcl sb-thread))
178
                (when threaded
179
                  (format t "Test #~A (ID ~A)~%" testcount counter)
180
                  (force-output))
181
                (unless #-(or scl
182
                              lispworks
183
                              (and sbcl sb-thread))
184
                        nil
185
                        #+(or scl
186
                              lispworks
187
                              (and sbcl sb-thread))
188
                        threaded
189
                  (when (zerop (mod testcount 10))
190
                    (format t ".")
191
                    (force-output))
192
                  (when (zerop (mod testcount 100))
193
                    (terpri)))
194
                (handler-case
195
                  (let* ((*use-bmh-matchers* (if (and (> factor 1) (plusp perl-time))
196
                                               *use-bmh-matchers*
197
                                               ;; if we only check for
198
                                               ;; correctness we don't
199
                                               ;; care about speed that
200
                                               ;; match (but rather
201
                                               ;; about space
202
                                               ;; constraints of the
203
                                               ;; trial versions)
204
                                               nil))
205
                         (scanner (create-scanner regex
206
                                                 :case-insensitive-mode case-insensitive-mode
207
                                                 :multi-line-mode multi-line-mode
208
                                                 :single-line-mode single-line-mode
209
                                                 :extended-mode extended-mode)))
210
                    (multiple-value-bind (result1 result2 sub-starts sub-ends)
211
                        (scan scanner string)
212
                      (cond (perl-error
213
                              (push (format nil
214
                                            "~&expected an error but got a result")
215
                                    errors))
216
                            (t
217
                              (when (not (eq result1 ex-result))
218
                                (if result1
219
                                  (let ((result (subseq string result1 result2)))
220
                                    (unless (string= result ex-result)
221
                                      (push (format nil
222
                                                    "~&expected ~S but got ~S"
223
                                                    ex-result result)
224
                                            errors))
225
                                    (setq sub-starts (coerce sub-starts 'list)
226
                                          sub-ends (coerce sub-ends 'list))
227
                                    (loop for i from 0
228
                                          for ex-sub in ex-subs
229
                                          for sub-start = (nth i sub-starts)
230
                                          for sub-end = (nth i sub-ends)
231
                                          for sub = (if (and sub-start sub-end)
232
                                                      (subseq string sub-start sub-end)
233
                                                      nil)
234
                                          unless (string= ex-sub sub)
235
                                            do (push (format nil
236
                                                             "~&\\~A: expected ~S but got ~S"
237
                                                             (1+ i) ex-sub sub) errors)))
238
                                  (push (format nil
239
                                                "~&expected ~S but got ~S"
240
                                                ex-result result1)
241
                                        errors)))))
242
                      #+(or scl
243
                            lispworks
244
                            (and sbcl sb-thread))
245
                      (when threaded
246
                        (let ((thread-result (threaded-scan scanner string)))
247
                          (when thread-result
248
                          (push thread-result errors))))))
249
                  (condition (msg)
250
                    (unless perl-error
251
                      (push (format nil "~&got an unexpected error: '~A'" msg)
252
                            errors))))
253
                (setq errors (nreverse errors))
254
                (cond (errors
255
                        (when (or (<= factor 1) (zerop perl-time))
256
                          (format t "~&~4@A (~A):~{~&   ~A~}~%"
257
                                  counter info-string errors)))
258
                      ((and (> factor 1) (plusp perl-time))
259
                        (let ((result (time-regex factor regex string
260
                                                  :case-insensitive-mode case-insensitive-mode
261
                                                  :multi-line-mode multi-line-mode
262
                                                  :single-line-mode single-line-mode
263
                                                  :extended-mode extended-mode)))
264
                          (format t "~&~4@A: ~,4F (~A repetitions, Perl: ~,4F seconds, CL-PPCRE: ~,4F seconds)" counter
265
                                  (float (/ result perl-time)) factor perl-time result)
266
                          #+:cormanlisp (force-output *standard-output*)))
267
                      (t nil))))
268
     (values)))