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, 2003,
   3 ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;        Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Version: 4.19
   8 ;; Keywords: news, path
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 (defvar dgnushack-default-load-path (copy-sequence load-path))
  32
  33 (defalias 'facep 'ignore)
  34
  35 (require 'cl)
  36
  37 (defvar srcdir (or (getenv "srcdir") "."))
  38 (defvar loaddir (and load-file-name (file-name-directory load-file-name)))
  39
  40 (defun my-getenv (str)
  41   (let ((val (getenv str)))
  42     (if (equal val "no") nil val)))
  43
  44 (if (my-getenv "lispdir")
  45     (push (my-getenv "lispdir") load-path))
  46
  47 (push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" loaddir))
  48       load-path)
  49
  50 (push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" loaddir))
  51       load-path)
  52
  53 ;(push "/usr/share/emacs/site-lisp" load-path)
  54
  55 ;; If we are building w3 in a different directory than the source
  56 ;; directory, we must read *.el from source directory and write *.elc
  57 ;; into the building directory.  For that, we define this function
  58 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
  59 (defun byte-compile-dest-file (filename)
  60   "Convert an Emacs Lisp source file name to a compiled file name.
  61  In addition, remove directory name part from FILENAME."
  62   (setq filename (byte-compiler-base-file-name filename))
  63   (setq filename (file-name-sans-versions filename))
  64   (setq filename (file-name-nondirectory filename))
  65   (if (eq system-type 'windows-nt)
  66       (setq filename (downcase filename)))
  67   (cond ((eq system-type 'vax-vms)
  68          (concat (substring filename 0 (string-match ";" filename)) "c"))
  69         ((string-match emacs-lisp-file-regexp filename)
  70          (concat (substring filename 0 (match-beginning 0)) ".elc"))
  71         (t (concat filename ".elc"))))
  72
  73 (require 'bytecomp)
  74 ;; To avoid having defsubsts and inlines happen.
  75 ;(if (featurep 'xemacs)
  76 ;    (require 'byte-optimize)
  77 ;  (require 'byte-opt))
  78 ;(defun byte-optimize-inline-handler (form)
  79 ;  "byte-optimize-handler for the `inline' special-form."
  80 ;  (cons 'progn (cdr form)))
  81 ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun)
  82
  83 (when (and (not (featurep 'xemacs))
  84            (= emacs-major-version 21)
  85            (>= emacs-minor-version 3)
  86            (condition-case code
  87                (let ((byte-compile-error-on-warn t))
  88                  (byte-optimize-form (quote (pop x)) t)
  89                  nil)
  90              (error (string-match "called for effect"
  91                                   (error-message-string code)))))
  92   (defadvice byte-optimize-form-code-walker (around silence-warn-for-pop
  93                                                     (form for-effect)
  94                                                     activate)
  95     "Silence the warning \"...called for effect\" for the `pop' form.
  96 It is effective only when the `pop' macro is defined by cl.el rather
  97 than subr.el."
  98     (let (tmp)
  99       (if (and (eq (car-safe form) 'car)
 100                for-effect
 101                (setq tmp (get 'car 'side-effect-free))
 102                (not byte-compile-delete-errors)
 103                (not (eq tmp 'error-free))
 104                (eq (car-safe (cadr form)) 'prog1)
 105                (let ((var (cadr (cadr form)))
 106                      (last (nth 2 (cadr form))))
 107                  (and (symbolp var)
 108                       (null (nthcdr 3 (cadr form)))
 109                       (eq (car-safe last) 'setq)
 110                       (eq (cadr last) var)
 111                       (eq (car-safe (nth 2 last)) 'cdr)
 112                       (eq (cadr (nth 2 last)) var))))
 113           (progn
 114             (put 'car 'side-effect-free 'error-free)
 115             (unwind-protect
 116                 ad-do-it
 117               (put 'car 'side-effect-free tmp)))
 118         ad-do-it))))
 119
 120 (when (and (not (featurep 'xemacs))
 121            (byte-optimize-form
 122             '(and (> 0 1)
 123                   (message "This should not appear in the byte-code."))
 124             t))
 125   (defadvice byte-optimize-form-code-walker
 126     (around fix-bug-in-and/or-forms (form for-effect) activate)
 127     "Optimize the rest of the and/or forms.
 128 It has been fixed in XEmacs before releasing 21.4 and also has been
 129 fixed in Emacs 22."
 130     (if (and for-effect (memq (car-safe form) '(and or)))
 131         (let ((fn (car form))
 132               (backwards (reverse (cdr form))))
 133           (while (and backwards
 134                       (null (setcar backwards
 135                                     (byte-optimize-form (car backwards) t))))
 136             (setq backwards (cdr backwards)))
 137           (if (and (cdr form) (null backwards))
 138               (byte-compile-log
 139                "  all subforms of %s called for effect; deleted" form))
 140           (when backwards
 141             (setcdr backwards
 142                     (mapcar 'byte-optimize-form (cdr backwards))))
 143           (setq ad-return-value (cons fn (nreverse backwards))))
 144       ad-do-it)))
 145
 146 ;; Work around for an incompatibility (XEmacs 21.4 vs. 21.5), see the
 147 ;; following threads:
 148 ;;
 149 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56414
 150 ;; Subject: attachment problems found but not fixed
 151 ;;
 152 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56459
 153 ;; Subject: Splitting mail -- XEmacs 21.4 vs 21.5
 154 ;;
 155 ;; http://thread.gmane.org/gmane.emacs.xemacs.beta/20519
 156 ;; Subject: XEmacs 21.5 and Gnus fancy splitting.
 157 ;;
 158 ;; Should be fixed in XEmacs (March 2007).
 159 ;; http://thread.gmane.org/gmane.emacs.xemacs.patches/8124
 160 ;; When should we remove this workaround?
 161 ;;
 162 (when (and (featurep 'xemacs)
 163            (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
 164              (modify-syntax-entry ?= " " table)
 165              (with-temp-buffer
 166                (with-syntax-table table
 167                  (insert "foo=bar")
 168                  (goto-char (point-min))
 169                  (forward-sexp 1)
 170                  (eolp)))))
 171   ;; The original `with-syntax-table' uses `copy-syntax-table' which
 172   ;; doesn't seem to copy modified syntax entries in XEmacs 21.5.
 173   (defmacro with-syntax-table (syntab &rest body)
 174     "Evaluate BODY with the SYNTAB as the current syntax table."
 175     `(let ((stab (syntax-table)))
 176        (unwind-protect
 177            (progn
 178              ;;(set-syntax-table (copy-syntax-table ,syntab))
 179              (set-syntax-table ,syntab)
 180              ,@body)
 181          (set-syntax-table stab)))))
 182
 183 (push srcdir load-path)
 184 (push loaddir load-path)
 185 (load (expand-file-name "lpath.el" loaddir) nil t)
 186
 187 (defalias 'device-sound-enabled-p 'ignore)
 188 (defalias 'play-sound-file 'ignore)
 189 (defalias 'efs-re-read-dir 'ignore)
 190 (defalias 'ange-ftp-re-read-dir 'ignore)
 191 (defalias 'define-mail-user-agent 'ignore)
 192
 193 (eval-and-compile
 194   (unless (featurep 'xemacs)
 195     (defalias 'get-popup-menu-response 'ignore)
 196     (defalias 'event-object 'ignore)
 197     (defalias 'x-defined-colors 'ignore)
 198     (defalias 'read-color 'ignore)))
 199
 200 (eval-and-compile
 201   (when (featurep 'xemacs)
 202     (unless (fboundp 'defadvice)
 203       (autoload 'defadvice "advice" nil nil 'macro))
 204     (autoload 'Info-directory "info" nil t)
 205     (autoload 'Info-index "info" nil t)
 206     (autoload 'Info-index-next "info" nil t)
 207     (autoload 'Info-menu "info" nil t)
 208     (autoload 'ad-add-advice "advice")
 209     (unless (and (emacs-version>= 21 5)
 210                  (not (featurep 'sxemacs)))
 211       ;; calendar/auto-autoloads.el provides it.
 212       (autoload 'add-to-invisibility-spec "dummy"))
 213     (autoload 'annotations-at "annotations")
 214     (autoload 'apropos "apropos" nil t)
 215     (autoload 'apropos-command "apropos" nil t)
 216     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 217     (autoload 'browse-url "browse-url" nil t)
 218     (autoload 'browse-url-of-file "browse-url" nil t)
 219     (autoload 'c-mode "cc-mode" nil t)
 220     (autoload 'customize-apropos "cus-edit" nil t)
 221     (autoload 'customize-group "cus-edit" nil t)
 222     (autoload 'customize-save-variable "cus-edit" nil t)
 223     (autoload 'customize-set-variable "cus-edit" nil t)
 224     (autoload 'customize-variable "cus-edit" nil t)
 225     (autoload 'debug "debug" nil t)
 226     (if (featurep 'mule)
 227         (unless (locate-library "mule-ccl")
 228           (autoload 'define-ccl-program "ccl" nil nil 'macro))
 229       (defalias 'define-ccl-program 'ignore))
 230     (autoload 'delete-annotation "annotations")
 231     (autoload 'dolist "cl-macs" nil nil 'macro)
 232     (autoload 'enriched-decode "enriched")
 233     (autoload 'eudc-expand-inline "eudc" nil t)
 234     (autoload 'executable-find "executable")
 235     (autoload 'font-lock-fontify-buffer "font-lock" nil t)
 236     (when (and (emacs-version>= 21 5)
 237                (not (featurep 'sxemacs)))
 238       (autoload 'get-display-table "disp-table")
 239       (autoload 'put-display-table "disp-table"))
 240     (autoload 'info "info" nil t)
 241     (autoload 'mail-extract-address-components "mail-extr")
 242     (autoload 'mail-fetch-field "mail-utils")
 243     (autoload 'make-annotation "annotations")
 244     (autoload 'make-display-table "disp-table")
 245     (autoload 'pgg-snarf-keys-region "pgg" nil t)
 246     (autoload 'pp "pp")
 247     (autoload 'ps-despool "ps-print" nil t)
 248     (autoload 'ps-spool-buffer "ps-print" nil t)
 249     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 250     (autoload 'read-passwd "passwd")
 251     (autoload 'regexp-opt "regexp-opt")
 252     (autoload 'reporter-submit-bug-report "reporter")
 253     (if (and (emacs-version>= 21 5)
 254              (not (featurep 'sxemacs)))
 255         (autoload 'setenv "process" nil t)
 256       (autoload 'setenv "env" nil t))
 257     (autoload 'sgml-mode "psgml" nil t)
 258     (autoload 'smtpmail-send-it "smtpmail")
 259     (autoload 'sort-numeric-fields "sort" nil t)
 260     (autoload 'sort-subr "sort")
 261     (autoload 'thing-at-point "thingatpt")
 262     (autoload 'toggle-truncate-lines "view-less" nil t)
 263     (autoload 'trace-function-background "trace" nil t)
 264     (autoload 'unmorse-region "morse" nil t)
 265     (autoload 'w3-do-setup "w3")
 266     (autoload 'w3-prepare-buffer "w3-display")
 267     (autoload 'w3-region "w3-display" nil t)
 268     (defalias 'frame-char-height 'frame-height)
 269     (defalias 'frame-char-width 'frame-width)
 270     (defalias 'frame-parameter 'frame-property)
 271     (defalias 'make-overlay 'ignore)
 272     (defalias 'overlay-end 'ignore)
 273     (defalias 'overlay-get 'ignore)
 274     (defalias 'overlay-put 'ignore)
 275     (defalias 'overlay-start 'ignore)
 276     (defalias 'overlays-in 'ignore)
 277     (defalias 'replace-dehighlight 'ignore)
 278     (defalias 'replace-highlight 'ignore)
 279     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 280
 281 (defun dgnushack-emacs-compile-defcustom-p ()
 282   "Return non-nil if Emacs byte compiles `defcustom' forms.
 283 Those Emacsen will warn against undefined variables and functions used
 284 in `defcustom' forms."
 285   (let ((outbuf (with-temp-buffer
 286                   (insert "(defcustom foo (1+ (random)) \"\" :group 'emacs)\n")
 287                   (byte-compile-from-buffer (current-buffer) "foo.el"))))
 288     (when outbuf
 289       (prog1
 290           (with-current-buffer outbuf
 291             (goto-char (point-min))
 292             (search-forward " 'foo '(byte-code " nil t))
 293         (kill-buffer outbuf)))))
 294
 295 (when (dgnushack-emacs-compile-defcustom-p)
 296   (maybe-fbind '(defined-colors face-attribute))
 297   (maybe-bind '(idna-program installation-directory)))
 298
 299 (defun dgnushack-compile-verbosely ()
 300   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 301 patches to gnus, you should consider modifying make.bat to call
 302 dgnushack-compile-verbosely.  All other users should continue to use
 303 dgnushack-compile."
 304   (dgnushack-compile t))
 305
 306 (defun dgnushack-compile (&optional warn)
 307   ;;(setq byte-compile-dynamic t)
 308   (unless warn
 309     (setq byte-compile-warnings
 310           '(free-vars unresolved callargs redefine)))
 311   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 312         ;;(byte-compile-generate-call-tree t)
 313         file elc)
 314     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 315     ;; installed.
 316     (when (featurep 'xemacs)
 317       (setq gnus-xmas-glyph-directory "dummy"))
 318     (dolist (file '("dgnushack.el" "lpath.el"))
 319       (setq files (delete file files)))
 320     (when (featurep 'base64)
 321       (setq files (delete "base64.el" files)))
 322     (condition-case code
 323         (require 'w3-parse)
 324       (error
 325        (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") ""))
 326        (dolist (file '("webmail.el" "nnwfm.el"))
 327          (setq files (delete file files)))))
 328     (condition-case code
 329         (require 'mh-e)
 330       (error
 331        (message "No mh-e: %s %s" (cadr code) (or (locate-library "mh-e") ""))
 332        (setq files (delete "gnus-mh.el" files))))
 333     (condition-case code
 334         (require 'xml)
 335       (error
 336        (message "No xml: %s %s" (cadr code) (or (locate-library "xml") ""))
 337        (setq files (delete "nnrss.el" files))))
 338     (dolist (file
 339              (if (featurep 'xemacs)
 340                  '("md5.el")
 341                '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el")))
 342       (setq files (delete file files)))
 343
 344     (dolist (file files)
 345       (setq file (expand-file-name file srcdir))
 346       (when (and (file-exists-p
 347                   (setq elc (concat (file-name-nondirectory file) "c")))
 348                  (file-newer-than-file-p file elc))
 349         (delete-file elc)))
 350
 351     (while (setq file (pop files))
 352       (setq file (expand-file-name file srcdir))
 353       (when (or (not (file-exists-p
 354                       (setq elc (concat (file-name-nondirectory file) "c"))))
 355                 (file-newer-than-file-p file elc))
 356         (ignore-errors
 357           (byte-compile-file file))))))
 358
 359 (defun dgnushack-recompile ()
 360   (require 'gnus)
 361   (byte-recompile-directory "." 0))
 362
 363 (defvar dgnushack-gnus-load-file
 364   (if (featurep 'xemacs)
 365       (expand-file-name "auto-autoloads.el")
 366     (expand-file-name "gnus-load.el")))
 367
 368 (defvar dgnushack-cus-load-file
 369   (if (featurep 'xemacs)
 370       (expand-file-name "custom-load.el")
 371     (expand-file-name "cus-load.el")))
 372
 373 (defun dgnushack-make-cus-load ()
 374   (load "cus-dep")
 375   (let ((cusload-base-file dgnushack-cus-load-file))
 376     (if (fboundp 'custom-make-dependencies)
 377         (custom-make-dependencies)
 378       (Custom-make-dependencies))
 379     (when (featurep 'xemacs)
 380       (message "Compiling %s..." dgnushack-cus-load-file)
 381       (byte-compile-file dgnushack-cus-load-file))))
 382
 383 (defun dgnushack-make-auto-load ()
 384   (require 'autoload)
 385   (unless (make-autoload '(define-derived-mode child parent name
 386                             "docstring" body)
 387                          "file")
 388     (defadvice make-autoload (around handle-define-derived-mode activate)
 389       "Handle `define-derived-mode'."
 390       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 391           (setq ad-return-value
 392                 (list 'autoload
 393                       (list 'quote (nth 1 (ad-get-arg 0)))
 394                       (ad-get-arg 1)
 395                       (nth 4 (ad-get-arg 0))
 396                       t nil))
 397         ad-do-it))
 398     (put 'define-derived-mode 'doc-string-elt 3))
 399   (let ((generated-autoload-file dgnushack-gnus-load-file)
 400         (make-backup-files nil)
 401         (autoload-package-name "gnus"))
 402     (if (featurep 'xemacs)
 403         (if (file-exists-p generated-autoload-file)
 404             (delete-file generated-autoload-file))
 405       (with-temp-file generated-autoload-file
 406         (insert ?\014)))
 407     (batch-update-autoloads)))
 408
 409 (defun dgnushack-make-load ()
 410   (unless (featurep 'xemacs)
 411     (message "Generating %s..." dgnushack-gnus-load-file)
 412     (with-temp-file dgnushack-gnus-load-file
 413       (insert-file-contents dgnushack-cus-load-file)
 414       (delete-file dgnushack-cus-load-file)
 415       (goto-char (point-min))
 416       (search-forward ";;; Code:")
 417       (forward-line)
 418       (delete-region (point-min) (point))
 419       (insert "\
 420 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 421 ;;
 422 ;;; Code:
 423 ")
 424       (goto-char (point-max))
 425       (if (search-backward "custom-versions-load-alist" nil t)
 426           (forward-line -1)
 427         (forward-line -1)
 428         (while (eq (char-after) ?\;)
 429           (forward-line -1))
 430         (forward-line))
 431       (delete-region (point) (point-max))
 432       (insert "\n")
 433       ;; smiley-* are duplicated. Remove them all.