Permalink
Browse files

db schema change 6: test run description: the :contact (:email "someo…

…ne@host.com") construct is changed to just :contact-email "someone@host.com"
  • Loading branch information...
1 parent 29cae9a commit ca5107f22de05afab9998d04c9e5c0bade2993d2 @avodonosov avodonosov committed Jan 27, 2013
View
@@ -262,7 +262,7 @@ the PREDICATE."
:lib-world lib-world
:time (get-universal-time)
:run-duration :unknown
- :contact (list :email (user-email agent))))))
+ :contact-email (user-email agent)))))
(dolist (lisp pending-lisps)
(handler-bind
((serious-condition (lambda (c)
@@ -11,7 +11,7 @@ performed in the current lisp system."
:lib-world lib-world
:time (get-universal-time)
:run-duration :unknown
- :contact (list :email user-email)))
+ :contact-email user-email))
(defun fmt-time (universal-time &optional destination)
"The preferred time format used in the cl-test-grid project."
@@ -126,7 +126,7 @@ as the system load status.")
(format stream " library: ~A~%" libname)
(format stream " lib-world: ~A~%" (getf run-descr :lib-world))
(format stream " lisp: ~A~%" (getf run-descr :lisp))
- (format stream " contributor email: ~A~%" (getf (getf run-descr :contact) :email))
+ (format stream " contributor email: ~A~%" (getf run-descr :contact-email))
(format stream " timestamp: ~A~%" (pretty-fmt-time (get-universal-time)))
(format stream "============================================================~%"))))
@@ -218,7 +218,7 @@ upon the BODY completion runs the BODY again."
(format stream " system: ~A~%" system-name)
(format stream " lib-world: ~A~%" (getf run-descr :lib-world))
(format stream " lisp: ~A~%" (getf run-descr :lisp))
- (format stream " contributor email: ~A~%" (getf (getf run-descr :contact) :email))
+ (format stream " contributor email: ~A~%" (getf run-descr :contact-email))
(format stream " timestamp: ~A~%" (pretty-fmt-time (get-universal-time)))
(format stream "============================================================~%"))))
@@ -313,7 +313,7 @@ results in this directory are tested."
(defun complete-test-run2 (description run-dir quicklisp-dir lisp-exe &key project-names helper-lisp-exe)
(unless (getf description :lib-world) (error "please specify :lib-world in the description"))
- (unless (getf (getf description :contact) :email) (error "lease specify :contact (:email ...) in the description"))
+ (unless (getf description :contact-email) (error "lease specify :contact-email in the description"))
(let* ((*response-file-temp-dir* (or *response-file-temp-dir* run-dir))
(run-info-file (run-info-file run-dir))
(saved-test-run (when (probe-file run-info-file)
View
@@ -134,12 +134,12 @@
(defun print-test-run (out test-run &optional (indent 0))
(let ((descr (getf test-run :descr)))
(format out
- "(:descr (:lisp ~s :lib-world ~s :time ~s :run-duration ~s :contact (:email ~s))~%"
+ "(:descr (:lisp ~s :lib-world ~s :time ~s :run-duration ~s :contact-email ~s)~%"
(getf descr :lisp)
(getf descr :lib-world)
(getf descr :time)
(getf descr :run-duration)
- (getf (getf descr :contact) :email)))
+ (getf descr :contact-email)))
(format out "~v,0t:results (" (1+ indent))
(print-list-elements out
(sort (copy-list (getf test-run :results))
@@ -201,14 +201,3 @@
:element-type 'character ;'(unsigned-byte 8) + flexi-stream
)
(test-grid-utils::safe-read in)))
-
-
-#|
- DB version change history:
- 0 - initial
- 1 - cl-routes and cl-closure-template are renamed to routes and closure-template
- 2 - routes and closure-template are renamed back to cl-routes and cl-closure-template
- 3 - bknr.datastore is renamed to bknr-datastore, in order to match the Quicklisp release name
- 4 - the :load-failed status of testsutes is replaced by just :fail
- 5 - the :version field of DB is renamed to :schema
-|#
@@ -0,0 +1,28 @@
+;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
+;;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;;; See LICENSE for details.
+
+(in-package #:test-grid-data)
+
+#|
+ DB version change history:
+ 0 - initial
+ 1 - cl-routes and cl-closure-template are renamed to routes and closure-template
+ 2 - routes and closure-template are renamed back to cl-routes and cl-closure-template
+ 3 - bknr.datastore is renamed to bknr-datastore, in order to match the Quicklisp release name
+ 4 - the :load-failed status of testsutes is replaced by just :fail
+ 5 - the :version field of DB is renamed to :schema
+ 6 - the :contact (:email "someone@host.com") construct is changed to just :contact-email "someone@host.com"
+|#
+
+(defun schema-change-006 (db)
+ (unless (= 5 (getf db :schema))
+ (error "Expected database schema is 5"))
+ (list :schema 6
+ :runs (mapcar (lambda (run)
+ (let* ((descr (copy-list (getf run :descr)))
+ (email (getf (getf descr :contact) :email)))
+ (remf descr :contact)
+ (setf (getf descr :contact-email) email)
+ (updated-plist run :descr descr)))
+ (getf db :runs))))
@@ -12,7 +12,7 @@ test results summary for particular lib-world."
(let ((descr (test-grid-data::run-descr run)))
(when (string= lib-world (getf descr :lib-world))
(push (list (getf descr :lisp)
- (getf (getf descr :contact) :email))
+ (getf descr :contact-email))
result))))
(format t "cl-test-grid@googlegroups.com~{,~A~}~%"
(remove-duplicates (sort (mapcar #'second result) #'string<)
@@ -80,9 +80,7 @@ WHERE is a predicate of one argument - test result record."
(defmethod test-run-duration ((item joined-lib-result))
(getf (test-grid-data::run-descr (test-run item)) :run-duration))
(defmethod contact-email ((item joined-lib-result))
- (getf (getf (test-grid-data::run-descr (test-run item))
- :contact)
- :email))
+ (getf (test-grid-data::run-descr (test-run item)) :contact-email))
(defmethod libname ((item joined-lib-result))
(getf (lib-result item) :libname))
(defmethod status ((item joined-lib-result))
@@ -58,7 +58,7 @@ values: :OK, :UNEXPECTED-OK, :CRASH, :TIMEOUT, :FAIL, :NO-RESOURSE, :KNOWN-FAIL.
(test-grid-agent::pretty-fmt-time (getf run-descr :time))
(html-template:escape-string-all (princ-to-string (getf run-descr :lib-world)))
(html-template:escape-string-all (princ-to-string (getf run-descr :lisp)))
- (html-template:escape-string-all (princ-to-string (getf (getf run-descr :contact) :email))))
+ (html-template:escape-string-all (princ-to-string (getf run-descr :contact-email))))
(dolist (lib test-grid-testsuites::*all-libs*)
(format out "<td>~A</td>"
(funcall status-renderer run (find lib lib-statuses
View
@@ -10,4 +10,5 @@
((:module "data"
:serial t
:components ((:file "data")
+ (:file "schema-changes")
(:file "blobs")))))

0 comments on commit ca5107f

Please sign in to comment.