source: project/chicken/branches/prerelease/chicken-bug.scm @ 9381

Last change on this file since 9381 was 9381, checked in by Ivan Raikov, 12 years ago

Merged trunk into prerelease

File size: 9.3 KB
Line 
1;;;; chicken-bug.scm - Bug report-generator
2;
3; Copyright (c) 2008, The Chicken Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(use srfi-13 posix utils tcp extras)
28
29
30#>
31#ifndef C_TARGET_CC
32# define C_TARGET_CC  C_INSTALL_CC
33#endif
34
35#ifndef C_TARGET_CXX
36# define C_TARGET_CXX  C_INSTALL_CXX
37#endif
38<#
39
40
41(define-constant +bug-report-file+ "chicken-bug-report.~a-~a-~a")
42
43(define-constant +fallbackdestinations+ 
44  "chicken-janitors@nongnu.org\nchicken-hackers@nongnu.org\nchicken-users@nongnu.org")
45
46(define-constant +destination+ "chicken-janitors@nongnu.org")
47(define-constant +mxservers+ (list "mx10.gnu.org" "mx20.gnu.org"))
48
49(define-foreign-variable +cc+ c-string "C_TARGET_CC")
50(define-foreign-variable +cxx+ c-string "C_TARGET_CXX")
51(define-foreign-variable +c-include-path+ c-string "C_INSTALL_INCLUDE_HOME")
52
53
54(define (collect-info)
55  (print "\n--------------------------------------------------\n")
56  (print "This is a bug report generated by chicken-bug(1).\n")
57  (print "Date:\t" (seconds->string (current-seconds)) "\n\n")
58  (printf "User information:\t~s~%~%" (user-information (current-user-id)))
59  (print "Host information:\n")
60  (print "\tmachine type:\t" (machine-type))
61  (print "\tsoftware type:\t" (software-type))
62  (print "\tsoftware version:\t" (software-version))
63  (print "\tbuild platform:\t" (build-platform) "\n")
64  (print "CHICKEN version is:\n" (chicken-version #t) "\n")
65  (print "Home directory:\t" (chicken-home) "\n")
66  (printf "Include path:\t~s~%~%" ##sys#include-pathnames)
67  (print "Features:")
68  (for-each
69   (lambda (lst) 
70     (display "\n  ")
71     (for-each
72      (lambda (f)
73        (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
74      lst) )
75   (chop (sort (map keyword->string ##sys#features) string<?) 5))
76  (print "\n\nchicken-config.h:\n")
77  (with-input-from-file (make-pathname +c-include-path+ "chicken-config.h")
78    (lambda ()
79      (display (read-all)) ) )
80  (newline)
81  (when (and (string=? +cc+ "gcc") (feature? 'unix))
82    (print "CC seems to be gcc, trying to obtain version...\n")
83    (with-input-from-pipe "gcc -v 2>&1"
84      (lambda ()
85        (display (read-all)))))
86  (newline) )
87
88(define (usage code)
89  (print #<<EOF
90usage: chicken-bug [FILENAME ...]
91
92  -help  -h            show this message
93  -to-stdout           write bug report to standard output
94  -                    read description from standard input
95
96Generates a bug report file from user input or alternatively
97from the contents of files given on the command line.
98
99EOF
100) 
101  (exit code) )
102
103(define (user-input)
104  (when (##sys#tty-port? (current-input-port))
105    (print #<<EOF
106This is the CHICKEN bug report generator. Please enter a detailed
107description of the problem you have encountered and enter CTRL-D (EOF)
108once you have finished. Press CTRL-C to abort the program. You can
109also pass the description from a file (just abort now and re-invoke
110"chicken-bug" with one or more input files given on the command-line)
111
112EOF
113) )
114  (read-all) )
115
116(define (justify n)
117  (let ((s (number->string n)))
118    (if (> (string-length s) 1)
119        s
120        (string-append "0" s))))
121
122(define (main args)
123  (let ((msg "")
124        (files #f)
125        (stdout #f))
126    (for-each
127     (lambda (arg)
128       (cond ((string=? "-" arg) 
129              (set! files #t)
130              (set! msg (string-append msg "\n\nUser input:\n\n" (user-input))) )
131             ((member arg '("--help" "-h" "-help"))
132              (usage 0) )
133             ((string=? "-to-stdout" arg)
134              (set! stdout #t) )
135             (else
136              (set! files #t)
137              (set! msg 
138                (string-append
139                 msg
140                 "\n\nFile added: " arg "\n\n"
141                 (read-all arg) ) ) ) ) )
142     args)
143    (unless files
144      (set! msg (string-append msg "\n\n" (user-input))))
145    (newline)
146    (match-let ((#(_ _ _ day mon yr _ _ _ _) (seconds->local-time (current-seconds))))
147        (if stdout
148            (begin
149                (print msg)
150                (collect-info))
151            (try-mail
152                +mxservers+
153                (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
154                (mail-headers)
155                (with-output-to-string
156                    (lambda ()
157                        (print msg)
158                        (collect-info))))))))
159      ;(let* ((file (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day)))
160        ;     (port (if stdout (current-output-port) (open-output-file file))))
161        ;(with-output-to-port port
162        ;  (lambda ()
163        ;    (print msg)
164        ;    (collect-info) ) )
165        ;(unless stdout
166        ;  (close-output-port port)
167        ;  (print "\nA bug report has been written to `" file "'. Please send it to")
168        ;  (print "one of the following addresses:\n\n" +destinations+) ) ) ) ) )
169
170(define (try-mail servs fname hdrs msg)
171    (if (null? servs)
172        (begin
173            (with-output-to-file fname
174                (lambda () (print msg)))
175            (print "\nCould not send mail automatically!\n\nA bug report has been written to `" fname "'.  Please send it to")
176            (print "one of the following addresses:\n\n" +fallbackdestinations+))
177        (or (send-mail (car servs) msg hdrs fname)
178            (try-mail (cdr servs) fname hdrs msg))))
179
180(define (mail-date-str tm)
181    (string-append
182        (case (vector-ref tm 6)
183            ((0) "Sun, ")
184            ((1) "Mon, ")
185            ((2) "Tue, ")
186            ((3) "Wed, ")
187            ((4) "Thu, ")
188            ((5) "Fri, ")
189            ((6) "Sat, "))
190        (string-pad (number->string (vector-ref tm 3)) 2 #\0)
191        (case (vector-ref tm 4)
192            ((0)  " Jan ")
193            ((1)  " Feb ")
194            ((2)  " Mar ")
195            ((3)  " Apr ")
196            ((4)  " May ")
197            ((5)  " Jun ")
198            ((6)  " Jul ")
199            ((7)  " Aug ")
200            ((8)  " Sep ")
201            ((9)  " Oct ")
202            ((10) " Nov ")
203            ((11) " Dec "))
204        (number->string (+ 1900 (vector-ref tm 5)))
205        " "
206        (string-pad (number->string (vector-ref tm 2)) 2 #\0)
207        ":"
208        (string-pad (number->string (vector-ref tm 1)) 2 #\0)
209        ":"
210        (string-pad (number->string (vector-ref tm 0)) 2 #\0)
211        " +0000"))
212
213(define (mail-headers)
214    (string-append
215        "Date: " (mail-date-str (seconds->utc-time (current-seconds))) "\r\n"
216        "From: \"chicken-bug user\" <chicken-bug-command@callcc.org>\r\n"
217        "To: \"Chicken Janitors\" <chicken-janitors@nongnu.org>\r\n"
218        "Subject: Automated chicken-bug output -- "))
219
220(define (mail-read i o)
221    (let ((v   (condition-case (read-line i)
222                   (var () (close-input-port i) (close-output-port o) #f))))
223        (if v
224            (if (char-numeric? (string-ref v 0))
225                (string->number (substring v 0 3))
226                (mail-read i o))
227            #f)))
228
229(define (mail-write i o m)
230    (let ((v   (condition-case (display m o)
231                   (var () (close-input-port i) (close-output-port o) #f))))
232        (if v
233            (mail-read i o)
234            #f)))
235
236(define (mail-check i o v e k)
237    (if (and v (= v e))
238        #t
239        (begin
240            (close-input-port i)
241            (close-output-port o)
242            (k #f))))
243
244(define (send-mail serv msg hdrs fname)
245  (print "connecting to " serv " ...")
246    (receive (i o)
247        (tcp-connect serv 25)
248        (call-with-current-continuation
249            (lambda (k)
250                (mail-check i o (mail-read i o) 220 k)
251                (mail-check i o (mail-write i o "HELO callcc.org\r\n") 250 k)
252                (mail-check i o (mail-write i o "MAIL FROM:<chicken-bug-command@callcc.org>\r\n") 250 k)
253                (mail-check i o (mail-write i o "RCPT TO:<chicken-janitors@nongnu.org>\r\n") 250 k)
254                (mail-check i o (mail-write i o "DATA\r\n") 354 k)
255                (mail-check i o (mail-write i o (string-append hdrs fname "\r\n\r\n" msg "\r\n.\r\n")) 250 k)
256                (display "QUIT" o)
257                (close-input-port i)
258                (close-output-port o)
259                (print "Bug report successfully mailed to the Chicken maintainers.\nThank you very much!\n\n")
260                #t))))
261
262(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.