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 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 (unless (featurep 'xemacs)
  52   (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
  53     (if (and (fboundp 'merge)
  54              (subrp (symbol-function 'merge)))
  55         form
  56       `(let ((type ,type)
  57              (seq1 ,seq1)
  58              (seq2 ,seq2)
  59              (pred ,pred))
  60          (or (listp seq1) (setq seq1 (append seq1 nil)))
  61          (or (listp seq2) (setq seq2 (append seq2 nil)))
  62          (let ((res nil))
  63            (while (and seq1 seq2)
  64              (if (funcall pred (car seq2) (car seq1))
  65                  (push (pop seq2) res)
  66                (push (pop seq1) res)))
  67            (let ((x (nconc (nreverse res) seq1 seq2)))
  68              (cond ((eq type 'list) (if (listp x) x (append x nil)))
  69                    ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  70                    ((eq type 'string) (if (stringp x) x (concat x)))
  71                    ((eq type 'array) (if (arrayp x) x (vconcat x)))
  72                    ((and (eq type 'character) (stringp x) (= (length x) 1))
  73                     (aref x 0))
  74                    ((and (eq type 'character) (symbolp x))
  75                     (aref (symbol-name x) 0))
  76                    ((eq type 'float) (float x))
  77                    ((typep x type) x)
  78                    (t (error "Can't coerce %s to type %s" x type))))))))
  79
  80   (define-compiler-macro copy-list (&whole form list)
  81     (if (and (fboundp 'copy-list)
  82              (subrp (symbol-function 'copy-list)))
  83         form
  84       `(let ((list ,list))
  85          (if (consp list)
  86              (let ((res nil))
  87                (while (consp list) (push (pop list) res))
  88                (prog1 (nreverse res) (setcdr res list)))
  89            (car list)))))
  90
  91   (define-compiler-macro remove (&whole form item seq)
  92     (if (>= emacs-major-version 21)
  93         form
  94       `(delete ,item (copy-sequence ,seq)))))
  95
  96 ;; If we are building w3 in a different directory than the source
  97 ;; directory, we must read *.el from source directory and write *.elc
  98 ;; into the building directory.  For that, we define this function
  99 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
 100 (defun byte-compile-dest-file (filename)
 101   "Convert an Emacs Lisp source file name to a compiled file name.
 102  In addition, remove directory name part from FILENAME."
 103   (setq filename (byte-compiler-base-file-name filename))
 104   (setq filename (file-name-sans-versions filename))
 105   (setq filename (file-name-nondirectory filename))
 106   (if (memq system-type '(win32 w32 mswindows windows-nt))
 107       (setq filename (downcase filename)))
 108   (cond ((eq system-type 'vax-vms)
 109          (concat (substring filename 0 (string-match ";" filename)) "c"))
 110         ((string-match emacs-lisp-file-regexp filename)
 111          (concat (substring filename 0 (match-beginning 0)) ".elc"))
 112         (t (concat filename ".elc"))))
 113
 114 (require 'bytecomp)
 115 ;; To avoid having defsubsts and inlines happen.
 116 ;(if (featurep 'xemacs)
 117 ;    (require 'byte-optimize)
 118 ;  (require 'byte-opt))
 119 ;(defun byte-optimize-inline-handler (form)
 120 ;  "byte-optimize-handler for the `inline' special-form."
 121 ;  (cons 'progn (cdr form)))
 122 ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun)
 123
 124 (push srcdir load-path)
 125 (load (expand-file-name "lpath.el" srcdir) nil t)
 126
 127 (defalias 'device-sound-enabled-p 'ignore)
 128 (defalias 'play-sound-file 'ignore)
 129 (defalias 'nndb-request-article 'ignore)
 130 (defalias 'efs-re-read-dir 'ignore)
 131 (defalias 'ange-ftp-re-read-dir 'ignore)
 132 (defalias 'define-mail-user-agent 'ignore)
 133
 134 (eval-and-compile
 135   (unless (featurep 'xemacs)
 136     (defalias 'get-popup-menu-response 'ignore)
 137     (defalias 'event-object 'ignore)
 138     (defalias 'x-defined-colors 'ignore)
 139     (defalias 'read-color 'ignore)))
 140
 141 (eval-and-compile
 142   (when (featurep 'xemacs)
 143     (autoload 'Info-directory "info" nil t)
 144     (autoload 'Info-menu "info" nil t)
 145     (autoload 'annotations-at "annotations")
 146     (autoload 'apropos "apropos" nil t)
 147     (autoload 'apropos-command "apropos" nil t)
 148     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 149     (autoload 'browse-url "browse-url" nil t)
 150     (autoload 'customize-apropos "cus-edit" nil t)
 151     (autoload 'customize-save-variable "cus-edit" nil t)
 152     (autoload 'customize-variable "cus-edit" nil t)
 153     (autoload 'delete-annotation "annotations")
 154     (autoload 'dolist "cl-macs" nil nil 'macro)
 155     (autoload 'enriched-decode "enriched")
 156     (autoload 'info "info" nil t)
 157     (autoload 'make-annotation "annotations")
 158     (autoload 'make-display-table "disp-table")
 159     (autoload 'pp "pp")
 160     (autoload 'ps-despool "ps-print" nil t)
 161     (autoload 'ps-spool-buffer "ps-print" nil t)
 162     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 163     (autoload 'read-passwd "passwd")
 164     (autoload 'regexp-opt "regexp-opt")
 165     (autoload 'reporter-submit-bug-report "reporter")
 166     (if (emacs-version>= 21 5)
 167         (autoload 'setenv "process" nil t)
 168       (autoload 'setenv "env" nil t))
 169     (autoload 'smtpmail-send-it "smtpmail")
 170     (autoload 'sort-numeric-fields "sort" nil t)
 171     (autoload 'sort-subr "sort")
 172     (autoload 'trace-function-background "trace" nil t)
 173     (autoload 'w3-do-setup "w3")
 174     (autoload 'w3-prepare-buffer "w3-display")
 175     (autoload 'w3-region "w3-display" nil t)
 176     (defalias 'frame-char-height 'frame-height)
 177     (defalias 'frame-char-width 'frame-width)
 178     (defalias 'frame-parameter 'frame-property)
 179     (defalias 'make-overlay 'ignore)
 180     (defalias 'overlay-end 'ignore)
 181     (defalias 'overlay-get 'ignore)
 182     (defalias 'overlay-put 'ignore)
 183     (defalias 'overlay-start 'ignore)
 184     (defalias 'overlays-in 'ignore)
 185     (defalias 'replace-dehighlight 'ignore)
 186     (defalias 'replace-highlight 'ignore)
 187     (defalias 'run-with-idle-timer 'ignore)
 188     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 189
 190 (defun dgnushack-compile (&optional warn)
 191   ;;(setq byte-compile-dynamic t)
 192   (unless warn
 193     (setq byte-compile-warnings
 194           '(free-vars unresolved callargs redefine)))
 195   (unless (locate-library "cus-edit")
 196     (error "You do not seem to have Custom installed.
 197 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 198 You also then need to add the following to the lisp/dgnushack.el file:
 199
 200      (push \"~/lisp/custom\" load-path)
 201
 202 Modify to suit your needs."))
 203   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 204         ;;(byte-compile-generate-call-tree t)
 205         file elc)
 206     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 207     ;; installed.
 208     (when (featurep 'xemacs)
 209       (setq gnus-xmas-glyph-directory "dummy"))
 210     (dolist (file '("dgnushack.el" "lpath.el"))
 211       (setq files (delete file files)))
 212     (when (featurep 'base64)
 213       (setq files (delete "base64.el" files)))
 214     (condition-case code
 215         (require 'w3-parse)
 216       (error
 217        (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") ""))
 218        (dolist (file '("nnultimate.el" "webmail.el" "nnwfm.el"))
 219          (setq files (delete file files)))))
 220     (condition-case code
 221         (require 'mh-e)
 222       (error
 223        (message "No mh-e: %s %s" (cadr code) (or (locate-library "mh-e") ""))
 224        (setq files (delete "gnus-mh.el" files))))
 225     (condition-case code
 226         (require 'xml)
 227       (error
 228        (message "No xml: %s %s" (cadr code) (or (locate-library "xml") ""))
 229        (setq files (delete "nnrss.el" files))))
 230     (dolist (file
 231              (if (featurep 'xemacs)
 232                  '("md5.el")
 233                '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el")))
 234       (setq files (delete file files)))
 235
 236     (dolist (file files)
 237       (setq file (expand-file-name file srcdir))
 238       (when (and (file-exists-p
 239                   (setq elc (concat (file-name-nondirectory file) "c")))
 240                  (file-newer-than-file-p file elc))
 241         (delete-file elc)))
 242
 243     (while (setq file (pop files))
 244       (setq file (expand-file-name file srcdir))
 245       (when (or (not (file-exists-p
 246                       (setq elc (concat (file-name-nondirectory file) "c"))))
 247                 (file-newer-than-file-p file elc))
 248         (ignore-errors
 249           (byte-compile-file file))))))
 250
 251 (defun dgnushack-recompile ()
 252   (require 'gnus)
 253   (byte-recompile-directory "." 0))
 254
 255 (defvar dgnushack-gnus-load-file (expand-file-name "gnus-load.el"))
 256 (defvar dgnushack-cus-load-file (expand-file-name "cus-load.el"))
 257
 258 (defun dgnushack-make-cus-load ()
 259   (load "cus-dep")
 260   (let ((cusload-base-file dgnushack-cus-load-file))
 261     (if (fboundp 'custom-make-dependencies)
 262         (custom-make-dependencies)
 263       (Custom-make-dependencies))))
 264
 265 (defun dgnushack-make-auto-load ()
 266   (require 'autoload)
 267   (unless (make-autoload '(define-derived-mode child parent name
 268                             "docstring" body)
 269                          "file")
 270     (defadvice make-autoload (around handle-define-derived-mode activate)
 271       "Handle `define-derived-mode'."
 272       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 273           (setq ad-return-value
 274                 (list 'autoload
 275                       (list 'quote (nth 1 (ad-get-arg 0)))
 276                       (ad-get-arg 1)
 277                       (nth 4 (ad-get-arg 0))
 278                       t nil))
 279         ad-do-it))
 280     (put 'define-derived-mode 'doc-string-elt 3))
 281   (let ((generated-autoload-file dgnushack-gnus-load-file)
 282         (make-backup-files nil)
 283         (autoload-package-name "gnus"))
 284     (if (featurep 'xemacs)
 285         (if (file-exists-p generated-autoload-file)
 286             (delete-file generated-autoload-file))
 287       (with-temp-file generated-autoload-file
 288         (insert ?\014)))
 289     (batch-update-autoloads)))
 290
 291 (defun dgnushack-make-load ()
 292   (message (format "Generating %s..." dgnushack-gnus-load-file))
 293   (with-temp-file dgnushack-gnus-load-file
 294     (insert-file-contents dgnushack-cus-load-file)
 295     (delete-file dgnushack-cus-load-file)
 296     (goto-char (point-min))
 297     (search-forward ";;; Code:")
 298     (forward-line)
 299     (delete-region (point-min) (point))
 300     (insert "\
 301 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 302 ;;
 303 ;;; Code:
 304 ")
 305     (goto-char (point-max))
 306     (if (search-backward "custom-versions-load-alist" nil t)
 307         (forward-line -1)
 308       (forward-line -1)
 309       (while (eq (char-after) ?\;)
 310         (forward-line -1))
 311       (forward-line))
 312     (delete-region (point) (point-max))
 313     (insert "\n")
 314     ;; smiley-* are duplicated. Remove them all.
 315     (let ((point (point)))
 316       (insert-file-contents dgnushack-gnus-load-file)
 317       (goto-char point)
 318       (while (search-forward "smiley-" nil t)
 319         (beginning-of-line)
 320         (if (looking-at "(autoload ")
 321             (delete-region (point) (progn (forward-sexp) (point)))
 322           (forward-line))))
 323     ;;
 324     (goto-char (point-max))
 325     (when (search-backward "\n(provide " nil t)
 326       (forward-line -1)
 327       (delete-region (point) (point-max)))
 328     (insert "\
 329
 330 \(provide 'gnus-load)
 331
 332 ;;; Local Variables:
 333 ;;; version-control: never
 334 ;;; no-byte-compile: t
 335 ;;; no-update-autoloads: t
 336 ;;; End:
 337 ;;; gnus-load.el ends here
 338 ")
 339     ;; Workaround the bug in some version of XEmacs.
 340     (when (featurep 'xemacs)
 341       (condition-case nil
 342           (require 'cus-load)
 343         (error nil))
 344       (goto-char (point-min))
 345       (when (and (fboundp 'custom-add-loads)
 346                  (not (search-forward "\n(autoload 'custom-add-loads " nil t)))
 347         (search-forward "\n;;; Code:" nil t)
 348         (forward-line 1)
 349         (insert "\n(autoload 'custom-add-loads \"cus-load\")\n"))))
 350   (message (format "Compiling %s..." dgnushack-gnus-load-file))
 351   (byte-compile-file dgnushack-gnus-load-file))
 352
 353 ;;; dgnushack.el ends here