cgit.sxemacs.org Git - packages/blob - xemacs-packages/build/build.el

   1 ;;;     $Id: build.el,v 1.52 2003-10-13 15:52:13 james Exp $
   2
   3 ;;{{{ Legalese
   4
   5 ;; Copyright (C) 1997-2002 Adrian Aichner
   6
   7 ;; Author: Adrian Aichner <adrian@xemacs.org>
   8 ;; Date: $Date: 2003-10-13 15:52:13 $
   9 ;; Version: $Revision: 1.52 $
  10 ;; Keywords: internal
  11
  12 ;; This file is part of XEmacs.
  13
  14 ;; XEmacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; XEmacs is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  26 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  27 ;; 02111-1307, USA.
  28
  29 ;;; Synched up with: Not synched.
  30
  31 ;;}}}
  32
  33 ;;{{{ provide/require
  34
  35 (provide 'build)
  36
  37 (require 'custom)
  38 (require 'cus-edit)
  39 (require 'widget)
  40 (if (featurep 'sxemacs)
  41     (require 'build-rpt)
  42   (require 'build-report))
  43
  44 (autoload 'ring-insert-at-beginning "ring")
  45 (autoload 'efs-copy-file "efs")
  46
  47 ;; `url-copy-file' (buffer: build.el, mode: Lisp)
  48
  49 (eval-when-compile
  50   (require 'cl))
  51
  52 ;; Pull in compile, if it is available.
  53 (condition-case nil
  54     (require 'compile)
  55   (error nil))
  56
  57 (eval-when-compile
  58   (require 'wid-edit))
  59
  60 ;; Pull in pcl-cvs, if it is available.
  61 (condition-case nil
  62     (require 'pcl-cvs)
  63   (error nil))
  64
  65 ;;}}}
  66
  67 (defcustom build-from-what
  68   "Tarballs"
  69   "The Source Code units XEmacs is to be built from (\"Tarballs\" or
  70 \"CVS\")."
  71   :type '(choice
  72           :custom-state t
  73           (const "Tarballs")
  74           (const "CVS"))
  75   :group 'build)
  76
  77 (defcustom build-with-what
  78   "GNU Tools"
  79   "The Toolset XEmacs is to be built with (\"GNU Tools\" or
  80 \"Microsoft Tools\")."
  81   :type '(choice
  82           :custom-state t
  83           (const "GNU Tools")
  84           (const "Microsoft Tools"))
  85   :group 'build)
  86
  87 ;;{{{ Version info
  88
  89 ;;;
  90 ;;; Version-handling, based on ideas from w3.
  91 ;;;
  92 (defconst build-version-number
  93   (let ((x "2.00"))
  94     (if (string-match "Name:[ \t\n]+\\([^\n]+\\) \\$" x)
  95         (setq x (match-string 1 x))
  96       (setq x (substring x 0)))
  97     (mapconcat
  98      (function (lambda (x) (if (= x ?-) "." (char-to-string x)))) x ""))
  99   "Version number of build package.")
 100
 101 (defconst build-version-date
 102   (let ((x "2002-03-07"))
 103     (if (string-match "Date:[ \t\n]+\\([^\n]+\\) \\$" x)
 104         (match-string 1 x)
 105       x))
 106   "Date this version of build was released.")
 107
 108 (defconst build-version
 109   (format "build %s %s" build-version-number build-version-date)
 110   "More descriptive version of build-version-number.")
 111
 112 ;;;###autoload
 113 (defun build-version (&optional here)
 114   "Show the version number of `build' in the minibuffer.
 115 If optional argument HERE is non-nil, insert info at point."
 116   (interactive "P")
 117   (if here
 118       (insert build-version)
 119     (if (interactive-p)
 120         (message-or-box "%s" build-version)
 121       build-version)))
 122 ;;}}}
 123
 124 ;;{{{ Build
 125
 126 (defgroup build nil
 127   "Simplifies Building XEmacs; i.e. Fetching, Configuring, Making, and
 128 Reporting."
 129   :link '(url-link :tag "XEmacs Build Reference Manual"
 130                    "http://www.xemacs.org/Documentation/packages/html/build.html")
 131   :link '(url-link :tag "XEmacs Beta README"
 132                    "ftp://ftp@ftp.xemacs.org/pub/xemacs/beta/README")
 133   :link '(url-link :tag "XEmacs Gamma README"
 134                    "ftp://ftp@ftp.xemacs.org/pub/xemacs/gamma/README")
 135   :link '(url-link :tag "XEmacs Stable README"
 136                    "ftp://ftp@ftp.xemacs.org/pub/xemacs/stable/README")
 137   :group 'emacs)
 138
 139
 140 (defun build-call-process (command infile buffer displayp)
 141   (let (exit-status result)
 142     (with-temp-buffer
 143       (condition-case signal
 144           (setq exit-status
 145                 (apply 'call-process
 146                        (append
 147                         (list (car command) infile buffer displayp)
 148                         (cdr command))))
 149         (error
 150          (warn "\n%s\ncannot be executed: %S %S\n"
 151                (mapconcat 'identity command " ")
 152                (car signal) (cdr signal))))
 153       ;; return value of result
 154       (setq result (cons exit-status (buffer-string))))))
 155
 156 ;;;###autoload
 157 (defun build ()
 158   "Creates a widget-based interface to build a beta/release version of
 159 XEmacs.  All aspects of fetching tarballs, configuring, making and
 160 reporting can be customized and executed from the newly created buffer
 161 *Build*."
 162   (interactive)
 163   (let
 164       (exit-status
 165        (command
 166         (list
 167          "cvs" "-v"))
 168        infile
 169        (buffer (list t t))
 170        displayp
 171        result
 172 ;        build-from-cvs-button-widget
 173 ;        build-from-tarballs-button-widget
 174        (name "*Build XEmacs*"))
 175     (kill-buffer (get-buffer-create name))
 176     (switch-to-buffer (get-buffer-create name))
 177     (kill-all-local-variables)
 178     ;; Determine availability of CVS client.
 179     (message-or-box
 180      "build: checking whether you have cvs, please wait")
 181     (setq result
 182           (build-call-process command infile buffer displayp))
 183     (cond
 184      ((null (car result))
 185       (setq build-cvs-available-p nil)
 186       (warn "\nprogram %s cannot be found or executed\n"
 187             (car command))
 188       (setq build-from-what "Tarballs"))
 189      ((/= (car result) 0)
 190       (setq build-cvs-available-p nil)
 191       (warn "\n%s\nfailed with following output:\n%s\n"
 192             (mapconcat 'identity command " ")
 193             (cdr result))
 194       (setq build-from-what "Tarballs")
 195       (widget-insert
 196        "\n\nPlease install cvs, unless you want to build from our tarballs.\n"))
 197      (t
 198       (setq build-cvs-available-p t)
 199       (setq build-from-what "CVS")
 200       (message-or-box
 201        "build: cvs is available")))
 202     ;; Create widget-based interface.
 203     (widget-insert
 204      "Visit info documentation for the XEmacs build package inside ")
 205     (widget-create
 206      'info-link
 207      :tag "XEmacs"
 208      :value "(build)")
 209     (widget-insert "\nor on the XEmacs website at\n")
 210     (widget-create
 211      'url-link
 212      :value
 213      "http://www.xemacs.org/Documentation/packages/html/build.html")
 214     (widget-insert "\n\n")
 215     (let
 216         ((inhibit-read-only t))
 217       (setq build-current-build-settings-widget
 218             (widget-create
 219              'string
 220              :tag "Current Build Settings"
 221              :value
 222              "unknown")))
 223     (widget-apply
 224      build-current-build-settings-widget
 225      :deactivate)
 226     (widget-insert "\n")
 227     (widget-create 'push-button
 228                    :notify (lambda (&rest ignore)
 229                              (let
 230                                  ((name (widget-value build-settings-widget)))
 231                                (widget-apply
 232                                 build-current-build-settings-widget
 233                                 :activate)
 234                                (widget-value-set
 235                                 build-current-build-settings-widget
 236                                 name)
 237                                (widget-apply
 238                                 build-current-build-settings-widget
 239                                 :deactivate)
 240                                (widget-setup)
 241                                (build-settings-load name build-settings)
 242                                (message-or-box
 243                                 "loaded \"%s\" build-settings"
 244                                 name)))
 245                    "Load")
 246     (widget-insert " ")
 247     (widget-create 'push-button
 248                    :notify (lambda (&rest ignore)
 249                              (let*
 250                                  ((args
 251                                    (widget-get build-settings-widget :args))
 252                                   (value (widget-value build-settings-widget))
 253                                   new-args)
 254                                (if (string= value "default")
 255                                    (message-or-box
 256                                     "cannot delete \"%s\" build-settings"
 257                                     value)
 258                                  (when
 259                                      (yes-or-no-p
 260                                       (format "delete \"%s\" build-settings? " value))
 261                                    (setq
 262                                     new-args
 263                                     (remrassoc
 264                                      (list
 265                                       :value
 266                                       value)
 267                                      args))
 268                                    (widget-put
 269                                     build-settings-widget
 270                                     :args new-args)
 271                                    (widget-put
 272                                     build-settings-name-widget
 273                                     :args
 274                                     (cons (list 'string :value "default")
 275                                           new-args))
 276                                    (widget-value-set
 277                                     build-settings-widget
 278                                     (widget-get
 279                                      (first (widget-get build-settings-widget :args))
 280                                      :value))
 281                                    (widget-setup)
 282                                    (setq
 283                                     build-settings
 284                                     (remassoc
 285                                      value
 286                                      build-settings))
 287                                    (message-or-box
 288                                     "deleted \"%s\" build-settings"
 289                                     value)))))
 290                    "Delete")
 291     (widget-insert " ")
 292     (setq build-settings-widget
 293           (widget-create 'choice
 294                          :tag "build settings"
 295                          :value "default"
 296                          :args
 297                          (cons
 298                           (list 'item :value "default")
 299                           (mapcar
 300                            (function
 301                             (lambda (setting)
 302                               (let ((name setting))
 303                                 (list 'item :value (car setting)))))
 304                            build-settings))
 305 ;                        :notify (lambda (widget &rest ignore)
 306 ;                                  (setq build-settings (widget-value widget)))
 307                          '(item :value "default")))
 308     (widget-value-set
 309      build-settings-widget
 310      (widget-get
 311       (first (widget-get build-settings-widget :args))
 312       :value))
 313     (widget-create 'push-button
 314                    :notify (lambda (&rest ignore)
 315                              (let
 316                                  ((name
 317                                    (widget-value build-settings-name-widget)))
 318                                (unless
 319                                    (and
 320                                     (assoc name build-settings)
 321                                     (not
 322                                      (yes-or-no-p
 323                                       (format "overwrite current \"%s\" build-settings? " name))))
 324                                  (setq
 325                                   build-settings
 326                                   (build-settings-save-custom-group
 327                                    'build
 328                                    name
 329                                    build-settings))
 330                                  (unless
 331                                      (rassoc
 332                                       (cdr (list 'item :value name))
 333                                       (widget-get build-settings-widget :args))
 334                                    (widget-put
 335                                     build-settings-widget
 336                                     :args
 337                                     (cons (list 'item :value name)
 338                                           (widget-get build-settings-widget :args)))
 339                                    (widget-put
 340                                     build-settings-name-widget
 341                                     :args
 342                                     (cons (list 'item :value name)
 343                                           (widget-get build-settings-name-widget :args))))
 344                                  (customize-save-variable 'build-settings build-settings)
 345                                  (message-or-box
 346                                   "saved \"%s\" build-settings"
 347                                   name))))
 348                    "Save")
 349     (widget-insert " ")
 350     (setq build-settings-name-widget
 351           (widget-create 'choice
 352                          :tag "current build settings as"
 353                          :value "default"
 354                          :args
 355                          (cons
 356                           (list 'string :value "default")
 357                           (mapcar
 358                            (function
 359                             (lambda (setting)
 360                               (let ((name setting))
 361                                 (list 'item :value (car setting)))))
 362                            build-settings))
 363 ;                        :notify (lambda (widget &rest ignore)
 364 ;                                  (setq build-settings (widget-value widget)))
 365                          ))
 366     (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")
 367     (widget-create 'push-button
 368                    :notify (lambda (&rest ignore)
 369                              (customize-browse 'build))
 370                    "Browse Build Options ...")
 371     (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")
 372     (setq build-from-what-choice-widget
 373           (widget-create 'choice
 374                          :tag "Build from"
 375                          :value build-from-what
 376                          :notify (lambda (widget &rest ignore)
 377                                    (setq build-from-what (widget-value widget))
 378                                    (cond
 379                                     ((string-equal build-from-what "CVS")
 380                                      (widget-apply
 381                                       build-from-cvs-button-widget
 382                                       :activate)
 383                                      (widget-apply
 384                                       build-from-tarballs-button-widget
 385                                       :deactivate))
 386                                     ((string-equal build-from-what "Tarballs")
 387                                      (widget-apply
 388                                       build-from-cvs-button-widget
 389                                       :deactivate)
 390                                      (widget-apply
 391                                       build-from-tarballs-button-widget
 392                                       :activate))))
 393                          '(item :value "CVS")
 394                          '(item :value "Tarballs")))
 395     (widget-insert
 396      "Please decide now whether to build XEmacs from tarballs in .tar.gz\nformat or from CVS sources.  Using CVS is highly recommended.")
 397     (widget-insert "\n\n")
 398     (setq build-with-what-choice-widget
 399           (widget-create 'choice
 400                          :tag "Build with"
 401                          :value build-with-what
 402                          :notify (lambda (widget &rest ignore)
 403                                    (setq build-with-what (widget-value widget)))
 404                          '(item :value "GNU Tools")
 405                          '(item :value "Microsoft Tools")
 406                          ))
 407     (widget-insert
 408      "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.")
 409     (widget-insert "\n\n")
 410     (setq
 411      build-from-cvs-button-widget
 412      (widget-create 'push-button
 413                     :notify (lambda (&rest ignore)
 414                               (build-from-CVS))
 415                     "Build XEmacs From CVS Now"))
 416     (widget-insert "\n")
 417     ;; Recommend installation of CVS or provide cvs version
 418     ;; information.
 419     (if build-cvs-available-p
 420         (widget-insert (format "cvs -v returns this:\n%s\n" (cdr result)))
 421       (widget-insert
 422        "\n\nPlease install cvs, unless you want to build from our tarballs.\n"))
 423     ;; Building XEmacs from tarballs.
 424     (setq
 425      build-from-tarballs-button-widget
 426      (widget-create 'push-button
 427                     :notify (lambda (&rest ignore)
 428                               (build-from-tarballs))
 429                     "Build XEmacs From Tarballs Now"))
 430     ;; Initialize these buttons according to `build-from-what'.
 431     (cond
 432      ((string-equal build-from-what "CVS")
 433       (widget-apply
 434        build-from-cvs-button-widget
 435        :activate)
 436       (widget-apply
 437        build-from-tarballs-button-widget
 438        :deactivate))
 439      ((string-equal build-from-what "Tarballs")
 440       (widget-apply
 441        build-from-cvs-button-widget
 442        :deactivate)
 443       (widget-apply
 444        build-from-tarballs-button-widget
 445        :activate)))
 446     (widget-insert
 447      "\nProceed after you have chosen what sources to build from and what\ntools to build with.\n")
 448 ;    (widget-browse-other-window build-settings-widget)
 449     (use-local-map widget-keymap)
 450     (widget-setup)
 451     (custom-mode)
 452     (goto-char (point-min))))
 453
 454 ;;}}}
 455
 456 ;;{{{ Build Compilation
 457
 458 ;;{{{ Compilation
 459 (make-variable-buffer-local
 460  'compilation-finish-function)
 461 (make-variable-buffer-local
 462  'compilation-exit-message-function)
 463
 464 (setq
 465  compilation-finish-function
 466  'build-compilation-finish-function
 467  compilation-exit-message-function
 468  (function build-compilation-exit-message-function))
 469
 470 ;;}}}
 471
 472 (defun build-compilation-mode-hook ()
 473   (set (make-local-variable 'auto-save-hook)
 474        '(lambda ()
 475           (message "Auto-saved %s\n" (buffer-name))))
 476   (auto-save-mode 1)
 477   (insert
 478    (format
 479     "Compilation started at %s %+.4d (%s)\n"
 480     (current-time-string)
 481     (/ (nth 0 (current-time-zone)) 36)
 482     (nth 1 (current-time-zone)))))
 483
 484 (defun build-compilation-finish-function (comp-buffer finish-string)
 485   (message "Build Make finished in %s with status \"%s\"."
 486            (buffer-name comp-buffer) finish-string))
 487
 488 (defun build-compilation-exit-message-function (proc exit-msg)
 489   (message "Build Make exited with proc status \"%s\", exit status \"%s\", exit message \"%s\"."
 490            (process-status proc) (process-exit-status proc) exit-msg)
 491   (cons exit-msg (process-exit-status proc)))
 492
 493 ;;}}}
 494
 495 ;;{{{ Build Configure
 496
 497 (defconst build-configure-option-category
 498   "^\\(\\S-+\\).+\\(options\\|features\\):$"
 499   "REGEXP matching an XEmacs configuration option category in
 500 configure.usage")
 501
 502 (defconst build-configure-option-paragraph
 503   "^\\(--[a-zA-Z][-a-zA-Z0-9]+\\)\\(=\\(\\S-+\\)\\)?\\(\\s-+(\\*)\\)?\\s-+\\(\\(.+\\)\\(\n[ \t]+.+\\)*\\)$"
 504   "REGEXP matching one XEmacs configuration option in
 505 configure.usage")
 506
 507 (defun build-configure (&optional dir)
 508   "Configure XEmacs according to the settings in customized group
 509 `build' and its members."
 510   (interactive)
 511   (if dir
 512       (cd dir))
 513   (let ((cmd
 514          (format "sh configure%s"
 515                  (mapconcat
 516                   (function (lambda (e)
 517                               (cond
 518                                ((or (string= "" (rest e))
 519                                     (string= "autodetected" (rest e))
 520                                     (string= "defaulted" (rest e)))
 521                                 "")
 522                                ((string= "yes" (rest e))
 523                                 (format " '%s'" (first e)))
 524                                ((and
 525                                  (string-match "\\`--without-\\(.+\\)\\'" (first e))
 526                                  (string= "no" (rest e)))
 527                                 (format " '-with-%s'" (match-string 1 (first e))))
 528                                (t
 529                                 (format " '%s=%s'" (first e) (rest e))))))
 530                   (delete-duplicates
 531                    build-configure-options :from-end t
 532                    :test (lambda (a b)
 533                            (string=
 534                             (first a) (first b))))
 535                   "")))
 536         (compilation-mode-hook
 537          'build-compilation-mode-hook)
 538         (compilation-buffer-name-function
 539          '(lambda (mode)
 540             (generate-new-buffer-name
 541              (cond
 542               ((string-equal build-from-what "Tarballs")
 543                (concat build-tarball-prefix "-configure.err"))
 544               ((string-equal build-from-what "CVS")
 545                (concat build-cvs-checkout-dir "-configure.err")))
 546              ))))
 547     (compile cmd)))
 548
 549 ;;; Functionality which was prototyped in co2cu.el:
 550
 551 (defun build-configure-customize (a-list)
 552   (mapcar
 553    (lambda (cat)
 554      (princ (format "(defgroup build-configure-%s nil\n" (first cat)))
 555      (princ (format "  \"%s options.\"\n" (first cat)))
 556      (princ "  :group 'build-configure)\n\n")
 557      (list (first cat)
 558            (mapcar
 559             (lambda (opt)
 560               (cond
 561                ((or (member "TYPE[,TYPE]..." (second opt))
 562                     (and (member "TYPE" (second opt))
 563                          (string-match
 564                           "list\\s-+of"
 565                           (apply 'concat (fourth opt)))))
 566                 (build-configure-types cat opt)
 567                 )
 568                ((member "TYPE" (second opt))
 569                 (build-configure-type cat opt)
 570                 )
 571                ((member "FLAGS" (second opt))
 572                 (build-configure-string cat opt)
 573                 )
 574                ;; compiler=XXXX prior to r21.0-b34
 575                ((member "XXXX" (second opt))
 576                 (build-configure-file cat opt)
 577                 )
 578                ;; compiler=prog after Martin Buchholz's configure
 579                ;; mega-patch to r21.0-b34-pre2
 580                ((member "prog" (second opt))
 581                 (build-configure-file cat opt)
 582                 )
 583                ((member "VALUE" (second opt))
 584                 (build-configure-string cat opt)
 585                 )
 586                ((member "DIR" (second opt))
 587                 (build-configure-dir cat opt)
 588                 )
 589                ((member "LIB" (second opt))
 590                 (build-configure-file cat opt)
 591                 )
 592                ((member "PATH" (second opt))
 593                 (build-configure-path cat opt)
 594                 )
 595                ((or (null (second opt))
 596                     (subsetp (second opt)
 597                              '("no" "yes") :test 'string-equal))
 598                 (build-configure-type cat opt)
 599                 )
 600                (t
 601                 (build-configure-type cat opt)
 602                 )
 603                ))
 604             (delete-duplicates
 605              (cdr cat) :from-end t
 606              :test (lambda (a b)
 607                      (string=
 608                       (first a) (first b)))))))
 609    a-list))
 610
 611 (defun build-configure-process-option (option value detected doc category a-list)
 612   (let (prev-val prev-doc pos doc-vals)
 613     (unless (null value)
 614       (setq prev-val
 615             (first (cdr (assoc option (assoc category a-list)))))
 616       (setq prev-val
 617             (append prev-val (list value))))
 618     (setq detected
 619           (or
 620            (second (cdr (assoc option (assoc category a-list))))
 621            (null (null detected))))
 622     (setq prev-doc
 623           (third (cdr (assoc option (assoc category a-list)))))
 624     (unless (null doc)
 625       (setq prev-doc (append prev-doc (list doc)))
 626       (setq pos 0)
 627       (setq doc-vals (concat (first prev-doc)))
 628       (while (string-match "`\\(\\w+\\)'" doc pos)
 629         (setq prev-val
 630               (append prev-val (list (match-string 1 doc))))
 631         (setq pos (match-end 0)))
 632       (unless
 633           (null
 634            (string-match "\\([Vv]alid\\s-+types\\s-+are\\s-+\\|(\\)\\(\\(\\w+\\)\\(,\\s-*\\(\\(and\\|or\\)\\s-+\\)?\\(\\w+\\)\\)+\\)\\()\\|\\.\\)" doc 0))
 635         (setq doc-vals (match-string 2 doc))
 636         (setq pos 0)
 637         (while
 638             (string-match "\\(\\(,\\s-*\\(\\(and\\|or\\)\\s-+\\)?\\)?\\(\\w+\\)\\)" doc-vals pos)
 639           (setq prev-val
 640                 (append prev-val (list (match-string 5 doc-vals))))
 641           (setq pos (match-end 0)))))
 642     (setcdr
 643      (assoc category a-list)
 644      (acons
 645       option
 646       (list prev-val detected prev-doc)
 647       (cdr (assoc category a-list))))))
 648
 649 (defun build-configure-generate (&optional file)
 650   (interactive "fconfigure.usage file: ")
 651   (unless file
 652     (setq file
 653           (expand-file-name
 654            "configure.usage"
 655            (cond
 656             ((string-equal build-from-what "Tarballs")
 657              (expand-file-name
 658               build-tarball-prefix
 659               build-tarball-dest))
 660             ((string-equal build-from-what "CVS")
 661              (expand-file-name
 662               build-cvs-checkout-dir
 663               build-cvs-checkout-parent-dir))))))
 664   (let
 665       (category categories option value detected doc build-configure-alist
 666                 (buffer "build-configure.el"))
 667     (kill-buffer (get-buffer-create buffer))
 668     (with-output-to-temp-buffer buffer
 669       (save-window-excursion
 670         (find-file-read-only file)
 671         (build-configure-prolog file)
 672         (goto-char (point-min))
 673         (while (< (point) (point-max))
 674           (cond
 675            ((looking-at build-configure-option-paragraph)
 676             (goto-char (match-end 0))
 677             (build-configure-process-option
 678              (match-string 1)
 679              (match-string 3)
 680              (match-string 4)
 681              (match-string 5)
 682              category
 683              build-configure-alist))
 684            ((looking-at build-configure-option-category)
 685             (goto-char (match-end 0))
 686             (setq category (match-string 1))
 687             (setq build-configure-alist
 688                   (append build-configure-alist (list (list category)))))
 689            ;; We avoid matching a potentially zero-length string to
 690            ;; avoid infinite looping.
 691            ((looking-at
 692              "^.+$")
 693             (goto-char (match-end 0)))
 694            ((looking-at "\n")
 695             (goto-char (match-end 0)))))
 696         (build-configure-customize build-configure-alist)
 697 ;        (print build-configure-alist)
 698         ))
 699 ;    (set-buffer buffer)
 700 ;    (switch-to-buffer (get-buffer-create name))
 701     (kill-all-local-variables)
 702     (lisp-mode)
 703     (font-lock-mode 1)
 704     (toggle-read-only 1)))
 705
 706 (defun build-configure-string (cat opt)
 707   (princ (format "(defcustom build-configure%s\n" (first opt)))
 708   (princ "  \"\"\n")
 709   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 710   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 711   (princ "  :type '(string)\n")
 712   (princ "  :set 'build-configure-set-value)\n")
 713   (princ "\n"))
 714
 715 (defun build-configure-file (cat opt)
 716   (princ (format "(defcustom build-configure%s\n" (first opt)))
 717   (princ "  \"\"\n")
 718   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 719   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 720   (princ "  :type '(file)\n")
 721   (princ "  :set 'build-configure-set-value)\n")
 722   (princ "\n"))
 723
 724 (defun build-configure-dir (cat opt)
 725   (princ (format "(defcustom build-configure%s\n" (first opt)))
 726   (princ "  \"\"\n")
 727   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 728   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 729   (princ "  :type '(directory)\n")
 730   (princ "  :set 'build-configure-set-value)\n")
 731   (princ "\n"))
 732
 733 (defun build-configure-path (cat opt)
 734   (princ (format "(defcustom build-configure%s\n" (first opt)))
 735   (princ "  '()\n")
 736   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 737   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 738   (princ "  :type '(repeat\n")
 739   (princ "          :custom-show t\n")
 740   (princ "          :documentation-shown t\n")
 741   (princ "          (directory))\n")
 742   (princ "  :set 'build-set-path)\n")
 743   (princ "\n"))
 744
 745 (defun build-configure-types (cat opt)
 746   (princ (format "(defcustom build-configure%s\n" (first opt)))
 747   (princ (format "  '(%S)\n"
 748                  (if (third opt) "autodetected" "defaulted")))
 749   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 750   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 751   (princ "  :type '(choice\n")
 752   (if (third opt)
 753       (princ "          (const (\"autodetected\"))\n")
 754     (princ "          (const (\"defaulted\"))\n"))
 755   (princ "          (const (\"no\"))\n")
 756   (princ "          (set")
 757   (mapc (lambda (e)
 758           (princ (format "\n           (const %S)" e)))
 759         (set-difference
 760          (second opt)
 761          '("no" "TYPE[,TYPE]..." "TYPE")
 762          :test 'string=))
 763   (princ "))\n")
 764   (princ "  :set 'build-set-types)\n")
 765   (princ "\n"))
 766
 767 (defun build-configure-type (cat opt)
 768   (princ (format "(defcustom build-configure%s\n" (first opt)))
 769   (princ (format "  %S\n"
 770                  (if (third opt) "autodetected" "defaulted")))
 771   (princ (format "  %S\n" (build-configure-fill-doc (fourth opt))))
 772   (princ (format "  :group \'build-configure-%s\n" (first cat)))
 773   (princ "  :type '(choice\n")
 774   (if (third opt)
 775       (princ "          (const \"autodetected\")\n")
 776     (princ "          (const \"defaulted\")\n"))
 777   (princ "          (const \"no\")")
 778   (if (subsetp (second opt) '("no" "yes") :test 'string-equal)
 779       (princ "\n          (const \"yes\")")
 780     (mapc (lambda (e)
 781             (princ (format "\n          (const %S)" e)))
 782           (set-difference
 783            (second opt)
 784            '("no" "TYPE[,TYPE]..." "TYPE")
 785            :test 'string=)))
 786   (princ ")\n")
 787   (princ "  :set 'build-configure-set-value)\n")
 788   (princ "\n"))
 789
 790 (defun build-configure-fill-doc (doc)
 791   (with-temp-buffer
 792     (let ((sentence-end-double-space t)
 793           (use-hard-newlines t)
 794           (colon-double-space t))
 795       (insert (mapconcat 'eval doc "  "))
 796       (canonically-space-region (point-min) (point-max))
 797       (fill-region (point-min) (point-max))
 798       (goto-char (point-min))
 799       (while (re-search-forward "\\s-+\\'" nil t)
 800         (replace-match "" nil nil))
 801       (buffer-string))))
 802
 803 (defun build-configure-prolog (file)
 804   (princ ";;; Produced from
 805 ;;; ")
 806   (princ file)
 807   (princ "
 808 ;;; by ")
 809   (princ
 810    ;; Make sure the RCS keyword Id does not end up in the output file,
 811    ;; in case build.el is not `co -kv ...' or during development.
 812    (with-temp-buffer
 813      (insert build-version)
 814      (while (re-search-backward "\\$" nil t)
 815        (replace-match "" nil nil))
 816      (buffer-string)))
 817   (princ "\n;;; at\n;;; ")
 818   (princ (format-time-string "%a %b %d %T %Z %Y"))
 819   (princ "
 820 (provide 'build-configure)\n
 821 (setq build-configure-options nil)\n
 822 (defun build-configure-sym-to-opt (sym)
 823   (substring (symbol-name sym) 15))\n
 824 (defun build-set-path (sym val)
 825   (setq  build-configure-options
 826          (acons (build-configure-sym-to-opt sym)
 827                 (mapconcat '(lambda (item) item) val \":\")
 828                 build-configure-options))
 829   (set-default sym val))\n
 830 (defun build-set-types (sym val)
 831   (setq build-configure-options
 832         (acons (build-configure-sym-to-opt sym)
 833                (mapconcat '(lambda (item) item) val \",\")
 834                build-configure-options))
 835   (set-default sym val))\n
 836 (defun build-configure-set-value (sym val)
 837   (setq build-configure-options
 838         (acons (build-configure-sym-to-opt sym) val
 839                build-configure-options))
 840   (set-default sym val))\n
 841 (defgroup build-configure nil
 842   \"XEmacs Build Configuration.\"
 843   :group 'build)\n
 844 "))
 845
 846 ;;}}}
 847
 848 ;;{{{ Build CVS
 849
 850 (defvar build-cvs-available-p nil
 851   "Internal variable keeping track whether CVS is available.")
 852
 853 (defgroup build-cvs nil
 854   "Standardizes the fetching of XEmacs from the CVS repository."
 855   :group 'build)
 856
 857 (defun build-cvs-get-branch-and-release-tags ()
 858   "Retrieve all symbolic names (CVS tags) for XEmacs from version.sh."
 859   (interactive)
 860   (let*
 861       (exit-status
 862        (file "XEmacs/xemacs/version.sh")
 863        (co-command
 864         (list
 865          "cvs" "-d" build-cvs-xemacs-repository "checkout" file))
 866        (status-command
 867         (list
 868          "cvs" "-d" build-cvs-xemacs-repository "status" "-v" file))
 869        infile
 870        (buffer (list t t))
 871        displayp
 872        result
 873        last-match-end
 874        this-match-beginning
 875        tags)
 876     (with-temp-buffer
 877       (cd (temp-directory))
 878       (unless
 879           (file-exists-p file)
 880         (message-or-box
 881          "build: checking out %s to determine cvs tags" file)
 882         (setq result
 883               (build-call-process co-command infile buffer displayp))
 884         (cond
 885          ((null (car result))
 886           (warn "\nprogram %s cannot be found or executed\n"
 887                 (car co-command)))
 888          ((/= (car result) 0)
 889           (warn "\n%s\nfailed with following output:\n%s\n"
 890                 (mapconcat 'identity co-command " ")
 891                 (cdr result)))
 892          (t
 893           (message-or-box
 894            "build: %s has been checked out" file))))
 895       (message-or-box
 896        "build: retrieving cvs tags from %s" file)
 897       (setq result
 898             (build-call-process status-command infile buffer displayp))
 899       (cond
 900        ((null (car result))
 901         (warn "\nprogram %s cannot be found or executed\n"
 902               (car status-command)))
 903        ((/= (car result) 0)
 904         (warn "\n%s\nfailed with following output:\n%s\n"
 905               (mapconcat 'identity status-command " ")
 906               (cdr result)))
 907        (t
 908         (message-or-box
 909          "build: cvs tags have been retrieved from %s" file)))
 910       (if
 911           (setq this-match-beginning
 912                 (string-match "^\\s-+Existing Tags:\n" (cdr result)))
 913           (setq last-match-end (match-end 0)))
 914       (while
 915           (and
 916            (setq this-match-beginning
 917                  (string-match
 918                   "\t\\(\\S-+\\)\\s-+\\(.*\\)\n" (cdr result) last-match-end))
 919            (= last-match-end this-match-beginning))
 920         (setq last-match-end (match-end 0))
 921         (if last-match-end
 922             (push (list
 923                    (match-string 1 (cdr result))
 924                    (match-string 2 (cdr result))) tags)))
 925       (reverse tags))))
 926
 927 (defun build-cvs-checkout-options-validate (sym val)
 928   (cond
 929    ((string-match "-\\(d\\|N\\)\\b" val)
 930     (customize-set-value sym build-cvs-checkout-options)
 931     (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."))
 932    (t
 933     (build-cvs-set-var-and-update-buffer sym val))))
 934
 935 (defun build-cvs-set-var-and-update-buffer (sym val)
 936   "Internal function for build."
 937   (set-default sym val)
 938   (when (fboundp 'build-from-CVS)
 939     (save-window-excursion
 940       (save-excursion
 941         (build-from-CVS)))))
 942
 943 (defcustom build-cvs-checkout-options
 944   "-P"
 945   "CVS checkout command-line options to use for all CVS commands."
 946   :type 'string
 947   :set 'build-cvs-checkout-options-validate
 948   :group 'build-cvs)
 949
 950 (defcustom build-cvs-options
 951   "-z3"
 952   "CVS command-line options to use for all CVS commands."
 953   :type 'string
 954   :set 'build-cvs-set-var-and-update-buffer
 955   :group 'build-cvs)
 956
 957 (defcustom build-cvs-update-options
 958   "-P -d"
 959   "CVS update command-line options to use for all CVS commands."
 960   :type 'string
 961   :set 'build-cvs-set-var-and-update-buffer
 962   :group 'build-cvs)
 963
 964 (defcustom build-cvs-checkout-parent-dir
 965   (temp-directory)
 966   "The parent directory on the local host into which the
 967 `build-cvs-xemacs-module' will be checked out, named according to
 968 `build-cvs-checkout-dir'."
 969   :type 'directory
 970   :set 'build-cvs-set-var-and-update-buffer
 971   :group 'build-cvs)
 972
 973 (defconst build-cvs-xemacs-module
 974   "xemacs"
 975   "CVS XEmacs module name to be checked out.")
 976
 977 (defvar build-cvs-checkout-dir
 978   nil
 979   "Internal variable updated from user variable
 980   `build-cvs-working-dir-naming'.")
 981
 982 (defcustom build-cvs-use-pcl-cvs
 983   nil
 984   "*Whether build is to use PCL-CVS, when available.
 985 Alternatively, build will run CVS commands via `compile'."
 986   :type 'boolean
 987   :set 'build-cvs-set-var-and-update-buffer
 988   :group 'build-cvs)
 989
 990 (defcustom build-cvs-xemacs-repository
 991   ":pserver:cvs@cvs.xemacs.org:/pack/xemacscvs"
 992   "CVS Repository where XEmacs can be checked out from."
 993   :type 'string
 994   :set 'build-cvs-set-var-and-update-buffer
 995   :group 'build-cvs)
 996
 997 (defcustom build-cvs-working-dir-naming
 998   '(format "%s-%s"
 999            build-cvs-xemacs-module
1000            build-cvs-xemacs-release)
1001   "The naming of the directory on the local host into which the
1002 `build-cvs-xemacs-module' will be checked out. Be aware that cvs
1003 checkout options -d and -N will affect the resulting directory
1004 structure.  Therefor these options are disallowed in
1005 `build-cvs-checkout-options'.  The -N option is not supported, in order
1006 to avoid unknown directory structures."
1007   :type '(choice
1008           (const :tag "Named after CVS MODULE" build-cvs-xemacs-module)
1009           (const :tag "Named after RELEASE Tag" build-cvs-xemacs-release)
1010           (const :tag "Named after MODULE-RELEASE"
1011                  (format "%s-%s"
1012                          build-cvs-xemacs-module
1013                          build-cvs-xemacs-release))
1014           (string :tag "Working Dir Named manually" ""))
1015   :set 'build-cvs-set-var-and-update-buffer
1016   :group 'build-cvs)
1017
1018 (defcustom build-cvs-xemacs-release
1019   "HEAD"
1020   "CVS XEmacs release to be checked out.
1021 The list of available releases is updated via cvs, if installed, by
1022 `build-from-CVS'.  Use \"Specify Tag Name\" to fill in the name of a
1023 release tag not yet in the list of choices."
1024   :type '(choice :custom-state t
1025                  (string :tag "Unlisted Release Name" "")
1026                  (const :tag "release-21-1 (branch: 1.165.2)" "release-21-1")
1027                  (const :tag "release-21-4 (branch: 1.166.2)" "release-21-4")
1028                  (const :tag "r21-5-9 (revision: 1.183)" "r21-5-9"))
1029   :set 'build-cvs-set-var-and-update-buffer
1030   :group 'build-cvs)
1031
1032 (defun build-cvs-login ()
1033   "Login to XEmacs CVS repository."
1034   (interactive)
1035   (unless (file-exists-p build-cvs-checkout-parent-dir)
1036     (make-directory build-cvs-checkout-parent-dir t))
1037   (cd build-cvs-checkout-parent-dir)
1038   (let (exit-status
1039         (command
1040          (list
1041           "cvs" build-cvs-options "-d" build-cvs-xemacs-repository "login"))
1042         (file (make-temp-name (expand-file-name "cvs-login" (getenv "TEMP"))))
1043         (buffer (list t t))
1044         displayp)
1045     (with-temp-file file (insert "cvs\n"))
1046     (message-or-box "build: cvs login at cvs.xemacs.org, please wait")
1047     (setq result
1048           (build-call-process command file buffer displayp))
1049     (cond
1050      ((null (car result))
1051       (setq build-cvs-available-p nil)
1052       (warn "\nprogram %s cannot be found or executed\n"
1053             (car command)))
1054      ((/= (car result) 0)
1055       (setq build-cvs-available-p nil)
1056       (warn "\n%s\nfails with following output:\n%s\n"
1057             (mapconcat 'identity command " ")
1058             (cdr result)))
1059      (t
1060       (setq build-cvs-available-p t)
1061       (message-or-box "build: cvs login succeeded")))
1062     (delete-file file)))
1063
1064 (defun build-cvs-checkout (&optional release-tag)
1065   "Fetch XEmacs from the repository."
1066   (interactive "sXEmacs Release Tag: ")
1067   (unless (file-exists-p build-cvs-checkout-parent-dir)
1068     (make-directory build-cvs-checkout-parent-dir t))
1069   (cd build-cvs-checkout-parent-dir)
1070   (let ((cmd
1071          (format "cvs %s -d%s checkout %s -d %s%s %s"
1072                  build-cvs-options
1073                  build-cvs-xemacs-repository
1074                  build-cvs-checkout-options
1075                  build-cvs-checkout-dir
1076                  (if (and release-tag
1077                           (not (string-equal release-tag "")))
1078                      (concat " -r " release-tag)
1079                    "")
1080                  build-cvs-xemacs-module))
1081         (compilation-mode-hook
1082          'build-compilation-mode-hook)
1083         (compilation-buffer-name-function
1084          '(lambda (mode)
1085             (generate-new-buffer-name
1086              (format "%s-cvs-checkout%s.err" build-cvs-checkout-dir
1087                      (if (and release-tag
1088                               (not (string-equal release-tag "")))
1089                          (format "-%s" release-tag)
1090                        ""))))))
1091     (compile cmd)))
1092
1093 (defun build-cvs-update (&optional release-tag)
1094   "Update XEmacs from the repository to newest release or to release
1095 specified by RELEASE-TAG'."
1096   (interactive "sXEmacs Release Tag: ")
1097   (cd
1098    (expand-file-name build-cvs-checkout-dir
1099                      build-cvs-checkout-parent-dir))
1100   (let ((cmd
1101          (format "cvs %s update %s%s"
1102                  build-cvs-options
1103                  build-cvs-update-options
1104                  (if (and release-tag
1105                           (not (string-equal release-tag "")))
1106                      (concat " -r " release-tag)
1107                    " -A")
1108                  ))
1109         (compilation-mode-hook
1110          'build-compilation-mode-hook)
1111         (compilation-buffer-name-function
1112          '(lambda (mode)
1113             (generate-new-buffer-name
1114              (concat build-cvs-checkout-dir "-cvs-update"
1115                      (when (and release-tag
1116                                 (not (string-equal release-tag "")))
1117                        (format "-%s" release-tag))
1118                      ".err")))))
1119     (cond
1120      ((and
1121        build-cvs-use-pcl-cvs
1122        (featurep 'pcl-cvs))
1123       (cvs-update
1124        (expand-file-name build-cvs-checkout-dir
1125                          build-cvs-checkout-parent-dir)
1126        (split-string build-cvs-update-options "\\s-+")))
1127      (t
1128       (compile cmd)))))
1129
1130 ;;}}}
1131
1132 ;;{{{ Build From
1133
1134 (defun build-from-CVS ()
1135   (interactive)
1136   (let
1137       ((name
1138         (format "*Build XEmacs From CVS With %s*" build-with-what)))
1139     (kill-buffer (get-buffer-create name))
1140     (switch-to-buffer (get-buffer-create name))
1141     (kill-all-local-variables)
1142     (unless (file-exists-p build-cvs-checkout-parent-dir)
1143       (make-directory build-cvs-checkout-parent-dir t))
1144     (cd build-cvs-checkout-parent-dir)
1145     ;; #### FIXME build-cvs-checkout-dir is not driven by custom
1146     ;; events as it should be!
1147     (setq build-cvs-checkout-dir
1148           (eval build-cvs-working-dir-naming))
1149     (put 'build-cvs-xemacs-release 'custom-type
1150          (append
1151           '(choice
1152             :custom-state t)
1153           (cons
1154            '(string :tag "Unlisted Release Name" "")
1155            (mapcar
1156             (function
1157              (lambda (tag)
1158                (list
1159                 'const
1160                 :tag (format "%s %s" (first tag) (second tag)) (first tag))))
1161             (build-cvs-get-branch-and-release-tags)))))
1162     (widget-insert "\n")
1163     (widget-create 'push-button
1164                    :notify (lambda (&rest ignore)
1165                              (let
1166                                  ((buffer-back "*Build XEmacs*"))
1167                                (if (buffer-live-p (get-buffer buffer-back))
1168                                    (switch-to-buffer buffer-back)
1169                                  (build))))
1170                    "Go Back")
1171     (widget-insert
1172      "\nYou need to customize CVS options and then download a release\nof XEmacs.\n\n")
1173     (widget-create 'push-button
1174                    :notify (lambda (&rest ignore)
1175                              (customize-browse 'build-cvs))
1176                    "Browse Build CVS Options ...")
1177     (widget-insert "\n")
1178     (widget-insert
1179      (format "\t%+20s: %s\n" "Use Pcl Cvs"
1180              (if build-cvs-use-pcl-cvs "Yes" "No")))
1181     (widget-insert
1182      (format "\t%+20s: \"%s\"\n" "XEmacs CVS Repository"
1183              build-cvs-xemacs-repository))
1184     (widget-insert
1185      (format "\t%+20s: \"%s\"\n" "CVS Options"
1186              build-cvs-options))
1187     (widget-insert
1188      (format "\t%+20s: \"%s\"\n" "Checkout Options"
1189              build-cvs-checkout-options))
1190     (widget-insert
1191      (format "\t%+20s: \"%s\"\n" "Update Options"
1192              build-cvs-update-options))
1193     (widget-insert
1194      (format "\t%+20s: \"%s\"\n" "XEmacs Module"
1195              build-cvs-xemacs-module))
1196     (widget-insert
1197      (format "\t%+20s: \"%s\"\n" "XEmacs Release"
1198              build-cvs-xemacs-release))
1199     (widget-insert
1200      (format "\t%+20s: %S\n" "Working Dir Naming"
1201              build-cvs-working-dir-naming))
1202     (widget-insert
1203      (format "\t%+20s: \"%s\"\n" "Checkout Parent Dir"
1204              build-cvs-checkout-parent-dir))
1205     (widget-insert
1206      (format "\t%+20s: \"%s\"\n" "Working Dir"
1207              build-cvs-checkout-dir))
1208     (widget-insert "\n")
1209     (widget-create 'push-button
1210                    :notify (lambda (&rest ignore)
1211                              (build-cvs-login))
1212                    "CVS Login XEmacs")
1213     (widget-insert "\n\n")
1214     (widget-create 'push-button
1215                    :notify (lambda (&rest ignore)
1216                              (build-cvs-checkout
1217                               build-cvs-xemacs-release))
1218                    "CVS Checkout XEmacs")
1219     (widget-insert "\n\n")
1220     (widget-create 'push-button
1221                    :notify (lambda (&rest ignore)
1222                              (build-cvs-update
1223                               build-cvs-xemacs-release))
1224                    (format
1225                     "CVS Update XEmacs To CVS Tag \"%s\""
1226                     build-cvs-xemacs-release))
1227     (widget-insert "\nor\n")
1228     (widget-create 'push-button
1229                    :notify (lambda (&rest ignore)
1230                              (build-cvs-update))
1231                    "CVS Update To Latest XEmacs on Trunk")
1232     (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")
1233     (widget-create 'push-button
1234                    :notify (lambda (&rest ignore)
1235                              (let
1236                                  ((dir
1237                                    (cond
1238                                     ((string-equal build-with-what "GNU Tools")
1239                                      (expand-file-name
1240                                       build-cvs-checkout-dir
1241                                       build-cvs-checkout-parent-dir))
1242                                     ((string-equal build-with-what "Microsoft Tools")
1243                                      (expand-file-name
1244                                       "nt"
1245                                       (expand-file-name
1246                                        build-cvs-checkout-dir
1247                                        build-cvs-checkout-parent-dir))))))
1248                                (if
1249                                    (file-directory-p
1250                                     (file-name-as-directory dir))
1251                                    (cond
1252                                     ((string-equal build-with-what "GNU Tools")
1253                                      (build-with-GNU dir))
1254                                     ((string-equal build-with-what "Microsoft Tools")
1255                                      (build-with-MS dir)))
1256                                  (message-or-box "need to checkout to create %s?" dir))))
1257                    (format "Build XEmacs With %s Now ..." build-with-what))
1258     (use-local-map widget-keymap)
1259     (widget-setup)
1260     (custom-mode)
1261     (goto-char (point-min))))
1262
1263 (defun build-from-tarballs ()
1264   (interactive)
1265   (let
1266       ((name
1267         (format "*Build XEmacs From Tarballs With %s*" build-with-what)))
1268     (kill-buffer (get-buffer-create name))
1269     (switch-to-buffer (get-buffer-create name))
1270     (kill-all-local-variables)
1271     (cd build-tarball-dest)
1272     (widget-insert "\n")
1273     (widget-create 'push-button
1274                    :notify (lambda (&rest ignore)
1275                              (let
1276                                  ((buffer-back "*Build XEmacs*"))
1277                                (if (buffer-live-p (get-buffer buffer-back))
1278                                    (switch-to-buffer buffer-back)
1279                                  (build))))
1280                    "Go Back")
1281     (widget-insert
1282      "\nYou need to customize Tarball options and then download a beta/release\nversion of XEmacs.\n\n")
1283     (widget-create 'push-button
1284                    :notify (lambda (&rest ignore)
1285                              (customize-browse 'build-tarball))
1286                    "Browse Build Tarball Options ...")
1287     (widget-insert "\n\t")
1288     (widget-create 'push-button
1289                    :notify (lambda (&rest ignore)
1290                              (dired build-tarball-site))
1291                    "Browse Build Tarball Site ...")
1292     (widget-insert "\n\t")
1293     (widget-create 'push-button
1294                    :notify (lambda (&rest ignore)
1295                              (build-tarball-expand-all))
1296                    "View Build Tarball Set ...")
1297     (widget-insert "\n\t")
1298     (widget-create 'push-button
1299                    :notify (lambda (&rest ignore)
1300                              (build-tarball-get-all))
1301                    "Download Build Tarball Set")
1302     (widget-insert "\n\t")
1303     (widget-create 'push-button
1304                    :notify (lambda (&rest ignore)
1305                              (build-tarball-extract-all))
1306                    "Install Downloaded Build Tarball Set")
1307     (widget-insert "\n\n")
1308     (widget-create 'push-button
1309                    :notify (lambda (&rest ignore)
1310                              (cond
1311                               ((string-equal build-with-what "GNU Tools")
1312                                (build-with-GNU
1313                                 (expand-file-name
1314                                  build-tarball-prefix
1315                                  build-tarball-dest)))
1316                               ((string-equal build-with-what "Microsoft Tools")
1317                                (build-with-MS
1318                                 (expand-file-name
1319                                  "nt"
1320                                  (expand-file-name
1321                                   build-tarball-prefix
1322                                   build-tarball-dest))))))
1323                    (format "Build XEmacs With %s Now ..." build-with-what))
1324     (use-local-map widget-keymap)
1325     (widget-setup)
1326     (custom-mode)
1327     (goto-char (point-min))))
1328
1329 ;;}}}
1330
1331 ;;{{{ Build Tarballs
1332
1333 (defgroup build-tarball nil
1334   "Standardized the fetching of XEmacs beta/release tarballs."
1335   :group 'build)
1336
1337 (defcustom build-tarball-dest
1338   (temp-directory)
1339   "The destination directory on the local host the `build-tarball-set'
1340 will be deposited in."
1341   :type 'directory
1342   :group 'build-tarball)
1343
1344 (defcustom build-tarball-dir
1345   "beta"
1346   "The sub-directory under `build-tarball-site' in which the
1347 `build-tarball-set' is located."
1348   :type '(choice
1349           :custom-state t
1350           (const "beta")
1351           (const "gamma")
1352           (const "stable"))
1353   :group 'build-tarball)
1354
1355 (defcustom build-tarball-prefix
1356   "xemacs-21.5.6"
1357   "The prefix shared among all of the `build-tarball-set'.  This makes
1358 it easy to switch over from one beta/gamma/stable release tarball set
1359 to the next,
1360 e.g. from \"xemacs-21.5.5\" to \"xemacs-21.5.6\"."
1361   :type 'string
1362   :group 'build-tarball)
1363
1364 (defcustom build-tarball-set
1365   nil
1366   "The set of final name components of XEmacs tarballs you wish to
1367 fetch."
1368   :type'(set
1369          (const :tag "XEmacs byte-compiled lisp tarball" "-elc.tar.gz")
1370          (const :tag "XEmacs byte-compiled lisp tarball signature" "-elc.tar.gz.asc")
1371          (const :tag "XEmacs info tarball" "-info.tar.gz")
1372          (const :tag "XEmacs info tarball signature" "-info.tar.gz.asc")
1373          (const :tag "XEmacs Mule tarball" "-mule.tar.gz")
1374          (const :tag "XEmacs Mule tarball signature" "-mule.tar.gz.asc")
1375          (const :tag "XEmacs source tarball" ".tar.gz")
1376          (const :tag "XEmacs source tarball signature" ".tar.gz.asc")
1377          (repeat
1378           :custom-show t
1379           :documentation-shown t
1380           (string "")))
1381   :group 'build-tarball)
1382
1383 (defcustom build-tarball-site
1384   "/ftp@ftp.xemacs.org:/pub/xemacs/"
1385   "The EFS path to a top-level XEmacs directory to fetch the XEmacs
1386   `build-tarball-set' from.
1387 The list of available sites is dynamically generated based on
1388 `package-get-download-sites'.  In addition you may set the value to a
1389 manually chosen EFS path."
1390   :link '(url-link :tag "XEmacs Download Locations"
1391                    "http://www.xemacs.org/Download/")
1392   :type (append
1393          '(choice :custom-state t)
1394          (cons
1395           '(directory :tag "EFS Path" "/user@host.domain:/directory/")
1396           (remove
1397            nil
1398            (mapcar
1399             (function
1400              (lambda (entry)
1401                (let (comment host path efs-path)
1402                  (setq comment (nth 0 entry)
1403                        host (nth 1 entry)
1404                        path (nth 2 entry))
1405                  (when
1406                      (and host
1407                           (not (string-equal comment "Pre-Releases")))
1408                    (setq efs-path (format "/ftp@%s:/%s" host path))
1409                    (list
1410                     'const
1411                     :tag (format "%s - %s" efs-path comment)
1412                     (file-name-directory efs-path))))))
1413             package-get-download-sites))))
1414   :group 'build-tarball)
1415
1416 (defun build-tarball-expand (item)
1417   (let ((prfx
1418          (expand-file-name
1419           build-tarball-prefix
1420           (concat build-tarball-site build-tarball-dir))))
1421     (concat prfx item)))
1422
1423 (defun build-tarball-collapse (item)
1424   (let ((str
1425          (concat build-tarball-site build-tarball-dir build-tarball-prefix)))
1426     (string-match str item)
1427     (replace-match "" t t item)))
1428
1429 (defun build-tarball-get (file)
1430   (if (not (featurep 'efs))
1431       (message-or-box
1432        "please install efs to be able to \"Download Build Tarball Set\".")
1433     (let ((efs-mode-hook
1434            '(lambda ()
1435               (set (make-local-variable 'efs-expire-ftp-buffers) nil)
1436               (set (make-local-variable 'auto-save-hook)
1437                    '(lambda ()
1438                       (message "Auto-saved %s\n" (buffer-name))))
1439               (auto-save-mode 1))))
1440       (efs-copy-file
1441        (build-tarball-expand file)
1442        (concat
1443         (expand-file-name
1444          build-tarball-prefix build-tarball-dest)
1445         file)
1446        1 nil t))))
1447
1448 (defun build-tarball-extract (file)
1449   (cd build-tarball-dest)
1450   (let ((cmd
1451          (format "gunzip -c %s%s | tar -xvf -" build-tarball-prefix file))
1452         (compilation-mode-hook
1453          'build-compilation-mode-hook)
1454         (compilation-buffer-name-function
1455          '(lambda (mode)
1456             (generate-new-buffer-name
1457              (concat
1458               (file-name-sans-extension
1459                (file-name-sans-extension
1460                 (concat build-tarball-prefix file))) "-toc.err"))))
1461         )
1462     (if (string-match "tar\\.gz$" file)
1463         (compile cmd)
1464       (warn "%s is not a tar.gz file, skipped."
1465             (concat build-tarball-prefix file)))))
1466
1467 (defun build-tarball-get-all ()
1468   "Get all the expanded files of `build-tarball-set'.
1469 Use `build-tarball-expand-all' to find out which tarballs would be
1470 fetched by this function.  All tarballs are saved under
1471 `build-tarball-dest'"
1472   (interactive)
1473   (mapc 'build-tarball-get build-tarball-set))
1474
1475 (defun build-tarball-extract-all ()
1476   "Extract all files from the locally present `build-tarball-set' which
1477 have to be in \".tar.gz\" format."
1478   (interactive)
1479   (mapc 'build-tarball-extract build-tarball-set))
1480
1481 (defun build-tarball-expand-all ()
1482   "Print the expanded value of `build-tarball-set' to temporary buffer
1483 \"*Build Tarball Set*\"."
1484   (interactive)
1485   (cd build-tarball-dest)
1486   (with-output-to-temp-buffer
1487       "*Build Tarball Set*"
1488     (princ (mapconcat 'build-tarball-expand build-tarball-set "\n"))))
1489
1490 (defun build-tarball-add-url ()
1491   "Add URL near point to `build-tarball-set' via
1492 `url-get-url-at-point'."
1493   (interactive)
1494   (setq build-tarball-set (cons (url-get-url-at-point) build-tarball-set)))
1495
1496 ;;}}}
1497
1498 ;;{{{ Build With
1499
1500 (defvar build-with-MS-has-config-inc
1501   nil
1502   "Internal variable indicating whether the XEmacs to be built has
1503 support for config.inc.")
1504
1505 (defgroup build-with-MS nil
1506   "Standardizes the building of XEmacs with MiroSoft tools."
1507   :group 'build)
1508
1509 (defcustom build-with-MS-make-command
1510   "nmake"
1511   "Path of Microsoft make utility used to build XEmacs."
1512   :type 'file
1513   :group 'build-with-MS)
1514
1515 (defcustom build-with-MS-make-options
1516   '("/f xemacs.mak")
1517   "Options to use with Microsoft make utility when building XEmacs."
1518   :type '(repeat string)
1519   :group 'build-with-MS)
1520
1521 (defun build-with-GNU (dir)
1522   (interactive)
1523   (let
1524       ((name "*Build XEmacs With GNU Tools*"))
1525     ;; Overwrite any customized setting for this build session so
1526     ;; that build-report will find the right information.
1527     (customize-set-variable
1528      'build-report-installation-file
1529      (expand-file-name "Installation" dir))
1530     (customize-set-variable
1531      'build-report-version-file
1532      (expand-file-name "version.sh" dir))
1533     (kill-buffer (get-buffer-create name))
1534     (switch-to-buffer (get-buffer-create name))
1535     (kill-all-local-variables)
1536     (cd dir)
1537     (widget-insert "\n")
1538     (widget-create 'push-button
1539                    :notify (lambda (&rest ignore)
1540                              (let
1541                                  (buffer-back get-back)
1542                                (cond
1543                                 ((string-equal build-from-what "Tarballs")
1544                                  (setq buffer-back "*Build XEmacs From Tarballs With GNU Tools*")
1545                                  (setq get-back 'build-from-tarballs))
1546                                 ((string-equal build-from-what "CVS")
1547                                  (setq buffer-back "*Build XEmacs From CVS With GNU Tools*")
1548                                  (setq get-back 'build-from-CVS)))
1549                                (if (buffer-live-p (get-buffer buffer-back))
1550                                    (switch-to-buffer buffer-back)
1551                                  (funcall get-back))))
1552                    "Go Back")
1553     (widget-insert "\n\n")
1554     (widget-create 'push-button
1555                    :notify (lambda (&rest ignore)
1556                              (build-configure-generate "configure.usage"))
1557                    "Generate Build Configure")
1558     (widget-insert "\n\t")
1559     (widget-apply
1560      (widget-create 'push-button
1561                     :notify (lambda (&rest ignore)
1562                               (eval-buffer "build-configure.el"))
1563                     "Activate Generated Build Configure")
1564      (if (boundp 'build-configure-options)
1565          :deactivate
1566        :activate))
1567     (when (boundp 'build-configure-options)
1568       (widget-insert
1569        "\n\tYou will need to restart XEmacs first if you want to activate the\n\tgenerated interface to Build Make again."))
1570     (widget-insert "\n\t")
1571     (widget-create 'push-button
1572                    :notify (lambda (&rest ignore)
1573                              (customize-browse 'build-configure))
1574                    "Browse Build Configure ...")
1575     (widget-insert "\n\t")
1576     (widget-create 'push-button
1577                    :notify (lambda (&rest ignore)
1578                              (build-configure))
1579                    "Run XEmacs Configure")
1580     (widget-insert "\n\n")
1581     (widget-create 'push-button
1582                    :notify (lambda (&rest ignore)
1583                              (build-make-generate))
1584                    "Generate XEmacs Make")
1585 ;    (widget-insert "\n\t")
1586 ;    (widget-create 'push-button
1587 ;                  :notify (lambda (&rest ignore)
1588 ;                            (customize-browse 'build-make))
1589 ;                  "Browse Build-Make")
1590     (widget-insert "\n\t")
1591     (widget-create 'push-button
1592                    :notify (lambda (&rest ignore)
1593                              (call-interactively 'build-make))
1594                    "Run XEmacs Make")
1595     (widget-insert "\n\n")
1596     (widget-create 'push-button
1597                    :notify (lambda (&rest ignore)
1598                              (build-build-report))
1599                    "Generate XEmacs Build Report ...")
1600     (widget-insert "\n\n")
1601     (use-local-map widget-keymap)
1602     (widget-setup)
1603     (custom-mode)
1604     (goto-char (point-min))))
1605
1606 (defun build-with-MS (dir)
1607   (interactive "DXEmacs source directry: ")
1608   (let
1609       ((name "*Build XEmacs With Microsoft Tools*"))
1610     ;; Overwrite any customized setting for this build session so
1611     ;; that build-report will find the right information.
1612     (customize-set-variable
1613      'build-report-installation-file
1614      (expand-file-name
1615       "Installation"
1616       (expand-file-name
1617        ".."
1618        dir)))
1619     (customize-set-variable
1620      'build-report-version-file
1621      (expand-file-name
1622       "version.sh"
1623       (expand-file-name
1624        ".."
1625        dir)))
1626     (setq build-with-MS-has-config-inc
1627           (multiple-value-bind
1628               (major minor beta codename)
1629               (build-report-version-file-data
1630                build-report-version-file)
1631             ;; APA: config.inc file was introduced by Ben Wing in 21.2-b32.
1632             (if
1633                 (and
1634                  (>= (string-to-int major) 21)
1635                  (or
1636                   ;; 21.2 versions >= b32
1637                   (and
1638                    (= (string-to-int minor) 2)
1639                    (>= (string-to-int beta) 32))
1640                   ;; 21 versions with minor number > 2
1641                   (> (string-to-int minor) 2)))
1642                 t
1643               nil)))
1644     (kill-buffer (get-buffer-create name))
1645     (switch-to-buffer (get-buffer-create name))
1646     (kill-all-local-variables)
1647     (cd (expand-file-name "" dir))
1648     (widget-insert "\n")
1649     (widget-create 'push-button
1650                    :notify (lambda (&rest ignore)
1651                              (let
1652                                  (buffer-back get-back)
1653                                (cond
1654                                 ((string-equal build-from-what "Tarballs")
1655                                  (setq buffer-back "*Build XEmacs From Tarballs With Microsoft Tools*")
1656                                  (setq get-back 'build-from-tarballs))
1657                                 ((string-equal build-from-what "CVS")
1658                                  (setq buffer-back "*Build XEmacs From CVS With Microsoft Tools*")
1659                                  (setq get-back 'build-from-CVS)))
1660                                (if (buffer-live-p (get-buffer buffer-back))
1661                                    (switch-to-buffer buffer-back)
1662                                  (funcall get-back))))
1663                    "Go Back")
1664     (widget-insert "\n")
1665     (widget-insert
1666      "\nYou need to customize Microsoft Tools options.\n\n")
1667     (widget-create 'push-button
1668                    :notify (lambda (&rest ignore)
1669                              (customize-browse 'build-with-MS))
1670                    "Browse Build With MS Options ...")
1671     (widget-insert "\n\n")
1672     (widget-create 'push-button
1673                    :notify (lambda (&rest ignore)
1674                              (build-make-generate "xemacs.mak"))
1675                    "Generate XEmacs Make")
1676     (widget-insert "\n\t")
1677     (widget-apply
1678      (widget-create 'push-button
1679                     :notify (lambda (&rest ignore)
1680                               (eval-buffer "build-make.el"))
1681                     "Activate Generated Build Make")
1682      (if (boundp 'build-make-options)
1683          :deactivate
1684        :activate))
1685     (when (boundp 'build-make-options)
1686       (widget-insert
1687        "\n\tYou will need to restart XEmacs to activate\n\tthe generated interface to Build Make again."))
1688     (widget-insert "\n\t")
1689     (widget-create 'push-button
1690                    :notify (lambda (&rest ignore)
1691                              (customize-browse 'build-make))
1692                    "Browse Build Make ...")
1693     (widget-insert "\n\t")
1694     (widget-apply
1695      (widget-create 'push-button
1696                     :notify (lambda (&rest ignore)
1697                               (eval-buffer "build-make.el")
1698                               (build-config-inc-generate))
1699                     "Generate config.inc")
1700      (if build-with-MS-has-config-inc
1701          :activate
1702        :deactivate))
1703     (widget-insert
1704      "\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!")
1705     (widget-insert "\n\n")
1706     (widget-create 'push-button
1707                    :notify (lambda (&rest ignore)
1708                              (build-make
1709                               "distclean"
1710                               (mapconcat
1711                                'identity
1712                                (cons
1713                                 build-with-MS-make-command
1714                                 build-with-MS-make-options)
1715                                " ")))
1716                    "Clean XEmacs Distribution")
1717     (widget-insert "\n\n")
1718     (widget-create 'push-button
1719                    :notify (lambda (&rest ignore)
1720                              (build-make
1721                               "all"
1722                               (concat
1723                                (mapconcat
1724                                 'identity
1725                                 (cons
1726                                  build-with-MS-make-command
1727                                  build-with-MS-make-options)
1728                                 " ")
1729                                (unless build-with-MS-has-config-inc
1730                                  (build-make-get-option-string)))))
1731                    "Build XEmacs")
1732     (widget-insert "\n\n")
1733     (widget-create 'push-button
1734                    :notify (lambda (&rest ignore)
1735                              (build-make
1736                               "install"
1737                               (concat
1738                                (mapconcat
1739                                 'identity
1740                                 (cons
1741                                  build-with-MS-make-command
1742                                  build-with-MS-make-options)
1743                                 " ")
1744                                (unless build-with-MS-has-config-inc
1745                                  (build-make-get-option-string)))))
1746                    "Build and Install XEmacs")
1747     (widget-insert "\n\n")
1748     (widget-create 'push-button
1749                    :notify (lambda (&rest ignore)
1750                              (build-make
1751                               "check-temacs"
1752                               (concat
1753                                (mapconcat
1754                                 'identity
1755                                 (cons
1756                                  build-with-MS-make-command
1757                                  build-with-MS-make-options)
1758                                 " ")
1759                                (unless build-with-MS-has-config-inc
1760                                  (build-make-get-option-string)))))
1761                    "Check temacs (XEmacs before dumping)")
1762     (widget-insert "\n\n")
1763     (widget-create 'push-button
1764                    :notify (lambda (&rest ignore)
1765                              (build-make
1766                               "check"
1767                               (concat
1768                                (mapconcat
1769                                 'identity
1770                                 (cons
1771                                  build-with-MS-make-command
1772                                  build-with-MS-make-options)
1773                                 " ")
1774                                (unless build-with-MS-has-config-inc
1775                                  (build-make-get-option-string)))))
1776                    "Check XEmacs")
1777     (widget-insert "\n\n")
1778     (widget-create 'push-button
1779                    :notify (lambda (&rest ignore)
1780                              (build-build-report))
1781                    "Generate XEmacs Build Report ...")
1782     (widget-insert "\n\n")
1783     (use-local-map widget-keymap)
1784     (widget-setup)
1785     (custom-mode)
1786     (goto-char (point-min))))
1787
1788 ;;}}}
1789
1790 ;;{{{ Build Report
1791
1792 (defun build-build-report ()
1793   (interactive)
1794   (let
1795       ((name "*Generate XEmacs Build Report*"))
1796     (kill-buffer (get-buffer-create name))
1797     (switch-to-buffer (get-buffer-create name))
1798     (widget-insert "\n")
1799     (widget-create 'push-button
1800                    :notify (lambda (&rest ignore)
1801                              (let
1802                                  (buffer-back get-back dir)
1803                                (cond
1804                                 ((string-equal build-with-what "GNU Tools")
1805                                  (setq buffer-back "*Build XEmacs With GNU Tools*")
1806                                  (setq get-back 'build-with-GNU))
1807                                 ((string-equal build-with-what "Microsoft Tools")
1808                                  (setq buffer-back "*Build XEmacs With Microsoft Tools*")
1809                                  (setq get-back 'build-with-MS)))
1810                                (cond
1811                                 ((string-equal build-from-what "Tarballs")
1812                                  (setq dir
1813                                        (expand-file-name
1814                                         build-tarball-prefix
1815                                         build-tarball-dest)))
1816                                 ((string-equal build-from-what "CVS")
1817                                  (setq dir
1818                                        (expand-file-name
1819                                         build-cvs-checkout-dir
1820                                         build-cvs-checkout-parent-dir))))
1821                                (if (buffer-live-p (get-buffer buffer-back))
1822                                    (switch-to-buffer buffer-back)
1823                                  (funcall get-back dir))))
1824                    "Go Back")
1825     (widget-insert "\n\n")
1826     (widget-create 'push-button
1827                    :notify (lambda (&rest ignore)
1828                              (customize-browse 'build-report))
1829                    "Browse Build Report ...")
1830     (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")
1831     (widget-create 'push-button
1832                    :notify (lambda (&rest ignore)
1833                              (call-interactively 'build-report))
1834                    "Generate Build Report ...")
1835     (widget-insert "\n")
1836     (use-local-map widget-keymap)
1837     (widget-setup)
1838     (custom-mode)
1839     (goto-char (point-min))))
1840
1841 ;;}}}
1842
1843 ;;{{{ Build Make
1844
1845 (defvar build-make-alist
1846   nil
1847   "Internal variable keeping track of makefile macros and targets")
1848
1849 (defconst build-make-target-doc-paragraph
1850   "^##\\s-*make\\s-+\\([^
1851         ]+\\(\\s-+or\\s-+make\\s-+\\([^
1852         ]+\\)\\)*\\)\\(\\s-*\\(\\(.*\\)\\(\n##\\s-\\{3,\\}.+\\)*\\)\\)$"
1853   "Internal REGEXP matching a XEmacs makefile target comment.  These comments
1854 don't exist in `xemacs.mak'")
1855
1856 (defconst build-make-target-paragraph
1857   "\\(^#.+
1858 \\)?\\(\\(\\w\\|_\\)+\\)\\s-*:.*"
1859   "Internal REGEXP matching a XEmacs makefile target name.")
1860
1861 (defconst build-make-macro-paragraph
1862   "^\\(?:!message Please specify root directory for your .* installation: \\)?\\(\\(\\w\\|_\\)+\\)\\s-*=\\s-*\\(\\(.*\\\\
1863 \\)*.+\\)$"
1864   "Internal REGEXP matching a XEmacs makefile macro definition.")
1865
1866 (defconst build-make-prolog
1867   "
1868 (provide 'build-make)
1869
1870 (setq build-make-options nil)
1871
1872 (defun build-make-sym-to-opt (sym)
1873   ;; #### Strip the \"build-make-\" prefix.
1874   (substring (symbol-name sym) 11))
1875
1876 (defun build-make-set-value (sym val)
1877   (setq build-make-options
1878         (remassoc (build-make-sym-to-opt sym) build-make-options))
1879   (unless (equal val (first (get sym 'standard-value)))
1880     (setq build-make-options
1881           (acons (build-make-sym-to-opt sym) val
1882                  build-make-options)))
1883   (set-default sym val))
1884
1885 (defgroup build-make nil
1886   \"build-make options.\"
1887   :group 'build)
1888
1889 "
1890   "Internal variable of `build'.")
1891
1892 (defun build-config-inc-generate (&optional dir)
1893   (interactive)
1894   (let
1895       ((buffer (buffer-name (generate-new-buffer "config.inc"))))
1896     (if dir
1897         (cd dir))
1898     (with-output-to-temp-buffer buffer
1899       (save-window-excursion
1900         (princ "# -*- mode: makefile -*-\n")
1901         (princ (format "# generated by %s" build-version))
1902         (princ "\n\n")
1903         (princ
1904          (if (boundp 'build-make-options)
1905              (mapconcat
1906               (function (lambda (e)
1907                           (cond
1908                            (t
1909                             (format "%s=%s\n" (first e) (rest e))))))
1910               (sort
1911                (delete-duplicates
1912                 build-make-options :from-end t
1913                 :test (lambda (a b)
1914                         (string=
1915                          (first a) (first b))))
1916                (lambda (a b)
1917                  (string<
1918                   (first a) (first b))))
1919               "")
1920            ""))
1921         ))
1922     (set-buffer buffer)
1923     (kill-all-local-variables)
1924     (makefile-mode)
1925     (font-lock-mode 1)
1926     (toggle-read-only 1)))
1927
1928 (defun build-make (&optional target command)
1929   "Build the XEmacs target argument according to the settings in
1930 customized group `build' and its members."
1931   (interactive "sTarget: \nsCommand: ")
1932   (let ((cmd
1933          (if (string-equal command "")
1934              (format "make %s" target)
1935            (format "%s %s" command target)))
1936         (compilation-mode-hook
1937          'build-compilation-mode-hook)
1938         (compilation-buffer-name-function
1939          '(lambda (mode)
1940             (generate-new-buffer-name
1941              (format "%s-make%s.err"
1942                      (cond
1943                       ((string-equal build-from-what "Tarballs")
1944                        build-tarball-prefix)
1945                       ((string-equal build-from-what "CVS")
1946                        build-cvs-checkout-dir))
1947                      (if target
1948                          (format "-%s" target)
1949                        ""))))))
1950     (compile cmd)))
1951
1952 (defun build-make-generate (&optional file)
1953   (interactive "fMakefile: ")
1954   (setq build-make-alist (list (cons 'macros nil) (cons 'targets nil)))
1955   (unless file
1956     (setq file
1957           (expand-file-name
1958            "Makefile.in"
1959            (cond
1960             ((string-equal build-from-what "Tarballs")
1961              (expand-file-name
1962               build-tarball-prefix
1963               build-tarball-dest))
1964             ((string-equal build-from-what "CVS")
1965              (expand-file-name
1966               build-cvs-checkout-dir
1967               build-cvs-checkout-parent-dir))))))
1968   (let
1969       (category categories option value detected doc
1970                 (buffer "build-make.el"))
1971     (with-output-to-temp-buffer buffer
1972       (save-window-excursion
1973         (find-file-read-only file)
1974 ;       (build-make-prolog file)
1975         (goto-char (point-min))
1976         (while (< (point) (point-max))
1977           (cond
1978            ((looking-at build-make-target-doc-paragraph)
1979             (goto-char (match-end 0))
1980             (build-make-process-target-doc
1981              ;; target [or target ...]
1982              (match-string 1)
1983              ;; documentation for current targets; possibly
1984              ;; spreading multiple lines.
1985              (match-string 5)
1986              build-make-alist))
1987            ((looking-at build-make-target-paragraph)
1988             (goto-char (match-end 0))
1989             (when (> (length (match-string 1)) 0)
1990               (build-make-process-target-doc
1991                ;; target name
1992                (match-string 2)
1993                ;; documentation for target; possibly
1994                ;; spreading multiple lines.
1995                (match-string 1)
1996                build-make-alist))
1997             )
1998            ((looking-at build-make-macro-paragraph)
1999             (goto-char (match-end 0))
2000 ;           (unless (string-match "\\$" (match-string 3))
2001             (build-make-process-macro
2002              ;; macro name
2003              (match-string 1)
2004              ;; macro value
2005              (match-string 3)
2006              build-make-alist))
2007 ;           )
2008            ((looking-at
2009              "^.+$")
2010             (goto-char (match-end 0)))
2011            ((looking-at "\n")
2012             (goto-char (match-end 0)))
2013            ))
2014         (build-make-customize build-make-alist)
2015         ))
2016     (set-buffer buffer)
2017     (insert "(setq build-make-alist (quote")
2018 ;    (cl-prettyprint (nreverse build-make-alist))
2019     (cl-prettyprint build-make-alist)
2020     (insert "))\n")
2021     (toggle-read-only 1)))
2022
2023 (defun build-make-get-option-string ()
2024   (if (boundp 'build-make-options)
2025       (mapconcat
2026        (function (lambda (e)
2027                    (cond
2028                     (t
2029                      (format " %s=\"%s\"" (first e) (rest e))))))
2030        (delete-duplicates
2031         build-make-options :from-end t
2032         :test (lambda (a b)
2033                 (string=
2034                  (first a) (first b))))
2035        "")
2036     ""))
2037
2038 (defun build-make-process-target-doc (targets doc a-list)
2039   (setq targets (replace-in-string targets "or\\(\n\\|\\s-\\)+make" ""))
2040   (setq doc (replace-in-string doc "##?\\s-+" ""))
2041   (setq doc (build-configure-fill-doc (list doc)))
2042   (setcdr (assoc 'targets a-list)
2043           (append (list (list targets doc)) (cdr (assoc 'targets a-list)))))
2044
2045 (defun build-make-process-macro (name value a-list)
2046   (unless (assoc name (assoc 'macros a-list))
2047     (setcdr (assoc 'macros a-list)
2048             (append (list (list name value)) (cdr (assoc 'macros a-list))))))
2049
2050 (defun build-make-customize (a-list)
2051   (princ build-make-prolog)
2052   (mapcar
2053    (lambda (macro)
2054      (if (string-match "_DIR\\'" (first macro))
2055          (build-make-file (first macro) (second macro))
2056        (build-make-string (first macro) (second macro))))
2057    (rest (assoc 'macros a-list))))
2058
2059 (defun build-make-string (name val)
2060   (princ (format "(defcustom build-make-%s\n" name))
2061   (princ (format "  %S\n" val))
2062   (princ (format "  \"macro %s\"\n" name))
2063   (princ (format "  :group \'build-make\n"))
2064   (princ "  :type 'string\n")
2065   (princ "  :set 'build-make-set-value)\n")
2066   (princ "\n"))
2067
2068 (defun build-make-file (name val)
2069   (princ (format "(defcustom build-make-%s\n" name))
2070   (princ (format "  %S\n" val))
2071   (princ (format "  \"macro %s\"\n" name))
2072   (princ (format "  :group \'build-make\n"))
2073   (princ "  :type 'file\n")
2074   (princ "  :set 'build-make-set-value)\n")
2075   (princ "\n"))
2076
2077 ;;}}}
2078
2079 ;;{{{ Build Settings
2080
2081 (defcustom build-settings
2082   nil
2083   "Internal alist of named settings for building multiple XEmacs
2084 configurations.
2085 This variable is updated via \"Delete\", Load\", and \"Save\" buttons
2086 of the `build' GUI."
2087   :type 'sexp
2088   :group 'build)
2089
2090 (defun build-settings-save-custom-group (group key alist)
2091   "Save customization values of custom GROUP as value of KEY in ALIST"
2092   (dolist
2093       (cgm (custom-group-members group nil))
2094     (let ((symbol (first cgm))
2095           (type (second cgm)))
2096       (cond
2097        ((equal type 'custom-group)
2098         (setq alist (build-settings-save-custom-group symbol key alist)))
2099        (t
2100         (unless
2101             (assoc key alist)
2102           (setq alist
2103                 (acons key nil alist)))
2104         (if (get symbol 'customized-value)
2105             (setcdr
2106              (assoc key alist)
2107              (append
2108               (cdr
2109                (assoc key alist))
2110               (list
2111                (list symbol (car
2112                              (get symbol 'customized-value)))))))))))
2113   alist)
2114
2115 (defun build-settings-load (key alist)
2116   "Load build variable settings from alist."
2117   (interactive)
2118   (dolist
2119       (var (cdr (assoc key alist)))
2120     (message "%S\n\t%S" (car var) (car (cdr var)))
2121     (set (car var) (eval (car (cdr var))))
2122     ))
2123
2124 ;;}}}
2125
2126 ;; build.el ends here