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,95,96,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      Katsumi Yamaoka <yamaoka@jpl.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 ;; Set coding priority of Shift-JIS to the bottom.
  31 (defvar *predefined-category*)
  32 (defvar coding-category-list)
  33 (if (featurep 'xemacs)
  34     (fset 'set-coding-priority 'ignore)
  35   (fset 'coding-priority-list 'ignore)
  36   (fset 'set-coding-priority-list 'ignore))
  37 (cond ((and (featurep 'xemacs) (featurep 'mule))
  38        (if (memq 'shift-jis (coding-priority-list))
  39            (set-coding-priority-list
  40             (nconc (delq 'shift-jis (coding-priority-list)) '(shift-jis)))))
  41       ((boundp 'MULE)
  42        (put '*coding-category-sjis* 'priority (length *predefined-category*)))
  43       ((featurep 'mule)
  44        (if (memq 'coding-category-sjis coding-category-list)
  45            (set-coding-priority
  46             (nconc (delq 'coding-category-sjis coding-category-list)
  47                    '(coding-category-sjis))))))
  48
  49 (fset 'facep 'ignore)
  50
  51 (require 'cl)
  52
  53 ;; Emulating cl functions.
  54 (unless (featurep 'xemacs)
  55   (define-compiler-macro last (&whole form x &optional n)
  56     (if (and (fboundp 'last)
  57              (subrp (symbol-function 'last)))
  58         form
  59       (if n
  60           `(let* ((x ,x)
  61                   (n ,n)
  62                   (m 0)
  63                   (p x))
  64              (while (consp p)
  65                (incf m)
  66                (pop p))
  67              (if (<= n 0)
  68                  p
  69                (if (< n m)
  70                    (nthcdr (- m n) x)
  71                  x)))
  72         `(let ((x ,x))
  73            (while (consp (cdr x))
  74              (pop x))
  75            x))))
  76
  77   (define-compiler-macro mapc (&whole form fn seq &rest rest)
  78     (if (and (fboundp 'mapc)
  79              (subrp (symbol-function 'mapc)))
  80         form
  81       (if rest
  82           `(let* ((fn ,fn)
  83                   (seq ,seq)
  84                   (args (list seq ,@rest))
  85                   (m (apply (function min) (mapcar (function length) args)))
  86                   (n 0))
  87              (while (< n m)
  88                (apply fn (mapcar (function (lambda (arg) (nth n arg))) args))
  89                (setq n (1+ n)))
  90              seq)
  91         `(let ((seq ,seq))
  92            (mapcar ,fn seq)
  93            seq))))
  94
  95   (define-compiler-macro mapcon (&whole form fn seq &rest rest)
  96     (if (and (fboundp 'mapcon)
  97              (subrp (symbol-function 'mapcon)))
  98         form
  99       (if rest
 100           `(let ((fn ,fn)
 101                  res
 102                  (args (list ,seq ,@rest))
 103                  p)
 104              (while (not (memq nil args))
 105                (push (apply ,fn args) res)
 106                (setq p args)
 107                (while p
 108                  (setcar p (cdr (pop p)))
 109                  ))
 110              (apply (function nconc) (nreverse res)))
 111         `(let ((fn ,fn)
 112                res
 113                (arg ,seq))
 114            (while arg
 115              (push (funcall ,fn arg) res)
 116              (setq arg (cdr arg)))
 117            (apply (function nconc) (nreverse res))))))
 118
 119   (define-compiler-macro member-if (&whole form pred list)
 120     (if (and (fboundp 'member-if)
 121              (subrp (symbol-function 'member-if)))
 122         form
 123       `(let ((fn ,pred)
 124              (seq ,list))
 125          (while (and seq
 126                      (not (funcall fn (car seq))))
 127            (pop seq))
 128          seq)))
 129
 130   (define-compiler-macro union (&whole form list1 list2)
 131     (if (and (fboundp 'union)
 132              (subrp (symbol-function 'union)))
 133         form
 134       `(let ((a ,list1)
 135              (b ,list2))
 136          (cond ((null a) b)
 137                ((null b) a)
 138                ((equal a b) a)
 139                (t
 140                 (or (>= (length a) (length b))
 141                     (setq a (prog1 b (setq b a))))
 142                 (while b
 143                   (or (memq (car b) a)
 144                       (push (car b) a))
 145                   (pop b))
 146                 a)))))
 147   )
 148
 149 ;; If we are building w3 in a different directory than the source
 150 ;; directory, we must read *.el from source directory and write *.elc
 151 ;; into the building directory.  For that, we define this function
 152 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
 153 (defun byte-compile-dest-file (filename)
 154   "Convert an Emacs Lisp source file name to a compiled file name.
 155  In addition, remove directory name part from FILENAME."
 156   (setq filename (byte-compiler-base-file-name filename))
 157   (setq filename (file-name-sans-versions filename))
 158   (setq filename (file-name-nondirectory filename))
 159   (if (memq system-type '(win32 w32 mswindows windows-nt))
 160       (setq filename (downcase filename)))
 161   (cond ((eq system-type 'vax-vms)
 162          (concat (substring filename 0 (string-match ";" filename)) "c"))
 163         ((string-match emacs-lisp-file-regexp filename)
 164          (concat (substring filename 0 (match-beginning 0)) ".elc"))
 165         (t (concat filename ".elc"))))
 166
 167 (require 'bytecomp)
 168
 169 (unless (fboundp 'si:byte-optimize-form-code-walker)
 170   (byte-optimize-form nil);; Load `byte-opt' or `byte-optimize'.
 171   (setq max-specpdl-size 3000)
 172   (fset 'si:byte-optimize-form-code-walker
 173         (symbol-function 'byte-optimize-form-code-walker))
 174   (defun byte-optimize-form-code-walker (form for-effect)
 175     (if (and for-effect (memq (car-safe form) '(and or)))
 176         ;; Fix bug in and/or forms.
 177         (let ((fn (car form))
 178               (backwards (reverse (cdr form))))
 179           (while (and backwards
 180                       (null (setcar backwards
 181                                     (byte-optimize-form (car backwards) t))))
 182             (setq backwards (cdr backwards)))
 183           (if (and (cdr form) (null backwards))
 184               (byte-compile-log
 185                "  all subforms of %s called for effect; deleted" form))
 186           (if backwards
 187               (let ((head backwards))
 188                 (while (setq backwards (cdr backwards))
 189                   (setcar backwards (byte-optimize-form (car backwards)
 190                                                         nil)))
 191                 (cons fn (nreverse head)))))
 192       (si:byte-optimize-form-code-walker form for-effect)))
 193   (byte-compile 'byte-optimize-form-code-walker))
 194
 195 (defvar srcdir (or (getenv "srcdir") "."))
 196
 197 ;(push "/usr/share/emacs/site-lisp" load-path)
 198
 199 ;; Attempt to pickup the additional load-path(s).
 200 (load (expand-file-name "dgnuspath.el" srcdir) nil nil t)
 201 (condition-case err
 202     (load "~/.lpath.el" t nil t)
 203   (error (message "Error in \"~/.lpath.el\" file: %s" err)))
 204
 205 (condition-case nil
 206     (char-after)
 207   (wrong-number-of-arguments
 208    ;; Optimize byte code for `char-after'.
 209    (put 'char-after 'byte-optimizer 'byte-optimize-char-after)
 210    (defun byte-optimize-char-after (form)
 211      (if (null (cdr form))
 212          '(char-after (point))
 213        form))
 214    ))
 215
 216 (condition-case nil
 217     (char-before)
 218   (wrong-number-of-arguments
 219    (define-compiler-macro char-before (&whole form &optional pos)
 220      (if (null pos)
 221          '(char-before (point))
 222        form))))
 223
 224 ;; `char-after' and `char-before' must be well-behaved before lpath.el
 225 ;; is loaded.  Because it requires `poe' via `path-util'.
 226 (load (expand-file-name "lpath.el" srcdir) nil t t)
 227
 228 (unless (fboundp 'byte-compile-file-form-custom-declare-variable)
 229   ;; Bind defcustom'ed variables.
 230   (put 'custom-declare-variable 'byte-hunk-handler
 231        'byte-compile-file-form-custom-declare-variable)
 232   (defun byte-compile-file-form-custom-declare-variable (form)
 233     (if (memq 'free-vars byte-compile-warnings)
 234         (setq byte-compile-bound-variables
 235               (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
 236     form))
 237
 238 ;; Bind functions defined by `defun-maybe'.
 239 (put 'defun-maybe 'byte-hunk-handler 'byte-compile-file-form-defun-maybe)
 240 (defun byte-compile-file-form-defun-maybe (form)
 241   (if (and (not (fboundp (nth 1 form)))
 242            (memq 'unresolved byte-compile-warnings))
 243       (setq byte-compile-function-environment
 244             (cons (cons (nth 1 form)
 245                         (cons 'lambda (cdr (cdr form))))
 246                   byte-compile-function-environment)))
 247   form)
 248
 249 (condition-case nil
 250     :symbol-for-testing-whether-colon-keyword-is-available-or-not
 251   (void-variable
 252    ;; Bind keywords.
 253    (mapcar (lambda (keyword) (set keyword keyword))
 254            '(:button-keymap :data :file :mime-handle))))
 255
 256 ;; Unknown variables and functions.
 257 (unless (boundp 'buffer-file-coding-system)
 258   (defvar buffer-file-coding-system (symbol-value 'file-coding-system)))
 259 (unless (featurep 'xemacs)
 260   (defalias 'Custom-make-dependencies 'ignore)
 261   (defalias 'update-autoloads-from-directory 'ignore))
 262 (autoload 'texinfo-parse-line-arg "texinfmt")
 263
 264 (unless (fboundp 'with-temp-buffer)
 265   ;; Pickup some macros.
 266   (require 'emu))
 267
 268 (defalias 'device-sound-enabled-p 'ignore)
 269 (defalias 'play-sound-file 'ignore)
 270 (defalias 'nndb-request-article 'ignore)
 271 (defalias 'efs-re-read-dir 'ignore)
 272 (defalias 'ange-ftp-re-read-dir 'ignore)
 273 (defalias 'define-mail-user-agent 'ignore)
 274
 275 (defun dgnushack-compile (&optional warn)
 276   ;;(setq byte-compile-dynamic t)
 277   (unless warn
 278     (setq byte-compile-warnings
 279           '(free-vars unresolved callargs redefine)))
 280   (unless (locate-library "cus-edit")
 281     (error "You do not seem to have Custom installed.
 282 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 283 You also then need to add the following to the lisp/dgnushack.el file:
 284
 285      (push \"~/lisp/custom\" load-path)
 286
 287 Modify to suit your needs."))
 288   (let ((files (delete "dgnuspath.el"
 289                        (directory-files srcdir nil "^[^=].*\\.el$")))
 290         (xemacs (string-match "XEmacs" emacs-version))
 291         ;;(byte-compile-generate-call-tree t)
 292         file elc)
 293     (condition-case ()
 294         (require 'w3-forms)
 295       (error
 296        (dolist (file '("nnweb.el" "nnlistserv.el" "nnultimate.el"
 297                        "nnslashdot.el" "nnwarchive.el" "webmail.el"))
 298          (setq files (delete file files)))))
 299     (condition-case ()
 300         (require 'bbdb)
 301       (error (setq files (delete "gnus-bbdb.el" files))))
 302     (while (setq file (pop files))
 303       (unless (or (and (not xemacs)
 304                        (member file
 305                                '("gnus-xmas.el" "gnus-picon.el"
 306                                  "messagexmas.el" "nnheaderxm.el"
 307                                  "smiley.el" "x-overlay.el")))
 308                   (and (string-equal file "md5.el")
 309                        (not (and (fboundp 'md5)
 310                                  (subrp (symbol-function 'md5))))))
 311         (setq file (expand-file-name file srcdir))
 312         (when (or (not (file-exists-p (setq elc (concat file "c"))))
 313                   (file-newer-than-file-p file elc))
 314           (ignore-errors
 315             (byte-compile-file file)))))))
 316
 317 (defun dgnushack-recompile ()
 318   (require 'gnus)
 319   (byte-recompile-directory "." 0))
 320
 321 \f
 322 ;; Avoid byte-compile warnings.
 323 (defvar gnus-product-name)
 324 (defvar early-package-load-path)
 325 (defvar early-packages)
 326 (defvar last-package-load-path)
 327 (defvar last-packages)
 328 (defvar late-package-load-path)
 329 (defvar late-packages)
 330
 331 (defconst dgnushack-info-file-regexp
 332   (concat "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)"
 333           "\\.info\\(-[0-9]+\\)?$"))
 334
 335 (defconst dgnushack-texi-file-regexp
 336   "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)\\.texi$")
 337
 338 (defun dgnushack-make-package ()
 339   (require 'gnus)
 340   (let* ((product-name (downcase gnus-product-name))
 341          (lisp-dir (concat "lisp/" product-name "/"))
 342          make-backup-files)
 343
 344     (message "Updating autoloads for directory %s..." default-directory)
 345     (let ((generated-autoload-file "auto-autoloads.el")
 346           noninteractive
 347           (omsg (symbol-function 'message)))
 348       (defun message (fmt &rest args)
 349         (cond ((and (string-equal "Generating autoloads for %s..." fmt)
 350                     (file-exists-p (file-name-nondirectory (car args))))
 351                (funcall omsg fmt (file-name-nondirectory (car args))))
 352               ((string-equal "No autoloads found in %s" fmt))
 353               ((string-equal "Generating autoloads for %s...done" fmt))
 354               (t (apply omsg fmt args))))
 355       (unwind-protect
 356           (update-autoloads-from-directory default-directory)
 357         (fset 'message omsg)))
 358     (byte-compile-file "auto-autoloads.el")
 359
 360     (with-temp-buffer
 361       (let ((standard-output (current-buffer)))
 362         (Custom-make-dependencies "."))
 363       (message (buffer-string)))
 364     (require 'cus-load)
 365     (byte-compile-file "custom-load.el")
 366
 367     (message "Generating MANIFEST.%s for the package..." product-name)
 368     (with-temp-buffer
 369       (insert "pkginfo/MANIFEST." product-name "\n"
 370               lisp-dir
 371               (mapconcat
 372                'identity
 373                (sort (delete "dgnuspath.el"
 374                              (delete "patchs.elc"
 375                                      (directory-files "." nil "\\.elc?$")))
 376                      'string-lessp)
 377                (concat "\n" lisp-dir))
 378               "\ninfo/"
 379               (mapconcat
 380                'identity
 381                (sort (directory-files "../texi/"
 382                                       nil dgnushack-info-file-regexp)
 383                      'string-lessp)
 384                "\ninfo/")
 385               "\n")
 386       (write-file (concat "../MANIFEST." product-name)))))
 387
 388 (defun dgnushack-install-package ()
 389   (let ((package-dir (car command-line-args-left))
 390         dirs info-dir pkginfo-dir product-name lisp-dir manifest files)
 391     (unless package-dir
 392       (when (boundp 'early-packages)
 393         (setq dirs (delq nil (append (when early-package-load-path
 394                                        early-packages)
 395                                      (when late-package-load-path
 396                                        late-packages)
 397                                      (when last-package-load-path
 398                                        last-packages))))
 399         (while (and dirs (not package-dir))
 400           (when (file-exists-p (car dirs))
 401             (setq package-dir (car dirs)
 402                   dirs (cdr dirs))))))
 403     (unless package-dir
 404       (error "%s" "
 405 You must specify the name of the package path as follows:
 406
 407 % make install-package PACKAGEDIR=/usr/local/lib/xemacs/xemacs-packages
 408 "
 409              ))
 410     (setq info-dir (expand-file-name "info/" package-dir)
 411           pkginfo-dir (expand-file-name "pkginfo/" package-dir))
 412     (require 'gnus)
 413     (setq product-name (downcase gnus-product-name)
 414           lisp-dir (expand-file-name (concat "lisp/" product-name "/")
 415                                      package-dir)
 416           manifest (concat "MANIFEST." product-name))
 417
 418     (unless (file-directory-p lisp-dir)
 419       (make-directory lisp-dir t))
 420     (unless (file-directory-p info-dir)
 421       (make-directory info-dir))
 422     (unless (file-directory-p pkginfo-dir)
 423       (make-directory pkginfo-dir))
 424
 425     (setq files
 426           (sort (delete "dgnuspath.el"
 427                         (delete "dgnuspath.elc"
 428                                 (directory-files "." nil "\\.elc?$")))
 429                 'string-lessp))
 430     (mapcar
 431      (lambda (file)
 432        (unless (or (member file files)
 433                    (not (string-match "\\.elc?$" file)))
 434          (setq file (expand-file-name file lisp-dir))
 435          (message "Removing %s..." file)
 436          (condition-case nil
 437              (delete-file file)
 438            (error nil))))
 439      (directory-files lisp-dir nil nil nil t))
 440     (mapcar
 441      (lambda (file)
 442        (message "Copying %s to %s..." file lisp-dir)
 443        (copy-file file (expand-file-name file lisp-dir) t t))
 444      files)
 445
 446     (mapcar
 447      (lambda (file)
 448        (message "Copying ../texi/%s to %s..." file info-dir)
 449        (copy-file (expand-file-name file "../texi/")
 450                   (expand-file-name file info-dir)
 451                   t t))
 452      (sort (directory-files "../texi/" nil dgnushack-info-file-regexp)
 453            'string-lessp))
 454
 455     (message "Copying ../%s to %s..." manifest pkginfo-dir)
 456     (copy-file (expand-file-name manifest "../")
 457                (expand-file-name manifest pkginfo-dir) t t)
 458
 459     (message "Done")))
 460
 461 (defun dgnushack-texi-add-suffix-and-format ()
 462   (dgnushack-texi-format t))
 463
 464 (defun dgnushack-texi-format (&optional addsuffix)
 465   (if (not noninteractive)
 466       (error "batch-texinfo-format may only be used -batch."))
 467   (require 'texinfmt)
 468   (let ((auto-save-default nil)
 469         (find-file-run-dired nil)
 470         coding-system-for-write)
 471     (let ((error 0)
 472           file
 473           (files ()))
 474       (while command-line-args-left
 475         (setq file (expand-file-name (car command-line-args-left)))
 476         (cond ((not (file-exists-p file))
 477                (message ">> %s does not exist!" file)
 478                (setq error 1
 479                      command-line-args-left (cdr command-line-args-left)))
 480               ((file-directory-p file)
 481                (setq command-line-args-left
 482                      (nconc (directory-files file)
 483                             (cdr command-line-args-left))))
 484               (t
 485                (setq files (cons file files)
 486                      command-line-args-left (cdr command-line-args-left)))))
 487       (while files
 488         (setq file (car files)
 489               files (cdr files))
 490         (condition-case err
 491             (progn
 492               (if buffer-file-name (kill-buffer (current-buffer)))
 493               (find-file file)
 494               (setq coding-system-for-write buffer-file-coding-system)
 495               (when (and addsuffix
 496                          (re-search-forward
 497                           "^@setfilename[\t ]+\\([^\t\n ]+\\)" nil t)
 498                          (not (string-match "\\.info$" (match-string 1))))
 499                 (insert ".info"))
 500               (buffer-disable-undo (current-buffer))
 501               ;; process @include before updating node
 502               ;; This might produce some problem if we use @lowersection or
 503               ;; such.
 504               (let ((input-directory default-directory)
 505                     (texinfo-command-end))
 506                 (while (re-search-forward "^@include" nil t)
 507                   (setq texinfo-command-end (point))
 508                   (let ((filename (concat input-directory
 509                                           (texinfo-parse-line-arg))))
 510                     (re-search-backward "^@include")
 511                     (delete-region (point) (save-excursion
 512                                              (forward-line 1)
 513                                              (point)))
 514                     (message "Reading included file: %s" filename)
 515                     (save-excursion
 516                       (save-restriction
 517                         (narrow-to-region
 518                          (point)
 519                          (+ (point)
 520                             (car (cdr (insert-file-contents filename)))))
 521                         (goto-char (point-min))
 522                         ;; Remove `@setfilename' line from included file,
 523                         ;; if any, so @setfilename command not duplicated.
 524                         (if (re-search-forward "^@setfilename"
 525                                                (save-excursion
 526                                                  (forward-line 100)
 527                                                  (point))
 528                                                t)
 529                             (progn
 530                               (beginning-of-line)
 531                               (delete-region (point) (save-excursion
 532                                                        (forward-line 1)
 533                                                        (point))))))))))
 534               (texinfo-mode)
 535               (texinfo-every-node-update)
 536               (set-buffer-modified-p nil)
 537               (message "texinfo formatting %s..." file)
 538               (texinfo-format-buffer nil)
 539               (if (buffer-modified-p)
 540                   (progn (message "Saving modified %s" (buffer-file-name))
 541                          (save-buffer))))
 542           (error
 543            (message ">> Error: %s" (prin1-to-string err))
 544            (message ">>  point at")
 545            (let ((s (buffer-substring (point)
 546                                       (min (+ (point) 100)
 547                                            (point-max))))
 548                  (tem 0))
 549              (while (setq tem (string-match "\n+" s tem))
 550                (setq s (concat (substring s 0 (match-beginning 0))
 551                                "\n>>  "
 552                                (substring s (match-end 0)))
 553                      tem (1+ tem)))
 554              (message ">>  %s" s))
 555            (setq error 1))))
 556       (kill-emacs error))))
 557
 558 ;;; dgnushack.el ends here