Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

158 lines (140 sloc) 5.642 kB
;;;; chicken-bug.scm - Bug report-generator
;
; Copyright (c) 2008-2011, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
; disclaimer.
; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
; disclaimer in the documentation and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
(require-extension srfi-13 posix tcp data-structures utils extras)
(define-constant +bug-report-file+ "chicken-bug-report.~a-~a-~a")
(define-foreign-variable +cc+ c-string "C_TARGET_CC")
(define-foreign-variable +cxx+ c-string "C_TARGET_CXX")
(define-foreign-variable +c-include-path+ c-string "C_INSTALL_INCLUDE_HOME")
(define (user-id)
(cond-expand
(mingw32 "<not available>")
(else (user-information (current-user-id)))))
(define (collect-info)
(print "\n--------------------------------------------------\n")
(print "This is a bug report generated by chicken-bug(1).\n")
(print "Date:\t" (seconds->string (current-seconds)) "\n\n")
(printf "User information:\t~s~%~%" (user-id))
(print "Host information:\n")
(print "\tmachine type:\t" (machine-type))
(print "\tsoftware type:\t" (software-type))
(print "\tsoftware version:\t" (software-version))
(print "\tbuild platform:\t" (build-platform) "\n")
(print "CHICKEN version is:\n" (chicken-version #t) "\n")
(print "Home directory:\t" (chicken-home) "\n")
(printf "Include path:\t~s~%~%" ##sys#include-pathnames)
(print "Features:")
(for-each
(lambda (lst)
(display "\n ")
(for-each
(lambda (f)
(printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
lst) )
(chop (sort (map keyword->string ##sys#features) string<?) 5))
(print "\n\nchicken-config.h:\n")
(with-input-from-file (make-pathname +c-include-path+ "chicken-config.h")
(lambda ()
(display (read-all)) ) )
(newline)
(when (and (string=? +cc+ "gcc") (feature? 'unix))
(print "CC seems to be gcc, trying to obtain version...\n")
(with-input-from-pipe "gcc -v 2>&1"
(lambda ()
(display (read-all)))))
(newline) )
(define (usage code)
(print #<<EOF
usage: chicken-bug [FILENAME ...]
-help -h show this message
-to-stdout write bug report to standard output
- read description from standard input
Generates a bug report file from user input or alternatively
from the contents of files given on the command line.
EOF
)
(exit code) )
(define (user-input)
(when (##sys#tty-port? (current-input-port))
(print #<<EOF
This is the CHICKEN bug report generator. Please enter a detailed
description of the problem you have encountered and enter CTRL-D (EOF)
or a line consisting only of "." to finish. Press CTRL-C to abort the program. You can
also pass the description from a file (just abort now and re-invoke
"chicken-bug" with one or more input files given on the command-line)
EOF
) )
(let loop ((data '()))
(let ((ln (read-line)))
(cond ((or (eof-object? ln) (string=? "." ln))
(string-concatenate-reverse data) )
(else (loop (cons ln data)))))))
(define (justify n)
(let ((s (number->string n)))
(if (> (string-length s) 1)
s
(string-append "0" s))))
(define (main args)
(let ((msg "")
(files #f)
(stdout #f))
(for-each
(lambda (arg)
(cond ((string=? "-" arg)
(set! files #t)
(set! msg (string-append msg "\n\nUser input:\n\n" (user-input))) )
((member arg '("--help" "-h" "-help"))
(usage 0) )
((string=? "-to-stdout" arg)
(set! stdout #t) )
(else
(set! files #t)
(set! msg
(string-append
msg
"\n\nFile added: " arg "\n\n"
(read-all arg) ) ) ) ) )
args)
(unless files
(set! msg (string-append msg "\n\n" (user-input))))
(newline)
(let* ((lt (seconds->local-time (current-seconds)))
(day (vector-ref lt 3))
(mon (vector-ref lt 4))
(yr (vector-ref lt 5)) )
(if stdout
(begin
(print msg)
(collect-info))
(generate-report
(sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
(with-output-to-string
(lambda ()
(print msg)
(collect-info))))))))
(define (generate-report fname msg)
(with-output-to-file fname
(lambda () (print msg)))
(print "\nA bug report has been written to `" fname "'."))
(main (command-line-arguments))
Jump to Line
Something went wrong with that request. Please try again.