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 ;; Define cl functions as compiler macros.
  54 (unless (and (fboundp 'copy-list)
  55              (subrp (symbol-function 'copy-list)))
  56   (define-compiler-macro copy-list (list)
  57     (` (let ((list (, list)))
  58          (if (consp list)
  59              (let ((res nil))
  60                (while (consp list) (push (pop list) res))
  61                (prog1 (nreverse res) (setcdr res list)))
  62            (car list)))))
  63   )
  64
  65 (unless (and (fboundp 'union)
  66              (subrp (symbol-function 'union)))
  67   (define-compiler-macro union (cl-list1 cl-list2 &rest cl-keys)
  68     (let ((adjoin (symbol-function 'adjoin)))
  69       (if cl-keys
  70           (` (let ((list1 (, cl-list1))
  71                    (list2 (, cl-list2))
  72                    (keys (, cl-keys)))
  73                (cond ((null list1) list2) ((null list2) list1)
  74                      ((equal list1 list2) list1)
  75                      (t
  76                       (or (>= (length list1) (length list2))
  77                           (setq list1 (prog1 list2 (setq list2 list1))))
  78                       (while list2
  79                         (if (or keys (numberp (car list2)))
  80                             (setq list1 (apply (, adjoin)
  81                                                (car list2) list1 keys))
  82                           (or (memq (car list2) list1)
  83                               (push (car list2) list1)))
  84                         (pop list2))
  85                       list1))))
  86         (` (let ((list1 (, cl-list1))
  87                  (list2 (, cl-list2)))
  88              (cond ((null list1) list2) ((null list2) list1)
  89                    ((equal list1 list2) list1)
  90                    (t
  91                     (or (>= (length list1) (length list2))
  92                         (setq list1 (prog1 list2 (setq list2 list1))))
  93                     (while list2
  94                       (if (numberp (car list2))
  95                           (setq list1 (funcall (, adjoin) (car list2) list1))
  96                         (or (memq (car list2) list1)
  97                             (push (car list2) list1)))
  98                       (pop list2))
  99                     list1)))))))
 100   )
 101
 102 (require 'bytecomp)
 103
 104 ;; Attempt to pickup the additional load-path(s).
 105 (load (expand-file-name "./dgnuspath.el") nil nil t)
 106 (condition-case err
 107     (load "~/.lpath.el" t nil t)
 108   (error (message "Error in \"~/.lpath.el\" file: %s" err)))
 109
 110 (push "." load-path)
 111
 112 (condition-case nil
 113     (char-after)
 114   (wrong-number-of-arguments
 115    ;; Optimize byte code for `char-after'.
 116    (put 'char-after 'byte-optimizer 'byte-optimize-char-after)
 117    (defun byte-optimize-char-after (form)
 118      (if (null (cdr form))
 119          '(char-after (point))
 120        form))
 121    (byte-defop-compiler char-after 0-1)))
 122
 123 (condition-case nil
 124     (char-before)
 125   (wrong-number-of-arguments
 126    ;; Optimize byte code for `char-before'.
 127    (put 'char-before 'byte-optimizer 'byte-optimize-char-before)
 128    (defun byte-optimize-char-before (form)
 129      (if (null (cdr form))
 130          '(char-before (point))
 131        form))))
 132
 133 ;; `char-after' and `char-before' must be well-behaved before lpath.el
 134 ;; is loaded.  Because it requires `poe' via `path-util'.
 135 (load "./lpath.el" nil t)
 136
 137 (unless (fboundp 'byte-compile-file-form-custom-declare-variable)
 138   ;; Bind defcustom'ed variables.
 139   (put 'custom-declare-variable 'byte-hunk-handler
 140        'byte-compile-file-form-custom-declare-variable)
 141   (defun byte-compile-file-form-custom-declare-variable (form)
 142     (if (memq 'free-vars byte-compile-warnings)
 143         (setq byte-compile-bound-variables
 144               (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
 145     form))
 146
 147 ;; Bind functions defined by `defun-maybe'.
 148 (put 'defun-maybe 'byte-hunk-handler 'byte-compile-file-form-defun-maybe)
 149 (defun byte-compile-file-form-defun-maybe (form)
 150   (if (and (not (fboundp (nth 1 form)))
 151            (memq 'unresolved byte-compile-warnings))
 152       (setq byte-compile-function-environment
 153             (cons (cons (nth 1 form)
 154                         (cons 'lambda (cdr (cdr form))))
 155                   byte-compile-function-environment)))
 156   form)
 157
 158 (condition-case nil
 159     :symbol-for-testing-whether-colon-keyword-is-available-or-not
 160   (void-variable
 161    ;; Bind keywords.
 162    (mapcar (lambda (keyword) (set keyword keyword))
 163            '(:button-keymap :data :file :mime-handle))))
 164
 165 ;; Unknown variables and functions.
 166 (unless (boundp 'buffer-file-coding-system)
 167   (defvar buffer-file-coding-system (symbol-value 'file-coding-system)))
 168 (autoload 'font-lock-set-defaults "font-lock")
 169 (unless (fboundp 'coding-system-get)
 170   (defalias 'coding-system-get 'ignore))
 171 (when (boundp 'MULE)
 172   (defalias 'find-coding-system 'ignore))
 173 (unless (fboundp 'get-charset-property)
 174   (defalias 'get-charset-property 'ignore))
 175 (unless (featurep 'xemacs)
 176   (defalias 'Custom-make-dependencies 'ignore)
 177   (defalias 'toolbar-gnus 'ignore)
 178   (defalias 'update-autoloads-from-directory 'ignore))
 179 (autoload 'texinfo-parse-line-arg "texinfmt")
 180
 181 (unless (fboundp 'with-temp-buffer)
 182   ;; Pickup some macros.
 183   (require 'emu))
 184
 185 (defalias 'device-sound-enabled-p 'ignore)
 186 (defalias 'play-sound-file 'ignore)
 187 (defalias 'nndb-request-article 'ignore)
 188 (defalias 'efs-re-read-dir 'ignore)
 189 (defalias 'ange-ftp-re-read-dir 'ignore)
 190 (defalias 'define-mail-user-agent 'ignore)
 191
 192 (eval-and-compile
 193   (unless (string-match "XEmacs" emacs-version)
 194     (fset 'get-popup-menu-response 'ignore)
 195     (fset 'event-object 'ignore)
 196     (fset 'x-defined-colors 'ignore)
 197     (fset 'read-color 'ignore)))
 198
 199 (defun dgnushack-compile (&optional warn)
 200   ;;(setq byte-compile-dynamic t)
 201   (unless warn
 202     (setq byte-compile-warnings
 203           '(free-vars unresolved callargs redefine)))
 204   (unless (locate-library "cus-edit")
 205     (error "You do not seem to have Custom installed.
 206 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 207 You also then need to add the following to the lisp/dgnushack.el file:
 208
 209      (push \"~/lisp/custom\" load-path)
 210
 211 Modify to suit your needs."))
 212   (let ((files (delete "dgnuspath.el"
 213                        (directory-files "." nil "^[^=].*\\.el$")))
 214         (xemacs (string-match "XEmacs" emacs-version))
 215         ;;(byte-compile-generate-call-tree t)
 216         file elc)
 217     (condition-case ()
 218         (require 'w3-forms)
 219       (error (setq files (delete "nnweb.el" (delete "nnlistserv.el" files)))))
 220     (condition-case ()
 221         (require 'bbdb)
 222       (error (setq files (delete "gnus-bbdb.el" files))))
 223     (while (setq file (pop files))
 224       (when (or (and (not xemacs)
 225                      (not (member file '("gnus-xmas.el" "gnus-picon.el"
 226                                          "messagexmas.el" "nnheaderxm.el"
 227                                          "smiley.el" "x-overlay.el"))))
 228                 (and xemacs
 229                      (not (member file '("md5.el")))))
 230         (when (or (not (file-exists-p (setq elc (concat file "c"))))
 231                   (file-newer-than-file-p file elc))
 232           (ignore-errors
 233             (byte-compile-file file)))))))
 234
 235 (defun dgnushack-recompile ()
 236   (require 'gnus)
 237   (byte-recompile-directory "." 0))
 238
 239 \f
 240 ;; Avoid byte-compile warnings.
 241 (defvar gnus-product-name)
 242 (defvar early-package-load-path)
 243 (defvar early-packages)
 244 (defvar last-package-load-path)
 245 (defvar last-packages)
 246 (defvar late-package-load-path)
 247 (defvar late-packages)
 248
 249 (defconst dgnushack-info-file-regexp
 250   (concat "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)"
 251           "\\.info\\(-[0-9]+\\)?$"))
 252
 253 (defconst dgnushack-texi-file-regexp
 254   "^\\(gnus\\|message\\|emacs-mime\\|gnus-ja\\|message-ja\\)\\.texi$")
 255
 256 (defun dgnushack-make-package ()
 257   (require 'gnus)
 258   (let* ((product-name (downcase gnus-product-name))
 259          (lisp-dir (concat "lisp/" product-name "/"))
 260          make-backup-files)
 261
 262     (message "Updating autoloads for directory %s..." default-directory)
 263     (let ((generated-autoload-file "auto-autoloads.el")
 264           noninteractive
 265           (omsg (symbol-function 'message)))
 266       (defun message (fmt &rest args)
 267         (cond ((and (string-equal "Generating autoloads for %s..." fmt)
 268                     (file-exists-p (file-name-nondirectory (car args))))
 269                (funcall omsg fmt (file-name-nondirectory (car args))))
 270               ((string-equal "No autoloads found in %s" fmt))
 271               ((string-equal "Generating autoloads for %s...done" fmt))
 272               (t (apply omsg fmt args))))
 273       (unwind-protect
 274           (update-autoloads-from-directory default-directory)
 275         (fset 'message omsg)))
 276     (byte-compile-file "auto-autoloads.el")
 277
 278     (with-temp-buffer
 279       (let ((standard-output (current-buffer)))
 280         (Custom-make-dependencies "."))
 281       (message (buffer-string)))
 282     (require 'cus-load)
 283     (byte-compile-file "custom-load.el")
 284
 285     (message "Generating MANIFEST.%s for the package..." product-name)
 286     (with-temp-buffer
 287       (insert "pkginfo/MANIFEST." product-name "\n"
 288               lisp-dir
 289               (mapconcat
 290                'identity
 291                (sort (delete "dgnuspath.el"
 292                              (delete "patchs.elc"
 293                                      (directory-files "." nil "\\.elc?$")))
 294                      'string-lessp)
 295                (concat "\n" lisp-dir))
 296               "\ninfo/"
 297               (mapconcat
 298                'identity
 299                (sort (directory-files "../texi/"
 300                                       nil dgnushack-info-file-regexp)
 301                      'string-lessp)
 302                "\ninfo/")
 303               "\n")
 304       (write-file (concat "../MANIFEST." product-name)))))
 305
 306 (defun dgnushack-install-package ()
 307   (let ((package-dir (car command-line-args-left))
 308         dirs info-dir pkginfo-dir product-name lisp-dir manifest files)
 309     (unless package-dir
 310       (when (boundp 'early-packages)
 311         (setq dirs (delq nil (append (when early-package-load-path
 312                                        early-packages)
 313                                      (when late-package-load-path
 314                                        late-packages)
 315                                      (when last-package-load-path
 316                                        last-packages))))
 317         (while (and dirs (not package-dir))
 318           (when (file-exists-p (car dirs))
 319             (setq package-dir (car dirs)
 320                   dirs (cdr dirs))))))
 321     (unless package-dir
 322       (error "%s" "
 323 You must specify the name of the package path as follows:
 324
 325 % make install-package PACKAGEDIR=/usr/local/lib/xemacs/xemacs-packages
 326 "
 327              ))
 328     (setq info-dir (expand-file-name "info/" package-dir)
 329           pkginfo-dir (expand-file-name "pkginfo/" package-dir))
 330     (require 'gnus)
 331     (setq product-name (downcase gnus-product-name)
 332           lisp-dir (expand-file-name (concat "lisp/" product-name "/")
 333                                      package-dir)
 334           manifest (concat "MANIFEST." product-name))
 335
 336     (unless (file-directory-p lisp-dir)
 337       (make-directory lisp-dir t))
 338     (unless (file-directory-p info-dir)
 339       (make-directory info-dir))
 340     (unless (file-directory-p pkginfo-dir)
 341       (make-directory pkginfo-dir))
 342
 343     (setq files
 344           (sort (delete "dgnuspath.el"
 345                         (delete "dgnuspath.elc"
 346                                 (directory-files "." nil "\\.elc?$")))
 347                 'string-lessp))
 348     (mapcar
 349      (lambda (file)
 350        (unless (member file files)
 351          (setq file (expand-file-name file lisp-dir))
 352          (message "Removing %s..." file)
 353          (condition-case nil
 354              (delete-file file)
 355            (error nil))))
 356      (directory-files lisp-dir nil nil nil t))
 357     (mapcar
 358      (lambda (file)
 359        (message "Copying %s to %s..." file lisp-dir)
 360        (copy-file file (expand-file-name file lisp-dir) t t))
 361      files)
 362
 363     (mapcar
 364      (lambda (file)
 365        (message "Copying ../texi/%s to %s..." file info-dir)
 366        (copy-file (expand-file-name file "../texi/")
 367                   (expand-file-name file info-dir)
 368                   t t))
 369      (sort (directory-files "../texi/" nil dgnushack-info-file-regexp)
 370            'string-lessp))
 371
 372     (message "Copying ../%s to %s..." manifest pkginfo-dir)
 373     (copy-file (expand-file-name manifest "../")
 374                (expand-file-name manifest pkginfo-dir) t t)
 375
 376     (message "Done")))
 377
 378 (defun dgnushack-texi-add-suffix-and-format ()
 379   (dgnushack-texi-format t))
 380
 381 (defun dgnushack-texi-format (&optional addsuffix)
 382   (if (not noninteractive)
 383       (error "batch-texinfo-format may only be used -batch."))
 384   (require 'texinfmt)
 385   (let ((auto-save-default nil)
 386         (find-file-run-dired nil)
 387         coding-system-for-write)
 388     (let ((error 0)
 389           file
 390           (files ()))
 391       (while command-line-args-left
 392         (setq file (expand-file-name (car command-line-args-left)))
 393         (cond ((not (file-exists-p file))
 394                (message ">> %s does not exist!" file)
 395                (setq error 1
 396                      command-line-args-left (cdr command-line-args-left)))
 397               ((file-directory-p file)
 398                (setq command-line-args-left
 399                      (nconc (directory-files file)
 400                             (cdr command-line-args-left))))
 401               (t
 402                (setq files (cons file files)
 403                      command-line-args-left (cdr command-line-args-left)))))
 404       (while files
 405         (setq file (car files)
 406               files (cdr files))
 407         (condition-case err
 408             (progn
 409               (if buffer-file-name (kill-buffer (current-buffer)))
 410               (find-file file)
 411               (setq coding-system-for-write buffer-file-coding-system)
 412               (when (and addsuffix
 413                          (re-search-forward
 414                           "^@setfilename[\t ]+\\([^\t\n ]+\\)" nil t)
 415                          (not (string-match "\\.info$" (match-string 1))))
 416                 (insert ".info"))
 417               (buffer-disable-undo (current-buffer))
 418               ;; process @include before updating node
 419               ;; This might produce some problem if we use @lowersection or
 420               ;; such.
 421               (let ((input-directory default-directory)
 422                     (texinfo-command-end))
 423                 (while (re-search-forward "^@include" nil t)
 424                   (setq texinfo-command-end (point))
 425                   (let ((filename (concat input-directory
 426                                           (texinfo-parse-line-arg))))
 427                     (re-search-backward "^@include")
 428                     (delete-region (point) (save-excursion
 429                                              (forward-line 1)
 430                                              (point)))
 431                     (message "Reading included file: %s" filename)
 432                     (save-excursion
 433                       (save-restriction
 434                         (narrow-to-region
 435                          (point)
 436                          (+ (point)
 437                             (car (cdr (insert-file-contents filename)))))
 438                         (goto-char (point-min))
 439                         ;; Remove `@setfilename' line from included file,
 440                         ;; if any, so @setfilename command not duplicated.
 441                         (if (re-search-forward "^@setfilename"
 442                                                (save-excursion
 443                                                  (forward-line 100)
 444                                                  (point))
 445                                                t)
 446                             (progn
 447                               (beginning-of-line)
 448                               (delete-region (point) (save-excursion
 449                                                        (forward-line 1)
 450                                                        (point))))))))))
 451               (texinfo-mode)
 452               (texinfo-every-node-update)
 453               (set-buffer-modified-p nil)
 454               (message "texinfo formatting %s..." file)
 455               (texinfo-format-buffer nil)
 456               (if (buffer-modified-p)
 457                   (progn (message "Saving modified %s" (buffer-file-name))
 458                          (save-buffer))))
 459           (error
 460            (message ">> Error: %s" (prin1-to-string err))
 461            (message ">>  point at")
 462            (let ((s (buffer-substring (point)
 463                                       (min (+ (point) 100)
 464                                            (point-max))))
 465                  (tem 0))
 466              (while (setq tem (string-match "\n+" s tem))
 467                (setq s (concat (substring s 0 (match-beginning 0))
 468                                "\n>>  "
 469                                (substring s (match-end 0)))
 470                      tem (1+ tem)))
 471              (message ">>  %s" s))
 472            (setq error 1))))
 473       (kill-emacs error))))
 474
 475 ;;; dgnushack.el ends here