;;; -*- Mode:Common-Lisp; Package:USER; Base:10; Fonts:(CPTFONT HL12B HL12BI) -*-

;;; 2/16/88 las - added bug machine type

(DEFVAR BUG-ORGANIZATION-NAME "")
(DEFVAR bug-host-name nil)
(DEFVAR bug-current-pointer 0.)
(DEFVAR bug-date-time NIL)
(DEFVAR bug-priority NIL)
(DEFVAR bug-type NIL)
(DEFVAR bug-description-of-problem NIL)
(DEFVAR bug-work-around NIL)
(DEFVAR bug-name NIL)
(DEFVAR bug-location NIL)
(DEFVAR bug-address NIL)
(DEFVAR bug-phone NIL)
(DEFVAR bug-net-address NIL)
(DEFPARAMETER bug-machine-type NIL)
(DEFVAR bug-software-configuration NIL)
(DEFVAR bug-hardware-configuration NIL)

(defun mail-fixed-bugs (pathname-to-use)
  (let ((mail-list '("fixed-bugs@pisces")))
    (WITH-OPEN-FILE (in-file pathname-to-use
			     :if-does-not :error)
      (mail:submit-mail in-file	:to mail-list :subject "Fixed bug report"))))



(DEFUN bug-server ()
  "2This function reads in a text file sent to a directory and parses out the
     information needed by the Vax bug database. It then sends this new file to
     a server on the vax to be placed into the database.*"
  
  (LET ((directory-pathname "pisces:spr.bug-reports;*.*#*")
	(fixed-directory "pisces:bug-info.fix-reports;*.*#*")
	(file-pathname  "pisces:spr.bug-reports;mail.text#>")
	(report-file-pathname "pisces:spr.bug-reports;bug-report-file.text#1")
	(log-file-pathname "pisces:spr.server-log;log.text#>"))
    (LOOP
      (CONDITION-CASE () 
	  (WHEN  (< 1 (LENGTH (fs:directory-list directory-pathname )))
	    (fs:rename-file file-pathname report-file-pathname)
	    (spr-server report-file-pathname)
	    (COPY-FILE report-file-pathname log-file-pathname)
	    (fs:delete-file report-file-pathname)
	    (fs:expunge-directory directory-pathname)
	    )
	(( net:local-network-error sys:host-not-responding fs:no-file-system)
	(SLEEP 600)))
      (CONDITION-CASE () 
	  (WHEN  (< 1 (LENGTH (fs:directory-list fixed-directory )))
	    (setf file-pathname (first (second (fs:directory-list fixed-directory))))
	    (mail-fixed-bugs (send file-pathname :string-for-printing))
	    (delete-file file-pathname)
	    (fs:expunge-directory fixed-directory)
	    )
	(( net:local-network-error sys:host-not-responding fs:no-file-system)
	(SLEEP 600)));1;condition-case*
	(SLEEP 120)
      );1;loop*
    );1;let*
  );1;bug-server*

(DEFUN spr-server(bug-directory-pathname)
  
  (LET
    (project-cust
     path-out
     buffer-pathname
     new-buffer-pathname
     (bug-reporting-error-directory "pisces:spr.error-directory;"))
    
    (declare (SPECIAL BUG-ORGANIZATION-NAME
		      bug-date-time
		      bug-priority
		      bug-type
		      bug-description-of-problem
		      bug-work-around
 		      bug-name
		      bug-location
		      bug-address
		      bug-phone
		      bug-net-address
		      bug-host-name
		      bug-machine-type
		      bug-backtrace
		      bug-software-configuration
		      bug-hardware-configuration))
    (CONDITION-CASE ()
	(DOLIST (msg-string (report-list bug-directory-pathname) t)
	  (WHEN (is-bug-p msg-string)
	    (PARSE-BUG-REPORT-STRING msg-string)
	    (WHEN (NOT (STRING-EQUAL bug-description-of-problem "invalid report"))
	      
;1;;        Create a unique filename for the VAX and write the file*
;1;;*	1   directly to the VAX.  *
	      (setq path-out (new-path))
;1;;   ******** Change By R.N.B.  Much cleaner way to do pathname still needs work though*
	      (setq buffer-pathname (send
				      (fs:parse-pathname "spr-host:bug;")
				      ;1;;(fs:parse-pathname "pisces:olson.bug.test-location;")*
				      :new-pathname
				      :name path-out  
				      :type "SPR"
				      :version :newest))
	      
	      ;1; now begin building buffer*
	      
	      ;1;;*(FORMAT t "~% writing temporary file ~A to the VAX..." buffer-pathname)
	      (IF (STRING-EQUAL Bug-organization-name "Texas Instruments")
					  (SETQ project-cust "P")
					  ;1;;else*
					  (SETQ project-cust "C"))
	      
	      (with-open-file (s buffer-pathname :direction :output :error :reprompt)
		
		;1; now insert CVV fields into buffer*
		(FORMAT s "SPR3~%")
		(FORMAT s ".styp;EXPLORER~%")
		(CONDITION-CASE ()
		    (FORMAT s ".snde;~O~%" (send (net:get-host bug-host-name) :chaos-address))
		  ((ERROR)
		   (FORMAT s ".snde;~O~%" (send si:local-host :chaos-address))))
		(FORMAT s ".host;~a~%" (get-site-option :host-for-bug-reports))
		(FORMAT s ".susr;~A~%" BUG-LOCATION)
		(format s ".suic;~%")
		(FORMAT S ".sadr;~a~%" BUG-ADDRESS)
		(FORMAT s ".stre;~a~%" BUG-ADDRESS)
		(FORMAT s ".sprn;NIL~%")
		(format S ".date;~a~%" BUG-DATE-TIME)
		(format S ".type;~a~%" BUG-TYPE)
		(UNLESS (EQL #\? BUG-PRIORITY)
		  (format s ".prio;~a~%" BUG-PRIORITY))
		(format s ".name;~a~%" BUG-NAME)
		(format S ".sorg;~a~%" Bug-organization-name)
		(format S ".porc;~a~%" PROJECT-CUST)
		(format s ".phon;~A~%" BUG-PHONE)
		(format s ".netw;~A~%" BUG-NET-ADDRESS)
		(format s ".cpum;~A~%" BUG-MACHINE-TYPE)
		;1; At this point starts variable-length information.*
		(format s ".desc;~%~A~%" BUG-DESCRIPTION-OF-PROBLEM)
		(format s ".work;~%~A~%" BUG-WORK-AROUND)
		(format s ".back;~%~A~%" BUG-BACKTRACE)
		(format s ".sftw;~%~A~%" BUG-SOFTWARE-CONFIGURATION)
		(FORMAT s ".hrdw;~%~A~%" BUG-HARDWARE-CONFIGURATION)
		) ;1;end with-open-file*
	      
	      ;1;;   ******** Change By R.N.B.  Much cleaner way to do pathname still needs work though*
	      (setq new-buffer-pathname (SEND
					  (fs:parse-pathname "v:spr$device:[flag]")
					  ;1;;*(fs:parse-pathname "spr-host:flag;")
					  ;1;;(fs:parse-pathname "pisces:olson.bug.test-location;")*
					  :new-pathname
					  :name  path-out  
					  :type "SPR"
					  :version :newest))
	      
	      (with-open-file (s new-buffer-pathname
				 :direction :output
				 :error :reprompt)
		(FORMAT s "SPRSERV"))
	      );1;when*
	    );1;when*
	  );1;dolist*
      ((net:local-network-error sys:host-not-responding fs:no-file-system)
       (COPY-FILE bug-directory-pathname bug-reporting-error-directory))
      );1;condition case*
    );1;let*
  );1;spr-server*

(DEFUN is-bug-p (report-string)
  (LET ((test-line "")
	(counter 0)
	(report-stream (MAKE-STRING-INPUT-STREAM report-string)))
    (LOOP
      (SETQ counter (1+ counter))
      (SETQ test-line (READ-LINE report-stream nil nil))
      (WHEN (SEARCH "EXPLORER (TM) BUG REPORT" test-line :test #'STRING-EQUAL)
	(RETURN t))
      (WHEN (OR (> counter 50)
		(NULL test-line))
	(WITH-OPEN-FILE
	  (s "pisces:spr.error-directory;error-log.text#>" :direction :output :error :reprompt)
	  (FORMAT s "~A" report-string))
	(RETURN nil));1;when*
      );1;loop*
    );1;let*
  );1;is-bug-p*

;; RJF 2-13-89 Added automatic breaking of lines that are too long and
;;             handling of embedded mail messages in the description and
;;             performanance improvements

(defvar max-bug-line-length 96.)

(DEFUN report-list (bug-file)
  "2this function parses through the file and returns alist that is made up of all 
     bug reports in bug-file. If only End Of File (eof) is encountered the function returns nil*"
  (LET ((line "")
	(report-string (make-array 20000 :type 'art-string :fill-pointer 0))
        (IN-DESC-OF-PROBLEM nil)
	(Bug-list ())
	)
    (WITH-OPEN-FILE (outfile bug-file
			     :direction :input
			     :error :reprompt)
      (LOOP
	(SETQ line (READ-LINE outfile nil nil))
	(WHEN  (EQUAL line nil)
	  (SETQ bug-list (CONS report-string bug-list))
	  (RETURN bug-list))
        ;;; The assumption is that the field marker DESCRIPTION-OF-PROBLEM: is in
        ;;; every bug report.  When "" character is between WORK-AROUND: CUSTOMER-ID:,
        ;;; or NAME:, whichever is found first then it is part of the sdescription and
        ;;; not the end of the bug
        (if (search "DESCRIPTION-OF-PROBLEM:" line :test #'string-equal :from-end t)
            (setq IN-DESC-OF-PROBLEM t))
	(if IN-DESC-OF-PROBLEM
           (progn
	     (delete "" line :test #'string-equal) 
	     (if (or (search "WORK-AROUND:" line :test #'string-equal :from-end t)
		     (search "CUSTOMER-ID:" line :test #'string-equal :from-end t)
		     (search "NAME       :" line :test #'string-equal :from-end t))
		 (setq IN-DESC-OF-PROBLEM nil))))
	(WHEN (SEARCH "" report-string)
	  (SETQ bug-list (CONS report-string bug-list))
	  (SETQ report-string (make-array 20000 :type 'art-string :fill-pointer 0)
		line ""
		IN-DESC-OF-PROBLEM nil))
        (if  (> (length line) max-bug-line-length)
	  (let ((len (length line))) 
	    (do* ((start 0 (+ start max-bug-line-length))
		  (end (+ start max-bug-line-length) (+ start max-bug-line-length)))
                 ((> start len) (return))
	      (SETQ report-string (string-nconc  report-string (subseq line start end) (STRING #\return)))))
	  (SETQ report-string (string-nconc report-string line (STRING #\return))))
	);1;loop*
      );1;with-open-file*
    );1;let*
  );1;report-list*


(DEFUN parse-text-p (text-stream)
  "2checks to see if any lines in a string of text exceed 80 characters*"
  (LET ((test-line ""))
    (SETQ test-line (READ-LINE text-stream nil nil))
    (WHEN (NULL test-line)
      (RETURN-FROM parse-text-p nil))
    (IF (> (LENGTH test-line) 80)
	(RETURN-FROM parse-text-p t)
	;1;else*
	(parse-text-p text-stream))
    );1;let*
  );1;parse-text-p*


(DEFUN parse-text (description)
  "2Parses the text sent into 80 character lines*"
  (LET ((old-newline-location 0)
	(newline-location 0)
	(space-location 0))
    (DO ((counter 0 (+ counter 1)))
	((NULL newline-location) description)
      (SETQ  newline-location (POSITION #\newline description :start old-newline-location))
      (WHEN (AND (NOT (NULL newline-location))
		 (> (- newline-location  old-newline-location) 80))
	(SETQ space-location (POSITION #\space description
				       :from-end t
				       :start old-newline-location
				       :end (+ old-newline-location 80)))
	(IF (NULL space-location)
	    (PROGN
	      (SETQ space-location (+ old-newline-location 80))
	      (SETQ description (CONCATENATE 'STRING
					     (SUBSEQ description 0 space-location)
					     (LIST #\newline)
					     (SUBSEQ description space-location))))
	    ;1;;else*
	    (SETQ description (SUBSTITUTE #\newline #\space description
					  :count 1
					  :from-end t
					  :end  (+ old-newline-location 80))));1;*
	)
      (WHEN (NOT (NULL newline-location ))
	(SETQ old-newline-location  (+ newline-location 1)))
      );1;do *
    );1;let*
  );1;parse-text*


(DEFUN parse-bug-report-string (report-string)
  (DECLARE (SPECIAL ;1;;bug-current-pointer*
		    bug-date-time
		    bug-priority
		    bug-type
		    bug-description-of-problem
		    bug-work-around
		    bug-name
		    bug-location
		    bug-address
		    bug-phone
		    bug-net-address
		    bug-machine-type
		    bug-backtrace
		    bug-host-name
		    bug-software-configuration
		    bug-hardware-configuration))
  ;1;;(SETQ bug-current-pointer 0.)*
  ;1;;Ensure date is in correct format*
  (LET ((stream (MAKE-STRING-OUTPUT-STREAM)))
    (MULTIPLE-VALUE-BIND (ignore errorp)
	(IGNORE-ERRORS
	  (time:print-universal-time
	    (time:parse-universal-time (clean (GET-NEXT-BUG-VALUE ':DATE-TIME REPORT-STRING)))
	    stream
	    time:*timezone*
	    :mm/dd/yy))
      (WHEN errorp
	(time:print-current-time stream :mm/dd/yy)))
    (SETQ BUG-DATE-TIME (GET-OUTPUT-STREAM-STRING stream)))

  (LOOP WITH String = (GET-NEXT-BUG-VALUE ':PRIORITY REPORT-STRING)
	FOR Counter FROM 0 TO (LENGTH String)
	DO (WHEN (NOT (EQL #\SPACE (CHAR String Counter)))
	     (WHEN (STRING-EQUAL "?" (CHAR String counter))
	       (RETURN (SETQ BUG-PRIORITY "M")));1;when to set bug priority to default if no value given*
	     (RETURN (SETQ BUG-PRIORITY (STRING-UPCASE (CHAR String Counter))))
	     );1;when*
	);1;loop*

  (LOOP WITH String = (GET-NEXT-BUG-VALUE ':TYPE REPORT-STRING)
	FOR Counter FROM 0 TO (LENGTH String)
	DO (IF (NOT (EQL #\SPACE (CHAR String Counter)))
	       ;1;;else*
	       (RETURN (SETQ BUG-TYPE (STRING-UPCASE (CHAR String Counter))))))
  (let ((string (GET-NEXT-BUG-VALUE ':MACHINE-TYPE REPORT-STRING)))
    (unless (string-equal string "")
      (LOOP WITH String = (GET-NEXT-BUG-VALUE ':MACHINE-TYPE REPORT-STRING)
	    FOR Counter FROM 0 TO (LENGTH String)
	    DO (IF (NOT (EQL #\SPACE (CHAR String Counter)))
	       ;1;;else*
		   (RETURN (SETQ BUG-MACHINE-TYPE (STRING-UPCASE (CHAR String Counter))))))))

  (SETQ BUG-DESCRIPTION-OF-PROBLEM (clean (GET-NEXT-BUG-VALUE ':DESCRIPTION-OF-PROBLEM REPORT-STRING)))
  (WHEN (parse-text-p (MAKE-STRING-INPUT-STREAM bug-description-of-problem))
    (SETQ  bug-description-of-problem (parse-text bug-description-of-problem)))
  (SETQ BUG-WORK-AROUND (clean (GET-NEXT-BUG-VALUE ':WORK-AROUND REPORT-STRING)))
  (WHEN (parse-text-p (MAKE-STRING-INPUT-STREAM bug-work-around))
    (SETQ  bug-work-around (parse-text bug-work-around)))
  (GET-NEXT-BUG-VALUE ':TRACKING-ID REPORT-STRING)	;1THIS HELPS AVOID PROBLEMS WITH THE WORD "NAME".*
  (SETQ BUG-NAME (clean (GET-NEXT-BUG-VALUE ':NAME report-string)))
  (SETQ BUG-LOCATION (clean (GET-NEXT-BUG-VALUE ':LOCATION REPORT-STRING)))
  (IF (ZEROP (LENGTH bug-location)) (SETQ bug-location "No user given"))
  (SETQ bug-organization-name (clean (GET-NEXT-BUG-VALUE ':CUSTOMER-ID REPORT-STRING)))
  (IF (ZEROP (LENGTH bug-organization-name)) (SETQ bug-organization-name "No organization given"))
  (SETQ BUG-ADDRESS (clean (GET-NEXT-BUG-VALUE ':ADDRESS REPORT-STRING)))
  (IF (ZEROP (LENGTH bug-address)) (SETQ bug-address "No address given"))
  (SETQ BUG-PHONE (clean (GET-NEXT-BUG-VALUE ':PHONE REPORT-STRING)))
  (SETQ BUG-NET-ADDRESS (clean-and-upcase (GET-NEXT-BUG-VALUE ':from REPORT-STRING)))
  (SETQ BUG-host-name (clean-and-upcase (GET-NEXT-BUG-VALUE ':sender REPORT-STRING)))
  (WHEN (NOT (NULL (POSITION "@" bug-host-name :test #'STRING-EQUAL)))
    (SETQ BUG-host-name (SUBSEQ bug-host-name (+ 1 (POSITION "@" bug-host-name :test #'STRING-EQUAL)))))
  (SETQ BUG-BACKTRACE (clean (GET-NEXT-BUG-VALUE ':BACKTRACE REPORT-STRING)))
  (SETQ BUG-SOFTWARE-CONFIGURATION (clean (GET-NEXT-BUG-VALUE ':SOFTWARE-CONFIGURATION REPORT-STRING)))
  (LET ((with-stars (GET-NEXT-BUG-VALUE ':HARDWARE-CONFIGURATION REPORT-STRING)))
    (SETQ BUG-HARDWARE-CONFIGURATION (clean
				       (substring with-stars 0
						  (SEARCH "****************" with-stars :test #'STRING-EQUAL)))))
  (WHEN (AND (STRING-EQUAL bug-description-of-problem "") (NOT (STRING-EQUAL bug-backtrace "nil")))
    (SETQ bug-description-of-problem "see backtrace"))
  (WHEN (AND (STRING-EQUAL bug-description-of-problem "") (STRING-EQUAL bug-backtrace "nil"))
    (SETQ bug-description-of-problem "invalid report"))
    );1; END OF PARSE-BUG-REPORT-STRING*

(DEFVAR ALL-BUG-KEYWORDS '(:DATE-TIME :PRIORITY :TYPE :DESCRIPTION-OF-PROBLEM :WORK-AROUND
			   :TRACKING-ID :CUSTOMER-ID :NAME
			   :LOCATION :ADDRESS :PHONE :FROM :NET-ADDRESS :MACHINE-TYPE :BACKTRACE :SOFTWARE-CONFIGURATION
			   :HARDWARE-CONFIGURATION :sender :received :message-id :resent-to :resent-from :resent-date
			   :to :resent-message-id :Cc :subject :date))


(DEFUN GET-NEXT-BUG-VALUE (KEYWORD report-string)
  "2Returns the string value of the field specified by KEYWORD in report-stream. The
    function should be used sequentially as called by PARSE-BUG-REPORT-STRING to get the
    fields out of a bug report in order of occurrence.
    The returned value is a string of characters starting from the character after the
    colon following KEYWORD, and ending with the carriage return before whatever keyword
    is specified after KEYWORD in the variable ALL-BUG-KEYWORDS.*"
  
  (LET* ((KEYLIST (MEMBER KEYWORD ALL-BUG-KEYWORDS :TEST #'STRING-EQUAL))
	 (KEY  (FIRST KEYLIST))
	 (report-stream (MAKE-STRING-INPUT-STREAM report-string))
	 (test-line "")
	 (value-string ""))
    (LOOP
      (SETQ test-line (READ-LINE report-stream nil nil))
;1;;      (FORMAT t " ~%~A~% key=*~A*   hlkey=*~A*~%" test-line key (mail:header-line-type test-line))*
;1;;      (DESCRIBE key)*
;1;;      (DESCRIBE (mail:header-line-type test-line))*
      (WHEN (EQUAL (mail:header-line-type test-line) key)
	(SETQ value-string (CONCATENATE 'STRING value-string (mail:header-line-body-string test-line )))
	(LOOP
	  (SETQ test-line (READ-LINE report-stream nil nil))
	  (IF (OR (AND
		    (mail:header-line-p test-line)
		    (MEMBER (mail:header-line-type test-line) all-bug-keywords :test #'EQUAL))
		  (NULL test-line))
	      (RETURN)
	      ;1;else*
	      (SETQ value-string (CONCATENATE 'STRING value-string test-line (STRING #\return)))
	      );1;if*
	  );1;loop*
	(RETURN-FROM get-next-bug-value value-string)
	);1;when*
      (WHEN (NULL test-line)
	(RETURN "no value supplied"))
      );1;loop*
    );1;let**
  );1;get-next-bug-value*


(DEFUN clean (str)  (STRING-TRIM '(#\newline #\space) str))

(DEFUN clean-and-upcase (str) (STRING-UPCASE (STRING-TRIM '(#\newline #\space) str)))