source: project/chicken/trunk/chicken-bug.scm @ 7864

Last change on this file since 7864 was 7864, checked in by felix winkelmann, 12 years ago

fixed uses of time->string and seconds->string (no trailing newline)

File size: 7.9 KB
Line 
1;;;; chicken-bug.scm - Bug report-generator
2
3
4(use srfi-13 posix utils tcp extras)
5
6
7#>
8#ifndef C_TARGET_CC
9# define C_TARGET_CC  C_INSTALL_CC
10#endif
11
12#ifndef C_TARGET_CXX
13# define C_TARGET_CXX  C_INSTALL_CXX
14#endif
15<#
16
17
18(define-constant +bug-report-file+ "chicken-bug-report.~a-~a-~a")
19
20(define-constant +fallbackdestinations+ 
21  "chicken-janitors@nongnu.org\nchicken-hackers@nongnu.org\nchicken-users@nongnu.org\nfelix@call-with-current-continuation.org")
22
23(define-constant +destination+ "chicken-janitors@nongnu.org")
24(define-constant +mxservers+ (list "mx10.gnu.org" "mx20.gnu.org"))
25
26(define-foreign-variable +cc+ c-string "C_TARGET_CC")
27(define-foreign-variable +cxx+ c-string "C_TARGET_CXX")
28(define-foreign-variable +c-include-path+ c-string "C_INSTALL_INCLUDE_HOME")
29
30
31(define (collect-info)
32  (print "\n--------------------------------------------------\n")
33  (print "This is a bug report generated by chicken-bug(1).\n")
34  (print "Date:\t" (seconds->string (current-seconds)) "\n\n")
35  (printf "User information:\t~s~%~%" (user-information (current-user-id)))
36  (print "Host information:\n")
37  (print "\tmachine type:\t" (machine-type))
38  (print "\tsoftware type:\t" (software-type))
39  (print "\tsoftware version:\t" (software-version))
40  (print "\tbuild platform:\t" (build-platform) "\n")
41  (print "CHICKEN version is:\n" (chicken-version #t) "\n")
42  (print "Home directory:\t" (chicken-home) "\n")
43  (printf "Include path:\t~s~%~%" ##sys#include-pathnames)
44  (print "Features:")
45  (for-each
46   (lambda (lst) 
47     (display "\n  ")
48     (for-each
49      (lambda (f)
50        (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
51      lst) )
52   (chop (sort (map keyword->string ##sys#features) string<?) 5))
53  (print "\n\nchicken-config.h:\n")
54  (with-input-from-file (make-pathname +c-include-path+ "chicken-config.h")
55    (lambda ()
56      (display (read-all)) ) )
57  (newline)
58  (when (and (string=? +cc+ "gcc") (feature? 'unix))
59    (print "CC seems to be gcc, trying to obtain version...\n")
60    (with-input-from-pipe "gcc -v 2>&1"
61      (lambda ()
62        (display (read-all)))))
63  (newline) )
64
65(define (usage code)
66  (print #<<EOF
67usage: chicken-bug [FILENAME ...]
68
69  -help  -h            show this message
70  -to-stdout           write bug report to standard output
71  -                    read description from standard input
72
73Generates a bug report file from user input or alternatively
74from the contents of files given on the command line.
75
76EOF
77) 
78  (exit code) )
79
80(define (user-input)
81  (when (##sys#tty-port? (current-input-port))
82    (print #<<EOF
83This is the CHICKEN bug report generator. Please enter a detailed
84description of the problem you have encountered and enter CTRL-D (EOF)
85once you have finished. Press CTRL-C to abort the program. You can
86also pass the description from a file (just abort now and re-invoke
87"chicken-bug" with one or more input files given on the command-line)
88
89EOF
90) )
91  (read-all) )
92
93(define (justify n)
94  (let ((s (number->string n)))
95    (if (> (string-length s) 1)
96        s
97        (string-append "0" s))))
98
99(define (main args)
100  (let ((msg "")
101        (files #f)
102        (stdout #f))
103    (for-each
104     (lambda (arg)
105       (cond ((string=? "-" arg) 
106              (set! files #t)
107              (set! msg (string-append msg "\n\nUser input:\n\n" (user-input))) )
108             ((member arg '("--help" "-h" "-help"))
109              (usage 0) )
110             ((string=? "-to-stdout" arg)
111              (set! stdout #t) )
112             (else
113              (set! files #t)
114              (set! msg 
115                (string-append
116                 msg
117                 "\n\nFile added: " arg "\n\n"
118                 (read-all arg) ) ) ) ) )
119     args)
120    (unless files
121      (set! msg (string-append msg "\n\n" (user-input))))
122    (newline)
123    (match-let ((#(_ _ _ day mon yr _ _ _ _) (seconds->local-time (current-seconds))))
124        (if stdout
125            (begin
126                (print msg)
127                (collect-info))
128            (try-mail
129                +mxservers+
130                (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
131                (mail-headers)
132                (with-output-to-string
133                    (lambda ()
134                        (print msg)
135                        (collect-info))))))))
136      ;(let* ((file (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day)))
137        ;     (port (if stdout (current-output-port) (open-output-file file))))
138        ;(with-output-to-port port
139        ;  (lambda ()
140        ;    (print msg)
141        ;    (collect-info) ) )
142        ;(unless stdout
143        ;  (close-output-port port)
144        ;  (print "\nA bug report has been written to `" file "'. Please send it to")
145        ;  (print "one of the following addresses:\n\n" +destinations+) ) ) ) ) )
146
147(define (try-mail servs fname hdrs msg)
148    (if (null? servs)
149        (begin
150            (with-output-to-file fname
151                (lambda () (print msg)))
152            (print "\nCould not send mail automatically!\n\nA bug report has been written to `" fname "'.  Please send it to")
153            (print "one of the following addresses:\n\n" +fallbackdestinations+))
154        (or (send-mail (car servs) msg hdrs fname)
155            (try-mail (cdr servs) fname hdrs msg))))
156
157(define (mail-date-str tm)
158    (string-append
159        (case (vector-ref tm 6)
160            ((0) "Sun, ")
161            ((1) "Mon, ")
162            ((2) "Tue, ")
163            ((3) "Wed, ")
164            ((4) "Thu, ")
165            ((5) "Fri, ")
166            ((6) "Sat, "))
167        (string-pad (number->string (vector-ref tm 3)) 2 #\0)
168        (case (vector-ref tm 4)
169            ((0)  " Jan ")
170            ((1)  " Feb ")
171            ((2)  " Mar ")
172            ((3)  " Apr ")
173            ((4)  " May ")
174            ((5)  " Jun ")
175            ((6)  " Jul ")
176            ((7)  " Aug ")
177            ((8)  " Sep ")
178            ((9)  " Oct ")
179            ((10) " Nov ")
180            ((11) " Dec "))
181        (number->string (+ 1900 (vector-ref tm 5)))
182        " "
183        (string-pad (number->string (vector-ref tm 2)) 2 #\0)
184        ":"
185        (string-pad (number->string (vector-ref tm 1)) 2 #\0)
186        ":"
187        (string-pad (number->string (vector-ref tm 0)) 2 #\0)
188        " +0000"))
189
190(define (mail-headers)
191    (string-append
192        "Date: " (mail-date-str (seconds->utc-time (current-seconds))) "\r\n"
193        "From: \"chicken-bug user\" <chicken-bug-command@callcc.org>\r\n"
194        "To: \"Chicken Janitors\" <chicken-janitors@nongnu.org>\r\n"
195        "Subject: Automated chicken-bug output -- "))
196
197(define (mail-read i o)
198    (let ((v   (condition-case (read-line i)
199                   (var () (close-input-port i) (close-output-port o) #f))))
200        (if v
201            (if (char-numeric? (string-ref v 0))
202                (string->number (substring v 0 3))
203                (mail-read i o))
204            #f)))
205
206(define (mail-write i o m)
207    (let ((v   (condition-case (display m o)
208                   (var () (close-input-port i) (close-output-port o) #f))))
209        (if v
210            (mail-read i o)
211            #f)))
212
213(define (mail-check i o v e k)
214    (if (and v (= v e))
215        #t
216        (begin
217            (close-input-port i)
218            (close-output-port o)
219            (k #f))))
220
221(define (send-mail serv msg hdrs fname)
222  (print "connecting to " serv " ...")
223    (receive (i o)
224        (tcp-connect serv 25)
225        (call-with-current-continuation
226            (lambda (k)
227                (mail-check i o (mail-read i o) 220 k)
228                (mail-check i o (mail-write i o "HELO callcc.org\r\n") 250 k)
229                (mail-check i o (mail-write i o "MAIL FROM:<chicken-bug-command@callcc.org>\r\n") 250 k)
230                (mail-check i o (mail-write i o "RCPT TO:<chicken-janitors@nongnu.org>\r\n") 250 k)
231                (mail-check i o (mail-write i o "DATA\r\n") 354 k)
232                (mail-check i o (mail-write i o (string-append hdrs fname "\r\n\r\n" msg "\r\n.\r\n")) 250 k)
233                (display "QUIT" o)
234                (close-input-port i)
235                (close-output-port o)
236                (print "Bug report successfully mailed to the Chicken maintainers.\nThank you very much!\n\n")
237                #t))))
238
239(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.