blob: 116711d3f3a2efa1a3ce47226f1b59544ac28a72 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
#!/bin/sh
exec scsh -e main -s "$0" "$@"
!#
;; Script to perform the nightly test/build of Scala.
;;
;; Always make sure that the latest version of this file is copied to
;; ~scalatest/bin/scala2-nightly-test.scm
;;
;; $Id$
;; SVN repository containing the Scala compiler.
(define scala-svn-repository-dir
"http://lampsvn.epfl.ch/svn-repos/scala/scala/trunk")
;; SVN module containing the compiler.
(define scala-svn-module-name "scala")
;; E-mail address to which the failure notification should be sent.
(define notify-emails '("scala-devel@groupes.epfl.ch"))
;;(define notify-emails '("stephane.micheloud@epfl.ch")) ; DEBUG
;; Directory in which the distribution should be built.
;(define nightly-build-dir
; (expand-file-name "~linuxsoft/archives/scala/nightly-scala2"))
;; End of configuration section.
(define (flatten-with-commas lst)
(cond
((null? lst) "")
(#t (fold (lambda (s accum) (string-append accum ", " s))
(car lst)
(cdr lst)))))
(define (main cmd-line)
(let ((prog (car cmd-line))
(args (cdr cmd-line)))
(if (= 1 (length args))
(scala-test (first args))
(display-usage-and-exit prog))))
(define (display-usage-and-exit prog)
(format #t "Usage: ~a <result-dir>\n" prog)
(exit 1))
(define (get-public-link file)
(temp-file-iterate (lambda (link) (create-symlink file link) link)
(expand-file-name "~/public_html/log-scala2-~a.txt")))
(define (get-checkout-dir base-dir date)
(expand-file-name (string-append (format-date "~Y-~m-~d" date) "-scala2") base-dir))
(define (start-section title)
(format #t "\n* ~a\n\n" title))
(define (scala-test base-dir)
(let* ((checkout-dir (get-checkout-dir base-dir (date)))
(log-file (expand-file-name "log-scala2" checkout-dir)))
(create-directory checkout-dir)
(call-with-output-file log-file
(lambda (log-port)
(with-current-output-port log-port
(with-current-error-port log-port
(stdports->stdio)
(with-cwd checkout-dir
(if (not (call-with-current-continuation scala-do-test))
(let ((link (get-public-link log-file)))
(send-warning-mail log-file
(file-name-nondirectory link)))))))))))
(define (scala-do-test return)
(dynamic-wind
(lambda ()
(display "In Emacs, read this file in -*- Outline -*- mode\n")
(start-section "Starting time")
(display (format-date "~Y-~m-~d ~H:~M ~Z\n" (date))))
(lambda ()
(let ((fail-if-error (lambda (code) (if (not (zero? code))
(return #f)))))
(start-section "Checking out Scala module")
(fail-if-error (run (svn co ,scala-svn-repository-dir
,scala-svn-module-name)))
(with-cwd scala-svn-module-name
(start-section "Creating small Scala distribution")
(fail-if-error (run (ant dist)))
(start-section "Testing Scala compiler")
(fail-if-error
(run (./test/scalatest --color=none
--show-log)))
;; (start-section "Creating nightly distribution")
;; (run (rm -rf ,nightly-build-dir))
;; (create-directory nightly-build-dir)
;; (fail-if-error (run (ant dist) (< /dev/null)))
#t)))
(lambda ()
(start-section "Ending time")
(display (format-date "~Y-~m-~d ~H:~M ~Z\n" (date))))))
(define (send-warning-mail log-file-name link-name)
(send-mail
notify-emails
`(("Subject" . "Failure of nightly Scala 2 test")
("To" . ,(flatten-with-commas notify-emails))
("Reply-To" . ,(car notify-emails)))
(string-append
"Tonight's automatic Scala test failed. More details can be found\n"
"in file "log-file-name"\n"
"which is available through the following URL:\n\n"
" http://lamp.epfl.ch/~scalatest/"link-name"\n"
"\n"
(run/string (fgrep "[FAILED]" ,log-file-name)))))
(define (send-mail to headers body)
(let ((mail-port (make-string-output-port)))
(for-each (lambda (name/contents)
(format mail-port "~a: ~a\n"
(car name/contents)
(cdr name/contents)))
headers)
(newline mail-port)
(write-string body mail-port)
(newline mail-port)
(run (sendmail "-i" ,@to)
(<< ,(string-output-port-output mail-port)))))
;;; Local Variables:
;;; mode:scheme
;;; End:
|
