Changeset 15308


Ignore:
Timestamp:
Apr 9, 2012, 5:22:13 PM (7 years ago)
Author:
kmcorbett
Message:

#951 ASDF hooks to compile specified systems with code coverage analysis. #952 changes for Hunchentoot 1.2.

Location:
trunk/source/examples/code-cover-test
Files:
3 added
3 edited
1 moved

Legend:

Unmodified
Added
Removed
  • trunk/source/examples/code-cover-test/README.txt

    r15178 r15308  
    33code-cover-test - CCL code coverage test example
    44
    5 To load use QuickLisp and/or ASDF, for example:
     5COMPILE A CL SYSTEM WITH CODE COVERAGE
    66
    7    (ql:quickload :code-cover-test)
    8 
    9 COMPILE A CL SYSTEM WITH CODE COVERAGE
     7In Common Lisp, a system is a code library or application declared
     8using DEFSYSTEM and containing one or more Lisp source files.
     9Ideally, each system has its own unit tests.
    1010
    11111. Load the code coverage test system
    1212
    13    (ql:quickload "code-cover-test")
    14    (in-package :code-cover-test)
     13   (load (translate-logical-pathname "ccl:examples;code-cover-test;code-cover-test.asd"))
     14   (ql:quickload :code-cover-test)
     15   (ql:quickload :code-cover-tests)
    1516
    16 2. Define CL systems to test. Ideally the system has a unit test driver.
     172. Configure one or more Common Lisp systems to test with code coverage
    1718
    18    Default is CL-PPCRE-TEST.
    19 
    20    TODO: parameterize this - currently the CL-PPCRE systems are hard-coded.
    21 
    22      * Define methods to specify systems and forms
    23      * Remove CL-PPCRE dependency from package CODE-COVER-TEST
     19   See code-cover-test/cl-ppcre-tests.lisp for an example that defines
     20   methods to run CL-PPCRE unit tests with code coverage analysis
     21   enabled.
    2422
    25233. Compile and run tests with code coverage
    2624
    27    (run-all-tests-with-code-coverage :compile-p t)
     25   (in-package :code-cover-test)
    2826
    29    To (re)compile and (re)initialize code coverage only (not run tests)
     27   (do-tests (make-instance 'cl-ppcre-tests))
    3028
    31    (init-code-coverage :compile-p t)
     29   To (re)compile and (re)initialize code coverage only (without running tests)
     30
     31   (init-code-coverage (make-instance 'cl-ppcre-tests))
    3232
    3333GENERATE REPORT ON CODE COVERAGE
    3434
    35351. Specify output directory - default is ~/tmp/code-cover-test
     36
     37   (in-package :code-cover-test)
    3638
    3739   (setq *output-directory-path* #P"~/tmp/code-cover-test/")
     
    4345VIEW CODE COVERAGE REPORTS
    4446
    45 Install the code coverage results into a Web server and view the generated page
    46 "index.html".  With some Web browsers, viewing the files using FILE URLs
    47 (without getting from on a Web server) will not serve the results in frames and
    48 Javascript UI won't work properly.
     47Use a Web browser to view the generated page "html/index.html".
     48
     49With some Web browsers, viewing the files using local file URLs
     50(without getting from on a Web server) will not show the results in
     51frames and the Javascript UI won't work properly. The recommended
     52approach is to serve the code coverage results via Web server.
    4953
    5054Following are instructions to view code coverage results via Hunchentoot.
     
    52561. Load the code coverage test server
    5357
    54    (ql:quickload "code-cover-test")
    55    (in-package :code-cover-test)
     58   (load (translate-logical-pathname "ccl:examples;code-cover-test;code-cover-test-server.asd"))
     59   (ql:quickload :code-cover-test-server)
    5660
    57612. Set the host and port as needed. These default to "localhost" and 9090, respectively.
     62
     63   (in-package :code-cover-test-server)
    5864
    5965   (setq *server-port* 9090. *server-host* "localhost")
     
    61673. Start the server       
    6268
    63    (start-code-coverage-test-server)
     69   (in-package :code-cover-test-server)
     70
     71   (start-server)
    6472
    6573   TODO: Make it easy to load code coverage server in a separate image to avoid
     
    72805. To stop the server:
    7381
    74    (stop-code-coverage-test-server)
     82   (in-package :code-cover-test-server)
     83
     84   (stop-server)
    7585
    7686   Restart as needed:
    7787
    78    (start-code-coverage-test-server)
     88   (start-server)
  • trunk/source/examples/code-cover-test/code-cover-test-server.lisp

    r15247 r15308  
    1 ;; -*- Mode:Lisp; tab-width:2; indent-tabs-mode:nil -*-
     1;; -*- Mode: Lisp; tab-width: 2; indent-tabs-mode: nil -*-
     2
     3;; Local host Web server for browsing code coverage test run results
    24
    35(require ':hunchentoot)
    46
    5 (in-package :code-cover-test)
     7(in-package :code-cover-test-server)
    68
     9;; Port and host name for socket binding
    710(defvar *server-port* 9090.)
    811(defvar *server-host* "localhost")
    912
    10 (defun server-files-path (&optional filename)
    11   (merge-pathnames (or filename (make-pathname)) *output-directory-path*))
     13;; Locating code coverage output files
     14
     15(defun server-files-path (filename)
     16  (check-type filename (or pathname string))
     17  (output-path filename))
    1218
    1319(defvar *server-message-log* #P"message.log")
    1420(defvar *server-access-log* #P"access.log")
     21
     22;; Server handles these URIs
    1523
    1624(defvar *results-uri* "/code-cover-test/")
     
    1826(defvar *results-full-uri* "/code-cover-test/index.html")
    1927
    20 (defvar _acceptor)                      ;one acceptor listening for this server
    21 (defvar _request)                       ;debugging
     28;; Debugging
     29(defvar _acceptor)
     30(defvar _request)
    2231
    23 (let* ((report-folder-handler
    24         (hunchentoot:create-folder-dispatcher-and-handler
    25          *results-uri* (make-pathname :defaults (index-file-path) :name nil :type nil)))
    26        (report-folder-verbose-handler
    27         (lambda (request)
    28           (let (script result)
    29             (setq script (hunchentoot::script-name request))
    30             (hunchentoot::log-message :debug "Folder handler called for ~a" script)
    31             (setq result (funcall report-folder-handler request))
    32             (hunchentoot::log-message :debug "Folder handler result for ~a - ~s" script result)
    33             ;; Returns
    34             result)))
    35        (report-special-handler
    36         (lambda (request)
    37           (let ((script (hunchentoot::script-name request)))
    38             (hunchentoot::log-message :debug "Special handler called for ~A" script)
    39             (when (member script (list *results-partial-uri* *results-uri*) :test #'equal)
    40               (hunchentoot::redirect *results-full-uri*)))))
    41        (handlers (list report-special-handler report-folder-verbose-handler)))
    42   (defun report-dispatch-handler (request)
    43     (let ((hunchentoot:*dispatch-table* handlers))
    44       (hunchentoot::list-request-dispatcher request))))
     32;; Handlers for URIs to get code coverage test run results
    4533
    46 (defun init-code-coverage-test-server ()
    47   (unless hunchentoot:*message-log-pathname*
    48     (setf hunchentoot:*message-log-pathname* (server-files-path *server-message-log*)))
    49   (unless hunchentoot:*access-log-pathname*
    50     (setf hunchentoot:*access-log-pathname* (server-files-path *server-access-log*)))
    51   ;; Returns
    52   (setq _acceptor (make-instance 'hunchentoot:acceptor :port *server-port* :address *server-host*)))
     34(defvar *report-file-dispatcher*
     35  (hunchentoot:create-static-file-dispatcher-and-handler
     36   *results-full-uri* (index-file-path)))
    5337
    54 (defun start-code-coverage-test-server (&key (initialize-p t))
    55   (and initialize-p (init-code-coverage-test-server))
    56   (pushnew 'report-dispatch-handler hunchentoot:*dispatch-table*)
     38(defvar *report-folder-dispatcher*
     39  (hunchentoot:create-folder-dispatcher-and-handler
     40   *results-uri* (make-pathname :defaults (index-file-path) :name nil :type nil)))
     41
     42(defun match-uri-p (request)
     43  (member (print (hunchentoot:script-name request))
     44          (list *results-uri* *results-partial-uri*)
     45          :test #'equal))
     46
     47(hunchentoot:define-easy-handler (report-index :uri 'match-uri-p) ()
     48  (hunchentoot:redirect *results-full-uri*))
     49
     50;; Initialize server - create acceptor
     51
     52(defun init-server ()
     53  (let ((message-log-pathname (server-files-path *server-message-log*))
     54        (access-log-pathname (server-files-path *server-access-log*)))
     55    ;; Returns
     56    (setq _acceptor
     57          (make-instance 'hunchentoot:easy-acceptor :port *server-port* :address *server-host*
     58                         :message-log-destination message-log-pathname
     59                         :access-log-destination access-log-pathname))))
     60
     61;; Install dispatcher/handlers and start server
     62
     63(defun start-server (&key (initialize-p t))
     64  (and initialize-p (init-server))
     65  (setq hunchentoot:*dispatch-table*
     66        (append hunchentoot:*dispatch-table*
     67                (list *report-file-dispatcher* *report-folder-dispatcher*)))
    5768  (hunchentoot:start _acceptor))
    5869
    59 (defun stop-code-coverage-test-server ()
     70;; Remove dispatcher/handlers and stop server
     71
     72(defun stop-server ()
    6073  (setf hunchentoot:*dispatch-table*
    61         (remove 'report-dispatch-handler hunchentoot:*dispatch-table*))
     74        (remove-if #'(lambda (handler)
     75                       (member handler (list *report-file-dispatcher* *report-folder-dispatcher*)))
     76                   hunchentoot:*dispatch-table*))
    6277  (hunchentoot:stop _acceptor))
  • trunk/source/examples/code-cover-test/code-cover-test.asd

    r15193 r15308  
    66(in-package code-cover-test.system)
    77
    8 (defsystem code-cover-test-loader
    9   :depends-on ( cl-ppcre cl-ppcre-test hunchentoot )
    10   :serial t
    11   :components
    12   ((:file "package")))
     8(defpackage code-cover-test
     9  (:use #:cl)
     10  (:export #:init-test-code-coverage
     11           #:run-all-tests-with-code-coverage
     12           #:report-code-coverage-test))
    1313
    1414(defsystem code-cover-test
    15   :depends-on ( code-cover-test-loader )
    16   :serial t
    1715  :components
    18   ((:file "code-cover-test")
    19    (:file "code-cover-server")))
     16  ((:file "compile-with-code-coverage")
     17   (:file "code-cover-test" :depends-on ("compile-with-code-coverage"))))
     18
     19(defsystem code-cover-tests
     20  :depends-on (code-cover-test cl-ppcre cl-ppcre-test)
     21  :components
     22  ((:file "cl-ppcre-tests")))
  • trunk/source/examples/code-cover-test/code-cover-test.lisp

    r15178 r15308  
    11;; -*- Mode:Lisp; tab-width:2; indent-tabs-mode:nil -*-
     2
     3;; Run tests and generate code coverage results
    24
    35#-ccl (error "This code uses the Clozure CL code coverage tool")
     
    57(in-package :code-cover-test)
    68
    7 (require :cl-ppcre-test)
     9;; Output files
    810
    911(defparameter *output-directory-path* #P"~/tmp/code-cover-test/")
     
    1214
    1315(defun output-path (filename)
    14   (merge-pathnames filename *output-directory-path*))
     16  (let ((path (merge-pathnames filename *output-directory-path*)))
     17    (ensure-directories-exist path)
     18    path))
    1519
    1620(defun state-file-path ()
     
    2327
    2428;; Wild guess at expected # of table entries (??)
     29
    2530(defvar *code-coverage-entry-size* 1800.)
    2631
     
    2833  (make-hash-table :size size))
    2934
    30 (defun compile-code-coverage (&optional undo)
    31   (let ((ccl:*compile-code-coverage* (not undo))
     35;; Base class for tests
     36
     37(defclass code-cover-test ()
     38  ((systems :initform nil :initarg :systems :accessor systems-of)))
     39
     40;; Compile unit tests with code coverage analysis (maybe) enabled
     41
     42(defmethod compile-code-coverage ((test code-cover-test) &key (compile-code-coverage-p t))
     43  (let ((ccl:*compile-code-coverage* compile-code-coverage-p)
    3244        (*load-verbose* t)
    3345        (*compile-verbose* t))
    34     (asdf:oos 'asdf:load-op ':cl-ppcre-test :force '(:cl-ppcre-test :cl-ppcre))
    35     (unless undo (ccl:save-coverage-in-file (state-file-path)))
    36     t))
     46    (with-slots (systems) test
     47      (if (and systems (atom systems))
     48          (setq systems (list systems)))
     49      (asdf:operate 'asdf:compile-op (first systems) :force systems)
     50      (ccl:save-coverage-in-file (state-file-path))
     51      t)))
    3752
    38 (let ((tests-compile-p-default t))
    39   (defun init-code-coverage (&key (compile-p tests-compile-p-default))
    40     (setf tests-compile-p-default compile-p) ;save flag for next time
    41     (setf *code-coverage-table* (init-code-coverage-table))
    42     ;; Compile sources files or restore coverage data from file
    43     (if compile-p
    44         (compile-code-coverage)
    45         (ccl:restore-coverage-from-file (state-file-path)))
    46     ;; Returns
    47     t))
     53(defmethod init-code-coverage ((test code-cover-test) &key
     54                               (compile-p t) (reset-p compile-p) (restore-p (not compile-p)))
     55  (setf *code-coverage-table* (init-code-coverage-table))
     56  ;; Maybe reset code coverage data
     57  (if reset-p
     58      (ccl:reset-coverage))
     59  ;; Maybe restore coverage data from file
     60  (if restore-p
     61      (ccl:restore-coverage-from-file (state-file-path)))
     62  ;; Maybe compile source files
     63  (if compile-p
     64      (compile-code-coverage test))
     65  ;; Returns
     66  nil)
     67
     68;; Tags for results display
     69
     70(defvar *verbose-tag-names* nil)
    4871
    4972(let ((counter 0.))
    50   (defun make-code-coverage-tag (sym)
    51     (intern (format nil "CODE-COVER-TEST-~d-~a"  (incf counter) sym) ':keyword)))
     73  (defun make-code-coverage-tag (sym &key (verbose *verbose-tag-names*))
     74    (intern (format nil "~:[~*~;CODE-COVER-TEST-~d-~]~a"
     75                    verbose (incf counter)
     76                    sym) ':keyword)))
    5277
    53 (defun run-all-tests-with-code-coverage (&key (compile-p nil compile-p-supplied-p) verbose (iterations 25.))
    54   (apply #'init-code-coverage
    55          (and compile-p-supplied-p (list :compile-p compile-p)))
    56   (let ((successp t))
    57     (macrolet ((run-test-suite (&body body)
    58                  (let ((tag (caar body)))
    59                    `(prog1
    60                         (unless (progn ,@body)
    61                           (setq successp nil))
    62                       (setf (gethash (make-code-coverage-tag ',tag)
    63                                      *code-coverage-table*)
    64                             (ccl:get-incremental-coverage))))))
    65       ;; run the automatically generated Perl tests
    66       (run-test-suite (perl-test :verbose verbose))
    67       (run-test-suite (test-optimized-test-functions :verbose verbose))
    68       (dotimes (n iterations)
    69         (run-test-suite (simple-tests :verbose verbose)))
    70       ;; Returns
    71       successp)))
     78;; Running tests
     79
     80(defvar *current-test*)
     81
     82(defmacro do-test (tag &body body)
     83  (let ((tag-form
     84         (etypecase tag
     85           (null (gentemp "TEST"))
     86           (symbol (list 'quote tag))
     87           (t tag))))
     88    `(do-test-body *current-test* ,tag-form
     89                   (lambda () ,@body))))
     90
     91(defmethod do-test-body ((test code-cover-test) tag fcn)
     92  (funcall fcn)
     93  (setf (gethash (make-code-coverage-tag tag)
     94                 *code-coverage-table*)
     95        (ccl:get-incremental-coverage)))
     96
     97(defmethod do-tests :around ((test code-cover-test) &rest args)
     98  (let ((*current-test* test)
     99        (*compile-code-coverage* t))
     100    (apply #'call-next-method test args)))
     101
     102(defmethod do-tests :before ((test code-cover-test) &rest args)
     103  (apply #'init-code-coverage test args))
     104
     105;; Generating formatted results
    72106
    73107(defun report-code-coverage-test (&optional (state *code-coverage-table*))
    74108  ;; Delete code coverage report output files *.html, *.js
    75109  (dolist (type '("js" "html"))
    76     (dolist (file (directory (output-path (make-pathname :name ':wild :type type))))
     110    (dolist (file
     111              (directory
     112               (output-path
     113                (make-pathname :directory '(:relative "html") :name ':wild :type type))))
    77114      (delete-file file)))
    78115  (ccl:report-coverage (index-file-path) :tags state))
Note: See TracChangeset for help on using the changeset viewer.