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 (require 'iswitchb)
  37
  38 (condition-case nil
  39     (require 'org-entities)
  40   (error nil))
  41
  42 (defvar srcdir (or (getenv "srcdir") "."))
  43 (defvar loaddir (and load-file-name (file-name-directory load-file-name)))
  44
  45 (defun my-getenv (str)
  46   (let ((val (getenv str)))
  47     (if (equal val "no") nil val)))
  48
  49 (if (my-getenv "lispdir")
  50     (push (my-getenv "lispdir") load-path))
  51
  52 (push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" loaddir))
  53       load-path)
  54
  55 (push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" loaddir))
  56       load-path)
  57
  58 ;(push "/usr/share/emacs/site-lisp" load-path)
  59
  60 ;; If we are building w3 in a different directory than the source
  61 ;; directory, we must read *.el from source directory and write *.elc
  62 ;; into the building directory.  For that, we define this function
  63 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
  64 (defun byte-compile-dest-file (filename)
  65   "Convert an Emacs Lisp source file name to a compiled file name.
  66  In addition, remove directory name part from FILENAME."
  67   (setq filename (byte-compiler-base-file-name filename))
  68   (setq filename (file-name-sans-versions filename))
  69   (setq filename (file-name-nondirectory filename))
  70   (if (eq system-type 'windows-nt)
  71       (setq filename (downcase filename)))
  72   (cond ((eq system-type 'vax-vms)
  73          (concat (substring filename 0 (string-match ";" filename)) "c"))
  74         ((string-match emacs-lisp-file-regexp filename)
  75          (concat (substring filename 0 (match-beginning 0)) ".elc"))
  76         (t (concat filename ".elc"))))
  77
  78 (require 'bytecomp)
  79 ;; To avoid having defsubsts and inlines happen.
  80 ;(if (featurep 'xemacs)
  81 ;    (require 'byte-optimize)
  82 ;  (require 'byte-opt))
  83 ;(defun byte-optimize-inline-handler (form)
  84 ;  "byte-optimize-handler for the `inline' special-form."
  85 ;  (cons 'progn (cdr form)))
  86 ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun)
  87
  88 ;; Work around for an incompatibility (XEmacs 21.4 vs. 21.5), see the
  89 ;; following threads:
  90 ;;
  91 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56414
  92 ;; Subject: attachment problems found but not fixed
  93 ;;
  94 ;; http://thread.gmane.org/gmane.emacs.gnus.general/56459
  95 ;; Subject: Splitting mail -- XEmacs 21.4 vs 21.5
  96 ;;
  97 ;; http://thread.gmane.org/gmane.emacs.xemacs.beta/20519
  98 ;; Subject: XEmacs 21.5 and Gnus fancy splitting.
  99 ;;
 100 ;; Should be fixed in XEmacs (March 2007).
 101 ;; http://thread.gmane.org/gmane.emacs.xemacs.patches/8124
 102 ;; When should we remove this workaround?
 103 ;;
 104 (when (and (featurep 'xemacs)
 105            (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
 106              (modify-syntax-entry ?= " " table)
 107              (with-temp-buffer
 108                (with-syntax-table table
 109                  (insert "foo=bar")
 110                  (goto-char (point-min))
 111                  (forward-sexp 1)
 112                  (eolp)))))
 113   ;; The original `with-syntax-table' uses `copy-syntax-table' which
 114   ;; doesn't seem to copy modified syntax entries in old XEmacs 21.5.
 115   (defmacro with-syntax-table (syntab &rest body)
 116     "Evaluate BODY with the SYNTAB as the current syntax table."
 117     `(let ((stab (syntax-table)))
 118        (unwind-protect
 119            (progn
 120              ;;(set-syntax-table (copy-syntax-table ,syntab))
 121              (set-syntax-table ,syntab)
 122              ,@body)
 123          (set-syntax-table stab)))))
 124
 125 (push srcdir load-path)
 126 (push loaddir load-path)
 127 (load (expand-file-name "lpath.el" loaddir) nil t)
 128
 129 (defalias 'device-sound-enabled-p 'ignore)
 130 (defalias 'play-sound-file 'ignore)
 131 (defalias 'efs-re-read-dir 'ignore)
 132 (defalias 'ange-ftp-re-read-dir 'ignore)
 133 (defalias 'define-mail-user-agent 'ignore)
 134
 135 (eval-and-compile
 136   (unless (featurep 'xemacs)
 137     (defalias 'get-popup-menu-response 'ignore)
 138     (defalias 'event-object 'ignore)
 139     (autoload 'iswitchb-read-buffer "iswitchb")
 140     (autoload 'netrc-credentials "netrc")
 141     (defalias 'x-defined-colors 'ignore)
 142     (defalias 'read-color 'ignore)))
 143
 144 (eval-and-compile
 145   (when (featurep 'xemacs)
 146     (unless (fboundp 'defadvice)
 147       (autoload 'defadvice "advice" nil nil 'macro))
 148     (autoload 'Info-directory "info" nil t)
 149     (autoload 'Info-index "info" nil t)
 150     (autoload 'Info-index-next "info" nil t)
 151     (autoload 'Info-menu "info" nil t)
 152     (autoload 'ad-add-advice "advice")
 153     (unless (and (emacs-version>= 21 5)
 154                  (not (featurep 'sxemacs)))
 155       ;; calendar/auto-autoloads.el provides it.
 156       (autoload 'add-to-invisibility-spec "dummy"))
 157     (autoload 'annotations-at "annotations")
 158     (autoload 'apropos "apropos" nil t)
 159     (autoload 'apropos-command "apropos" nil t)
 160     (autoload 'bbdb-complete-name "bbdb-com" nil t)
 161     (autoload 'browse-url "browse-url" nil t)
 162     (autoload 'browse-url-of-file "browse-url" nil t)
 163     (autoload 'c-mode "cc-mode" nil t)
 164     (autoload 'customize-apropos "cus-edit" nil t)
 165     (autoload 'customize-group "cus-edit" nil t)
 166     (autoload 'customize-save-variable "cus-edit" nil t)
 167     (autoload 'customize-set-variable "cus-edit" nil t)
 168     (autoload 'customize-variable "cus-edit" nil t)
 169     (autoload 'debug "debug" nil t)
 170     (if (featurep 'mule)
 171         (unless (locate-library "mule-ccl")
 172           (autoload 'define-ccl-program "ccl" nil nil 'macro))
 173       (defalias 'define-ccl-program 'ignore))
 174     (autoload 'delete-annotation "annotations")
 175     (autoload 'dolist "cl-macs" nil nil 'macro)
 176     (autoload 'enriched-decode "enriched")
 177     (autoload 'eudc-expand-inline "eudc" nil t)
 178     (autoload 'executable-find "executable")
 179     (autoload 'font-lock-fontify-buffer "font-lock" nil t)
 180     (when (and (emacs-version>= 21 5)
 181                (not (featurep 'sxemacs)))
 182       (autoload 'get-display-table "disp-table")
 183       (autoload 'put-display-table "disp-table"))
 184     (autoload 'info "info" nil t)
 185     (autoload 'mail-extract-address-components "mail-extr")
 186     (autoload 'mail-fetch-field "mail-utils")
 187     (autoload 'make-annotation "annotations")
 188     (autoload 'make-display-table "disp-table")
 189     (autoload 'pgg-snarf-keys-region "pgg" nil t)
 190     (autoload 'pp "pp")
 191     (autoload 'ps-despool "ps-print" nil t)
 192     (autoload 'ps-spool-buffer "ps-print" nil t)
 193     (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
 194     (autoload 'read-passwd "passwd")
 195     (autoload 'regexp-opt "regexp-opt")
 196     (autoload 'reporter-submit-bug-report "reporter")
 197     (if (and (emacs-version>= 21 5)
 198              (not (featurep 'sxemacs)))
 199         (autoload 'setenv "process" nil t)
 200       (autoload 'setenv "env" nil t))
 201     (autoload 'sgml-mode "psgml" nil t)
 202     (autoload 'smtpmail-send-it "smtpmail")
 203     (autoload 'sort-numeric-fields "sort" nil t)
 204     (autoload 'sort-subr "sort")
 205     (autoload 'thing-at-point "thingatpt")
 206     (autoload 'toggle-truncate-lines "view-less" nil t)
 207     (autoload 'trace-function-background "trace" nil t)
 208     (autoload 'unmorse-region "morse" nil t)
 209     (autoload 'w3-do-setup "w3")
 210     (autoload 'w3-prepare-buffer "w3-display")
 211     (autoload 'w3-region "w3-display" nil t)
 212     (defalias 'frame-char-height 'frame-height)
 213     (defalias 'frame-char-width 'frame-width)
 214     (defalias 'frame-parameter 'frame-property)
 215     (defalias 'make-overlay 'ignore)
 216     (defalias 'overlay-end 'ignore)
 217     (defalias 'overlay-get 'ignore)
 218     (defalias 'overlay-put 'ignore)
 219     (defalias 'overlay-start 'ignore)
 220     (defalias 'overlays-in 'ignore)
 221     (defalias 'replace-dehighlight 'ignore)
 222     (defalias 'replace-highlight 'ignore)
 223     (defalias 'w3-coding-system-for-mime-charset 'ignore)))
 224
 225 (defun dgnushack-emacs-compile-defcustom-p ()
 226   "Return non-nil if Emacs byte compiles `defcustom' forms.
 227 Those Emacsen will warn against undefined variables and functions used
 228 in `defcustom' forms."
 229   (let ((outbuf (with-temp-buffer
 230                   (insert "(defcustom foo (1+ (random)) \"\" :group 'emacs)\n")
 231                   (byte-compile-from-buffer (current-buffer) "foo.el"))))
 232     (when outbuf
 233       (prog1
 234           (with-current-buffer outbuf
 235             (goto-char (point-min))
 236             (search-forward " 'foo '(byte-code " nil t))
 237         (kill-buffer outbuf)))))
 238
 239 (when (dgnushack-emacs-compile-defcustom-p)
 240   (maybe-fbind '(defined-colors face-attribute))
 241   (maybe-bind '(idna-program installation-directory)))
 242
 243 (when (featurep 'xemacs)
 244   (defadvice byte-optimize-apply (before use-mapcan (form) activate)
 245     "Replace (apply 'nconc (mapcar ...)) with (mapcan ...)."
 246     (let ((last (nth (1- (length form)) form)))
 247       (when (and (eq last (third form))
 248                  (consp last)
 249                  (eq 'mapcar (car last))
 250                  (equal (nth 1 form) ''nconc))
 251         (setq form (cons 'mapcan (cdr last)))))))
 252
 253 (defun dgnushack-compile-verbosely ()
 254   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 255 patches to gnus, you should consider modifying make.bat to call
 256 dgnushack-compile-verbosely.  All other users should continue to use
 257 dgnushack-compile."
 258   (dgnushack-compile t))
 259
 260 (defun dgnushack-compile (&optional warn)
 261   ;;(setq byte-compile-dynamic t)
 262   (unless warn
 263     (setq byte-compile-warnings
 264           '(free-vars unresolved callargs redefine suspicious)))
 265   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 266         ;;(byte-compile-generate-call-tree t)
 267         file elc)
 268     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 269     ;; installed.
 270     (when (featurep 'xemacs)
 271       (setq gnus-xmas-glyph-directory "dummy"))
 272     (dolist (file '(".dir-locals.el" "dgnushack.el" "lpath.el"))
 273       (setq files (delete file files)))
 274     (when (featurep 'base64)
 275       (setq files (delete "base64.el" files)))
 276     (condition-case code
 277         (require 'w3-parse)
 278       (error
 279        (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") ""))
 280        (dolist (file '("webmail.el" "nnwfm.el"))
 281          (setq files (delete file files)))))
 282     (condition-case code
 283         ;; Under XEmacs 21.4 this loads easy-mmode.elc that provides
 284         ;; the Emacs functions `propertize' and `replace-regexp-in-string'.
 285         (require 'mh-e)
 286       (error
 287        (message "No mh-e: %s %s" (cadr code) (or (locate-library "mh-e") ""))
 288        (setq files (delete "gnus-mh.el" files))))
 289     (condition-case code
 290         (require 'xml)
 291       (error
 292        (message "No xml: %s %s" (cadr code) (or (locate-library "xml") ""))
 293        (setq files (delete "nnrss.el" files))))
 294     (dolist (file