git.chise.org Git - elisp/gnus.git-/blob - lisp/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 ;; Work around for an incompatibility (XEmacs 21.4 vs. 21.5), see the
 236 ;; following threads:
 237 ;;
 238 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56414
 239 ;; Subject: attachment problems found but not fixed
 240 ;;
 241 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56459
 242 ;; Subject: Splitting mail -- XEmacs 21.4 vs 21.5
 243 ;;
 244 ;; http://thread.gmane.org/gmane.emacs.xemacs.beta/20519
 245 ;; Subject: XEmacs 21.5 and Gnus fancy splitting.
 246 (when (and (featurep 'xemacs)
 247            (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
 248              (modify-syntax-entry ?= " " table)
 249              (with-temp-buffer
 250                (with-syntax-table table
 251                  (insert "foo=bar")
 252                  (goto-char (point-min))
 253                  (forward-sexp 1)
 254                  (eolp)))))
 255   ;; The original `with-syntax-table' uses `copy-syntax-table' which
 256   ;; doesn't seem to copy modified syntax entries in XEmacs 21.5.
 257   (defmacro with-syntax-table (syntab &rest body)
 258     "Evaluate BODY with the SYNTAB as the current syntax table."
 259     `(let ((stab (syntax-table)))
 260        (unwind-protect
 261            (progn
 262              ;;(set-syntax-table (copy-syntax-table ,syntab))
 263              (set-syntax-table ,syntab)
 264              ,@body)
 265          (set-syntax-table stab)))))
 266
 267 (push srcdir load-path)
 268 (push loaddir load-path)
 269 (load (expand-file-name "lpath.el" loaddir) nil t)
 270
 271 (require 'custom)
 272
 273 ;; Bind functions defined by `defun-maybe'.
 274 (put 'defun-maybe 'byte-hunk-handler 'byte-compile-file-form-defun-maybe)
 275 (defun byte-compile-file-form-defun-maybe (form)
 276   (if (and (not (fboundp (nth 1 form)))
 277            (memq 'unresolved byte-compile-warnings))
 278       (setq byte-compile-function-environment
 279             (cons (cons (nth 1 form)
 280                         (cons 'lambda (cdr (cdr form))))
 281                   byte-compile-function-environment)))
 282   form)
 283
 284 ;; Unknown variables and functions.
 285 (unless (featurep 'xemacs)
 286   (defalias 'Custom-make-dependencies 'ignore)
 287   (defalias 'update-autoloads-from-directory 'ignore))
 288
 289 (defalias 'device-sound-enabled-p 'ignore)
 290 (defalias 'play-sound-file 'ignore)
 291 (defalias 'nndb-request-article 'ignore)
 292 (defalias 'efs-re-read-dir 'ignore)
 293 (defalias 'ange-ftp-re-read-dir 'ignore)
 294 (defalias 'define-mail-user-agent 'ignore)
 295
 296 (eval-and-compile
 297   (when (featurep 'xemacs)
 298     (unless (fboundp 'defadvice)
 299       (autoload 'defadvice "advice" nil nil 'macro))
 300     (autoload 'Info-directory "info" nil t)
 301     (autoload 'Info-menu "info" nil t)
 302     (autoload 'annotations-at "annotations")
 303     (autoload 'apropos "apropos" nil t)
 304     (autoload 'apropos-command "apropos" nil t)
 305     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 306     (autoload 'browse-url "browse-url" nil t)
 307     (autoload 'c-mode "cc-mode" nil t)
 308     (autoload 'customize-apropos "cus-edit" nil t)
 309     (autoload 'customize-save-variable "cus-edit" nil t)
 310     (autoload 'customize-set-variable "cus-edit" nil t)
 311     (autoload 'customize-variable "cus-edit" nil t)
 312     (autoload 'delete-annotation "annotations")
 313     (autoload 'dolist "cl-macs" nil nil 'macro)
 314     (autoload 'enriched-decode "enriched")
 315     (autoload 'executable-find "executable")
 316     (autoload 'font-lock-fontify-buffer "font-lock" nil t)
 317     (autoload 'info "info" nil t)
 318     (autoload 'mail-extract-address-components "mail-extr")
 319     (autoload 'mail-fetch-field "mail-utils")
 320     (autoload 'make-annotation "annotations")
 321     (autoload 'make-display-table "disp-table")
 322     (autoload 'pp "pp")
 323     (autoload 'ps-despool "ps-print" nil t)
 324     (autoload 'ps-spool-buffer "ps-print" nil t)
 325     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 326     (autoload 'read-passwd "passwd")
 327     (autoload 'regexp-opt "regexp-opt")
 328     (autoload 'reporter-submit-bug-report "reporter")
 329     (if (and (emacs-version>= 21 5)
 330              (not (featurep 'sxemacs)))
 331         (autoload 'setenv "process" nil t)
 332       (autoload 'setenv "env" nil t))
 333     (autoload 'sgml-mode "psgml" nil t)
 334     (autoload 'sha1 "sha1")
 335     (autoload 'sha1-binary "sha1")
 336     (autoload 'smtpmail-send-it "smtpmail")
 337     (autoload 'sort-numeric-fields "sort" nil t)
 338     (autoload 'sort-subr "sort")
 339     (autoload 'trace-function-background "trace" nil t)
 340     (autoload 'w3-do-setup "w3")
 341     (autoload 'w3-prepare-buffer "w3-display")
 342     (autoload 'w3-region "w3-display" nil t)
 343     (defalias 'frame-char-height 'frame-height)
 344     (defalias 'frame-char-width 'frame-width)
 345     (defalias 'frame-parameter 'frame-property)
 346     (defalias 'make-overlay 'ignore)
 347     (defalias 'overlay-end 'ignore)
 348     (defalias 'overlay-get 'ignore)
 349     (defalias 'overlay-put 'ignore)
 350     (defalias 'overlay-start 'ignore)
 351     (defalias 'overlays-in 'ignore)
 352     (defalias 'replace-dehighlight 'ignore)
 353     (defalias 'replace-highlight 'ignore)
 354     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 355
 356 ;; T-gnus stuff.
 357 (eval-and-compile
 358   (when (featurep 'xemacs)
 359     (autoload 'c-mode "cc-mode" nil t)
 360     (autoload 'font-lock-mode "font-lock" nil t)
 361     (autoload 'read-kbd-macro "edmacro" nil t)
 362     (autoload 'turn-on-font-lock "font-lock" nil t))
 363   (autoload 'nnheader-detect-coding-region "nnheader")
 364   (autoload 'std11-extract-addresses-components "nnheader")
 365   (autoload 'std11-fold-region "nnheader")
 366   (autoload 'std11-narrow-to-field "nnheader")
 367   (autoload 'std11-unfold-region "nnheader"))
 368
 369 (defconst dgnushack-unexporting-files
 370   (append '("dgnushack.el" "dgnuspath.el" "dgnuskwds.el" "lpath.el"
 371             "legacy-gnus-agent.el")
 372           (unless (or (condition-case code
 373                           (require 'w3-parse)
 374                         (error
 375                          (message "No w3: %s%s, retrying..."
 376                                   (error-message-string code)
 377                                   (if (setq code (locate-library "w3-parse"))
 378                                       (concat " (" code ")")
 379                                     ""))
 380                          nil))
 381                       ;; Maybe mis-configured Makefile is used (e.g.
 382                       ;; configured for FSFmacs but XEmacs is running).
 383                       (let ((lp (delete dgnushack-w3-directory
 384                                         (copy-sequence load-path))))
 385                         (if (let ((load-path lp))
 386                               (condition-case nil
 387                                   (require 'w3-parse)
 388                                 (error nil)))
 389                             ;; If success, fix `load-path' for compiling.
 390                             (progn
 391                               (setq load-path lp)
 392                               (message " => fixed; W3DIR=%s"
 393                                        (file-name-directory
 394                                         (locate-library "w3-parse")))
 395                               t)
 396                           (message " => ignored")
 397                           nil)))
 398             '("nnultimate.el" "webmail.el" "nnwfm.el"))
 399           (condition-case code
 400               (progn (require 'mh-e) nil)
 401             (error
 402              (message "No mh-e: %s%s (ignored)"
 403                       (error-message-string code)
 404                       (if (setq code (locate-library "mh-e"))
 405                           (concat " (" code ")")
 406                         ""))
 407              '("gnus-mh.el")))
 408           (condition-case code
 409               (progn (require 'xml) nil)
 410             (error
 411              (message "No xml: %s%s (ignored)"
 412                       (error-message-string code)
 413                       (if (setq code (locate-library "xml"))
 414                           (concat " (" code ")")
 415                         ""))
 416              '("nnrss.el")))
 417           (condition-case code
 418               (progn (require 'bbdb) nil)
 419             (error
 420              (message "No bbdb: %s%s (ignored)"
 421                       (error-message-string code)
 422                       (if (setq code (locate-library "bbdb"))
 423                           (concat " (" code ")")
 424                         ""))
 425              '("gnus-bbdb.el")))
 426           (unless (featurep 'xemacs)
 427             '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el"))
 428           (when (and (fboundp 'base64-decode-string)
 429                      (subrp (symbol-function 'base64-decode-string)))
 430             '("base64.el"))
 431           (when (and (fboundp 'md5) (subrp (symbol-function 'md5)))
 432             '("md5.el"))
 433           (when (featurep 'xemacs)
 434             '("gnus-load.el")))
 435   "Files which will not be installed.")
 436
 437 (defconst dgnushack-exporting-files
 438   (let ((files (directory-files srcdir nil "^[^=].*\\.el$" t)))
 439     (dolist (file dgnushack-unexporting-files)
 440       (setq files (delete file files)))
 441     (sort files 'string-lessp))
 442   "Files which will be compiled and installed.")
 443
 444 (defun dgnushack-exporting-files ()
 445   "Print name of files which will be installed."
 446   (princ (mapconcat 'identity dgnushack-exporting-files " ")))
 447
 448 (defconst dgnushack-dont-compile-files
 449   '("gnus-load.el"
 450     "mm-bodies.el" "mm-decode.el" "mm-encode.el" "mm-extern.el"
 451     "mm-partial.el" "mm-uu.el" "mm-view.el" "mml-sec.el" "mml-smime.el"
 452     "mml.el" "mml1991.el" "mml2015.el")
 453   "Files which should not be byte-compiled.")
 454
 455 (defun dgnushack-compile-verbosely ()
 456   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 457 patches to gnus, you should consider modifying make.bat to call
 458 dgnushack-compile-verbosely.  All other users should continue to use
 459 dgnushack-compile."
 460   (dgnushack-compile t))
 461
 462 (defun dgnushack-compile (&optional warn)
 463   ;;(setq byte-compile-dynamic t)
 464   (unless warn
 465     (setq byte-compile-warnings
 466           '(free-vars unresolved callargs redefine)))
 467
 468   ;; Show `load-path'.
 469   (message "load-path=(\"%s\")"
 470            (mapconcat 'identity load-path "\"\n           \""))
 471
 472   (dolist (file dgnushack-exporting-files)
 473     (setq file (expand-file-name file srcdir))
 474     (when (and (file-exists-p
 475                 (setq elc (concat (file-name-nondirectory file) "c")))
 476                (file-newer-than-file-p file elc))
 477       (delete-file elc)))
 478
 479   ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 480   ;; installed.
 481   (when (featurep 'xemacs)
 482     (setq gnus-xmas-glyph-directory "dummy"))
 483
 484   (let ((files dgnushack-exporting-files)
 485         ;;(byte-compile-generate-call-tree t)
 486         file elc)
 487     (while (setq file (pop files))
 488       (unless (member file dgnushack-dont-compile-files)
 489         (setq file (expand-file-name file srcdir))
 490         (when (or (not (file-exists-p
 491                         (setq elc (concat (file-name-nondirectory file) "c"))))
 492                   (file-newer-than-file-p file elc))
 493           (ignore-errors
 494             (byte-compile-file file)))))))
 495
 496 (defun dgnushack-recompile ()
 497   (require 'gnus)
 498   (byte-recompile-directory "." 0))
 499
 500 (defvar dgnushack-gnus-load-file
 501   (if (featurep 'xemacs)
 502       (expand-file-name "auto-autoloads.el" srcdir)
 503     (expand-file-name "gnus-load.el" srcdir)))
 504
 505 (defvar dgnushack-cus-load-file
 506   (if (featurep 'xemacs)
 507       (expand-file-name "custom-load.el" srcdir)
 508     (expand-file-name "cus-load.el" srcdir)))
 509
 510 (defun dgnushack-make-cus-load ()
 511   (load "cus-dep")
 512   (let ((cusload-base-file dgnushack-cus-load-file))
 513     (if (fboundp 'custom-make-dependencies)
 514         (custom-make-dependencies)
 515       (Custom-make-dependencies))
 516     (when (featurep 'xemacs)
 517       (message "Compiling %s..." dgnushack-cus-load-file)
 518       (byte-compile-file dgnushack-cus-load-file))))
 519
 520 (defun dgnushack-make-auto-load ()
 521   (require 'autoload)
 522   (unless (make-autoload '(define-derived-mode child parent name
 523                             "docstring" body)
 524                          "file")
 525     (defadvice make-autoload (around handle-define-derived-mode activate)
 526       "Handle `define-derived-mode'."
 527       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 528           (setq ad-return-value
 529                 (list 'autoload
 530                       (list 'quote (nth 1 (ad-get-arg 0)))
 531                       (ad-get-arg 1)
 532                       (nth 4 (ad-get-arg 0))
 533                       t nil))
 534         ad-do-it))
 535     (put 'define-derived-mode 'doc-string-elt 3))
 536   (let ((generated-autoload-file dgnushack-gnus-load-file)
 537         (make-backup-files nil)
 538         (autoload-package-name "gnus"))
 539     (if (featurep 'xemacs)
 540         (if (file-exists-p generated-autoload-file)
 541             (delete-file generated-autoload-file))
 542       (with-temp-file generated-autoload-file
 543         (insert ?\014)))
 544     (if (featurep 'xemacs)
 545         (let ((si:message (symbol-function 'message)))
 546           (defun message (fmt &rest args)
 547             (cond ((and (string-equal "Generating autoloads for %s..." fmt)
 548                         (file-exists-p (file-name-nondirectory (car args))))
 549                    (funcall si:message
 550                             fmt (file-name-nondirectory (car args))))
 551                   ((string-equal "No autoloads found in %s" fmt))
 552                   ((string-equal "Generating autoloads for %s...done" fmt))
 553                   (t (apply si:message fmt args))))
 554           (unwind-protect
 555               (batch-update-autoloads)
 556             (fset 'message si:message)))
 557       (batch-update-autoloads))))
 558
 559 (defun dgnushack-make-load ()
 560   (unless (featurep 'xemacs)
 561     (message "Generating %s..." dgnushack-gnus-load-file)
 562     (with-temp-file dgnushack-gnus-load-file
 563       (insert-file-contents dgnushack-cus-load-file)
 564       (delete-file dgnushack-cus-load-file)
 565       (goto-char (point-min))
 566       (search-forward ";;; Code:")
 567       (forward-line)
 568       (delete-region (point-min) (point))
 569       (insert "\
 570 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 571 ;;
 572 ;;; Code:
 573 ")
 574       (goto-char (point-max))
 575       (if (search-backward "custom-versions-load-alist" nil t)
 576           (forward-line -1)
 577         (forward-line -1)
 578         (while (eq (char-after) ?\;)
 579           (forward-line -1))
 580         (forward-line))
 581       (delete-region (point) (point-max))
 582       (insert "\n")
 583       ;; smiley-* are duplicated. Remove them all.
 584       (let ((point (point)))
 585         (insert-file-contents dgnushack-gnus-load-file)
 586         (goto-char point)
 587         (while (search-forward "smiley-" nil t)
 588           (beginning-of-line)
 589           (if (looking-at "(autoload ")
 590               (delete-region (point) (progn (forward-sexp) (point)))
 591             (forward-line))))
 592       ;;
 593       (goto-char (point-max))
 594       (when (search-backward "\n(provide " nil t)
 595         (forward-line -1)
 596         (delete-region (point) (point-max)))
 597       (insert "\
 598
 599 \(provide 'gnus-load)
 600
 601 ;;; Local Variables:
 602 ;;; version-control: never
 603 ;;; no-byte-compile: t
 604 ;;; no-update-autoloads: t
 605 ;;; End:
 606 ;;; gnus-load.el ends here
 607 ")
 608       ))
 609   (message "Compiling %s..." dgnushack-gnus-load-file)
 610   (byte-compile-file dgnushack-gnus-load-file)
 611   (when (featurep 'xemacs)
 612     (message "Creating dummy gnus-load.el...")
 613     (with-temp-file (expand-file-name "gnus-load.el")
 614       (insert "\
 615
 616 \(provide 'gnus-load)
 617
 618 ;;; Local Variables:
 619 ;;; version-control: never
 620 ;;; no-byte-compile: t
 621 ;;; no-update-autoloads: t
 622 ;;; End:
 623 ;;; gnus-load.el ends here"))))
 624
 625 \f
 626 (defconst dgnushack-info-file-regexp-en
 627   (let ((names '("gnus" "message" "emacs-mime"))
 628         regexp name)
 629     (while (setq name (pop names))
 630       (setq regexp (concat regexp "^" name "\\.info\\(-[0-9]+\\)?$"
 631                            (when names "\\|"))))
 632     regexp)
 633   "Regexp matching English info files.")
 634
 635 (defconst dgnushack-info-file-regexp-ja
 636   (let ((names '("gnus-ja" "message-ja"))
 637         regexp name)
 638     (while (setq name (pop names))
 639       (setq regexp (concat regexp "^" name "\\.info\\(-[0-9]+\\)?$"
 640                            (when names "\\|"))))
 641     regexp)
 642   "Regexp matching Japanese info files.")
 643
 644 (defun dgnushack-remove-extra-files-in-package ()
 645   "Remove extra files in the lisp directory of the XEmacs package."
 646   (let ((lisp-dir (expand-file-name (concat "lisp/"
 647                                             ;; GNUS_PRODUCT_NAME
 648                                             (cadr command-line-args-left)
 649                                             "/")
 650                                     ;; PACKAGEDIR
 651                                     (car command-line-args-left))))
 652     (setq command-line-args-left nil)
 653     (when (file-directory-p lisp-dir)
 654       (let (files)
 655         (dolist (file dgnushack-exporting-files)
 656           (setq files (nconc files (list file (concat file "c")))))
 657         (dolist (file (directory-files lisp-dir nil nil t t))
 658           (unless (member file files)
 659             (setq file (expand-file-name file lisp-dir))
 660             (message "Removing %s..." file)
 661             (condition-case nil
 662                 (delete-file file)
 663               (error nil))))))))
 664
 665 (defun dgnushack-install-package-manifest ()
 666   "Install MANIFEST file as an XEmacs package."
 667   (let* ((package-dir (pop command-line-args-left))
 668          (product-name (pop command-line-args-left))
 669          (pkginfo-dir (expand-file-name "pkginfo" package-dir))
 670          (name (expand-file-name (concat "MANIFEST." product-name)
 671                                  pkginfo-dir))
 672          make-backup-files)
 673     (unless (file-directory-p pkginfo-dir)
 674       (message "Creating directory %s/..." pkginfo-dir)
 675       (make-directory pkginfo-dir))
 676     (message "Generating %s..." name)
 677     (with-temp-file name
 678       (insert "pkginfo/MANIFEST." product-name "\n")
 679       (let ((lisp-dir (concat "lisp/" product-name "/"))
 680             (files (sort (directory-files "." nil "\\.elc?$" t) 'string-lessp))
 681             file)
 682         (while (setq file (pop files))
 683           (unless (member file dgnushack-unexporting-files)
 684             (insert lisp-dir file "\n")))
 685         (setq files
 686               (sort (directory-files "../texi/" nil
 687                                      (concat dgnushack-info-file-regexp-en
 688                                              "\\|"
 689                                              dgnushack-info-file-regexp-ja)
 690                                      t)
 691                     'string-lessp))
 692         (while (setq file (pop files))
 693           (insert "info/" file "\n"))
 694         (insert "etc/gnus-tut.txt\n")
 695         (setq files
 696               (sort (directory-files "../etc/images/gnus/" nil
 697                                      "\\.\\(pbm\\|xbm\\|xpm\\)\\'"
 698                                      t)
 699                     'string-lessp))
 700         (while (setq file (pop files))
 701           (insert "etc/images/gnus/" file "\n"))
 702         (insert "etc/images/gnus/x-splash\n")
 703         (setq files
 704               (sort (directory-files "../etc/images/smilies/" nil
 705                                      "\\.\\(pbm\\|xpm\\)\\'"
 706                                      t)
 707                     'string-lessp))
 708         (while (setq file (pop files))
 709           (insert "etc/images/smilies/" file "\n"))))))
 710
 711 (defun dgnushack-find-lisp-shadows (&optional lispdir)
 712   "Return a list of directories in which other Gnus installations exist.
 713 This function looks for the other Gnus installations which will shadow
 714 the new Gnus Lisp modules which have been installed in LISPDIR, using
 715 the default `load-path'.  The return value will make sense only when
 716 LISPDIR is existent and is listed in the default `load-path'.  Assume
 717 LISPDIR will be prepended to `load-path' by a user if the default
 718 `load-path' does not contain it."
 719   (unless lispdir
 720     (setq lispdir (getenv "lispdir")))
 721   (when (and lispdir (file-directory-p lispdir))
 722     (setq lispdir (file-truename (directory-file-name lispdir)))
 723     (let ((indices '("gnus.elc" "gnus.el" "gnus.el.bz2" "gnus.el.gz"
 724                      "message.elc" "message.el" "message.el.bz2"
 725                      "message.el.gz"))
 726           (path (delq nil (mapcar
 727                            (lambda (p)
 728                              (condition-case nil
 729                                  (when (and p (file-directory-p p))
 730                                    (file-truename (directory-file-name p)))
 731                                (error nil)))
 732                            dgnushack-default-load-path)))
 733           rest elcs)
 734       (while path
 735         (setq rest (cons (car path) rest)
 736               path (delete (car rest) (cdr path))))
 737       (setq path (nreverse (cdr (member lispdir rest)))
 738             rest nil)
 739       (while path
 740         (setq elcs indices)
 741         (while elcs
 742           (when (file-exists-p (expand-file-name (pop elcs) (car path)))
 743             (setq rest (cons (car path) rest)
 744                   elcs nil)))
 745         (setq path (cdr path)))
 746       (prog1
 747           (setq path (nreverse rest))
 748         (when path
 749           (let (print-level print-length)
 750             (princ (concat "\n\
 751 WARNING: The other gnus installation" (if (cdr path) "s have" " has") "\
 752  been detected in:\n\n  " (mapconcat 'identity path "\n  ") "\n\n\
 753 You will need to modify the run-time `load-path', remove them manually,
 754 or remove them using `make remove-installed-shadows'.\n\n"))))))))
 755
 756 (defun dgnushack-remove-lisp-shadows (&optional lispdir)
 757   "Remove the other Gnus installations which shadow the recent one."
 758   (let ((path (with-temp-buffer
 759                 (let ((standard-output (current-buffer)))
 760                   (dgnushack-find-lisp-shadows lispdir))))
 761         elcs files shadows file)
 762     (when path
 763       (unless (setq elcs (directory-files srcdir nil "\\.elc\\'"))
 764         (error "You should build .elc files first."))
 765       (setq files
 766             (apply
 767              'append
 768              (mapcar
 769               (lambda (el)
 770                 (list (concat el "c") el (concat el ".bz2") (concat el ".gz")))
 771               (append
 772                (list (file-name-nondirectory dgnushack-gnus-load-file)
 773                      (file-name-nondirectory dgnushack-cus-load-file))
 774                (mapcar (lambda (elc) (substring elc 0 -1)) elcs)))))
 775       (while path
 776         (setq shadows files)
 777         (while shadows
 778           (setq file (expand-file-name (pop shadows) (car path)))
 779           (when (file-exists-p file)
 780             (princ (concat "  Removing " file "..."))
 781             (condition-case nil
 782                 (progn
 783                   (delete-file file)
 784                   (princ "done\n"))
 785               (error (princ "failed\n")))))
 786         (setq path (cdr path))))))
 787
 788 ;;; dgnushack.el ends here