LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031606. :SYSTEM-TYPE :LOGICAL :VERSION 2. :TYPE "LISP" :NAME "BUG-REPORT" :DIRECTORY ("REL3-SOURCE" "MAIL-READER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758716262. :AUTHOR "REL3" :LENGTH-IN-BYTES 14145. :LENGTH-IN-BLOCKS 14. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      ;;; -*- Mode:Common-Lisp; Package:ZWEI; Base:8 -*-;;;      RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;TEXAS INSTRUMENTS INCORPORATED.;;; P.O. BOX 2909;;;      AUSTIN, TEXAS 78769;;;    MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.(defflavor bug-report-object   ((to "") (cc "") (subject "")  (system-that-errored "")    (name "") (location "") (postal-address "") (phone "") (mail-address "") (tracking-id "")    (date-time "") (priority "") (type "")    (user-description "") (work-around "")    (backtrace "") (software-configuration "") (hardware-configuration ""))   ()  :gettable-instance-variables  :settable-instance-variables  :inittable-instance-variables)(defmethod (bug-report-object :init-from-environment) (&optional eh-backtrace eh-system-that-errored)  ;; This will initialize a bug object for the standard information that is contained  ;; in a bug report except the data the user must fill in.  The backtrace and system  ;; that errored come from the error handler and must be passed in.  (let ((attribute-alist (get-bug-report-attribute-alist)))    (setq date-time              (time:print-current-time nil))    (setq to                     (or (cadr (assoc :mail-address-for-bug-reports attribute-alist)) ""))    (setq cc                     (or (cadr (assoc :mail-address attribute-alist)) ""))    (setq subject                "Explorer Bug Report")    (setq priority               "?")    (setq type                   "B")    (setq name                   (or (cadr (assoc :personal-name attribute-alist)) ""))    (setq location               (or (cadr (assoc :location attribute-alist)) ""))    (setq postal-address         (or (cadr (assoc :postal-address attribute-alist)) ""))    (setq phone                  (or (cadr (assoc :work-phone attribute-alist)) ""))    (setq mail-address           (or (cadr (assoc :mail-address attribute-alist)) ""))    (setq system-that-errored    (or eh-system-that-errored ""))    (setq backtrace              (or (pad-string eh-backtrace) ""))    (setq software-configuration (or (pad-string (pretty-description-string (si:system-version-info))) ""))    (setq hardware-configuration (or (pad-string (si:get-hardware-info)) ""))))(defmethod (bug-report-object :full-bug-report) ()  ;; Returns a string with the entire bug report, including headers.  Suitable  ;; for stashing in an editor buffer, for example.  (string-append    "To:      " to #\return    "CC:      " cc #\return    "Subject: " subject #\return #\return    (send self :bug-report-body)))(defmethod (bug-report-object :bug-report-body) ()  ;; Returns a string with the bug report body (no headers like to: cc: subject:)  (string-append    "      EXPLORER (TM) BUG REPORT" #\return #\return    "DATE-TIME  : " date-time #\return    "PRIORITY   : " priority "     (H)igh (M)edium (L)ow" #\return    "TYPE       : " type     "     (B)ug  (D)esign (M)anual" #\return #\return    "DESCRIPTION-OF-PROBLEM:" #\return "   " user-description #\return #\return    "WORK-AROUND:" #\return "   " work-around #\return #\return    "CUSTOMER-ID: " tracking-id #\return #\return    "NAME       : " name #\return    "LOCATION   : " location #\return    "ADDRESS    : " postal-address #\return    "PHONE      : " phone #\return    "NET-ADDRESS: " mail-address #\return #\return    (if (and backtrace     (plusp (length backtrace)))(string-append "BACKTRACE:" #\return #\return backtrace #\return)"")    "SOFTWARE-CONFIGURATION:" #\return #\return software-configuration #\return #\return    "HARDWARE-CONFIGURATION:" #\return hardware-configuration #\return    "    ********************************    *         Return to:           *    *                              *    *  EXPLORER BUG REPORTS        *    *  c/o Explorer Project Manager*    *  TEXAS INSTRUMENTS, MS 2201  *    *  P.O. Box 2909               *    *  Austin, Texas   78769       *    ********************************" #\return))(compile-flavor-methods bug-report-object)(defun BUG ()  "Create A bug report editor frame and go to it from Lisp"  (mail-bug))(defcom COM-BUG"Mail a bug report." ()  (mail-bug)  dis-none);;; Add "BUG" to the zmacs command table, therefore allowing meta-x BUG.(eval-when (load)  (set-comtab    *zmacs-comtab*    nil    '(("BUG" . com-bug))));; The error handler passes the backtrace string and a string for the system which errored.;; This needs to get passed into the mail template -- but mail templates don't support arguments.;; So, unfortunately, I need to pass them in as globals to the template -- I can't make local;; bindings either because of the process switch.  So, we need the following two globals:(defvar *backtrace* nil)(defvar *system-that-errored* nil);; MAIL-BUG and PRETTY-DESCRIPTION-STRING needs to be moved from sys:zmacs;zmacs.lisp to here.(DEFUN MAIL-BUG (&optional backtrace (system-that-errored "Explorer"))  "General routine that can be called from anywhere, or by the error handler togenerate a bug report.  This will work when in the cold-load-stream, gettingthe input directly from the keyboard instead of a pre-formatted mail buffer.BACKTRACE is the string that the error handler passes in showing the stack,etc.SYSTEM-THAT-ERRORED is a string indicating what system failed, also passed by  the error handler (however, this seems to be NIL)."      (cond ((and (eq *terminal-io* si:cold-load-stream)      (fboundp 'mail:submit-mail)      (fboundp 'qsend-get-message)) (format *query-io* "~%Mail a Bug Report from the Cold Load Stream ... ~2%") (mail-cold-bug backtrace system-that-errored))((and (fboundp 'mail:submit-mail)      (fboundp 'find-or-create-idle-zmacs-window)) (let ((fcn (get-mail-template-function 'Bug-Report)))   (if fcn       (progn (format *query-io* "~&Mail a bug report from Mail Buffer.  Entering the editor...") (let ((zmacs-window (find-or-create-idle-zmacs-window)))   (w:await-window-exposure)   ;; These get set here, and get cleared out by the Bug Template   ;; You can't reset them in this function, because it would occur   ;; before the bug template had a chance to use them.   (setq *backtrace* backtrace *system-that-errored* system-that-errored)   (send zmacs-window :force-kbd-input `(:execute  ,fcn))   (send zmacs-window :select)))              ;;else       (format *query-io* "~&Bug Report Template not found.  Attempting simple Bug Report ...")       (mail-cold-bug backtrace system-that-errored))))(t (format *query-io* "~&Cannot file a bug report because the necessary systems are not installed."))))       (define-mail-template BUG-REPORT "Bug Report" :mail  "File a Bug Report"  ;; Put the window that called the bug template on the :return-to-window-after-send   ;; property, so that we go back to that window after the bug report is sent out.  (putprop *interval* (aref w:previously-selected-windows 0) :return-to-window-after-send)  ;; Create an instance of a bug-report object and initialize it with the  ;; data in the current environment.  This includes everything except what  ;; the user needs to type in to describe the problem.  Note *backtrace*  ;; and *system-that-errored* are globals which are normally nil but are bound  ;; to the appropriate values just before this template is called.  Then they  ;; are set back to nil, to be sure that this data isn't used accidently later.  (let ((bug-object (make-instance 'bug-report-object)))    (send bug-object :init-from-environment *backtrace* *system-that-errored*)    ;; Insert the bug info into the buffer    (insert (point) (send bug-object :full-bug-report)))  (setq *backtrace* nil*system-that-errored* nil)  ;; position point at the description field. This fails ofcourse, if the  ;; text is changed for this line.  (do ((line (bp-line (point)) (line-next line)))      ((or (null line)   (string-equal line "DESCRIPTION-OF-PROBLEM:"))       (and line    (move-bp (point) (end-line (create-bp (line-next line) 0)))))))(defun mail-cold-bug (&optional backtrace system-that-errored)  "Collects user information for a bug that landed you in the cold load stream,and mails it to address specified"  (let ((bug-object (make-instance 'bug-report-object));; This input list indicates which bug fields will be edited.  It must contain 3 elements;; and can have 4 elements.;;    ele 1 - instance variable of bug object to edit;;    ele 2 - string, without args, to be passed to format for the prompt;;    ele 3 - t if RETURN (or END) should end the field.  nil if END must end the field;;    ele 4 - optional list of acceptable strings this field can take(input-list `((:to                "~&~%Mail to: " t)      (:cc                "~&CC: " t)      (:subject           "~&Subject: " t)      (:priority          "~&Priority - (H)igh (M)edium (L)ow : " t ("h" "m" "l"))      (:type              "~&Type of Problem - (B)ug (D)esign (M)anual : " t ("b" "d" "m"))      (:user-description  "~&~%Description of Problem: (press END when finished)~%" nil)      (:work-around       "~&~%Work Around: (press END when finished)~%" nil)      (:tracking-id       "~&~%Tracking-Id (optional): " t))))    (send bug-object :init-from-environment backtrace system-that-errored)    ;; since we're not in an editor buffer, let's not default these two fields.    (send bug-object :set-cc "")    (send bug-object :set-subject "")    (send bug-object :set-priority "")        ;; repeat  until bug report sucessfully sent or they quit    (do (done) (done)      ;; let them input/edit some stuff for the bug report      (dolist (input input-list)(do () (nil)  (let ((old-value (send bug-object (first input))))    (format t (second input))    (if (not (equal old-value ""))(format t " (default-> ~a) " old-value))    (let ((values-list (fourth input))  (input-text (qsend-get-message *standard-input* nil (third input))))      (when (not (equal input-text ""))    (setf (send bug-object (first input)) input-text))      (if (and values-list       (not (member (send bug-object (first input)) values-list :test #'string-equal)))  (beep)  ;;else  (return))))))            (when (y-or-n-p "~&~%Mail Bug Report? ");; build up the actual bug report and (attempt to) mail it. (setq done (mail:submit-mail (send bug-object :bug-report-body)       :to (list (send bug-object :to))       :other-headers (list (string-append "CC:    " (send bug-object :cc)))       :subject (send bug-object :subject))))      (unless done(and (y-or-n-p "~%Bug Report not successfully handled.  Quit? ")     (setq done t))))))(defun GET-BUG-REPORT-ATTRIBUTE-ALIST (&optional local-only-p);;; Returns an alist of the attributes used in the bug report.  It does this;;; safely, so in case the network/namespace is broken, we don't go into the error;;; handler again.  A default alist is returned in the case the namespace in;;; available at all.  This also will replace #\return with a ";" so that things;;; like :POSTAL-ADDRESS will come out on a single line.  (let ((bug-attributes '(:mail-address-for-bug-reports  :location  :postal-address  :personal-name  :work-phone))(default-bug-report-address "EXPBUG@CSC.TI.COM")(default-mail-address (string-append user-id #\@ si:local-host-name))alist)    (condition-case nil(progn (dolist (option bug-attributes alist)   (push (list option       (or (substitute #\; #\return (get-site-option option local-only-p))   (cond ((eq option :mail-address-for-bug-reports)  default-bug-report-address) ((eq option :personal-name)  user-id) ((eq option :mail-address)  default-mail-address) (t "")))) alist)) ;; This object holds the correct mail address.  It looks for mail:*user-mail-address* ;; or :mail-address on USER object in the namespace, or USER-ID@SI:LOCAL-HOST-NAME. (push (list :mail-address (send (mail:default-from-address) :string-for-printing)) alist))            ;; If we run into some error hitting the namespace,  try again just getting      ;; LOCAL cached namespace information (if this wasn't a local access).  Otherwise      ;; just return some defaulted values.      (error       (if local-only-p   `((:mail-address-for-bug-reports ,default-bug-report-address)     (:personal-name ,user-id)     (:mail-address ,default-mail-address))   ;;else   (get-bug-report-attribute-alist t))))))(DEFUN PRETTY-DESCRIPTION-STRING (DESCRIPTION)  ;; Insert CR after every 72 characters in description string.  (LET ((NEW-DESCRIPTION DESCRIPTION))    (LOOP WITH LINE-START = 0  FOR START = 0 THEN (+ COMMA-POS 2)  AS PREV-COMMA-POS = NIL THEN COMMA-POS  AS COMMA-POS = (LISP:SEARCH ", " (THE STRING NEW-DESCRIPTION)      :START2 START      :TEST #'CHAR-EQUAL)  WHEN (> (- (OR COMMA-POS (LENGTH NEW-DESCRIPTION )) LINE-START) 72.)  UNLESS (NULL PREV-COMMA-POS)  DO (SETF (AREF NEW-DESCRIPTION (1+ PREV-COMMA-POS)) #\NEWLINE)     (SETQ LINE-START (+ PREV-COMMA-POS 2))     (SETQ COMMA-POS PREV-COMMA-POS)  UNTIL (NULL COMMA-POS))    NEW-DESCRIPTION))(defun pad-string (str &optional (pad 3))  "Put PAD number of blanks before every line in STR"  (and str       (stringp str)       (let ((new-string (make-array 0 :type :art-string :fill-pointer 0 :initial-element #\space))     (pad-string (make-string pad :initial-element #\space))     (str-len (length str))) (do* ((start 0 (1+ end))       (end (position #\return str) (position #\return str :start (1+ end))))      ((eq start str-len)       (copy-seq new-string))   (if (null end)       (setq end (1- str-len)))   (string-nconc new-string pad-string (subseq str start (1+ end)))))))first-bp buffer)))      (let ((first-bp (interval-first-bp msg)))(move-bp (interval-first-bp buffer) first-bp)(move-bp (interval-last-bp buffer) (interval-last-bp msg))(move-bp (buffer