cgit.sxemacs.org Git - sxemacs/blob - lisp/build-rpt.el

   1 ;;; build-rpt.el --- Automatically formatted build reports for XEmacs
   2
   3 ;; Copyright (C) 1997-2001 Adrian Aichner
   4 ;; Copyright (C) 2004 - 2007 Steve Youngs
   5
   6 ;; Author: Adrian Aichner <adrian@xemacs.org>
   7 ;; Keywords: internal
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not synched.
  25
  26 ;;; Commentary:
  27
  28 ;; The Idea:
  29 ;; Let SXEmacs report interesting aspects of how it was built.
  30
  31 ;; The Concept:
  32 ;; User creates an SXEmacs Build Report by just calling
  33 ;; M-x build-rpt
  34 ;; which will initialise a mail buffer with relevant information
  35 ;; derived from the SXEmacs build process. Point is left at the
  36 ;; beginning of the report for user to input some personal notes and
  37 ;; send the report.
  38
  39 ;; The Status:
  40 ;; This is the first `Proof of Concept'.
  41
  42 ;; The Author:
  43 ;; Adrian Aichner, Teradyne GmbH Munich, Sun., Apr. 20, 1997.
  44
  45 ;; First update for SXEmacs 2004-12-07 by Steve Youngs.
  46
  47 ;; Renamed to build-rpt so it doesn't conflict with build-report.el in
  48 ;;   XEmacs package "build" -- 2006-01-21 by Steve Youngs.
  49
  50 ;;; Code:
  51
  52 (require 'config)
  53 (require 'custom)
  54 (require 'cl)
  55
  56 ;; gag the byte-compiler... we really do know what we are doing
  57 (eval-when-compile
  58   (globally-declare-boundp
  59    '(gnus-newsgroup-name gnus-article-copy mail-header-separator))
  60   (globally-declare-fboundp
  61    '(gnus-alive-p gnus-slave gnus-slave-unplugged gnus-post-news
  62                   gnus-group-mail message-field-value message-goto-to
  63                   message-goto-subject message-goto-body user-mail-address
  64                   mail-send-and-exit)))
  65
  66
  67 ;;; Customization support for build-rpt starts here.
  68
  69 (defgroup build-rpt nil
  70   "Standardises the Creation of SXEmacs Build Rpts."
  71   :load 'build-rpt
  72   :group 'build)
  73
  74 (defcustom build-rpt-destination
  75   (list
  76    "SXEmacs Build Reports <sxemacs-builds@sxemacs.org>"
  77    "SXEmacs Devel <sxemacs-devel@sxemacs.org>"
  78    "Steve Youngs <steve@sxemacs.org>")
  79   "*The list of mail addresses SXEmacs Build Reports should most likely
  80 go to."
  81   :type '(repeat
  82           :custom-show t
  83           :documentation-shown t
  84           string)
  85   :group 'build-rpt)
  86
  87 (defcustom build-rpt-keep-regexp
  88   (list
  89    #r"^\(cd\|n?make\)\s-"
  90    "errors?"
  91    "warnings?"
  92    #r"pure.*\(space\|size\)"
  93    "hides\\b"
  94    "strange"
  95    "shadowings"
  96    #r"^Compil\(ing\s-+in\|ation\)"
  97    "^Using"
  98    "not\\s-+found"
  99    "^While\\s-+compiling.*\\(\n\\s-+.+\\)*"
 100    "^Note:"
 101    "Installing"
 102    "[Ff]ile(s) copied"
 103    "^[A-Za-z_]+="
 104    "\\s-+tests\\s-+"
 105    "^\\(real\\|user\\|sys\\)\\s-+[0-9]+m")
 106   "*Regexp of make process output lines to keep in the report."
 107   :type '(repeat
 108           :custom-show t
 109           :documentation-shown t
 110           regexp)
 111   :group 'build-rpt)
 112
 113 (defcustom build-rpt-delete-regexp
 114   (list
 115    "confl.*with.*auto-inlining"
 116    "^Formatting:"
 117    "(100%) tests successful"
 118    "errors that should"
 119    "wrong-error")
 120   "*Regexp of make process output lines to delete from the report."
 121   :type '(repeat
 122           :custom-show t
 123           :documentation-shown t
 124           regexp)
 125   :group 'build-rpt)
 126
 127 (defcustom build-rpt-make-output-dir (config-value 'sxe_blddir)
 128   "*Directory where the build report file is found."
 129   :type '(directory
 130           :custom-show t
 131           :documentation-shown t)
 132   :group 'build-rpt)
 133
 134 (defcustom build-rpt-make-output-files
 135   (list
 136    ",,vars.out"
 137    ",,beta.out"
 138    ",,make-all.out"
 139    ",,make-check-temacs.out"
 140    ",,make-check.out"
 141    ",,make-install.out")
 142   "*List of Filenames where stdout and stderr of SXEmacs make process
 143 have been stored.  These are relative to
 144 `build-rpt-make-output-dir`.  You'll have to run make with output
 145 redirection, like so...
 146
 147   $ make 2>&1 | tee ,,make-all.out
 148   $ make check 2>&1 | tee ,,make-check.out
 149 "
 150   :type '(repeat
 151           :custom-show t
 152           :documentation-shown t
 153           file)
 154   :group 'build-rpt)
 155
 156 (defcustom build-rpt-installation-file
 157   (expand-file-name "Installation"
 158                     (gethash 'sxe_blddir (config-value-hash-table)))
 159   "*Installation file produced by SXEmacs configure process."
 160   :type '(file
 161           :custom-show t
 162           :documentation-shown t)
 163   :group 'build-rpt)
 164
 165 (defcustom build-rpt-version-file
 166   (expand-file-name
 167    "config.h"
 168    (file-name-as-directory
 169     (paths-construct-path
 170      (list (gethash 'sxe_blddir (config-value-hash-table))
 171            "src"))))
 172   "*File containing version info."
 173   :type '(file
 174           :custom-show t
 175           :documentation-shown t)
 176   :group 'build-rpt)
 177
 178 (defcustom build-rpt-subject
 179   (concat "[%s] "
 180           (gethash 'SXEMACS_GIT_VERSION (config-value-hash-table))
 181           " on " system-configuration)
 182   "*SXEmacs Build Report Subject Line. %s-sequences will be substituted
 183   with user input through `build-rpt' according to
 184   `build-rpt-prompts' using `format'."
 185   :type '(string
 186           :custom-show t
 187           :documentation-shown t)
 188   :group 'build-rpt)
 189
 190 (defcustom build-rpt-prompts
 191   (quote (("Status?: "  ("Success" "Tests fail" "Failure" "Vanilla problems" "Problems"))))
 192   "*SXEmacs Build Report Prompt(s). This is a list of prompt-string
 193   lists used by `build-rpt' in conjunction with
 194   `build-rpt-subject'. Each list consists of a prompt string
 195   followed by any number of strings which can be chosen via the history
 196   mechanism."
 197   :type '(repeat
 198           :custom-show t
 199           :documentation-shown t
 200           (list
 201            :tag "Prompt"
 202            string
 203            (repeat
 204             :tag "Values"
 205             string)))
 206   :group 'build-rpt)
 207
 208 (defcustom build-rpt-file-encoding
 209   "7bit"
 210   "*SXEmacs Build Report File Encoding to be used when MIME support is
 211   available."
 212   :group 'build-rpt)
 213
 214 (defcustom build-rpt-use-gnus-p nil
 215   "*Whether the SXEmacs Build Report should be set up by Gnus.
 216 Note that Gnus has to be fully started, i.e. there has to be a
 217 *Group* buffer"
 218   :group 'build-rpt
 219   :type 'boolean)
 220
 221 (defcustom build-rpt-use-gnus-group ""
 222   "*Name of a group in the group buffer to send the build report from.
 223 This is useful if there are customised settings along with the group."
 224   :type 'string
 225   :group 'build-rpt)
 226
 227 (defcustom build-rpt-use-gnus-plugged t
 228   "*When non-nil, start Gnus in \"plugged\" mode if it isn't running."
 229   :type 'boolean
 230   :group 'build-rpt)
 231
 232 ;; Symbol Name mappings from TM to SEMI serving as Compatibility
 233 ;; Bandaid
 234 (when (featurep 'mime-setup)
 235   ;; No (defvaralias ...) so far. Thanks to "Didier Verna"
 236   ;; <didier@xemacs.org> for reporting my incorrect defvaraliasing of
 237   ;; `mime-editor/insert-tag'.
 238   ;; Thanks to Jens-Ulrik Holger Petersen
 239   ;; <petersen@kurims.kyoto-u.ac.jp> for suggesting the conditional
 240   ;; aliasing of SEMI functions.
 241   (unless (fboundp 'mime-edit-content-beginning)
 242     (defalias 'mime-edit-content-beginning 'mime-editor/content-beginning))
 243   (unless (fboundp 'mime-edit-insert-tag)
 244     (defalias 'mime-edit-insert-tag 'mime-editor/insert-tag))
 245   (unless (fboundp 'mime-edit-insert-binary-file)
 246     (defalias 'mime-edit-insert-binary-file
 247       'mime-editor/insert-binary-file)))
 248
 249 (defun build-rpt-make-output-get ()
 250   "Returns the filename the SXEmacs make output is saved in."
 251   (interactive)
 252   (if (or (string-equal build-rpt-make-output-dir "")
 253           (null build-rpt-make-output-dir))
 254       (mapcar
 255        (function
 256         (lambda (f)
 257           (expand-file-name
 258            f
 259            (file-name-as-directory
 260             (gethash 'sxe_blddir (config-value-hash-table))))))
 261        build-rpt-make-output-files)
 262     (mapcar
 263      (function
 264       (lambda (f)
 265         (expand-file-name
 266          f
 267          (file-name-as-directory build-rpt-make-output-dir))))
 268      build-rpt-make-output-files)))
 269
 270 (defun build-rpt-read-destination ()
 271   (if (listp build-rpt-destination)
 272       (read-string
 273        "Build Report Destination: "
 274        (car build-rpt-destination)
 275        'build-rpt-destination)
 276     (read-string
 277      "Build Report Destination: "
 278      build-rpt-destination)))
 279
 280 (defvar build-rpt-interactive nil
 281   "Flag used signal when build report is being called interactively
 282 and as such the user should be the one sending the email.
 283 When nil the build report is sent as soon as it is built.")
 284
 285 (defvar build-rpt-email (if (listp build-rpt-destination)
 286                             (car build-rpt-destination)
 287                           build-rpt-destination)
 288   "The destination for the current build-report")
 289
 290
 291
 292 ;;;###autoload
 293 (defun send-build-rpt (&rest args)
 294   "Send report build information including Installation and make output.
 295
 296 Uses first argument for status.  Then uses
 297 `compose-mail' to create a mail message.  The Subject header contains
 298 status and version information.  Point is left at the beginning of the
 299 mail text.  Add some notes if you like, and send the report.
 300
 301 Looks for Installation and the make output file (see
 302 `build-rpt-make-output-files') in the build directory of the
 303 running SXEmacs by default (customisable via
 304 `build-rpt-make-output-dir').  The output from make is filtered
 305 through `build-rpt-keep-regexp' and `build-rpt-delete-regexp'
 306 before including in the message.
 307
 308 See also `mail-user-agent', `build-rpt-email', and
 309 `build-rpt-installation-file'."
 310   (let ((user-mail-address (if user-mail-address
 311                                user-mail-address
 312                              (if (and (interactive-p)
 313                                       (featurep 'sendmail))
 314                                  (user-mail-address)
 315                                (concat (user-real-login-name)
 316                                        "-notconfigured@"
 317                                        (if mail-host-address
 318                                            mail-host-address
 319                                          "localhost"))))))
 320   (save-excursion
 321     (if (and build-rpt-use-gnus-p
 322              (featurep 'gnus))
 323         (progn
 324           (unless (gnus-alive-p)
 325             (if build-rpt-use-gnus-plugged
 326                 ;; use slave in case there is a Gnus running in another
 327                 ;; SXEmacs process
 328                 (gnus-slave)
 329               (gnus-slave-unplugged)))
 330           (if (not (string= "" build-rpt-use-gnus-group))
 331               (let ((group gnus-newsgroup-name)
 332                     (gnus-article-copy))
 333                 (setq gnus-newsgroup-name build-rpt-use-gnus-group)
 334                 (gnus-post-news "" build-rpt-use-gnus-group)
 335                 (setq gnus-newsgroup-name group))
 336             (gnus-group-mail 1))
 337           (unless (message-field-value "to")
 338             (message-goto-to)
 339             (insert build-rpt-email))
 340           (message-goto-subject)
 341           (insert (apply #'format build-rpt-subject args))
 342           (message-goto-body))
 343       (if (featurep 'sendmail)
 344           (progn
 345             (compose-mail
 346              build-rpt-email
 347              (apply 'format build-rpt-subject args)
 348              nil
 349              nil
 350              nil
 351              nil
 352              nil)
 353             (goto-char (point-max))
 354             (re-search-backward mail-header-separator)
 355             (next-line 1))
 356         (pop-to-buffer "*build-rpt*")
 357         (insert (format (concat "Please save this buffer to a file and email it\n"
 358                                 "Or, alternatively, rerun `M-x build-rpt' after installing the\n"
 359                                 "\"mail-lib\" XEmacs package.\n\n"
 360                                 "To: SXEmacs Builds <sxemacs-builds@sxemacs.org>\n"
 361                                 "Subject: %s\n\n")
 362                         (apply #'format build-rpt-subject args)))))
 363     (let* ((rpt-begin (point))
 364            (files (reverse (build-rpt-make-output-get)))
 365            (file (car files)))
 366       (while file
 367         (if (file-exists-p file)
 368             (insert (build-rpt-insert-make-output rpt-begin file))
 369           (insert (format "%s not found!\n" file)))
 370         (insert "\n")
 371         (setq files (cdr files))
 372         (setq file (car files)))
 373       (insert (build-rpt-insert-config-values rpt-begin))
 374       (insert "\n")
 375       (insert (build-rpt-insert-ldd rpt-begin))
 376       (insert "\n")
 377       (if (file-exists-p build-rpt-installation-file)
 378           (insert (build-rpt-insert-installation-file rpt-begin))
 379         (insert (format "%s not found!\n" build-rpt-installation-file)))
 380       (insert "\n")
 381       (insert (build-rpt-insert-header rpt-begin))
 382       (if build-rpt-interactive
 383           (goto-char rpt-begin)
 384         (mail-send-and-exit t))))))
 385
 386 ;;;###autoload
 387 (defun build-rpt (&rest args)
 388   "Report build information including Installation and make output.
 389
 390 Prompts for status (usually \"Success\" or \"Failure\").  Then uses
 391 `compose-mail' to create a mail message.  The Subject header contains
 392 status and version information.  Point is left at the beginning of the
 393 mail text.  Add some notes if you like, and send the report.
 394
 395 Looks for Installation and the make output file (see
 396 `build-rpt-make-output-files') in the build directory of the
 397 running SXEmacs by default (customisable via
 398 `build-rpt-make-output-dir').  The output from make is filtered
 399 through `build-rpt-keep-regexp' and `build-rpt-delete-regexp'
 400 before including in the message.
 401
 402 See also `mail-user-agent', `build-rpt-destination', and
 403 `build-rpt-installation-file'."
 404   ;; `interactive' form returns value for formal parameter `args'.
 405   (interactive
 406    (let (prompt
 407          hist
 408          arg
 409          (prompts build-rpt-prompts))
 410      (progn
 411        (while prompts
 412          (defvar hist)
 413          (setq prompt (caar prompts))
 414          (setq hist (cdar prompts))
 415          ;; `build-rpt-prompts' used to be a list of lists, the
 416          ;; first element of each list being the prompt, the rest being
 417          ;; the history.  The history is now in a separate list.  We
 418          ;; better check for that.
 419          (if (listp (car hist))
 420              (setq hist (car hist)))
 421          (setq prompts (cdr prompts))
 422          (setq arg (cons (read-string prompt "" 'hist) arg)))
 423        arg)))
 424   (let ((build-rpt-email (build-rpt-read-destination))
 425         (build-rpt-interactive (interactive-p)))
 426     (apply 'send-build-rpt args)))
 427
 428 (defun build-rpt-insert-header (where)
 429   "Inserts the build-rpt-header at the point specified by `where'."
 430   (goto-char where)
 431   (with-temp-buffer
 432     (insert
 433      (format "
 434 > SXEmacs Build Report generated by emacs-version
 435 > %s
 436 > with system-configuration
 437 > %s
 438 > follows:\n\n" emacs-version system-configuration))
 439     (buffer-string)))
 440
 441 (defun build-rpt-insert-make-output (where file)
 442   "Inserts the output of the SXEmacs Beta make run in the
 443 current buffer at position WHERE.
 444 The make process output must have been saved in
 445 `build-rpt-make-output-files' during the SXEmacs Beta building."
 446   (goto-char where)
 447   (with-temp-buffer
 448     (if (file-exists-p file)
 449         (progn
 450           (if (featurep 'mime-setup)
 451               (progn
 452                 (mime-edit-insert-tag
 453                  "text"
 454                  "plain"
 455                  (concat
 456                   "\nContent-Disposition: attachment;"
 457                   " filename=\""
 458                   (file-name-nondirectory
 459                    file)
 460                   "\""))
 461                 (mime-edit-insert-binary-file
 462                  file
 463                  build-rpt-file-encoding))
 464             (insert-file-contents file))
 465           (when build-rpt-keep-regexp
 466             (goto-char (point-min))
 467             (delete-non-matching-lines (build-rpt-keep)))
 468           (when build-rpt-delete-regexp
 469             (goto-char (point-min))
 470             (delete-matching-lines (build-rpt-delete)))
 471           (goto-char (point-min))
 472           (insert "\n")
 473           (insert
 474            (format "> Contents of %s\n" file)))
 475       (insert "> " file
 476               " does not exist!\n\n"))
 477     (buffer-string)))
 478
 479 (defun build-rpt-insert-installation-file (where)
 480   "Inserts the contents of the `build-rpt-installation-file'
 481 created by the SXEmacs Beta configure process."
 482   (goto-char where)
 483   (with-temp-buffer
 484     (if (file-exists-p build-rpt-installation-file)
 485         (progn
 486           (insert "> Contents of "
 487                   build-rpt-installation-file
 488                   ":\n")
 489           (insert "> (Output from ./configure)\n\n")
 490           (if (featurep 'mime-setup)
 491               (progn
 492                 (mime-edit-insert-tag
 493                  "text"
 494                  "plain"
 495                  (concat
 496                   "\nContent-Disposition: attachment;"
 497                   " filename=\""
 498                   (file-name-nondirectory
 499                    build-rpt-installation-file)
 500                   "\""))
 501                 (mime-edit-insert-binary-file
 502                  build-rpt-installation-file
 503                  build-rpt-file-encoding))
 504             (insert-file-contents
 505              build-rpt-installation-file)))
 506       (insert "> " build-rpt-installation-file
 507               " does not exist!\n\n"))
 508     (buffer-string)))
 509
 510 (defun build-rpt-insert-config-values (where)
 511   "Inserts the contents of the `config-value-hash-table'.
 512 created by the SXEmacs Beta configure process."
 513   (goto-char where)
 514   (with-temp-buffer
 515     (if (null (config-value-hash-table))
 516         (insert "> `config-value-hash-table' is empty, which is weird :(!\n\n")
 517         (progn
 518           (insert "> Contents of `config-value-hash-table':\n")
 519           (let ((curp (point))
 520                 value-empty)
 521             (maphash
 522              #'(lambda (key value)
 523                  (if (and (stringp value)
 524                           (string= "" value))
 525                      (setq value-empty (cons key value-empty))
 526                    (insert (format "%s %S\n" key value))))
 527              (config-value-hash-table))
 528             (goto-char curp)
 529             ;; we are at `curp' again
 530             (insert (format "Empty keys: %s\n\n"
 531                             (mapconcat #'prin1-to-string
 532                                        value-empty "  "))))))
 533     (buffer-string)))
 534
 535 (defun build-rpt-insert-ldd (where)
 536   "Inserts the output of the shell command ldd sxemacs."
 537   (goto-char where)
 538   (with-temp-buffer
 539     (let ((running-binary-tests
 540            '((lambda ()
 541                (expand-file-name (car command-line-args)
 542                                  command-line-default-directory))
 543              (lambda ()
 544                (locate-file (car command-line-args)
 545                             (split-string (getenv "PATH") ":")))))
 546            (running-binary)
 547            (ldd
 548             (let ((sysconfl (split-string system-configuration "-")))
 549               (cond
 550                ((member "apple" sysconfl)
 551                 "otool -XL")
 552                (t
 553                 "ldd")))))
 554
 555       ;; perform binary finder tests
 556       (while (and (null running-binary) (car-safe running-binary-tests))
 557         (let ((candidate (funcall (car running-binary-tests))))
 558           (setq running-binary
 559                 (and candidate
 560                      (file-exists-p candidate)
 561                      candidate)
 562                 running-binary-tests (cdr running-binary-tests))))
 563
 564       (if (null running-binary)
 565           (insert "cannot obtain ld-dependencies.\n")
 566         (insert (shell-command-to-string (concat ldd " " running-binary)))
 567         (goto-char (point-min))
 568         (while (re-search-forward "^\\s-+" nil t)
 569           (replace-match "")))
 570       (goto-char (point-min))
 571       (insert "> shared library dependencies:\n"))
 572     (buffer-string)))
 573
 574 (defun build-rpt-keep ()
 575   "Concatenate elements of `build-rpt-keep-regexp' and a general
 576 MIME tag REGEXP.  The result is a REGEXP string matching either of the
 577 REGEXPs in `build-rpt-keep-regexp' or a general MIME tag REGEXP."
 578   (mapconcat #'identity
 579              (cons #r"^--\[\[\|\]\]$" build-rpt-keep-regexp) "\\|"))
 580
 581 (defun build-rpt-delete ()
 582   "Concatenate elements of `build-rpt-delete-regexp' and a general
 583 MIME tag REGEXP.  The result is a REGEXP string matching either of the
 584 REGEXPs in `build-rpt-delete-regexp' or a general MIME tag REGEXP."
 585   (mapconcat '(lambda (item) item)
 586              build-rpt-delete-regexp "\\|"))
 587
 588 ;; To ensure we always get the right build reporter, alias the
 589 ;; incompatible one to ours if it is ever loaded.
 590 ;;;###autoload
 591 (eval-after-load "build-report"
 592   (defalias 'build-report 'build-rpt))
 593
 594 (provide 'build-rpt)
 595 ;;; build-rpt.el ends here