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, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Version: 4.19
   7 ;; Keywords: news, path
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (defalias 'facep 'ignore)
  31
  32 (require 'cl)
  33
  34 (defvar srcdir (or (getenv "srcdir") "."))
  35
  36 (defun my-getenv (str)
  37   (let ((val (getenv str)))
  38     (if (equal val "no") nil val)))
  39
  40 (if (my-getenv "lispdir")
  41     (push (my-getenv "lispdir") load-path))
  42
  43 (push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" srcdir))
  44       load-path)
  45
  46 (push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" srcdir))
  47       load-path)
  48
  49 ;(push "/usr/share/emacs/site-lisp" load-path)
  50
  51 ;; Define compiler macros for the functions provided by cl in old Emacsen.
  52 (unless (featurep 'xemacs)
  53   (define-compiler-macro assq-delete-all (&whole form key alist)
  54     (if (>= emacs-major-version 21)
  55         form
  56       `(let* ((key ,key)
  57               (alist ,alist)
  58               (tail alist))
  59          (while tail
  60            (if (and (consp (car tail)) (eq (car (car tail)) key))
  61                (setq alist (delq (car tail) alist)))
  62            (setq tail (cdr tail)))
  63          alist)))
  64
  65   (define-compiler-macro butlast (&whole form x &optional n)
  66     (if (>= emacs-major-version 21)
  67         form
  68       (if n
  69           `(let ((x ,x)
  70                  (n ,n))
  71              (if (and n (<= n 0))
  72                  x
  73                (let ((m (length x)))
  74                  (or n (setq n 1))
  75                  (and (< n m)
  76                       (progn
  77                         (if (> n 0)
  78                             (progn
  79                               (setq x (copy-sequence x))
  80                               (setcdr (nthcdr (- (1- m) n) x) nil)))
  81                         x)))))
  82         `(let* ((x ,x)
  83                 (m (length x)))
  84            (and (< 1 m)
  85                 (progn
  86                   (setq x (copy-sequence x))
  87                   (setcdr (nthcdr (- m 2) x) nil)
  88                   x))))))
  89
  90   (define-compiler-macro remove (&whole form item seq)
  91     (if (>= emacs-major-version 21)
  92         form
  93       `(delete ,item (copy-sequence ,seq)))))
  94
  95 ;; If we are building w3 in a different directory than the source
  96 ;; directory, we must read *.el from source directory and write *.elc
  97 ;; into the building directory.  For that, we define this function
  98 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
  99 (defun byte-compile-dest-file (filename)
 100   "Convert an Emacs Lisp source file name to a compiled file name.
 101  In addition, remove directory name part from FILENAME."
 102   (setq filename (byte-compiler-base-file-name filename))
 103   (setq filename (file-name-sans-versions filename))
 104   (setq filename (file-name-nondirectory filename))
 105   (if (memq system-type '(win32 w32 mswindows windows-nt))
 106       (setq filename (downcase filename)))
 107   (cond ((eq system-type 'vax-vms)
 108          (concat (substring filename 0 (string-match ";" filename)) "c"))
 109         ((string-match emacs-lisp-file-regexp filename)
 110          (concat (substring filename 0 (match-beginning 0)) ".elc"))
 111         (t (concat filename ".elc"))))
 112
 113 (require 'bytecomp)
 114 ;; To avoid having defsubsts and inlines happen.
 115 ;(if (featurep 'xemacs)
 116 ;    (require 'byte-optimize)
 117 ;  (require 'byte-opt))
 118 ;(defun byte-optimize-inline-handler (form)
 119 ;  "byte-optimize-handler for the `inline' special-form."
 120 ;  (cons 'progn (cdr form)))
 121 ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun)
 122
 123 (push srcdir load-path)
 124 (load (expand-file-name "lpath.el" srcdir) nil t)
 125
 126 (defalias 'device-sound-enabled-p 'ignore)
 127 (defalias 'play-sound-file 'ignore)
 128 (defalias 'nndb-request-article 'ignore)
 129 (defalias 'efs-re-read-dir 'ignore)
 130 (defalias 'ange-ftp-re-read-dir 'ignore)
 131 (defalias 'define-mail-user-agent 'ignore)
 132
 133 (eval-and-compile
 134   (unless (featurep 'xemacs)
 135     (defalias 'get-popup-menu-response 'ignore)
 136     (defalias 'event-object 'ignore)
 137     (defalias 'x-defined-colors 'ignore)
 138     (defalias 'read-color 'ignore)))
 139
 140 (eval-and-compile
 141   (when (featurep 'xemacs)
 142     ;; XEmacs 21.1 needs some extra hand holding
 143     (when (eq emacs-minor-version 1)
 144       (autoload 'custom-declare-face "cus-face" nil t)
 145       (autoload 'cl-compile-time-init "cl-macs" nil t)
 146       (autoload 'defadvice "advice" nil nil 'macro))
 147     (unless (fboundp 'defadvice)
 148       (autoload 'defadvice "advice" nil nil 'macro))
 149     (autoload 'Info-directory "info" nil t)
 150     (autoload 'Info-menu "info" nil t)
 151     (autoload 'annotations-at "annotations")
 152     (autoload 'apropos "apropos" nil t)
 153     (autoload 'apropos-command "apropos" nil t)
 154     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 155     (autoload 'browse-url "browse-url" nil t)
 156     (autoload 'customize-apropos "cus-edit" nil t)
 157     (autoload 'customize-save-variable "cus-edit" nil t)
 158     (autoload 'customize-variable "cus-edit" nil t)
 159     (autoload 'delete-annotation "annotations")
 160     (autoload 'dolist "cl-macs" nil nil 'macro)
 161     (autoload 'enriched-decode "enriched")
 162     (autoload 'info "info" nil t)
 163     (autoload 'make-annotation "annotations")
 164     (autoload 'make-display-table "disp-table")
 165     (autoload 'pp "pp")
 166     (autoload 'ps-despool "ps-print" nil t)
 167     (autoload 'ps-spool-buffer "ps-print" nil t)
 168     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 169     (autoload 'read-passwd "passwd")
 170     (autoload 'regexp-opt "regexp-opt")
 171     (autoload 'reporter-submit-bug-report "reporter")
 172     (if (emacs-version>= 21 5)
 173         (autoload 'setenv "process" nil t)
 174       (autoload 'setenv "env" nil t))
 175     (autoload 'smtpmail-send-it "smtpmail")
 176     (autoload 'sort-numeric-fields "sort" nil t)
 177     (autoload 'sort-subr "sort")
 178     (autoload 'trace-function-background "trace" nil t)
 179     (autoload 'w3-do-setup "w3")
 180     (autoload 'w3-prepare-buffer "w3-display")
 181     (autoload 'w3-region "w3-display" nil t)
 182     (defalias 'frame-char-height 'frame-height)
 183     (defalias 'frame-char-width 'frame-width)
 184     (defalias 'frame-parameter 'frame-property)
 185     (defalias 'make-overlay 'ignore)
 186     (defalias 'overlay-end 'ignore)
 187     (defalias 'overlay-get 'ignore)
 188     (defalias 'overlay-put 'ignore)
 189     (defalias 'overlay-start 'ignore)
 190     (defalias 'overlays-in 'ignore)
 191     (defalias 'replace-dehighlight 'ignore)
 192     (defalias 'replace-highlight 'ignore)
 193     (defalias 'run-with-idle-timer 'ignore)
 194     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 195
 196 (defun dgnushack-compile-verbosely ()
 197   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 198 patches to gnus, you should consider modifying make.bat to call
 199 dgnushack-compile-verbosely.  All other users should continue to use
 200 dgnushack-compile."
 201   (dgnushack-compile t))
 202
 203 (defun dgnushack-compile (&optional warn)
 204   ;;(setq byte-compile-dynamic t)
 205   (unless warn
 206     (setq byte-compile-warnings
 207           '(free-vars unresolved callargs redefine)))
 208   (unless (locate-library "cus-edit")
 209     (error "You do not seem to have Custom installed.
 210 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 211 You also then need to add the following to the lisp/dgnushack.el file:
 212
 213      (push \"~/lisp/custom\" load-path)
 214
 215 Modify to suit your needs."))
 216   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 217         ;;(byte-compile-generate-call-tree t)
 218         file elc)
 219     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 220     ;; installed.
 221     (when (featurep 'xemacs)
 222       (setq gnus-xmas-glyph-directory "dummy"))
 223     (dolist (file '("dgnushack.el" "lpath.el"))
 224       (setq files (delete file files)))
 225     (when (featurep 'base64)
 226       (setq files (delete "base64.el" files)))
 227     (condition-case code
 228         (require 'w3-parse)
 229       (error
 230        (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") ""))
 231        (dolist (file '("nnultimate.el" "webmail.el" "nnwfm.el"))
 232          (setq files (delete file files)))))
 233     (condition-case code
 234         (require 'mh-e)
 235       (error
 236        (message "No mh-e: %s %s" (cadr code) (or (locate-library "mh-e") ""))
 237        (setq files (delete "gnus-mh.el" files))))
 238     (condition-case code
 239         (require 'xml)
 240       (error
 241        (message "No xml: %s %s" (cadr code) (or (locate-library "xml") ""))
 242        (setq files (delete "nnrss.el" files))))
 243     (dolist (file
 244              (if (featurep 'xemacs)
 245                  '("md5.el")
 246                '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el")))
 247       (setq files (delete file files)))
 248
 249     (dolist (file files)
 250       (setq file (expand-file-name file srcdir))
 251       (when (and (file-exists-p
 252                   (setq elc (concat (file-name-nondirectory file) "c")))
 253                  (file-newer-than-file-p file elc))
 254         (delete-file elc)))
 255
 256     (while (setq file (pop files))
 257       (setq file (expand-file-name file srcdir))
 258       (when (or (not (file-exists-p
 259                       (setq elc (concat (file-name-nondirectory file) "c"))))
 260                 (file-newer-than-file-p file elc))
 261         (ignore-errors
 262           (byte-compile-file file))))))
 263
 264 (defun dgnushack-recompile ()
 265   (require 'gnus)
 266   (byte-recompile-directory "." 0))
 267
 268 (defvar dgnushack-gnus-load-file (expand-file-name "gnus-load.el"))
 269 (defvar dgnushack-cus-load-file (expand-file-name "cus-load.el"))
 270
 271 (defun dgnushack-make-cus-load ()
 272   (load "cus-dep")
 273   (let ((cusload-base-file dgnushack-cus-load-file))
 274     (if (fboundp 'custom-make-dependencies)
 275         (custom-make-dependencies)
 276       (Custom-make-dependencies))))
 277
 278 (defun dgnushack-make-auto-load ()
 279   (require 'autoload)
 280   (unless (make-autoload '(define-derived-mode child parent name
 281                             "docstring" body)
 282                          "file")
 283     (defadvice make-autoload (around handle-define-derived-mode activate)
 284       "Handle `define-derived-mode'."
 285       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 286           (setq ad-return-value
 287                 (list 'autoload
 288                       (list 'quote (nth 1 (ad-get-arg 0)))
 289                       (ad-get-arg 1)
 290                       (nth 4 (ad-get-arg 0))
 291                       t nil))
 292         ad-do-it))
 293     (put 'define-derived-mode 'doc-string-elt 3))
 294   (let ((generated-autoload-file dgnushack-gnus-load-file)
 295         (make-backup-files nil)
 296         (autoload-package-name "gnus"))
 297     (if (featurep 'xemacs)
 298         (if (file-exists-p generated-autoload-file)
 299             (delete-file generated-autoload-file))
 300       (with-temp-file generated-autoload-file
 301         (insert ?\014)))
 302     (batch-update-autoloads)))
 303
 304 (defun dgnushack-make-load ()
 305   (message "Generating %s..." dgnushack-gnus-load-file)
 306   (with-temp-file dgnushack-gnus-load-file
 307     (insert-file-contents dgnushack-cus-load-file)
 308     (delete-file dgnushack-cus-load-file)
 309     (goto-char (point-min))
 310     (search-forward ";;; Code:")
 311     (forward-line)
 312     (delete-region (point-min) (point))
 313     (insert "\
 314 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 315 ;;
 316 ;;; Code:
 317 ")
 318     (goto-char (point-max))
 319     (if (search-backward "custom-versions-load-alist" nil t)
 320         (forward-line -1)
 321       (forward-line -1)
 322       (while (eq (char-after) ?\;)
 323         (forward-line -1))
 324       (forward-line))
 325     (delete-region (point) (point-max))
 326     (insert "\n")
 327     ;; smiley-* are duplicated. Remove them all.
 328     (let ((point (point)))
 329       (insert-file-contents dgnushack-gnus-load-file)
 330       (goto-char point)
 331       (while (search-forward "smiley-" nil t)
 332         (beginning-of-line)
 333         (if (looking-at "(autoload ")
 334             (delete-region (point) (progn (forward-sexp) (point)))
 335           (forward-line))))
 336     ;;
 337     (goto-char (point-max))
 338     (when (search-backward "\n(provide " nil t)
 339       (forward-line -1)
 340       (delete-region (point) (point-max)))
 341     (insert "\
 342
 343 \(provide 'gnus-load)
 344
 345 ;;; Local Variables:
 346 ;;; version-control: never
 347 ;;; no-byte-compile: t
 348 ;;; no-update-autoloads: t
 349 ;;; End:
 350 ;;; gnus-load.el ends here
 351 ")
 352     ;; Workaround the bug in some version of XEmacs.
 353     (when (featurep 'xemacs)
 354       (condition-case nil
 355           (require 'cus-load)
 356         (error nil))
 357       (goto-char (point-min))
 358       (when (and (fboundp 'custom-add-loads)
 359                  (not (search-forward "\n(autoload 'custom-add-loads " nil t)))
 360         (search-forward "\n;;; Code:" nil t)
 361         (forward-line 1)
 362         (insert "\n(autoload 'custom-add-loads \"cus-load\")\n"))))
 363   (message "Compiling %s..." dgnushack-gnus-load-file)
 364   (byte-compile-file dgnushack-gnus-load-file))
 365
 366 ;;; dgnushack.el ends here