git.chise.org Git - elisp/gnus.git-/blob - dgnushack.el

   1 ;;; dgnushack.el --- a hack to set the load path for byte-compiling
   2 ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   3 ;; 2004, 2005
   4 ;;        Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
   8 ;; Version: 4.19
   9 ;; Keywords: news, path
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;;; Code:
  31
  32 ;; Set coding priority of Shift-JIS to the bottom.
  33 (if (featurep 'xemacs)
  34     (defalias 'set-coding-priority 'ignore)
  35   (defalias 'coding-priority-list 'ignore)
  36   (defalias 'set-coding-priority-list 'ignore))
  37 (cond ((and (featurep 'xemacs) (featurep 'mule))
  38        (if (memq 'shift-jis (coding-priority-list))
  39            (set-coding-priority-list
  40             (append (delq 'shift-jis (coding-priority-list)) '(shift-jis)))))
  41       ((featurep 'mule)
  42        (if (memq 'coding-category-sjis coding-category-list)
  43            (set-coding-priority
  44             (append (delq 'coding-category-sjis
  45                           (copy-sequence coding-category-list))
  46                     '(coding-category-sjis))))))
  47
  48 (defvar dgnushack-default-load-path (copy-sequence load-path))
  49
  50 (defalias 'facep 'ignore)
  51
  52 (require 'cl)
  53
  54 (unless (and
  55          ;; `dolist' might not be available because of ``-no-autoloads''.
  56          (fboundp 'dolist)
  57          ;; It may have been defined in egg.el.
  58          (dolist (var nil t)))
  59   (load "cl-macs" nil t))
  60
  61 (defvar srcdir (or (getenv "srcdir") "."))
  62 (defvar loaddir (and load-file-name (file-name-directory load-file-name)))
  63
  64 (defvar dgnushack-w3-directory (let ((w3dir (getenv "W3DIR")))
  65                                  (unless (zerop (length w3dir))
  66                                    (file-name-as-directory w3dir))))
  67
  68 (let ((urldir (getenv "URLDIR")))
  69   (unless (zerop (length urldir))
  70     (setq urldir (file-name-as-directory urldir))
  71     (push (file-name-as-directory urldir) load-path))
  72   (when (and dgnushack-w3-directory
  73              (not (string-equal urldir dgnushack-w3-directory)))
  74     (push dgnushack-w3-directory load-path)))
  75
  76 ;; If we are building w3 in a different directory than the source
  77 ;; directory, we must read *.el from source directory and write *.elc
  78 ;; into the building directory.  For that, we define this function
  79 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
  80 (defun byte-compile-dest-file (filename)
  81   "Convert an Emacs Lisp source file name to a compiled file name.
  82  In addition, remove directory name part from FILENAME."
  83   (setq filename (byte-compiler-base-file-name filename))
  84   (setq filename (file-name-sans-versions filename))
  85   (setq filename (file-name-nondirectory filename))
  86   (if (memq system-type '(win32 w32 mswindows windows-nt))
  87       (setq filename (downcase filename)))
  88   (cond ((eq system-type 'vax-vms)
  89          (concat (substring filename 0 (string-match ";" filename)) "c"))
  90         ((string-match emacs-lisp-file-regexp filename)
  91          (concat (substring filename 0 (match-beginning 0)) ".elc"))
  92         (t (concat filename ".elc"))))
  93
  94 (require 'bytecomp)
  95 ;; To avoid having defsubsts and inlines happen.
  96 ;(if (featurep 'xemacs)
  97 ;    (require 'byte-optimize)
  98 ;  (require 'byte-opt))
  99 ;(defun byte-optimize-inline-handler (form)
 100 ;  "byte-optimize-handler for the `inline' special-form."
 101 ;  (cons 'progn (cdr form)))
 102 ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun)
 103
 104 (when (and (not (featurep 'xemacs))
 105            (= emacs-major-version 21)
 106            (>= emacs-minor-version 3)
 107            (condition-case code
 108                (let ((byte-compile-error-on-warn t))
 109                  (byte-optimize-form (quote (pop x)) t)
 110                  nil)
 111              (error (string-match "called for effect"
 112                                   (error-message-string code)))))
 113   (defadvice byte-optimize-form-code-walker (around silence-warn-for-pop
 114                                                     (form for-effect)
 115                                                     activate)
 116     "Silence the warning \"...called for effect\" for the `pop' form.
 117 It is effective only when the `pop' macro is defined by cl.el rather
 118 than subr.el."
 119     (let (tmp)
 120       (if (and (eq (car-safe form) 'car)
 121                for-effect
 122                (setq tmp (get 'car 'side-effect-free))
 123                (not byte-compile-delete-errors)
 124                (not (eq tmp 'error-free))
 125                (eq (car-safe (cadr form)) 'prog1)
 126                (let ((var (cadr (cadr form)))
 127                      (last (nth 2 (cadr form))))
 128                  (and (symbolp var)
 129                       (null (nthcdr 3 (cadr form)))
 130                       (eq (car-safe last) 'setq)
 131                       (eq (cadr last) var)
 132                       (eq (car-safe (nth 2 last)) 'cdr)
 133                       (eq (cadr (nth 2 last)) var))))
 134           (progn
 135             (put 'car 'side-effect-free 'error-free)
 136             (unwind-protect
 137                 ad-do-it
 138               (put 'car 'side-effect-free tmp)))
 139         ad-do-it))))
 140
 141 (when (and (not (featurep 'xemacs))
 142            (byte-optimize-form '(and (> 0 1) foo) t))
 143   (defadvice byte-optimize-form-code-walker
 144     (around fix-bug-in-and/or-forms (form for-effect) activate)
 145     "Optimize the rest of the and/or forms.
 146 It has been fixed in XEmacs before releasing 21.4 and also has been
 147 fixed in Emacs after 21.3."
 148     (if (and for-effect (memq (car-safe form) '(and or)))
 149         (let ((fn (car form))
 150               (backwards (reverse (cdr form))))
 151           (while (and backwards
 152                       (null (setcar backwards
 153                                     (byte-optimize-form (car backwards) t))))
 154             (setq backwards (cdr backwards)))
 155           (if (and (cdr form) (null backwards))
 156               (byte-compile-log
 157                "  all subforms of %s called for effect; deleted" form))
 158           (when backwards
 159             (setcdr backwards
 160                     (mapcar 'byte-optimize-form (cdr backwards))))
 161           (setq ad-return-value (cons fn (nreverse backwards))))
 162       ad-do-it)))
 163
 164 ;; Add `configure-package-path' to `load-path' for XEmacs.  Those paths
 165 ;; won't appear in `load-path' when XEmacs starts with the `-no-autoloads'
 166 ;; option or the `-vanilla' option because of a bug. :<
 167 (when (and (featurep 'xemacs)
 168            (boundp 'configure-package-path)
 169            (listp configure-package-path))
 170   (let ((paths
 171          (apply 'nconc
 172                 (mapcar
 173                  (lambda (path)
 174                    (when (and (stringp path)
 175                               (not (string-equal path ""))
 176                               (file-directory-p
 177                                (setq path (expand-file-name "lisp" path))))
 178                      (directory-files path t)))
 179                  configure-package-path)))
 180         path adds)
 181     (while paths
 182       (setq path (car paths)
 183             paths (cdr paths))
 184       (when (and path
 185                  (not (or (string-match "/\\.\\.?\\'" path)
 186                           (member (file-name-as-directory path) load-path)
 187                           (member path load-path)))
 188                  (file-directory-p path))
 189         (push (file-name-as-directory path) adds)))
 190     (setq load-path (nconc (nreverse adds) load-path))))
 191
 192 (if (file-exists-p (expand-file-name "dgnuspath.el" srcdir))
 193     (load (expand-file-name "dgnuspath.el" srcdir) nil nil t))
 194
 195 (condition-case err
 196     (load "~/.lpath.el" t nil t)
 197   (error (message "Error in \"~/.lpath.el\" file: %s" err)))
 198
 199 (when (featurep 'xemacs)
 200   (condition-case nil
 201       (require 'timer-funcs)
 202     (error "
 203 You should upgrade your XEmacs packages, especially xemacs-base.\n"))
 204
 205   ;; The reason that to load `advice' is necessary is:
 206   ;; 1. `path-util' loads poe.elc.
 207   ;; 2. poe.elc requires the `ad-add-advice' function which is expanded
 208   ;;    from `defadvice'.
 209   ;; 3. XEmacs is running with the -no-autoloads option.
 210   (require 'advice))
 211
 212 ;; Don't load path-util until `char-after' and `char-before' have been
 213 ;; optimized because it requires `poe' and then modify the functions.
 214 (condition-case nil
 215     (require 'path-util)
 216   (error "\nIn %s,
 217 APEL was not found or an error occurred.  You will need to run the
 218 configure script again adding the --with-addpath=APEL_PATH option.\n"
 219          load-path))
 220
 221 (unless (locate-library "mel")
 222   (add-path "flim"))
 223 (unless (module-installed-p 'mel)
 224   ;; FLIM 1.14 may have installed in two "flim" subdirectories.
 225   (push (expand-file-name "flim"
 226                           (file-name-directory (get-latest-path "^apel$" t)))
 227         load-path)
 228   (unless (module-installed-p 'mel)
 229     (error "In %s,
 230 FLIM was not found.  You will need to run the configure script again
 231 adding the --with-addpath=FLIM_PATH option.\n"
 232            load-path)))
 233 (add-path "semi")
 234
 235 (when (and (featurep 'xemacs)
 236            (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
 237              (modify-syntax-entry ?= " " table)
 238              (with-temp-buffer
 239                (with-syntax-table table
 240                  (insert "foo=bar")
 241                  (goto-char (point-min))
 242                  (forward-sexp 1)
 243                  (eolp)))))
 244   ;; The original `with-syntax-table' uses `copy-syntax-table' which
 245   ;; doesn't seem to copy modified syntax entries in XEmacs 21.5.
 246   (defmacro with-syntax-table (syntab &rest body)
 247     "Evaluate BODY with the SYNTAB as the current syntax table."
 248     `(let ((stab (syntax-table)))
 249        (unwind-protect
 250            (progn
 251              ;;(set-syntax-table (copy-syntax-table ,syntab))
 252              (set-syntax-table ,syntab)
 253              ,@body)
 254          (set-syntax-table stab)))))
 255
 256 (push srcdir load-path)
 257 (push loaddir load-path)
 258 (load (expand-file-name "lpath.el" loaddir) nil t)
 259
 260 (require 'custom)
 261
 262 ;; Bind functions defined by `defun-maybe'.
 263 (put 'defun-maybe 'byte-hunk-handler 'byte-compile-file-form-defun-maybe)
 264 (defun byte-compile-file-form-defun-maybe (form)
 265   (if (and (not (fboundp (nth 1 form)))
 266            (memq 'unresolved byte-compile-warnings))
 267       (setq byte-compile-function-environment
 268             (cons (cons (nth 1 form)
 269                         (cons 'lambda (cdr (cdr form))))
 270                   byte-compile-function-environment)))
 271   form)
 272
 273 ;; Unknown variables and functions.
 274 (unless (featurep 'xemacs)
 275   (defalias 'Custom-make-dependencies 'ignore)
 276   (defalias 'update-autoloads-from-directory 'ignore))
 277
 278 (defalias 'device-sound-enabled-p 'ignore)
 279 (defalias 'play-sound-file 'ignore)
 280 (defalias 'nndb-request-article 'ignore)
 281 (defalias 'efs-re-read-dir 'ignore)
 282 (defalias 'ange-ftp-re-read-dir 'ignore)
 283 (defalias 'define-mail-user-agent 'ignore)
 284
 285 (eval-and-compile
 286   (when (featurep 'xemacs)
 287     (unless (fboundp 'defadvice)
 288       (autoload 'defadvice "advice" nil nil 'macro))
 289     (autoload 'Info-directory "info" nil t)
 290     (autoload 'Info-menu "info" nil t)
 291     (autoload 'annotations-at "annotations")
 292     (autoload 'apropos "apropos" nil t)
 293     (autoload 'apropos-command "apropos" nil t)
 294     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 295     (autoload 'browse-url "browse-url" nil t)
 296     (autoload 'c-mode "cc-mode" nil t)
 297     (autoload 'customize-apropos "cus-edit" nil t)
 298     (autoload 'customize-save-variable "cus-edit" nil t)
 299     (autoload 'customize-set-variable "cus-edit" nil t)
 300     (autoload 'customize-variable "cus-edit" nil t)
 301     (autoload 'delete-annotation "annotations")
 302     (autoload 'dolist "cl-macs" nil nil 'macro)
 303     (autoload 'enriched-decode "enriched")
 304     (autoload 'executable-find "executable")
 305     (autoload 'font-lock-fontify-buffer "font-lock" nil t)
 306     (autoload 'info "info" nil t)
 307     (autoload 'mail-extract-address-components "mail-extr")
 308     (autoload 'mail-fetch-field "mail-utils")
 309     (autoload 'make-annotation "annotations")
 310     (autoload 'make-display-table "disp-table")
 311     (autoload 'pp "pp")
 312     (autoload 'ps-despool "ps-print" nil t)
 313     (autoload 'ps-spool-buffer "ps-print" nil t)
 314     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 315     (autoload 'read-passwd "passwd")
 316     (autoload 'regexp-opt "regexp-opt")
 317     (autoload 'reporter-submit-bug-report "reporter")
 318     (if (and (emacs-version>= 21 5)
 319              (not (featurep 'sxemacs)))
 320         (autoload 'setenv "process" nil t)
 321       (autoload 'setenv "env" nil t))
 322     (autoload 'sgml-mode "psgml" nil t)
 323     (autoload 'sha1 "sha1")
 324     (autoload 'sha1-binary "sha1")
 325     (autoload 'smtpmail-send-it "smtpmail")
 326     (autoload 'sort-numeric-fields "sort" nil t)
 327     (autoload 'sort-subr "sort")
 328     (autoload 'trace-function-background "trace" nil t)
 329     (autoload 'w3-do-setup "w3")
 330     (autoload 'w3-prepare-buffer "w3-display")
 331     (autoload 'w3-region "w3-display" nil t)
 332     (defalias 'frame-char-height 'frame-height)
 333     (defalias 'frame-char-width 'frame-width)
 334     (defalias 'frame-parameter 'frame-property)
 335     (defalias 'make-overlay 'ignore)
 336     (defalias 'overlay-end 'ignore)
 337     (defalias 'overlay-get 'ignore)
 338     (defalias 'overlay-put 'ignore)
 339     (defalias 'overlay-start 'ignore)
 340     (defalias 'overlays-in 'ignore)
 341     (defalias 'replace-dehighlight 'ignore)
 342     (defalias 'replace-highlight 'ignore)
 343     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 344
 345 ;; T-gnus stuff.
 346 (eval-and-compile
 347   (when (featurep 'xemacs)
 348     (autoload 'c-mode "cc-mode" nil t)
 349     (autoload 'font-lock-mode "font-lock" nil t)
 350     (autoload 'read-kbd-macro "edmacro" nil t)
 351     (autoload 'turn-on-font-lock "font-lock" nil t))
 352   (autoload 'nnheader-detect-coding-region "nnheader")
 353   (autoload 'std11-extract-addresses-components "nnheader")
 354   (autoload 'std11-fold-region "nnheader")
 355   (autoload 'std11-narrow-to-field "nnheader")
 356   (autoload 'std11-unfold-region "nnheader"))
 357
 358 (defconst dgnushack-unexporting-files
 359   (append '("dgnushack.el" "dgnuspath.el" "dgnuskwds.el" "lpath.el"
 360             "legacy-gnus-agent.el")
 361           (unless (or (condition-case code
 362                           (require 'w3-parse)
 363                         (error
 364                          (message "No w3: %s%s, retrying..."
 365                                   (error-message-string code)
 366                                   (if (setq code (locate-library "w3-parse"))
 367                                       (concat " (" code ")")
 368                                     ""))
 369                          nil))
 370                       ;; Maybe mis-configured Makefile is used (e.g.
 371                       ;; configured for FSFmacs but XEmacs is running).
 372                       (let ((lp (delete dgnushack-w3-directory
 373                                         (copy-sequence load-path))))
 374                         (if (let ((load-path lp))
 375                               (condition-case nil
 376                                   (require 'w3-parse)
 377                                 (error nil)))
 378                             ;; If success, fix `load-path' for compiling.
 379                             (progn
 380                               (setq load-path lp)
 381                               (message " => fixed; W3DIR=%s"
 382                                        (file-name-directory
 383                                         (locate-library "w3-parse")))
 384                               t)
 385                           (message " => ignored")
 386                           nil)))
 387             '("nnultimate.el" "webmail.el" "nnwfm.el"))
 388           (condition-case code
 389               (progn (require 'mh-e) nil)
 390             (error
 391              (message "No mh-e: %s%s (ignored)"
 392                       (error-message-string code)
 393                       (if (setq code (locate-library "mh-e"))
 394                           (concat " (" code ")")
 395                         ""))
 396              '("gnus-mh.el")))
 397           (condition-case code
 398               (progn (require 'xml) nil)
 399             (error
 400              (message "No xml: %s%s (ignored)"
 401                       (error-message-string code)
 402                       (if (setq code (locate-library "xml"))
 403                           (concat " (" code ")")
 404                         ""))
 405              '("nnrss.el")))
 406           (condition-case code
 407               (progn (require 'bbdb) nil)
 408             (error
 409              (message "No bbdb: %s%s (ignored)"
 410                       (error-message-string code)
 411                       (if (setq code (locate-library "bbdb"))
 412                           (concat " (" code ")")
 413                         ""))
 414              '("gnus-bbdb.el")))
 415           (unless (featurep 'xemacs)
 416             '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el"))
 417           (when (and (fboundp 'base64-decode-string)
 418                      (subrp (symbol-function 'base64-decode-string)))
 419             '("base64.el"))
 420           (when (and (fboundp 'md5) (subrp (symbol-function 'md5)))
 421             '("md5.el"))
 422           (when (featurep 'xemacs)
 423             '("gnus-load.el")))
 424   "Files which will not be installed.")
 425
 426 (defconst dgnushack-exporting-files
 427   (let ((files (directory-files srcdir nil "^[^=].*\\.el$" t)))
 428     (dolist (file dgnushack-unexporting-files)
 429       (setq files (delete file files)))
 430     (sort files 'string-lessp))
 431   "Files which will be compiled and installed.")
 432
 433 (defun dgnushack-exporting-files ()
 434   "Print name of files which will be installed."
 435   (princ (mapconcat 'identity dgnushack-exporting-files " ")))
 436
 437 (defconst dgnushack-dont-compile-files
 438   '("gnus-load.el"
 439     "mm-bodies.el" "mm-decode.el" "mm-encode.el" "mm-extern.el"
 440     "mm-partial.el" "mm-uu.el" "mm-view.el" "mml-sec.el" "mml-smime.el"
 441     "mml.el" "mml1991.el" "mml2015.el")
 442   "Files which should not be byte-compiled.")
 443
 444 (defun dgnushack-compile-verbosely ()
 445   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 446 patches to gnus, you should consider modifying make.bat to call
 447 dgnushack-compile-verbosely.  All other users should continue to use
 448 dgnushack-compile."
 449   (dgnushack-compile t))
 450
 451 (defun dgnushack-compile (&optional warn)
 452   ;;(setq byte-compile-dynamic t)
 453   (unless warn
 454     (setq byte-compile-warnings
 455           '(free-vars unresolved callargs redefine)))
 456
 457   ;; Show `load-path'.
 458   (message "load-path=(\"%s\")"
 459            (mapconcat 'identity load-path "\"\n           \""))
 460
 461   (dolist (file dgnushack-exporting-files)
 462     (setq file (expand-file-name file srcdir))
 463     (when (and (file-exists-p
 464                 (setq elc (concat (file-name-nondirectory file) "c")))
 465                (file-newer-than-file-p file elc))
 466       (delete-file elc)))
 467
 468   ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 469   ;; installed.
 470   (when (featurep 'xemacs)
 471     (setq gnus-xmas-glyph-directory "dummy"))
 472
 473   (let ((files dgnushack-exporting-files)
 474         ;;(byte-compile-generate-call-tree t)
 475         file elc)
 476     (while (setq file (pop files))
 477       (unless (member file dgnushack-dont-compile-files)
 478         (setq file (expand-file-name file srcdir))
 479         (when (or (not (file-exists-p
 480                         (setq elc (concat (file-name-nondirectory file) "c"))))
 481                   (file-newer-than-file-p file elc))
 482           (ignore-errors
 483             (byte-compile-file file)))))))
 484
 485 (defun dgnushack-recompile ()
 486   (require 'gnus)
 487   (byte-recompile-directory "." 0))
 488
 489 (defvar dgnushack-gnus-load-file
 490   (if (featurep 'xemacs)
 491       (expand-file-name "auto-autoloads.el" srcdir)
 492     (expand-file-name "gnus-load.el" srcdir)))
 493
 494 (defvar dgnushack-cus-load-file
 495   (if (featurep 'xemacs)
 496       (expand-file-name "custom-load.el" srcdir)
 497     (expand-file-name "cus-load.el" srcdir)))
 498
 499 (defun dgnushack-make-cus-load ()
 500   (load "cus-dep")
 501   (let ((cusload-base-file dgnushack-cus-load-file))
 502     (if (fboundp 'custom-make-dependencies)
 503         (custom-make-dependencies)
 504       (Custom-make-dependencies))
 505     (when (featurep 'xemacs)
 506       (message "Compiling %s..." dgnushack-cus-load-file)
 507       (byte-compile-file dgnushack-cus-load-file))))
 508
 509 (defun dgnushack-make-auto-load ()
 510   (require 'autoload)
 511   (unless (make-autoload '(define-derived-mode child parent name
 512                             "docstring" body)
 513                          "file")
 514     (defadvice make-autoload (around handle-define-derived-mode activate)
 515       "Handle `define-derived-mode'."
 516       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 517           (setq ad-return-value
 518                 (list 'autoload
 519                       (list 'quote (nth 1 (ad-get-arg 0)))
 520                       (ad-get-arg 1)
 521                       (nth 4 (ad-get-arg 0))
 522                       t nil))
 523         ad-do-it))
 524     (put 'define-derived-mode 'doc-string-elt 3))
 525   (let ((generated-autoload-file dgnushack-gnus-load-file)
 526         (make-backup-files nil)
 527         (autoload-package-name "gnus"))
 528     (if (featurep 'xemacs)
 529         (if (file-exists-p generated-autoload-file)
 530             (delete-file generated-autoload-file))
 531       (with-temp-file generated-autoload-file
 532         (insert ?\014)))
 533     (if (featurep 'xemacs)
 534         (let ((si:message (symbol-function 'message)))
 535           (defun message (fmt &rest args)
 536             (cond ((and (string-equal "Generating autoloads for %s..." fmt)
 537                         (file-exists-p (file-name-nondirectory (car args))))
 538                    (funcall si:message
 539                             fmt (file-name-nondirectory (car args))))
 540                   ((string-equal "No autoloads found in %s" fmt))
 541                   ((string-equal "Generating autoloads for %s...done" fmt))
 542                   (t (apply si:message fmt args))))
 543           (unwind-protect
 544               (batch-update-autoloads)
 545             (fset 'message si:message)))
 546       (batch-update-autoloads))))
 547
 548 (defun dgnushack-make-load ()
 549   (unless (featurep 'xemacs)
 550     (message "Generating %s..." dgnushack-gnus-load-file)
 551     (with-temp-file dgnushack-gnus-load-file
 552       (insert-file-contents dgnushack-cus-load-file)
 553       (delete-file dgnushack-cus-load-file)
 554       (goto-char (point-min))
 555       (search-forward ";;; Code:")
 556       (forward-line)
 557       (delete-region (point-min) (point))
 558       (insert "\
 559 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 560 ;;
 561 ;;; Code:
 562 ")
 563       (goto-char (point-max))
 564       (if (search-backward "custom-versions-load-alist" nil t)
 565           (forward-line -1)
 566         (forward-line -1)
 567         (while (eq (char-after) ?\;)
 568           (forward-line -1))
 569         (forward-line))
 570       (delete-region (point) (point-max))
 571       (insert "\n")
 572       ;; smiley-* are duplicated. Remove them all.
 573       (let ((point (point)))
 574         (insert-file-contents dgnushack-gnus-load-file)
 575         (goto-char point)
 576         (while (search-forward "smiley-" nil t)
 577           (beginning-of-line)
 578           (if (looking-at "(autoload ")
 579               (delete-region (point) (progn (forward-sexp) (point)))
 580             (forward-line))))
 581       ;;
 582       (goto-char (point-max))
 583       (when (search-backward "\n(provide " nil t)
 584         (forward-line -1)
 585         (delete-region (point) (point-max)))
 586       (insert "\
 587
 588 \(provide 'gnus-load)
 589
 590 ;;; Local Variables:
 591 ;;; version-control: never
 592 ;;; no-byte-compile: t
 593 ;;; no-update-autoloads: t
 594 ;;; End:
 595 ;;; gnus-load.el ends here
 596 ")
 597       ))
 598   (message "Compiling %s..." dgnushack-gnus-load-file)
 599   (byte-compile-file dgnushack-gnus-load-file)
 600   (when (featurep 'xemacs)
 601     (message "Creating dummy gnus-load.el...")
 602     (with-temp-file (expand-file-name "gnus-load.el")
 603       (insert "\
 604
 605 \(provide 'gnus-load)
 606
 607 ;;; Local Variables:
 608 ;;; version-control: never
 609 ;;; no-byte-compile: t
 610 ;;; no-update-autoloads: t
 611 ;;; End:
 612 ;;; gnus-load.el ends here"))))
 613
 614 \f
 615 (defconst dgnushack-info-file-regexp-en
 616   (let ((names '("gnus" "message" "emacs-mime"))
 617         regexp name)
 618     (while (setq name (pop names))
 619       (setq regexp (concat regexp "^" name "\\.info\\(-[0-9]+\\)?$"
 620                            (when names "\\|"))))
 621     regexp)
 622   "Regexp matching English info files.")
 623
 624 (defconst dgnushack-info-file-regexp-ja
 625   (let ((names '("gnus-ja" "message-ja"))
 626         regexp name)
 627     (while (setq name (pop names))
 628       (setq regexp (concat regexp "^" name "\\.info\\(-[0-9]+\\)?$"
 629                            (when names "\\|"))))
 630     regexp)
 631   "Regexp matching Japanese info files.")
 632
 633 (defun dgnushack-remove-extra-files-in-package ()
 634   "Remove extra files in the lisp directory of the XEmacs package."
 635   (let ((lisp-dir (expand-file-name (concat "lisp/"
 636                                             ;; GNUS_PRODUCT_NAME
 637                                             (cadr command-line-args-left)
 638                                             "/")
 639                                     ;; PACKAGEDIR
 640                                     (car command-line-args-left))))
 641     (setq command-line-args-left nil)
 642     (when (file-directory-p lisp-dir)
 643       (let (files)
 644         (dolist (file dgnushack-exporting-files)
 645           (setq files (nconc files (list file (concat file "c")))))
 646         (dolist (file (directory-files lisp-dir nil nil t t))
 647           (unless (member file files)
 648             (setq file (expand-file-name file lisp-dir))
 649             (message "Removing %s..." file)
 650             (condition-case nil
 651                 (delete-file file)
 652               (error nil))))))))
 653
 654 (defun dgnushack-install-package-manifest ()
 655   "Install MANIFEST file as an XEmacs package."
 656   (let* ((package-dir (pop command-line-args-left))
 657          (product-name (pop command-line-args-left))
 658          (pkginfo-dir (expand-file-name "pkginfo" package-dir))
 659          (name (expand-file-name (concat "MANIFEST." product-name)
 660                                  pkginfo-dir))
 661          make-backup-files)
 662     (unless (file-directory-p pkginfo-dir)
 663       (message "Creating directory %s/..." pkginfo-dir)
 664       (make-directory pkginfo-dir))
 665     (message "Generating %s..." name)
 666     (with-temp-file name
 667       (insert "pkginfo/MANIFEST." product-name "\n")
 668       (let ((lisp-dir (concat "lisp/" product-name "/"))
 669             (files (sort (directory-files "." nil "\\.elc?$" t) 'string-lessp))
 670             file)
 671         (while (setq file (pop files))
 672           (unless (member file dgnushack-unexporting-files)
 673             (insert lisp-dir file "\n")))
 674         (setq files
 675               (sort (directory-files "../texi/" nil
 676                                      (concat dgnushack-info-file-regexp-en
 677                                              "\\|"
 678                                              dgnushack-info-file-regexp-ja)
 679                                      t)
 680                     'string-lessp))
 681         (while (setq file (pop files))
 682           (insert "info/" file "\n"))
 683         (insert "etc/gnus-tut.txt\n")
 684         (setq files
 685               (sort (directory-files "../etc/images/gnus/" nil
 686                                      "\\.\\(pbm\\|xbm\\|xpm\\)\\'"
 687                                      t)
 688                     'string-lessp))
 689         (while (setq file (pop files))
 690           (insert "etc/images/gnus/" file "\n"))
 691         (insert "etc/images/gnus/x-splash\n")
 692         (setq files
 693               (sort (directory-files "../etc/images/smilies/" nil
 694                                      "\\.\\(pbm\\|xpm\\)\\'"
 695                                      t)
 696                     'string-lessp))
 697         (while (setq file (pop files))
 698           (insert "etc/images/smilies/" file "\n"))))))
 699
 700 (defun dgnushack-find-lisp-shadows (&optional lispdir)
 701   "Return a list of directories in which other Gnus installations exist.
 702 This function looks for the other Gnus installations which will shadow
 703 the new Gnus Lisp modules which have been installed in LISPDIR, using
 704 the default `load-path'.  The return value will make sense only when
 705 LISPDIR is existent and is listed in the default `load-path'.  Assume
 706 LISPDIR will be prepended to `load-path' by a user if the default
 707 `load-path' does not contain it."
 708   (unless lispdir
 709     (setq lispdir (getenv "lispdir")))
 710   (when (and lispdir (file-directory-p lispdir))
 711     (setq lispdir (file-truename (directory-file-name lispdir)))
 712     (let ((indices '("gnus.elc" "gnus.el" "gnus.el.bz2" "gnus.el.gz"
 713                      "message.elc" "message.el" "message.el.bz2"
 714                      "message.el.gz"))
 715           (path (delq nil (mapcar
 716                            (lambda (p)
 717                              (condition-case nil
 718                                  (when (and p (file-directory-p p))
 719                                    (file-truename (directory-file-name p)))
 720                                (error nil)))
 721                            dgnushack-default-load-path)))
 722           rest elcs)
 723       (while path
 724         (setq rest (cons (car path) rest)
 725               path (delete (car rest) (cdr path))))
 726       (setq path (nreverse (cdr (member lispdir rest)))
 727             rest nil)
 728       (while path
 729         (setq elcs indices)
 730         (while elcs
 731           (when (file-exists-p (expand-file-name (pop elcs) (car path)))
 732             (setq rest (cons (car path) rest)
 733                   elcs nil)))
 734         (setq path (cdr path)))
 735       (prog1
 736           (setq path (nreverse rest))
 737         (when path
 738           (let (print-level print-length)
 739             (princ (concat "\n\
 740 WARNING: The other gnus installation" (if (cdr path) "s have" " has") "\
 741  been detected in:\n\n  " (mapconcat 'identity path "\n  ") "\n\n\
 742 You will need to modify the run-time `load-path', remove them manually,
 743 or remove them using `make remove-installed-shadows'.\n\n"))))))))
 744
 745 (defun dgnushack-remove-lisp-shadows (&optional lispdir)
 746   "Remove the other Gnus installations which shadow the recent one."
 747   (let ((path (with-temp-buffer
 748                 (let ((standard-output (current-buffer)))
 749                   (dgnushack-find-lisp-shadows lispdir))))
 750         elcs files shadows file)
 751     (when path
 752       (unless (setq elcs (directory-files srcdir nil "\\.elc\\'"))
 753         (error "You should build .elc files first."))
 754       (setq files
 755             (apply
 756              'append
 757              (mapcar
 758               (lambda (el)
 759                 (list (concat el "c") el (concat el ".bz2") (concat el ".gz")))
 760               (append
 761                (list (file-name-nondirectory dgnushack-gnus-load-file)
 762                      (file-name-nondirectory dgnushack-cus-load-file))
 763                (mapcar (lambda (elc) (substring elc 0 -1)) elcs)))))
 764       (while path
 765         (setq shadows files)
 766         (while shadows
 767           (setq file (expand-file-name (pop shadows) (car path)))
 768           (when (file-exists-p file)
 769             (princ (concat "  Removing " file "..."))
 770             (condition-case nil
 771                 (progn
 772                   (delete-file file)
 773                   (princ "done\n"))
 774               (error (princ "failed\n")))))
 775         (setq path (cdr path))))))
 776
 777 ;;; dgnushack.el ends here