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    ;; Optimize byte code for `char-before'.
 220    (put 'char-before 'byte-optimizer 'byte-optimize-char-before)
 221    (defun byte-optimize-char-before (form)
 222      (if (null (cdr form))
 223          '(char-before (point))
 224        form))
 225    ))
 226
 227 ;; `char-after' and `char-before' must be well-behaved before lpath.el
 228 ;; is loaded.  Because it requires `poe' via `path-util'.
 229 (load (expand-file-name "lpath.el" srcdir) nil t t)
 230
 231 (unless (fboundp 'byte-compile-file-form-custom-declare-variable)
 232   ;; Bind defcustom'ed variables.
 233   (put 'custom-declare-variable 'byte-hunk-handler
 234        'byte-compile-file-form-custom-declare-variable)
 235   (defun byte-compile-file-form-custom-declare-variable (form)
 236     (if (memq 'free-vars byte-compile-warnings)
 237         (setq byte-compile-bound-variables
 238               (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
 239     form))
 240
 241 ;; Bind functions defined by `defun-maybe'.
 242 (put 'defun-maybe 'byte-hunk-handler 'byte-compile-file-form-defun-maybe)
 243 (defun byte-compile-file-form-defun-maybe (form)
 244   (if (and (not (fboundp (nth 1 form)))
 245            (memq 'unresolved byte-compile-warnings))
 246       (setq byte-compile-function-environment
 247             (cons (cons (nth 1 form)
 248                         (cons 'lambda (cdr (cdr form))))
 249                   byte-compile-function-environment)))
 250   form)
 251
 252 (condition-case nil
 253     :symbol-for-testing-whether-colon-keyword-is-available-or-not
 254   (void-variable
 255    ;; Bind keywords.
 256    (mapcar (lambda (keyword) (set keyword keyword))
 257            '(:button-keymap :data :file :mime-handle))))
 258
 259 ;; Unknown variables and functions.
 260 (unless (boundp 'buffer-file-coding-system)
 261   (defvar buffer-file-coding-system (symbol-value 'file-coding-system)))
 262 (unless (featurep 'xemacs)
 263   (defalias 'Custom-make-dependencies 'ignore)
 264   (defalias 'update-autoloads-from-directory 'ignore))
 265 (autoload 'texinfo-parse-line-arg "texinfmt")
 266
 267 (unless (fboundp 'with-temp-buffer)
 268   ;; Pickup some macros.
 269   (require 'emu))
 270
 271 (defalias 'device-sound-enabled-p 'ignore)
 272 (defalias 'play-sound-file 'ignore)
 273 (defalias 'nndb-request-article 'ignore)
 274 (defalias 'efs-re-read-dir 'ignore)
 275 (defalias 'ange-ftp-re-read-dir 'ignore)
 276 (defalias 'define-mail-user-agent 'ignore)
 277
 278 (defun dgnushack-compile (&optional warn)
 279   ;;(setq byte-compile-dynamic t)
 280   (unless warn
 281     (setq byte-compile-warnings
 282           '(free-vars unresolved callargs redefine)))
 283   (unless (locate-library "cus-edit")
 284     (error "You do not seem to have Custom installed.
 285 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 286 You also then need to add the following to the lisp/dgnushack.el file:
 287
 288      (push \"~/lisp/custom\" load-path)
 289
 290 Modify to suit your needs."))
 291   (let ((files (delete "dgnuspath.el"
 292                        (directory-files srcdir nil "^[^=].*\\.el$")))
 293         (xemacs (string-match "XEmacs" emacs-version))
 294         ;;(byte-compile-generate-call-tree t)
 295         file elc)
 296     (condition-case ()
 297         (require 'w3-forms)
 298       (error
 299        (dolist (file '("nnweb.el" "nnlistserv.el" "nnultimate.el"
 300                        "nnslashdot.el" "nnwarchive.el" "webmail.el"))
 301          (setq files (delete file files)))))
 302     (condition-case ()
 303         (require 'bbdb)
 304       (error (setq files (delete "gnus-bbdb.el" files))))
 305     (while (setq file (pop files))
 306       (unless (or (and (not xemacs)
 307                        (member file
 308                                '("gnus-xmas.el" "gnus-picon.el"
 309                                  "messagexmas.el" "nnheaderxm.el"
 310                                  "smiley.el" "x-overlay.el")))
 311                   (and (string-equal file "md5.el")
 312                        (not (and (fboundp 'md5)
 313                                  (subrp (symbol-function 'md5))))))
 314         (setq file (expand-file-name file srcdir))
 315         (when (or (not (file-exists-p (setq elc (concat file "c"))))
 316                   (file-newer-than-file-p file elc))
 317           (ignore-errors
 318             (byte-compile-file file)))))))
 319
 320 (defun dgnushack-recompile ()
 321   (require 'gnus)
 322   (byte-recompile-directory "." 0))
 323
 324 \f
 325 ;; Avoid byte-compile warnings.
 326 (defvar gnus-product-name)
 327 (defvar early-package-load-path)
 328 (defvar early-packages)
 329 (defvar last-package-load-path)
 330 (defvar last-packages)
 331 (defvar late-package-load-path)
 332 (defvar late-packages)
 333
 334 (defconst dgnushack-info-file-regexp
 335   (concat "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)"
 336           "\\.info\\(-[0-9]+\\)?$"))
 337
 338 (defconst dgnushack-texi-file-regexp
 339   "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)\\.texi$")
 340
 341 (defun dgnushack-make-package ()
 342   (require 'gnus)
 343   (let* ((product-name (downcase gnus-product-name))
 344          (lisp-dir (concat "lisp/" product-name "/"))
 345          make-backup-files)
 346
 347     (message "Updating autoloads for directory %s..." default-directory)
 348     (let ((generated-autoload-file "auto-autoloads.el")
 349           noninteractive
 350           (omsg (symbol-function 'message)))
 351       (defun message (fmt &rest args)
 352         (cond ((and (string-equal "Generating autoloads for %s..." fmt)
 353                     (file-exists-p (file-name-nondirectory (car args))))
 354                (funcall omsg fmt (file-name-nondirectory (car args))))
 355               ((string-equal "No autoloads found in %s" fmt))
 356               ((string-equal "Generating autoloads for %s...done" fmt))
 357               (t (apply omsg fmt args))))
 358       (unwind-protect
 359           (update-autoloads-from-directory default-directory)
 360         (fset 'message omsg)))
 361     (byte-compile-file "auto-autoloads.el")
 362
 363     (with-temp-buffer
 364       (let ((standard-output (current-buffer)))
 365         (Custom-make-dependencies "."))
 366       (message (buffer-string)))
 367     (require 'cus-load)
 368     (byte-compile-file "custom-load.el")
 369
 370     (message "Generating MANIFEST.%s for the package..." product-name)
 371     (with-temp-buffer
 372       (insert "pkginfo/MANIFEST." product-name "\n"
 373               lisp-dir
 374               (mapconcat
 375                'identity
 376                (sort (delete "dgnuspath.el"
 377                              (delete "patchs.elc"
 378                                      (directory-files "." nil "\\.elc?$")))
 379                      'string-lessp)
 380                (concat "\n" lisp-dir))
 381               "\ninfo/"
 382               (mapconcat
 383                'identity
 384                (sort (directory-files "../texi/"
 385                                       nil dgnushack-info-file-regexp)
 386                      'string-lessp)
 387                "\ninfo/")
 388               "\n")
 389       (write-file (concat "../MANIFEST." product-name)))))
 390
 391 (defun dgnushack-install-package ()
 392   (let ((package-dir (car command-line-args-left))
 393         dirs info-dir pkginfo-dir product-name lisp-dir manifest files)
 394     (unless package-dir
 395       (when (boundp 'early-packages)
 396         (setq dirs (delq nil (append (when early-package-load-path
 397                                        early-packages)
 398                                      (when late-package-load-path
 399                                        late-packages)
 400                                      (when last-package-load-path
 401                                        last-packages))))
 402         (while (and dirs (not package-dir))
 403           (when (file-exists-p (car dirs))
 404             (setq package-dir (car dirs)
 405                   dirs (cdr dirs))))))
 406     (unless package-dir
 407       (error "%s" "
 408 You must specify the name of the package path as follows:
 409
 410 % make install-package PACKAGEDIR=/usr/local/lib/xemacs/xemacs-packages
 411 "
 412              ))
 413     (setq info-dir (expand-file-name "info/" package-dir)
 414           pkginfo-dir (expand-file-name "pkginfo/" package-dir))
 415     (require 'gnus)
 416     (setq product-name (downcase gnus-product-name)
 417           lisp-dir (expand-file-name (concat "lisp/" product-name "/")
 418                                      package-dir)
 419           manifest (concat "MANIFEST." product-name))
 420
 421     (unless (file-directory-p lisp-dir)
 422       (make-directory lisp-dir t))
 423     (unless (file-directory-p info-dir)
 424       (make-directory info-dir))
 425     (unless (file-directory-p pkginfo-dir)
 426       (make-directory pkginfo-dir))
 427
 428     (setq files
 429           (sort (delete "dgnuspath.el"
 430                         (delete "dgnuspath.elc"
 431                                 (directory-files "." nil "\\.elc?$")))
 432                 'string-lessp))
 433     (mapcar
 434      (lambda (file)
 435        (unless (or (member file files)
 436                    (not (string-match "\\.elc?$" file)))
 437          (setq file (expand-file-name file lisp-dir))
 438          (message "Removing %s..." file)
 439          (condition-case nil
 440              (delete-file file)
 441            (error nil))))
 442      (directory-files lisp-dir nil nil nil t))
 443     (mapcar
 444      (lambda (file)
 445        (message "Copying %s to %s..." file lisp-dir)
 446        (copy-file file (expand-file-name file lisp-dir) t t))
 447      files)
 448
 449     (mapcar
 450      (lambda (file)
 451        (message "Copying ../texi/%s to %s..." file info-dir)
 452        (copy-file (expand-file-name file "../texi/")
 453                   (expand-file-name file info-dir)
 454                   t t))
 455      (sort (directory-files "../texi/" nil dgnushack-info-file-regexp)
 456            'string-lessp))
 457
 458     (message "Copying ../%s to %s..." manifest pkginfo-dir)
 459     (copy-file (expand-file-name manifest "../")
 460                (expand-file-name manifest pkginfo-dir) t t)
 461
 462     (message "Done")))
 463
 464 (defun dgnushack-texi-add-suffix-and-format ()
 465   (dgnushack-texi-format t))
 466
 467 (defun dgnushack-texi-format (&optional addsuffix)
 468   (if (not noninteractive)
 469       (error "batch-texinfo-format may only be used -batch."))
 470   (require 'texinfmt)
 471   (let ((auto-save-default nil)
 472         (find-file-run-dired nil)
 473         coding-system-for-write)
 474     (let ((error 0)
 475           file
 476           (files ()))
 477       (while command-line-args-left
 478         (setq file (expand-file-name (car command-line-args-left)))
 479         (cond ((not (file-exists-p file))
 480                (message ">> %s does not exist!" file)
 481                (setq error 1
 482                      command-line-args-left (cdr command-line-args-left)))
 483               ((file-directory-p file)
 484                (setq command-line-args-left
 485                      (nconc (directory-files file)
 486                             (cdr command-line-args-left))))
 487               (t
 488                (setq files (cons file files)
 489                      command-line-args-left (cdr command-line-args-left)))))
 490       (while files
 491         (setq file (car files)
 492               files (cdr files))
 493         (condition-case err
 494             (progn
 495               (if buffer-file-name (kill-buffer (current-buffer)))
 496               (find-file file)
 497               (setq coding-system-for-write buffer-file-coding-system)
 498               (when (and addsuffix
 499                          (re-search-forward
 500                           "^@setfilename[\t ]+\\([^\t\n ]+\\)" nil t)
 501                          (not (string-match "\\.info$" (match-string 1))))
 502                 (insert ".info"))
 503               (buffer-disable-undo (current-buffer))
 504               ;; process @include before updating node
 505               ;; This might produce some problem if we use @lowersection or
 506               ;; such.
 507               (let ((input-directory default-directory)
 508                     (texinfo-command-end))
 509                 (while (re-search-forward "^@include" nil t)
 510                   (setq texinfo-command-end (point))
 511                   (let ((filename (concat input-directory
 512                                           (texinfo-parse-line-arg))))
 513                     (re-search-backward "^@include")
 514                     (delete-region (point) (save-excursion
 515                                              (forward-line 1)
 516                                              (point)))
 517                     (message "Reading included file: %s" filename)
 518                     (save-excursion
 519                       (save-restriction
 520                         (narrow-to-region
 521                          (point)
 522                          (+ (point)
 523                             (car (cdr (insert-file-contents filename)))))
 524                         (goto-char (point-min))
 525                         ;; Remove `@setfilename' line from included file,
 526                         ;; if any, so @setfilename command not duplicated.
 527                         (if (re-search-forward "^@setfilename"
 528                                                (save-excursion
 529                                                  (forward-line 100)
 530                                                  (point))
 531                                                t)
 532                             (progn
 533                               (beginning-of-line)
 534                               (delete-region (point) (save-excursion
 535                                                        (forward-line 1)
 536                                                        (point))))))))))
 537               (texinfo-mode)
 538               (texinfo-every-node-update)
 539               (set-buffer-modified-p nil)
 540               (message "texinfo formatting %s..." file)
 541               (texinfo-format-buffer nil)
 542               (if (buffer-modified-p)
 543                   (progn (message "Saving modified %s" (buffer-file-name))
 544                          (save-buffer))))
 545           (error
 546            (message ">> Error: %s" (prin1-to-string err))
 547            (message ">>  point at")
 548            (let ((s (buffer-substring (point)
 549                                       (min (+ (point) 100)
 550                                            (point-max))))
 551                  (tem 0))
 552              (while (setq tem (string-match "\n+" s tem))
 553                (setq s (concat (substring s 0 (match-beginning 0))
 554                                "\n>>  "
 555                                (substring s (match-end 0)))
 556                      tem (1+ tem)))
 557              (message ">>  %s" s))
 558            (setq error 1))))
 559       (kill-emacs error))))
 560
 561 ;;; dgnushack.el ends here