cgit.sxemacs.org Git - gnus/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
   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 "lispdir")))
  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 (unless (featurep 'xemacs)
  52   (define-compiler-macro last (&whole form x &optional n)
  53     (if (and (fboundp 'last)
  54              (subrp (symbol-function 'last)))
  55         form
  56       (if n
  57           `(let* ((x ,x)
  58                   (n ,n)
  59                   (m 0)
  60                   (p x))
  61              (while (consp p)
  62                (incf m)
  63                (pop p))
  64              (if (<= n 0)
  65                  p
  66                (if (< n m)
  67                    (nthcdr (- m n) x)
  68                  x)))
  69         `(let ((x ,x))
  70            (while (consp (cdr x))
  71              (pop x))
  72            x))))
  73   )
  74
  75 ;; If we are building w3 in a different directory than the source
  76 ;; directory, we must read *.el from source directory and write *.elc
  77 ;; into the building directory.  For that, we define this function
  78 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
  79 (defun byte-compile-dest-file (filename)
  80   "Convert an Emacs Lisp source file name to a compiled file name.
  81  In addition, remove directory name part from FILENAME."
  82   (setq filename (byte-compiler-base-file-name filename))
  83   (setq filename (file-name-sans-versions filename))
  84   (setq filename (file-name-nondirectory filename))
  85   (if (memq system-type '(win32 w32 mswindows windows-nt))
  86       (setq filename (downcase filename)))
  87   (cond ((eq system-type 'vax-vms)
  88          (concat (substring filename 0 (string-match ";" filename)) "c"))
  89         ((string-match emacs-lisp-file-regexp filename)
  90          (concat (substring filename 0 (match-beginning 0)) ".elc"))
  91         (t (concat filename ".elc"))))
  92
  93 (require 'bytecomp)
  94
  95 (push srcdir load-path)
  96 (load (expand-file-name "lpath.el" srcdir) nil t)
  97
  98 (defalias 'device-sound-enabled-p 'ignore)
  99 (defalias 'play-sound-file 'ignore)
 100 (defalias 'nndb-request-article 'ignore)
 101 (defalias 'efs-re-read-dir 'ignore)
 102 (defalias 'ange-ftp-re-read-dir 'ignore)
 103 (defalias 'define-mail-user-agent 'ignore)
 104
 105 (eval-and-compile
 106   (unless (featurep 'xemacs)
 107     (defalias 'get-popup-menu-response 'ignore)
 108     (defalias 'event-object 'ignore)
 109     (defalias 'x-defined-colors 'ignore)
 110     (defalias 'read-color 'ignore)))
 111
 112 (defun dgnushack-compile (&optional warn)
 113   ;;(setq byte-compile-dynamic t)
 114   (unless warn
 115     (setq byte-compile-warnings
 116           '(free-vars unresolved callargs redefine)))
 117   (unless (locate-library "cus-edit")
 118     (error "You do not seem to have Custom installed.
 119 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 120 You also then need to add the following to the lisp/dgnushack.el file:
 121
 122      (push \"~/lisp/custom\" load-path)
 123
 124 Modify to suit your needs."))
 125   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 126         ;;(byte-compile-generate-call-tree t)
 127         file elc)
 128     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 129     ;; installed.
 130     (when (featurep 'xemacs)
 131       (setq gnus-xmas-glyph-directory "dummy"))
 132     (dolist (file '("dgnushack.el" "lpath.el"))
 133       (setq files (delete file files)))
 134     (when (featurep 'base64)
 135       (setq files (delete "base64.el" files)))
 136     (condition-case code
 137         (require 'w3-forms)
 138       (error
 139        (message "No w3: %s %s" code (locate-library "w3-forms"))
 140        (dolist (file '("nnweb.el" "nnlistserv.el" "nnultimate.el"
 141                        "nnslashdot.el" "nnwarchive.el" "webmail.el"
 142                        "nnwfm.el"))
 143          (setq files (delete file files)))))
 144     (dolist (file
 145              (if (featurep 'xemacs)
 146                  '("md5.el" "smiley-ems.el")
 147                '("gnus-xmas.el" "gnus-picon.el" "messagexmas.el"
 148                  "nnheaderxm.el" "smiley.el")))
 149       (setq files (delete file files)))
 150
 151     (dolist (file files)
 152       (setq file (expand-file-name file srcdir))
 153       (when (and (file-exists-p
 154                   (setq elc (concat (file-name-nondirectory file) "c")))
 155                  (file-newer-than-file-p file elc))
 156         (delete-file elc)))
 157
 158     (while (setq file (pop files))
 159       (setq file (expand-file-name file srcdir))
 160       (when (or (not (file-exists-p
 161                       (setq elc (concat (file-name-nondirectory file) "c"))))
 162                 (file-newer-than-file-p file elc))
 163         (ignore-errors
 164           (byte-compile-file file))))))
 165
 166 (defun dgnushack-recompile ()
 167   (require 'gnus)
 168   (byte-recompile-directory "." 0))
 169
 170 (defvar dgnushack-gnus-load-file (expand-file-name "gnus-load.el"))
 171 (defvar dgnushack-cus-load-file (expand-file-name "cus-load.el"))
 172
 173 (defun dgnushack-make-cus-load ()
 174   (load "cus-dep")
 175   (let ((cusload-base-file dgnushack-cus-load-file))
 176     (if (fboundp 'custom-make-dependencies)
 177         (custom-make-dependencies)
 178       (Custom-make-dependencies))))
 179
 180 (defun dgnushack-make-auto-load ()
 181   (require 'autoload)
 182   (let ((generated-autoload-file dgnushack-gnus-load-file)
 183         (make-backup-files nil)
 184         (autoload-package-name "gnus"))
 185     (if (featurep 'xemacs)
 186         (if (file-exists-p generated-autoload-file)
 187             (delete-file generated-autoload-file))
 188       (with-temp-file generated-autoload-file
 189         (insert ?\014)))
 190     (batch-update-autoloads)))
 191
 192 (defun dgnushack-make-load ()
 193   (message (format "Generating %s..." dgnushack-gnus-load-file))
 194   (with-temp-file dgnushack-gnus-load-file
 195     (insert-file-contents dgnushack-cus-load-file)
 196     (delete-file dgnushack-cus-load-file)
 197     (goto-char (point-min))
 198     (search-forward ";;; Code:")
 199     (forward-line)
 200     (delete-region (point-min) (point))
 201     (insert "\
 202 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 203 ;;
 204 ;;; Code:
 205 ")
 206     (goto-char (point-max))
 207     (if (search-backward "custom-versions-load-alist" nil t)
 208         (forward-line -1)
 209       (forward-line -1)
 210       (while (eq (char-after) ?\;)
 211         (forward-line -1))
 212       (forward-line))
 213     (delete-region (point) (point-max))
 214     (insert "\n")
 215     ;; smiley-* are duplicated. Remove them all.
 216     (let ((point (point)))
 217       (insert-file-contents dgnushack-gnus-load-file)
 218       (goto-char point)
 219       (while (search-forward "smiley-" nil t)
 220         (beginning-of-line)
 221         (if (looking-at "(autoload ")
 222             (delete-region (point) (progn (forward-sexp) (point)))
 223           (forward-line))))
 224     ;;
 225     (goto-char (point-max))
 226     (when (search-backward "\n(provide " nil t)
 227       (forward-line -1)
 228       (delete-region (point) (point-max)))
 229     (insert "\
 230
 231 \(provide 'gnus-load)
 232
 233 ;;; Local Variables:
 234 ;;; version-control: never
 235 ;;; no-byte-compile: t
 236 ;;; no-update-autoloads: t
 237 ;;; End:
 238 ;;; gnus-load.el ends here\n"))
 239   (message (format "Compiling %s..." dgnushack-gnus-load-file))
 240   (byte-compile-file dgnushack-gnus-load-file))
 241
 242 ;;; dgnushack.el ends here