;;; $Id: build.el,v 1.52 2003-10-13 15:52:13 james Exp $ ;;{{{ Legalese ;; Copyright (C) 1997-2002 Adrian Aichner ;; Author: Adrian Aichner ;; Date: $Date: 2003-10-13 15:52:13 $ ;; Version: $Revision: 1.52 $ ;; Keywords: internal ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XEmacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. ;;; Synched up with: Not synched. ;;}}} ;;{{{ provide/require (provide 'build) (require 'custom) (require 'cus-edit) (require 'widget) (if (featurep 'sxemacs) (require 'build-rpt) (require 'build-report)) (autoload 'ring-insert-at-beginning "ring") (autoload 'efs-copy-file "efs") ;; `url-copy-file' (buffer: build.el, mode: Lisp) (eval-when-compile (require 'cl)) ;; Pull in compile, if it is available. (condition-case nil (require 'compile) (error nil)) (eval-when-compile (require 'wid-edit)) ;; Pull in pcl-cvs, if it is available. (condition-case nil (require 'pcl-cvs) (error nil)) ;;}}} (defcustom build-from-what "Tarballs" "The Source Code units XEmacs is to be built from (\"Tarballs\" or \"CVS\")." :type '(choice :custom-state t (const "Tarballs") (const "CVS")) :group 'build) (defcustom build-with-what "GNU Tools" "The Toolset XEmacs is to be built with (\"GNU Tools\" or \"Microsoft Tools\")." :type '(choice :custom-state t (const "GNU Tools") (const "Microsoft Tools")) :group 'build) ;;{{{ Version info ;;; ;;; Version-handling, based on ideas from w3. ;;; (defconst build-version-number (let ((x "2.00")) (if (string-match "Name:[ \t\n]+\\([^\n]+\\) \\$" x) (setq x (match-string 1 x)) (setq x (substring x 0))) (mapconcat (function (lambda (x) (if (= x ?-) "." (char-to-string x)))) x "")) "Version number of build package.") (defconst build-version-date (let ((x "2002-03-07")) (if (string-match "Date:[ \t\n]+\\([^\n]+\\) \\$" x) (match-string 1 x) x)) "Date this version of build was released.") (defconst build-version (format "build %s %s" build-version-number build-version-date) "More descriptive version of build-version-number.") ;;;###autoload (defun build-version (&optional here) "Show the version number of `build' in the minibuffer. If optional argument HERE is non-nil, insert info at point." (interactive "P") (if here (insert build-version) (if (interactive-p) (message-or-box "%s" build-version) build-version))) ;;}}} ;;{{{ Build (defgroup build nil "Simplifies Building XEmacs; i.e. Fetching, Configuring, Making, and Reporting." :link '(url-link :tag "XEmacs Build Reference Manual" "http://www.xemacs.org/Documentation/packages/html/build.html") :link '(url-link :tag "XEmacs Beta README" "ftp://ftp@ftp.xemacs.org/pub/xemacs/beta/README") :link '(url-link :tag "XEmacs Gamma README" "ftp://ftp@ftp.xemacs.org/pub/xemacs/gamma/README") :link '(url-link :tag "XEmacs Stable README" "ftp://ftp@ftp.xemacs.org/pub/xemacs/stable/README") :group 'emacs) (defun build-call-process (command infile buffer displayp) (let (exit-status result) (with-temp-buffer (condition-case signal (setq exit-status (apply 'call-process (append (list (car command) infile buffer displayp) (cdr command)))) (error (warn "\n%s\ncannot be executed: %S %S\n" (mapconcat 'identity command " ") (car signal) (cdr signal)))) ;; return value of result (setq result (cons exit-status (buffer-string)))))) ;;;###autoload (defun build () "Creates a widget-based interface to build a beta/release version of XEmacs. All aspects of fetching tarballs, configuring, making and reporting can be customized and executed from the newly created buffer *Build*." (interactive) (let (exit-status (command (list "cvs" "-v")) infile (buffer (list t t)) displayp result ; build-from-cvs-button-widget ; build-from-tarballs-button-widget (name "*Build XEmacs*")) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) ;; Determine availability of CVS client. (message-or-box "build: checking whether you have cvs, please wait") (setq result (build-call-process command infile buffer displayp)) (cond ((null (car result)) (setq build-cvs-available-p nil) (warn "\nprogram %s cannot be found or executed\n" (car command)) (setq build-from-what "Tarballs")) ((/= (car result) 0) (setq build-cvs-available-p nil) (warn "\n%s\nfailed with following output:\n%s\n" (mapconcat 'identity command " ") (cdr result)) (setq build-from-what "Tarballs") (widget-insert "\n\nPlease install cvs, unless you want to build from our tarballs.\n")) (t (setq build-cvs-available-p t) (setq build-from-what "CVS") (message-or-box "build: cvs is available"))) ;; Create widget-based interface. (widget-insert "Visit info documentation for the XEmacs build package inside ") (widget-create 'info-link :tag "XEmacs" :value "(build)") (widget-insert "\nor on the XEmacs website at\n") (widget-create 'url-link :value "http://www.xemacs.org/Documentation/packages/html/build.html") (widget-insert "\n\n") (let ((inhibit-read-only t)) (setq build-current-build-settings-widget (widget-create 'string :tag "Current Build Settings" :value "unknown"))) (widget-apply build-current-build-settings-widget :deactivate) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let ((name (widget-value build-settings-widget))) (widget-apply build-current-build-settings-widget :activate) (widget-value-set build-current-build-settings-widget name) (widget-apply build-current-build-settings-widget :deactivate) (widget-setup) (build-settings-load name build-settings) (message-or-box "loaded \"%s\" build-settings" name))) "Load") (widget-insert " ") (widget-create 'push-button :notify (lambda (&rest ignore) (let* ((args (widget-get build-settings-widget :args)) (value (widget-value build-settings-widget)) new-args) (if (string= value "default") (message-or-box "cannot delete \"%s\" build-settings" value) (when (yes-or-no-p (format "delete \"%s\" build-settings? " value)) (setq new-args (remrassoc (list :value value) args)) (widget-put build-settings-widget :args new-args) (widget-put build-settings-name-widget :args (cons (list 'string :value "default") new-args)) (widget-value-set build-settings-widget (widget-get (first (widget-get build-settings-widget :args)) :value)) (widget-setup) (setq build-settings (remassoc value build-settings)) (message-or-box "deleted \"%s\" build-settings" value))))) "Delete") (widget-insert " ") (setq build-settings-widget (widget-create 'choice :tag "build settings" :value "default" :args (cons (list 'item :value "default") (mapcar (function (lambda (setting) (let ((name setting)) (list 'item :value (car setting))))) build-settings)) ; :notify (lambda (widget &rest ignore) ; (setq build-settings (widget-value widget))) '(item :value "default"))) (widget-value-set build-settings-widget (widget-get (first (widget-get build-settings-widget :args)) :value)) (widget-create 'push-button :notify (lambda (&rest ignore) (let ((name (widget-value build-settings-name-widget))) (unless (and (assoc name build-settings) (not (yes-or-no-p (format "overwrite current \"%s\" build-settings? " name)))) (setq build-settings (build-settings-save-custom-group 'build name build-settings)) (unless (rassoc (cdr (list 'item :value name)) (widget-get build-settings-widget :args)) (widget-put build-settings-widget :args (cons (list 'item :value name) (widget-get build-settings-widget :args))) (widget-put build-settings-name-widget :args (cons (list 'item :value name) (widget-get build-settings-name-widget :args)))) (customize-save-variable 'build-settings build-settings) (message-or-box "saved \"%s\" build-settings" name)))) "Save") (widget-insert " ") (setq build-settings-name-widget (widget-create 'choice :tag "current build settings as" :value "default" :args (cons (list 'string :value "default") (mapcar (function (lambda (setting) (let ((name setting)) (list 'item :value (car setting))))) build-settings)) ; :notify (lambda (widget &rest ignore) ; (setq build-settings (widget-value widget))) )) (widget-insert "Build settings are named build configurations allowing you to switch\nbetween them quickly, once you have set them up and saved them. Please\nmake sure you have gone through all required customizations of the\nbuild process before you save them. You may change existing settings\nat a later time, though.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build)) "Browse Build Options ...") (widget-insert "\nBrowse and customize any options of the build process according to\nyour current choices for the sources to build from and the tools to\nbuild with.\n") (setq build-from-what-choice-widget (widget-create 'choice :tag "Build from" :value build-from-what :notify (lambda (widget &rest ignore) (setq build-from-what (widget-value widget)) (cond ((string-equal build-from-what "CVS") (widget-apply build-from-cvs-button-widget :activate) (widget-apply build-from-tarballs-button-widget :deactivate)) ((string-equal build-from-what "Tarballs") (widget-apply build-from-cvs-button-widget :deactivate) (widget-apply build-from-tarballs-button-widget :activate)))) '(item :value "CVS") '(item :value "Tarballs"))) (widget-insert "Please decide now whether to build XEmacs from tarballs in .tar.gz\nformat or from CVS sources. Using CVS is highly recommended.") (widget-insert "\n\n") (setq build-with-what-choice-widget (widget-create 'choice :tag "Build with" :value build-with-what :notify (lambda (widget &rest ignore) (setq build-with-what (widget-value widget))) '(item :value "GNU Tools") '(item :value "Microsoft Tools") )) (widget-insert "Furthermore, please specify whether you will build with GNU tools\nusing configure and make or Microsoft Tools using nt\\xemacs.mak and\nVC++ 4.0 or higher.") (widget-insert "\n\n") (setq build-from-cvs-button-widget (widget-create 'push-button :notify (lambda (&rest ignore) (build-from-CVS)) "Build XEmacs From CVS Now")) (widget-insert "\n") ;; Recommend installation of CVS or provide cvs version ;; information. (if build-cvs-available-p (widget-insert (format "cvs -v returns this:\n%s\n" (cdr result))) (widget-insert "\n\nPlease install cvs, unless you want to build from our tarballs.\n")) ;; Building XEmacs from tarballs. (setq build-from-tarballs-button-widget (widget-create 'push-button :notify (lambda (&rest ignore) (build-from-tarballs)) "Build XEmacs From Tarballs Now")) ;; Initialize these buttons according to `build-from-what'. (cond ((string-equal build-from-what "CVS") (widget-apply build-from-cvs-button-widget :activate) (widget-apply build-from-tarballs-button-widget :deactivate)) ((string-equal build-from-what "Tarballs") (widget-apply build-from-cvs-button-widget :deactivate) (widget-apply build-from-tarballs-button-widget :activate))) (widget-insert "\nProceed after you have chosen what sources to build from and what\ntools to build with.\n") ; (widget-browse-other-window build-settings-widget) (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) ;;}}} ;;{{{ Build Compilation ;;{{{ Compilation (make-variable-buffer-local 'compilation-finish-function) (make-variable-buffer-local 'compilation-exit-message-function) (setq compilation-finish-function 'build-compilation-finish-function compilation-exit-message-function (function build-compilation-exit-message-function)) ;;}}} (defun build-compilation-mode-hook () (set (make-local-variable 'auto-save-hook) '(lambda () (message "Auto-saved %s\n" (buffer-name)))) (auto-save-mode 1) (insert (format "Compilation started at %s %+.4d (%s)\n" (current-time-string) (/ (nth 0 (current-time-zone)) 36) (nth 1 (current-time-zone))))) (defun build-compilation-finish-function (comp-buffer finish-string) (message "Build Make finished in %s with status \"%s\"." (buffer-name comp-buffer) finish-string)) (defun build-compilation-exit-message-function (proc exit-msg) (message "Build Make exited with proc status \"%s\", exit status \"%s\", exit message \"%s\"." (process-status proc) (process-exit-status proc) exit-msg) (cons exit-msg (process-exit-status proc))) ;;}}} ;;{{{ Build Configure (defconst build-configure-option-category "^\\(\\S-+\\).+\\(options\\|features\\):$" "REGEXP matching an XEmacs configuration option category in configure.usage") (defconst build-configure-option-paragraph "^\\(--[a-zA-Z][-a-zA-Z0-9]+\\)\\(=\\(\\S-+\\)\\)?\\(\\s-+(\\*)\\)?\\s-+\\(\\(.+\\)\\(\n[ \t]+.+\\)*\\)$" "REGEXP matching one XEmacs configuration option in configure.usage") (defun build-configure (&optional dir) "Configure XEmacs according to the settings in customized group `build' and its members." (interactive) (if dir (cd dir)) (let ((cmd (format "sh configure%s" (mapconcat (function (lambda (e) (cond ((or (string= "" (rest e)) (string= "autodetected" (rest e)) (string= "defaulted" (rest e))) "") ((string= "yes" (rest e)) (format " '%s'" (first e))) ((and (string-match "\\`--without-\\(.+\\)\\'" (first e)) (string= "no" (rest e))) (format " '-with-%s'" (match-string 1 (first e)))) (t (format " '%s=%s'" (first e) (rest e)))))) (delete-duplicates build-configure-options :from-end t :test (lambda (a b) (string= (first a) (first b)))) ""))) (compilation-mode-hook 'build-compilation-mode-hook) (compilation-buffer-name-function '(lambda (mode) (generate-new-buffer-name (cond ((string-equal build-from-what "Tarballs") (concat build-tarball-prefix "-configure.err")) ((string-equal build-from-what "CVS") (concat build-cvs-checkout-dir "-configure.err"))) )))) (compile cmd))) ;;; Functionality which was prototyped in co2cu.el: (defun build-configure-customize (a-list) (mapcar (lambda (cat) (princ (format "(defgroup build-configure-%s nil\n" (first cat))) (princ (format " \"%s options.\"\n" (first cat))) (princ " :group 'build-configure)\n\n") (list (first cat) (mapcar (lambda (opt) (cond ((or (member "TYPE[,TYPE]..." (second opt)) (and (member "TYPE" (second opt)) (string-match "list\\s-+of" (apply 'concat (fourth opt))))) (build-configure-types cat opt) ) ((member "TYPE" (second opt)) (build-configure-type cat opt) ) ((member "FLAGS" (second opt)) (build-configure-string cat opt) ) ;; compiler=XXXX prior to r21.0-b34 ((member "XXXX" (second opt)) (build-configure-file cat opt) ) ;; compiler=prog after Martin Buchholz's configure ;; mega-patch to r21.0-b34-pre2 ((member "prog" (second opt)) (build-configure-file cat opt) ) ((member "VALUE" (second opt)) (build-configure-string cat opt) ) ((member "DIR" (second opt)) (build-configure-dir cat opt) ) ((member "LIB" (second opt)) (build-configure-file cat opt) ) ((member "PATH" (second opt)) (build-configure-path cat opt) ) ((or (null (second opt)) (subsetp (second opt) '("no" "yes") :test 'string-equal)) (build-configure-type cat opt) ) (t (build-configure-type cat opt) ) )) (delete-duplicates (cdr cat) :from-end t :test (lambda (a b) (string= (first a) (first b))))))) a-list)) (defun build-configure-process-option (option value detected doc category a-list) (let (prev-val prev-doc pos doc-vals) (unless (null value) (setq prev-val (first (cdr (assoc option (assoc category a-list))))) (setq prev-val (append prev-val (list value)))) (setq detected (or (second (cdr (assoc option (assoc category a-list)))) (null (null detected)))) (setq prev-doc (third (cdr (assoc option (assoc category a-list))))) (unless (null doc) (setq prev-doc (append prev-doc (list doc))) (setq pos 0) (setq doc-vals (concat (first prev-doc))) (while (string-match "`\\(\\w+\\)'" doc pos) (setq prev-val (append prev-val (list (match-string 1 doc)))) (setq pos (match-end 0))) (unless (null (string-match "\\([Vv]alid\\s-+types\\s-+are\\s-+\\|(\\)\\(\\(\\w+\\)\\(,\\s-*\\(\\(and\\|or\\)\\s-+\\)?\\(\\w+\\)\\)+\\)\\()\\|\\.\\)" doc 0)) (setq doc-vals (match-string 2 doc)) (setq pos 0) (while (string-match "\\(\\(,\\s-*\\(\\(and\\|or\\)\\s-+\\)?\\)?\\(\\w+\\)\\)" doc-vals pos) (setq prev-val (append prev-val (list (match-string 5 doc-vals)))) (setq pos (match-end 0))))) (setcdr (assoc category a-list) (acons option (list prev-val detected prev-doc) (cdr (assoc category a-list)))))) (defun build-configure-generate (&optional file) (interactive "fconfigure.usage file: ") (unless file (setq file (expand-file-name "configure.usage" (cond ((string-equal build-from-what "Tarballs") (expand-file-name build-tarball-prefix build-tarball-dest)) ((string-equal build-from-what "CVS") (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)))))) (let (category categories option value detected doc build-configure-alist (buffer "build-configure.el")) (kill-buffer (get-buffer-create buffer)) (with-output-to-temp-buffer buffer (save-window-excursion (find-file-read-only file) (build-configure-prolog file) (goto-char (point-min)) (while (< (point) (point-max)) (cond ((looking-at build-configure-option-paragraph) (goto-char (match-end 0)) (build-configure-process-option (match-string 1) (match-string 3) (match-string 4) (match-string 5) category build-configure-alist)) ((looking-at build-configure-option-category) (goto-char (match-end 0)) (setq category (match-string 1)) (setq build-configure-alist (append build-configure-alist (list (list category))))) ;; We avoid matching a potentially zero-length string to ;; avoid infinite looping. ((looking-at "^.+$") (goto-char (match-end 0))) ((looking-at "\n") (goto-char (match-end 0))))) (build-configure-customize build-configure-alist) ; (print build-configure-alist) )) ; (set-buffer buffer) ; (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) (lisp-mode) (font-lock-mode 1) (toggle-read-only 1))) (defun build-configure-string (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ " \"\"\n") (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(string)\n") (princ " :set 'build-configure-set-value)\n") (princ "\n")) (defun build-configure-file (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ " \"\"\n") (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(file)\n") (princ " :set 'build-configure-set-value)\n") (princ "\n")) (defun build-configure-dir (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ " \"\"\n") (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(directory)\n") (princ " :set 'build-configure-set-value)\n") (princ "\n")) (defun build-configure-path (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ " '()\n") (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(repeat\n") (princ " :custom-show t\n") (princ " :documentation-shown t\n") (princ " (directory))\n") (princ " :set 'build-set-path)\n") (princ "\n")) (defun build-configure-types (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ (format " '(%S)\n" (if (third opt) "autodetected" "defaulted"))) (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(choice\n") (if (third opt) (princ " (const (\"autodetected\"))\n") (princ " (const (\"defaulted\"))\n")) (princ " (const (\"no\"))\n") (princ " (set") (mapc (lambda (e) (princ (format "\n (const %S)" e))) (set-difference (second opt) '("no" "TYPE[,TYPE]..." "TYPE") :test 'string=)) (princ "))\n") (princ " :set 'build-set-types)\n") (princ "\n")) (defun build-configure-type (cat opt) (princ (format "(defcustom build-configure%s\n" (first opt))) (princ (format " %S\n" (if (third opt) "autodetected" "defaulted"))) (princ (format " %S\n" (build-configure-fill-doc (fourth opt)))) (princ (format " :group \'build-configure-%s\n" (first cat))) (princ " :type '(choice\n") (if (third opt) (princ " (const \"autodetected\")\n") (princ " (const \"defaulted\")\n")) (princ " (const \"no\")") (if (subsetp (second opt) '("no" "yes") :test 'string-equal) (princ "\n (const \"yes\")") (mapc (lambda (e) (princ (format "\n (const %S)" e))) (set-difference (second opt) '("no" "TYPE[,TYPE]..." "TYPE") :test 'string=))) (princ ")\n") (princ " :set 'build-configure-set-value)\n") (princ "\n")) (defun build-configure-fill-doc (doc) (with-temp-buffer (let ((sentence-end-double-space t) (use-hard-newlines t) (colon-double-space t)) (insert (mapconcat 'eval doc " ")) (canonically-space-region (point-min) (point-max)) (fill-region (point-min) (point-max)) (goto-char (point-min)) (while (re-search-forward "\\s-+\\'" nil t) (replace-match "" nil nil)) (buffer-string)))) (defun build-configure-prolog (file) (princ ";;; Produced from ;;; ") (princ file) (princ " ;;; by ") (princ ;; Make sure the RCS keyword Id does not end up in the output file, ;; in case build.el is not `co -kv ...' or during development. (with-temp-buffer (insert build-version) (while (re-search-backward "\\$" nil t) (replace-match "" nil nil)) (buffer-string))) (princ "\n;;; at\n;;; ") (princ (format-time-string "%a %b %d %T %Z %Y")) (princ " (provide 'build-configure)\n (setq build-configure-options nil)\n (defun build-configure-sym-to-opt (sym) (substring (symbol-name sym) 15))\n (defun build-set-path (sym val) (setq build-configure-options (acons (build-configure-sym-to-opt sym) (mapconcat '(lambda (item) item) val \":\") build-configure-options)) (set-default sym val))\n (defun build-set-types (sym val) (setq build-configure-options (acons (build-configure-sym-to-opt sym) (mapconcat '(lambda (item) item) val \",\") build-configure-options)) (set-default sym val))\n (defun build-configure-set-value (sym val) (setq build-configure-options (acons (build-configure-sym-to-opt sym) val build-configure-options)) (set-default sym val))\n (defgroup build-configure nil \"XEmacs Build Configuration.\" :group 'build)\n ")) ;;}}} ;;{{{ Build CVS (defvar build-cvs-available-p nil "Internal variable keeping track whether CVS is available.") (defgroup build-cvs nil "Standardizes the fetching of XEmacs from the CVS repository." :group 'build) (defun build-cvs-get-branch-and-release-tags () "Retrieve all symbolic names (CVS tags) for XEmacs from version.sh." (interactive) (let* (exit-status (file "XEmacs/xemacs/version.sh") (co-command (list "cvs" "-d" build-cvs-xemacs-repository "checkout" file)) (status-command (list "cvs" "-d" build-cvs-xemacs-repository "status" "-v" file)) infile (buffer (list t t)) displayp result last-match-end this-match-beginning tags) (with-temp-buffer (cd (temp-directory)) (unless (file-exists-p file) (message-or-box "build: checking out %s to determine cvs tags" file) (setq result (build-call-process co-command infile buffer displayp)) (cond ((null (car result)) (warn "\nprogram %s cannot be found or executed\n" (car co-command))) ((/= (car result) 0) (warn "\n%s\nfailed with following output:\n%s\n" (mapconcat 'identity co-command " ") (cdr result))) (t (message-or-box "build: %s has been checked out" file)))) (message-or-box "build: retrieving cvs tags from %s" file) (setq result (build-call-process status-command infile buffer displayp)) (cond ((null (car result)) (warn "\nprogram %s cannot be found or executed\n" (car status-command))) ((/= (car result) 0) (warn "\n%s\nfailed with following output:\n%s\n" (mapconcat 'identity status-command " ") (cdr result))) (t (message-or-box "build: cvs tags have been retrieved from %s" file))) (if (setq this-match-beginning (string-match "^\\s-+Existing Tags:\n" (cdr result))) (setq last-match-end (match-end 0))) (while (and (setq this-match-beginning (string-match "\t\\(\\S-+\\)\\s-+\\(.*\\)\n" (cdr result) last-match-end)) (= last-match-end this-match-beginning)) (setq last-match-end (match-end 0)) (if last-match-end (push (list (match-string 1 (cdr result)) (match-string 2 (cdr result))) tags))) (reverse tags)))) (defun build-cvs-checkout-options-validate (sym val) (cond ((string-match "-\\(d\\|N\\)\\b" val) (customize-set-value sym build-cvs-checkout-options) (warn "cannot use -d and -N. `build-cvs-checkout-dir' will be used as -d argument if set, else `build-cvs-xemacs-module' will be used. The -N option is unsupported.")) (t (build-cvs-set-var-and-update-buffer sym val)))) (defun build-cvs-set-var-and-update-buffer (sym val) "Internal function for build." (set-default sym val) (when (fboundp 'build-from-CVS) (save-window-excursion (save-excursion (build-from-CVS))))) (defcustom build-cvs-checkout-options "-P" "CVS checkout command-line options to use for all CVS commands." :type 'string :set 'build-cvs-checkout-options-validate :group 'build-cvs) (defcustom build-cvs-options "-z3" "CVS command-line options to use for all CVS commands." :type 'string :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defcustom build-cvs-update-options "-P -d" "CVS update command-line options to use for all CVS commands." :type 'string :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defcustom build-cvs-checkout-parent-dir (temp-directory) "The parent directory on the local host into which the `build-cvs-xemacs-module' will be checked out, named according to `build-cvs-checkout-dir'." :type 'directory :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defconst build-cvs-xemacs-module "xemacs" "CVS XEmacs module name to be checked out.") (defvar build-cvs-checkout-dir nil "Internal variable updated from user variable `build-cvs-working-dir-naming'.") (defcustom build-cvs-use-pcl-cvs nil "*Whether build is to use PCL-CVS, when available. Alternatively, build will run CVS commands via `compile'." :type 'boolean :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defcustom build-cvs-xemacs-repository ":pserver:cvs@cvs.xemacs.org:/pack/xemacscvs" "CVS Repository where XEmacs can be checked out from." :type 'string :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defcustom build-cvs-working-dir-naming '(format "%s-%s" build-cvs-xemacs-module build-cvs-xemacs-release) "The naming of the directory on the local host into which the `build-cvs-xemacs-module' will be checked out. Be aware that cvs checkout options -d and -N will affect the resulting directory structure. Therefor these options are disallowed in `build-cvs-checkout-options'. The -N option is not supported, in order to avoid unknown directory structures." :type '(choice (const :tag "Named after CVS MODULE" build-cvs-xemacs-module) (const :tag "Named after RELEASE Tag" build-cvs-xemacs-release) (const :tag "Named after MODULE-RELEASE" (format "%s-%s" build-cvs-xemacs-module build-cvs-xemacs-release)) (string :tag "Working Dir Named manually" "")) :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defcustom build-cvs-xemacs-release "HEAD" "CVS XEmacs release to be checked out. The list of available releases is updated via cvs, if installed, by `build-from-CVS'. Use \"Specify Tag Name\" to fill in the name of a release tag not yet in the list of choices." :type '(choice :custom-state t (string :tag "Unlisted Release Name" "") (const :tag "release-21-1 (branch: 1.165.2)" "release-21-1") (const :tag "release-21-4 (branch: 1.166.2)" "release-21-4") (const :tag "r21-5-9 (revision: 1.183)" "r21-5-9")) :set 'build-cvs-set-var-and-update-buffer :group 'build-cvs) (defun build-cvs-login () "Login to XEmacs CVS repository." (interactive) (unless (file-exists-p build-cvs-checkout-parent-dir) (make-directory build-cvs-checkout-parent-dir t)) (cd build-cvs-checkout-parent-dir) (let (exit-status (command (list "cvs" build-cvs-options "-d" build-cvs-xemacs-repository "login")) (file (make-temp-name (expand-file-name "cvs-login" (getenv "TEMP")))) (buffer (list t t)) displayp) (with-temp-file file (insert "cvs\n")) (message-or-box "build: cvs login at cvs.xemacs.org, please wait") (setq result (build-call-process command file buffer displayp)) (cond ((null (car result)) (setq build-cvs-available-p nil) (warn "\nprogram %s cannot be found or executed\n" (car command))) ((/= (car result) 0) (setq build-cvs-available-p nil) (warn "\n%s\nfails with following output:\n%s\n" (mapconcat 'identity command " ") (cdr result))) (t (setq build-cvs-available-p t) (message-or-box "build: cvs login succeeded"))) (delete-file file))) (defun build-cvs-checkout (&optional release-tag) "Fetch XEmacs from the repository." (interactive "sXEmacs Release Tag: ") (unless (file-exists-p build-cvs-checkout-parent-dir) (make-directory build-cvs-checkout-parent-dir t)) (cd build-cvs-checkout-parent-dir) (let ((cmd (format "cvs %s -d%s checkout %s -d %s%s %s" build-cvs-options build-cvs-xemacs-repository build-cvs-checkout-options build-cvs-checkout-dir (if (and release-tag (not (string-equal release-tag ""))) (concat " -r " release-tag) "") build-cvs-xemacs-module)) (compilation-mode-hook 'build-compilation-mode-hook) (compilation-buffer-name-function '(lambda (mode) (generate-new-buffer-name (format "%s-cvs-checkout%s.err" build-cvs-checkout-dir (if (and release-tag (not (string-equal release-tag ""))) (format "-%s" release-tag) "")))))) (compile cmd))) (defun build-cvs-update (&optional release-tag) "Update XEmacs from the repository to newest release or to release specified by RELEASE-TAG'." (interactive "sXEmacs Release Tag: ") (cd (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)) (let ((cmd (format "cvs %s update %s%s" build-cvs-options build-cvs-update-options (if (and release-tag (not (string-equal release-tag ""))) (concat " -r " release-tag) " -A") )) (compilation-mode-hook 'build-compilation-mode-hook) (compilation-buffer-name-function '(lambda (mode) (generate-new-buffer-name (concat build-cvs-checkout-dir "-cvs-update" (when (and release-tag (not (string-equal release-tag ""))) (format "-%s" release-tag)) ".err"))))) (cond ((and build-cvs-use-pcl-cvs (featurep 'pcl-cvs)) (cvs-update (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir) (split-string build-cvs-update-options "\\s-+"))) (t (compile cmd))))) ;;}}} ;;{{{ Build From (defun build-from-CVS () (interactive) (let ((name (format "*Build XEmacs From CVS With %s*" build-with-what))) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) (unless (file-exists-p build-cvs-checkout-parent-dir) (make-directory build-cvs-checkout-parent-dir t)) (cd build-cvs-checkout-parent-dir) ;; #### FIXME build-cvs-checkout-dir is not driven by custom ;; events as it should be! (setq build-cvs-checkout-dir (eval build-cvs-working-dir-naming)) (put 'build-cvs-xemacs-release 'custom-type (append '(choice :custom-state t) (cons '(string :tag "Unlisted Release Name" "") (mapcar (function (lambda (tag) (list 'const :tag (format "%s %s" (first tag) (second tag)) (first tag)))) (build-cvs-get-branch-and-release-tags))))) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let ((buffer-back "*Build XEmacs*")) (if (buffer-live-p (get-buffer buffer-back)) (switch-to-buffer buffer-back) (build)))) "Go Back") (widget-insert "\nYou need to customize CVS options and then download a release\nof XEmacs.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-cvs)) "Browse Build CVS Options ...") (widget-insert "\n") (widget-insert (format "\t%+20s: %s\n" "Use Pcl Cvs" (if build-cvs-use-pcl-cvs "Yes" "No"))) (widget-insert (format "\t%+20s: \"%s\"\n" "XEmacs CVS Repository" build-cvs-xemacs-repository)) (widget-insert (format "\t%+20s: \"%s\"\n" "CVS Options" build-cvs-options)) (widget-insert (format "\t%+20s: \"%s\"\n" "Checkout Options" build-cvs-checkout-options)) (widget-insert (format "\t%+20s: \"%s\"\n" "Update Options" build-cvs-update-options)) (widget-insert (format "\t%+20s: \"%s\"\n" "XEmacs Module" build-cvs-xemacs-module)) (widget-insert (format "\t%+20s: \"%s\"\n" "XEmacs Release" build-cvs-xemacs-release)) (widget-insert (format "\t%+20s: %S\n" "Working Dir Naming" build-cvs-working-dir-naming)) (widget-insert (format "\t%+20s: \"%s\"\n" "Checkout Parent Dir" build-cvs-checkout-parent-dir)) (widget-insert (format "\t%+20s: \"%s\"\n" "Working Dir" build-cvs-checkout-dir)) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-cvs-login)) "CVS Login XEmacs") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-cvs-checkout build-cvs-xemacs-release)) "CVS Checkout XEmacs") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-cvs-update build-cvs-xemacs-release)) (format "CVS Update XEmacs To CVS Tag \"%s\"" build-cvs-xemacs-release)) (widget-insert "\nor\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-cvs-update)) "CVS Update To Latest XEmacs on Trunk") (widget-insert "\nMake sure to \"Browse Build CVS Options ...\" first.\nChoose XEmacs release to be checked out.\nAlternatively you can simply get the latest sources on the trunk (not\non any branch). This is always the latest XEmacs version under\ndevelopment. As of 2002-03-14 the trunk is headed for XEmacs 21.5.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let ((dir (cond ((string-equal build-with-what "GNU Tools") (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)) ((string-equal build-with-what "Microsoft Tools") (expand-file-name "nt" (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)))))) (if (file-directory-p (file-name-as-directory dir)) (cond ((string-equal build-with-what "GNU Tools") (build-with-GNU dir)) ((string-equal build-with-what "Microsoft Tools") (build-with-MS dir))) (message-or-box "need to checkout to create %s?" dir)))) (format "Build XEmacs With %s Now ..." build-with-what)) (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) (defun build-from-tarballs () (interactive) (let ((name (format "*Build XEmacs From Tarballs With %s*" build-with-what))) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) (cd build-tarball-dest) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let ((buffer-back "*Build XEmacs*")) (if (buffer-live-p (get-buffer buffer-back)) (switch-to-buffer buffer-back) (build)))) "Go Back") (widget-insert "\nYou need to customize Tarball options and then download a beta/release\nversion of XEmacs.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-tarball)) "Browse Build Tarball Options ...") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (dired build-tarball-site)) "Browse Build Tarball Site ...") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (build-tarball-expand-all)) "View Build Tarball Set ...") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (build-tarball-get-all)) "Download Build Tarball Set") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (build-tarball-extract-all)) "Install Downloaded Build Tarball Set") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (cond ((string-equal build-with-what "GNU Tools") (build-with-GNU (expand-file-name build-tarball-prefix build-tarball-dest))) ((string-equal build-with-what "Microsoft Tools") (build-with-MS (expand-file-name "nt" (expand-file-name build-tarball-prefix build-tarball-dest)))))) (format "Build XEmacs With %s Now ..." build-with-what)) (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) ;;}}} ;;{{{ Build Tarballs (defgroup build-tarball nil "Standardized the fetching of XEmacs beta/release tarballs." :group 'build) (defcustom build-tarball-dest (temp-directory) "The destination directory on the local host the `build-tarball-set' will be deposited in." :type 'directory :group 'build-tarball) (defcustom build-tarball-dir "beta" "The sub-directory under `build-tarball-site' in which the `build-tarball-set' is located." :type '(choice :custom-state t (const "beta") (const "gamma") (const "stable")) :group 'build-tarball) (defcustom build-tarball-prefix "xemacs-21.5.6" "The prefix shared among all of the `build-tarball-set'. This makes it easy to switch over from one beta/gamma/stable release tarball set to the next, e.g. from \"xemacs-21.5.5\" to \"xemacs-21.5.6\"." :type 'string :group 'build-tarball) (defcustom build-tarball-set nil "The set of final name components of XEmacs tarballs you wish to fetch." :type'(set (const :tag "XEmacs byte-compiled lisp tarball" "-elc.tar.gz") (const :tag "XEmacs byte-compiled lisp tarball signature" "-elc.tar.gz.asc") (const :tag "XEmacs info tarball" "-info.tar.gz") (const :tag "XEmacs info tarball signature" "-info.tar.gz.asc") (const :tag "XEmacs Mule tarball" "-mule.tar.gz") (const :tag "XEmacs Mule tarball signature" "-mule.tar.gz.asc") (const :tag "XEmacs source tarball" ".tar.gz") (const :tag "XEmacs source tarball signature" ".tar.gz.asc") (repeat :custom-show t :documentation-shown t (string ""))) :group 'build-tarball) (defcustom build-tarball-site "/ftp@ftp.xemacs.org:/pub/xemacs/" "The EFS path to a top-level XEmacs directory to fetch the XEmacs `build-tarball-set' from. The list of available sites is dynamically generated based on `package-get-download-sites'. In addition you may set the value to a manually chosen EFS path." :link '(url-link :tag "XEmacs Download Locations" "http://www.xemacs.org/Download/") :type (append '(choice :custom-state t) (cons '(directory :tag "EFS Path" "/user@host.domain:/directory/") (remove nil (mapcar (function (lambda (entry) (let (comment host path efs-path) (setq comment (nth 0 entry) host (nth 1 entry) path (nth 2 entry)) (when (and host (not (string-equal comment "Pre-Releases"))) (setq efs-path (format "/ftp@%s:/%s" host path)) (list 'const :tag (format "%s - %s" efs-path comment) (file-name-directory efs-path)))))) package-get-download-sites)))) :group 'build-tarball) (defun build-tarball-expand (item) (let ((prfx (expand-file-name build-tarball-prefix (concat build-tarball-site build-tarball-dir)))) (concat prfx item))) (defun build-tarball-collapse (item) (let ((str (concat build-tarball-site build-tarball-dir build-tarball-prefix))) (string-match str item) (replace-match "" t t item))) (defun build-tarball-get (file) (if (not (featurep 'efs)) (message-or-box "please install efs to be able to \"Download Build Tarball Set\".") (let ((efs-mode-hook '(lambda () (set (make-local-variable 'efs-expire-ftp-buffers) nil) (set (make-local-variable 'auto-save-hook) '(lambda () (message "Auto-saved %s\n" (buffer-name)))) (auto-save-mode 1)))) (efs-copy-file (build-tarball-expand file) (concat (expand-file-name build-tarball-prefix build-tarball-dest) file) 1 nil t)))) (defun build-tarball-extract (file) (cd build-tarball-dest) (let ((cmd (format "gunzip -c %s%s | tar -xvf -" build-tarball-prefix file)) (compilation-mode-hook 'build-compilation-mode-hook) (compilation-buffer-name-function '(lambda (mode) (generate-new-buffer-name (concat (file-name-sans-extension (file-name-sans-extension (concat build-tarball-prefix file))) "-toc.err")))) ) (if (string-match "tar\\.gz$" file) (compile cmd) (warn "%s is not a tar.gz file, skipped." (concat build-tarball-prefix file))))) (defun build-tarball-get-all () "Get all the expanded files of `build-tarball-set'. Use `build-tarball-expand-all' to find out which tarballs would be fetched by this function. All tarballs are saved under `build-tarball-dest'" (interactive) (mapc 'build-tarball-get build-tarball-set)) (defun build-tarball-extract-all () "Extract all files from the locally present `build-tarball-set' which have to be in \".tar.gz\" format." (interactive) (mapc 'build-tarball-extract build-tarball-set)) (defun build-tarball-expand-all () "Print the expanded value of `build-tarball-set' to temporary buffer \"*Build Tarball Set*\"." (interactive) (cd build-tarball-dest) (with-output-to-temp-buffer "*Build Tarball Set*" (princ (mapconcat 'build-tarball-expand build-tarball-set "\n")))) (defun build-tarball-add-url () "Add URL near point to `build-tarball-set' via `url-get-url-at-point'." (interactive) (setq build-tarball-set (cons (url-get-url-at-point) build-tarball-set))) ;;}}} ;;{{{ Build With (defvar build-with-MS-has-config-inc nil "Internal variable indicating whether the XEmacs to be built has support for config.inc.") (defgroup build-with-MS nil "Standardizes the building of XEmacs with MiroSoft tools." :group 'build) (defcustom build-with-MS-make-command "nmake" "Path of Microsoft make utility used to build XEmacs." :type 'file :group 'build-with-MS) (defcustom build-with-MS-make-options '("/f xemacs.mak") "Options to use with Microsoft make utility when building XEmacs." :type '(repeat string) :group 'build-with-MS) (defun build-with-GNU (dir) (interactive) (let ((name "*Build XEmacs With GNU Tools*")) ;; Overwrite any customized setting for this build session so ;; that build-report will find the right information. (customize-set-variable 'build-report-installation-file (expand-file-name "Installation" dir)) (customize-set-variable 'build-report-version-file (expand-file-name "version.sh" dir)) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) (cd dir) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let (buffer-back get-back) (cond ((string-equal build-from-what "Tarballs") (setq buffer-back "*Build XEmacs From Tarballs With GNU Tools*") (setq get-back 'build-from-tarballs)) ((string-equal build-from-what "CVS") (setq buffer-back "*Build XEmacs From CVS With GNU Tools*") (setq get-back 'build-from-CVS))) (if (buffer-live-p (get-buffer buffer-back)) (switch-to-buffer buffer-back) (funcall get-back)))) "Go Back") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-configure-generate "configure.usage")) "Generate Build Configure") (widget-insert "\n\t") (widget-apply (widget-create 'push-button :notify (lambda (&rest ignore) (eval-buffer "build-configure.el")) "Activate Generated Build Configure") (if (boundp 'build-configure-options) :deactivate :activate)) (when (boundp 'build-configure-options) (widget-insert "\n\tYou will need to restart XEmacs first if you want to activate the\n\tgenerated interface to Build Make again.")) (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-configure)) "Browse Build Configure ...") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (build-configure)) "Run XEmacs Configure") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make-generate)) "Generate XEmacs Make") ; (widget-insert "\n\t") ; (widget-create 'push-button ; :notify (lambda (&rest ignore) ; (customize-browse 'build-make)) ; "Browse Build-Make") (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (call-interactively 'build-make)) "Run XEmacs Make") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-build-report)) "Generate XEmacs Build Report ...") (widget-insert "\n\n") (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) (defun build-with-MS (dir) (interactive "DXEmacs source directry: ") (let ((name "*Build XEmacs With Microsoft Tools*")) ;; Overwrite any customized setting for this build session so ;; that build-report will find the right information. (customize-set-variable 'build-report-installation-file (expand-file-name "Installation" (expand-file-name ".." dir))) (customize-set-variable 'build-report-version-file (expand-file-name "version.sh" (expand-file-name ".." dir))) (setq build-with-MS-has-config-inc (multiple-value-bind (major minor beta codename) (build-report-version-file-data build-report-version-file) ;; APA: config.inc file was introduced by Ben Wing in 21.2-b32. (if (and (>= (string-to-int major) 21) (or ;; 21.2 versions >= b32 (and (= (string-to-int minor) 2) (>= (string-to-int beta) 32)) ;; 21 versions with minor number > 2 (> (string-to-int minor) 2))) t nil))) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (kill-all-local-variables) (cd (expand-file-name "" dir)) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let (buffer-back get-back) (cond ((string-equal build-from-what "Tarballs") (setq buffer-back "*Build XEmacs From Tarballs With Microsoft Tools*") (setq get-back 'build-from-tarballs)) ((string-equal build-from-what "CVS") (setq buffer-back "*Build XEmacs From CVS With Microsoft Tools*") (setq get-back 'build-from-CVS))) (if (buffer-live-p (get-buffer buffer-back)) (switch-to-buffer buffer-back) (funcall get-back)))) "Go Back") (widget-insert "\n") (widget-insert "\nYou need to customize Microsoft Tools options.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-with-MS)) "Browse Build With MS Options ...") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make-generate "xemacs.mak")) "Generate XEmacs Make") (widget-insert "\n\t") (widget-apply (widget-create 'push-button :notify (lambda (&rest ignore) (eval-buffer "build-make.el")) "Activate Generated Build Make") (if (boundp 'build-make-options) :deactivate :activate)) (when (boundp 'build-make-options) (widget-insert "\n\tYou will need to restart XEmacs to activate\n\tthe generated interface to Build Make again.")) (widget-insert "\n\t") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-make)) "Browse Build Make ...") (widget-insert "\n\t") (widget-apply (widget-create 'push-button :notify (lambda (&rest ignore) (eval-buffer "build-make.el") (build-config-inc-generate)) "Generate config.inc") (if build-with-MS-has-config-inc :activate :deactivate)) (widget-insert "\n\tXEmacs versions prior to 21.2-b32 do not use config.inc.\n\tThose are configured by passing all variable values to nmake\n\ton the command-line.\n\nDon't forget to save config.inc before building!") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make "distclean" (mapconcat 'identity (cons build-with-MS-make-command build-with-MS-make-options) " "))) "Clean XEmacs Distribution") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make "all" (concat (mapconcat 'identity (cons build-with-MS-make-command build-with-MS-make-options) " ") (unless build-with-MS-has-config-inc (build-make-get-option-string))))) "Build XEmacs") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make "install" (concat (mapconcat 'identity (cons build-with-MS-make-command build-with-MS-make-options) " ") (unless build-with-MS-has-config-inc (build-make-get-option-string))))) "Build and Install XEmacs") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make "check-temacs" (concat (mapconcat 'identity (cons build-with-MS-make-command build-with-MS-make-options) " ") (unless build-with-MS-has-config-inc (build-make-get-option-string))))) "Check temacs (XEmacs before dumping)") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-make "check" (concat (mapconcat 'identity (cons build-with-MS-make-command build-with-MS-make-options) " ") (unless build-with-MS-has-config-inc (build-make-get-option-string))))) "Check XEmacs") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (build-build-report)) "Generate XEmacs Build Report ...") (widget-insert "\n\n") (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) ;;}}} ;;{{{ Build Report (defun build-build-report () (interactive) (let ((name "*Generate XEmacs Build Report*")) (kill-buffer (get-buffer-create name)) (switch-to-buffer (get-buffer-create name)) (widget-insert "\n") (widget-create 'push-button :notify (lambda (&rest ignore) (let (buffer-back get-back dir) (cond ((string-equal build-with-what "GNU Tools") (setq buffer-back "*Build XEmacs With GNU Tools*") (setq get-back 'build-with-GNU)) ((string-equal build-with-what "Microsoft Tools") (setq buffer-back "*Build XEmacs With Microsoft Tools*") (setq get-back 'build-with-MS))) (cond ((string-equal build-from-what "Tarballs") (setq dir (expand-file-name build-tarball-prefix build-tarball-dest))) ((string-equal build-from-what "CVS") (setq dir (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)))) (if (buffer-live-p (get-buffer buffer-back)) (switch-to-buffer buffer-back) (funcall get-back dir)))) "Go Back") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (customize-browse 'build-report)) "Browse Build Report ...") (widget-insert "\n\nYou may need to customize Build Report options in order to find all\ninformation created by your last building of XEamcs.\n\n") (widget-create 'push-button :notify (lambda (&rest ignore) (call-interactively 'build-report)) "Generate Build Report ...") (widget-insert "\n") (use-local-map widget-keymap) (widget-setup) (custom-mode) (goto-char (point-min)))) ;;}}} ;;{{{ Build Make (defvar build-make-alist nil "Internal variable keeping track of makefile macros and targets") (defconst build-make-target-doc-paragraph "^##\\s-*make\\s-+\\([^ ]+\\(\\s-+or\\s-+make\\s-+\\([^ ]+\\)\\)*\\)\\(\\s-*\\(\\(.*\\)\\(\n##\\s-\\{3,\\}.+\\)*\\)\\)$" "Internal REGEXP matching a XEmacs makefile target comment. These comments don't exist in `xemacs.mak'") (defconst build-make-target-paragraph "\\(^#.+ \\)?\\(\\(\\w\\|_\\)+\\)\\s-*:.*" "Internal REGEXP matching a XEmacs makefile target name.") (defconst build-make-macro-paragraph "^\\(?:!message Please specify root directory for your .* installation: \\)?\\(\\(\\w\\|_\\)+\\)\\s-*=\\s-*\\(\\(.*\\\\ \\)*.+\\)$" "Internal REGEXP matching a XEmacs makefile macro definition.") (defconst build-make-prolog " (provide 'build-make) (setq build-make-options nil) (defun build-make-sym-to-opt (sym) ;; #### Strip the \"build-make-\" prefix. (substring (symbol-name sym) 11)) (defun build-make-set-value (sym val) (setq build-make-options (remassoc (build-make-sym-to-opt sym) build-make-options)) (unless (equal val (first (get sym 'standard-value))) (setq build-make-options (acons (build-make-sym-to-opt sym) val build-make-options))) (set-default sym val)) (defgroup build-make nil \"build-make options.\" :group 'build) " "Internal variable of `build'.") (defun build-config-inc-generate (&optional dir) (interactive) (let ((buffer (buffer-name (generate-new-buffer "config.inc")))) (if dir (cd dir)) (with-output-to-temp-buffer buffer (save-window-excursion (princ "# -*- mode: makefile -*-\n") (princ (format "# generated by %s" build-version)) (princ "\n\n") (princ (if (boundp 'build-make-options) (mapconcat (function (lambda (e) (cond (t (format "%s=%s\n" (first e) (rest e)))))) (sort (delete-duplicates build-make-options :from-end t :test (lambda (a b) (string= (first a) (first b)))) (lambda (a b) (string< (first a) (first b)))) "") "")) )) (set-buffer buffer) (kill-all-local-variables) (makefile-mode) (font-lock-mode 1) (toggle-read-only 1))) (defun build-make (&optional target command) "Build the XEmacs target argument according to the settings in customized group `build' and its members." (interactive "sTarget: \nsCommand: ") (let ((cmd (if (string-equal command "") (format "make %s" target) (format "%s %s" command target))) (compilation-mode-hook 'build-compilation-mode-hook) (compilation-buffer-name-function '(lambda (mode) (generate-new-buffer-name (format "%s-make%s.err" (cond ((string-equal build-from-what "Tarballs") build-tarball-prefix) ((string-equal build-from-what "CVS") build-cvs-checkout-dir)) (if target (format "-%s" target) "")))))) (compile cmd))) (defun build-make-generate (&optional file) (interactive "fMakefile: ") (setq build-make-alist (list (cons 'macros nil) (cons 'targets nil))) (unless file (setq file (expand-file-name "Makefile.in" (cond ((string-equal build-from-what "Tarballs") (expand-file-name build-tarball-prefix build-tarball-dest)) ((string-equal build-from-what "CVS") (expand-file-name build-cvs-checkout-dir build-cvs-checkout-parent-dir)))))) (let (category categories option value detected doc (buffer "build-make.el")) (with-output-to-temp-buffer buffer (save-window-excursion (find-file-read-only file) ; (build-make-prolog file) (goto-char (point-min)) (while (< (point) (point-max)) (cond ((looking-at build-make-target-doc-paragraph) (goto-char (match-end 0)) (build-make-process-target-doc ;; target [or target ...] (match-string 1) ;; documentation for current targets; possibly ;; spreading multiple lines. (match-string 5) build-make-alist)) ((looking-at build-make-target-paragraph) (goto-char (match-end 0)) (when (> (length (match-string 1)) 0) (build-make-process-target-doc ;; target name (match-string 2) ;; documentation for target; possibly ;; spreading multiple lines. (match-string 1) build-make-alist)) ) ((looking-at build-make-macro-paragraph) (goto-char (match-end 0)) ; (unless (string-match "\\$" (match-string 3)) (build-make-process-macro ;; macro name (match-string 1) ;; macro value (match-string 3) build-make-alist)) ; ) ((looking-at "^.+$") (goto-char (match-end 0))) ((looking-at "\n") (goto-char (match-end 0))) )) (build-make-customize build-make-alist) )) (set-buffer buffer) (insert "(setq build-make-alist (quote") ; (cl-prettyprint (nreverse build-make-alist)) (cl-prettyprint build-make-alist) (insert "))\n") (toggle-read-only 1))) (defun build-make-get-option-string () (if (boundp 'build-make-options) (mapconcat (function (lambda (e) (cond (t (format " %s=\"%s\"" (first e) (rest e)))))) (delete-duplicates build-make-options :from-end t :test (lambda (a b) (string= (first a) (first b)))) "") "")) (defun build-make-process-target-doc (targets doc a-list) (setq targets (replace-in-string targets "or\\(\n\\|\\s-\\)+make" "")) (setq doc (replace-in-string doc "##?\\s-+" "")) (setq doc (build-configure-fill-doc (list doc))) (setcdr (assoc 'targets a-list) (append (list (list targets doc)) (cdr (assoc 'targets a-list))))) (defun build-make-process-macro (name value a-list) (unless (assoc name (assoc 'macros a-list)) (setcdr (assoc 'macros a-list) (append (list (list name value)) (cdr (assoc 'macros a-list)))))) (defun build-make-customize (a-list) (princ build-make-prolog) (mapcar (lambda (macro) (if (string-match "_DIR\\'" (first macro)) (build-make-file (first macro) (second macro)) (build-make-string (first macro) (second macro)))) (rest (assoc 'macros a-list)))) (defun build-make-string (name val) (princ (format "(defcustom build-make-%s\n" name)) (princ (format " %S\n" val)) (princ (format " \"macro %s\"\n" name)) (princ (format " :group \'build-make\n")) (princ " :type 'string\n") (princ " :set 'build-make-set-value)\n") (princ "\n")) (defun build-make-file (name val) (princ (format "(defcustom build-make-%s\n" name)) (princ (format " %S\n" val)) (princ (format " \"macro %s\"\n" name)) (princ (format " :group \'build-make\n")) (princ " :type 'file\n") (princ " :set 'build-make-set-value)\n") (princ "\n")) ;;}}} ;;{{{ Build Settings (defcustom build-settings nil "Internal alist of named settings for building multiple XEmacs configurations. This variable is updated via \"Delete\", Load\", and \"Save\" buttons of the `build' GUI." :type 'sexp :group 'build) (defun build-settings-save-custom-group (group key alist) "Save customization values of custom GROUP as value of KEY in ALIST" (dolist (cgm (custom-group-members group nil)) (let ((symbol (first cgm)) (type (second cgm))) (cond ((equal type 'custom-group) (setq alist (build-settings-save-custom-group symbol key alist))) (t (unless (assoc key alist) (setq alist (acons key nil alist))) (if (get symbol 'customized-value) (setcdr (assoc key alist) (append (cdr (assoc key alist)) (list (list symbol (car (get symbol 'customized-value))))))))))) alist) (defun build-settings-load (key alist) "Load build variable settings from alist." (interactive) (dolist (var (cdr (assoc key alist))) (message "%S\n\t%S" (car var) (car (cdr var))) (set (car var) (eval (car (cdr var)))) )) ;;}}} ;; build.el ends here