X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d7aff0d6929c16d15992304dd44c5f528df8f895..refs/heads/wip:/admin/admin.el diff --git a/admin/admin.el b/admin/admin.el index f8ca8aec26..7af9ffa417 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -1,6 +1,6 @@ ;;; admin.el --- utilities for Emacs administration -;; Copyright (C) 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 2001-2014 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -21,7 +21,7 @@ ;; add-release-logs Add ``Version X released'' change log entries. ;; set-version Change Emacs version number in source tree. -;; set-copyright Change emacs short copyright string (eg as +;; set-copyright Change Emacs short copyright string (eg as ;; printed by --version) in source tree. ;;; Code: @@ -46,7 +46,7 @@ Optional argument DATE is the release date, default today." (funcall add-log-time-format)))))) (setq root (expand-file-name root)) (unless (file-exists-p (expand-file-name "src/emacs.c" root)) - (error "%s doesn't seem to be the root of an Emacs source tree" root)) + (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) (require 'add-log) (or date (setq date (let ((add-log-time-zone-rule t)) (funcall add-log-time-format)))) @@ -62,18 +62,31 @@ Optional argument DATE is the release date, default today." (insert entry)))) (defun set-version-in-file (root file version rx) + "Subroutine of `set-version' and `set-copyright'." (find-file (expand-file-name file root)) (goto-char (point-min)) - (unless (re-search-forward rx nil t) - (error "Version not found in %s" file)) - (replace-match (format "%s" version) nil nil nil 1)) + (setq version (format "%s" version)) + (unless (re-search-forward rx nil :noerror) + (user-error "Version not found in %s" file)) + (if (not (equal version (match-string 1))) + (replace-match version nil nil nil 1) + (kill-buffer) + (message "No need to update `%s'" file))) (defun set-version (root version) "Set Emacs version to VERSION in relevant files under ROOT. Root must be the root of an Emacs source tree." - (interactive "DEmacs root directory: \nsVersion number: ") + (interactive (list + (read-directory-name "Emacs root directory: " source-directory) + (read-string "Version number: " + (replace-regexp-in-string "\\.[0-9]+\\'" "" + emacs-version)))) (unless (file-exists-p (expand-file-name "src/emacs.c" root)) - (error "%s doesn't seem to be the root of an Emacs source tree" root)) + (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) + (message "Setting version numbers...") + ;; There's also a "version 3" (standing for GPLv3) at the end of + ;; `README', but since `set-version-in-file' only replaces the first + ;; occurrence, it won't be replaced. (set-version-in-file root "README" version (rx (and "version" (1+ space) (submatch (1+ (in "0-9.")))))) @@ -104,7 +117,7 @@ Root must be the root of an Emacs source tree." ;; in two places those commas are followed by space, in two other ;; places they are not. (let* ((version-components (append (split-string version "\\.") - '("0" "0"))) + '("0" "0"))) (comma-version (concat (car version-components) "," (cadr version-components) "," @@ -153,8 +166,8 @@ Root must be the root of an Emacs source tree." {\\([0-9]\\{2,\\}\\)}.+%.+version of Emacs") (set-version-in-file root "etc/refcards/emacsver.tex" version "\\\\def\\\\versionemacs\ -{\\([0-9]\\{2,\\}\\)}.+%.+version of Emacs")))) - +{\\([0-9]\\{2,\\}\\)}.+%.+version of Emacs"))) + (message "Setting version numbers...done")) ;; Note this makes some assumptions about form of short copyright. (defun set-copyright (root copyright) @@ -167,7 +180,8 @@ Root must be the root of an Emacs source tree." (format "Copyright (C) %s Free Software Foundation, Inc." (format-time-string "%Y"))))) (unless (file-exists-p (expand-file-name "src/emacs.c" root)) - (error "%s doesn't seem to be the root of an Emacs source tree" root)) + (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) + (message "Setting copyrights...") (set-version-in-file root "configure.ac" copyright (rx (and bol "copyright" (0+ (not (in ?\"))) ?\" (submatch (1+ (not (in ?\")))) ?\"))) @@ -189,12 +203,14 @@ Root must be the root of an Emacs source tree." {\\([0-9]\\{4\\}\\)}.+%.+copyright year") (set-version-in-file root "etc/refcards/emacsver.tex" copyright "\\\\def\\\\year\ -{\\([0-9]\\{4\\}\\)}.+%.+copyright year"))) +{\\([0-9]\\{4\\}\\)}.+%.+copyright year")) + (message "Setting copyrights...done")) ;;; Various bits of magic for generating the web manuals (defun manual-misc-manuals (root) - "Return doc/misc manuals as list of strings." + "Return doc/misc manuals as list of strings. +ROOT should be the root of an Emacs source tree." ;; Similar to `make -C doc/misc echo-info', but works if unconfigured, ;; and for INFO_TARGETS rather than INFO_INSTALL. (with-temp-buffer @@ -211,8 +227,10 @@ Root must be the root of an Emacs source tree." (buffer-substring start (point)))) '("efaq-w32"))))) +;; TODO report the progress (defun make-manuals (root &optional type) "Generate the web manuals for the Emacs webpage. +ROOT should be the root of an Emacs source tree. Interactively with a prefix argument, prompt for TYPE. Optional argument TYPE is type of output (nil means all)." (interactive (let ((root (read-directory-name "Emacs root directory: " @@ -319,6 +337,7 @@ the @import directive." (manual-html-fix-node-div) (goto-char (point-max)) (re-search-backward "[\n \t]*") + ;; Close the div id="content" that fix-index-1 added. (insert "\n\n") (save-buffer))) @@ -328,7 +347,7 @@ This function also edits the HTML files so that they validate as HTML 4.01 Transitional, and pulls in the gnu.org stylesheet using the @import directive." (unless (file-exists-p texi-file) - (error "Manual file %s not found" texi-file)) + (user-error "Manual file %s not found" texi-file)) (make-directory dir t) (call-process "makeinfo" nil nil nil "-D" "WWW_GNU_ORG" @@ -359,13 +378,14 @@ the @import directive." (manual-html-fix-index-2) (if copyright-text (insert copyright-text)) + ;; Close the div id="content" that fix-index-1 added. (insert "\n\n")) ;; For normal nodes, give the header div a blue bg. - (manual-html-fix-node-div)) + (manual-html-fix-node-div t)) (save-buffer)))))) (defun manual-pdf (texi-file dest) - "Run texi2pdf on TEXI-FILE, emitting pdf output to DEST." + "Run texi2pdf on TEXI-FILE, emitting PDF output to DEST." (make-directory (or (file-name-directory dest) ".") t) (let ((default-directory (file-name-directory texi-file))) (call-process "texi2pdf" nil nil nil @@ -377,6 +397,7 @@ the @import directive." (make-directory (or (file-name-directory dest) ".") t) (let ((dvi-dest (concat (file-name-sans-extension dest) ".dvi")) (default-directory (file-name-directory texi-file))) + ;; FIXME: Use `texi2dvi --ps'? --xfq (call-process "texi2dvi" nil nil nil "-I" "../emacs" "-I" "../misc" texi-file "-o" dvi-dest) @@ -386,119 +407,215 @@ the @import directive." (defun manual-html-fix-headers () "Fix up HTML headers for the Emacs manual in the current buffer." - (let (opoint) - (insert manual-doctype-string) + (let ((texi5 (search-forward "\n") (insert manual-meta-string) (search-forward "") (goto-char (match-beginning 0)) (delete-region opoint (point)) (insert manual-style-string) - (search-forward "") - (delete-region opoint (match-beginning 0)))) + ;; Remove Texinfo 5 hard-coding bgcolor, text, link, vlink, alink. + (when (re-search-forward "") + (if (> (point) (1+ opoint)) + (delete-region opoint (1- (point)))) + (search-backward "" nil t) - (replace-match - "
" - t t) + (let (opoint div-end type) + (while (re-search-forward "
\\)" nil t) + (setq type (match-string 1)) + ;; NB it is this that makes the bg of non-header cells in the + ;; index tables be blue. Is that intended? + ;; Also, if you don't remove the
, the color of the first + ;; row in the table will be wrong. + ;; This all seems rather odd to me... + (replace-match " style=\"background-color:#DDDDFF\">" t t nil 2) (setq opoint (point)) - (re-search-forward "
") - (setq div-end (match-beginning 0)) - (goto-char opoint) - (if (search-forward "
" div-end 'move) - (replace-match "" t t))))) + (when (or split (equal type "node")) + ;; In Texinfo 4, the
(and anchor) comes after the
. + (re-search-forward "
") + (setq div-end (if (equal type "node") + (match-beginning 0) + (line-end-position 2))) + (goto-char opoint) + (if (search-forward "
" div-end 'move) + (replace-match "" t t) + (if split (forward-line -1)))) + ;; In Texinfo 5, the
(and anchor) comes before the
(?). + ;; Except in split output, where it comes on the line after + ;; the
. But only sometimes. I have no clue what the + ;; logic of where it goes is. + (when (equal type "header") + (goto-char opoint) + (when (re-search-backward "^
$" (line-beginning-position -3) t) + (replace-match "") + (goto-char opoint)))))) + (defun manual-html-fix-index-1 () + "Remove the h1 header, and the short and long contents lists. +Also start a \"content\" div." (let (opoint) - (re-search-forward "\n") + (re-search-forward "\n") (setq opoint (match-end 0)) - (search-forward "

\n\n"))) (defun manual-html-fix-index-2 (&optional table-workaround) - "Replace the index list in the current buffer with a HTML table." - (let (done open-td tag desc) - ;; Convert the list that Makeinfo made into a table. - (or (search-forward "
    " nil t) - (search-forward "
      ")) - (replace-match "") - (forward-line 1) - (while (not done) - (cond - ((or (looking-at "
    • \\(\\):[ \t]+\\(.*\\)$") - (looking-at "
    • \\(\\)$")) - (setq tag (match-string 1)) - (setq desc (match-string 2)) - (replace-match "" t t) - (when open-td - (save-excursion - (forward-char -1) - (skip-chars-backward " ") - (delete-region (point) (line-end-position)) - (insert "\n "))) - (insert "
      • \n ") - (if table-workaround - ;; This works around a Firefox bug in the mono file. - (insert "\n
      ") - (insert "")) - (insert tag "" (or desc "")) - (setq open-td t)) - ((eq (char-after) ?\n) - (delete-char 1) - ;; Negate the following `forward-line'. - (forward-line -1)) - ((looking-at "")) - ((looking-at "

      [- ]*The Detailed Node Listing[- \n]*") - (replace-match "

      \n + "Replace the index list in the current buffer with a HTML table. +Leave point after the table." + (if (re-search-forward "" nil t) + ;; Texinfo 5 already uses a table. Tweak it a bit. + (let (opoint done) + (replace-match " style=\"float:left\" width=\"100%\"" nil t nil 1) + (forward-line 1) + (while (not done) + (cond ((re-search-forward "\\)\ +:]*>\\(.*\\)" (line-end-position) t) + (replace-match (format "\\1\n") + (forward-line 1)) + ((looking-at "\n") + (replace-match "") + (replace-match "\n")) + ;; Not all manuals have the detailed menu. + ;; If it is there, split it into a separate table. + ((re-search-forward ".*The Detailed Node Listing *" + (line-end-position) t) + (setq opoint (match-beginning 0)) + (while (and (looking-at " *—") + (zerop (forward-line 1)))) + (delete-region opoint (point)) + (insert "
        
      \\2" + (if table-workaround + " bgcolor=\"white\"" ""))) + (search-forward "
      ") + (search-forward "
      \n\n\ +

      Detailed Node Listing

      \n\n

      ") + ;; FIXME Fragile! + ;; The Emacs and Elisp manual have some text at the + ;; start of the detailed menu that is not part of the menu. + ;; Other manuals do not. + (if (re-search-forward "in one step:" (line-end-position 3) t) + (forward-line 1)) + (insert "

      \n") + (search-forward "") + (delete-region (match-beginning 0) (match-end 0)) + (forward-line -1) + (or (looking-at "^$") (error "Parse error 1")) + (forward-line -1) + (if (looking-at "^$") (error "Parse error 2")) + (forward-line -1) + (or (looking-at "^$") (error "Parse error 3")) + (forward-line 1) + (insert "\n\ +") + (forward-line 1)) + ((looking-at ".*" nil t) + ;; FIXME? The following search seems dangerously lax. + (search-forward "
        ")) + (replace-match "
      \n") + (forward-line 1) + (insert "
      ") + (forward-line 1) + (while (not done) + (cond + ((or (looking-at "
    • \\(\\):[ \t]+\\(.*\\)$") + (looking-at "
    • \\(\\)$")) + (setq tag (match-string 1)) + (setq desc (match-string 2)) + (replace-match "" t t) + (when open-td + (save-excursion + (forward-char -1) + (skip-chars-backward " ") + (delete-region (point) (line-end-position)) + (insert "\n "))) + (insert "
      • \n ") + (if table-workaround + ;; This works around a Firefox bug in the mono file. + (insert "\n
      ") + (insert "")) + (insert tag "" (or desc "")) + (setq open-td t)) + ((eq (char-after) ?\n) + (delete-char 1) + ;; Negate the following `forward-line'. + (forward-line -1)) + ((looking-at "")) + ((looking-at "

      [- ]*The Detailed Node Listing[- \n]*") + (replace-match "

      \n

      Detailed Node Listing

      \n\n" t t) - (search-forward "

      ") - (search-forward "

      " nil t) - (goto-char (match-beginning 0)) - (skip-chars-backward "\n ") - (setq open-td nil) - (insert "

      \n\n")) - ((looking-at "") - (replace-match "" t t)) - ((looking-at "

      ") - (replace-match "" t t) - (when open-td - (insert " ") - (setq open-td nil)) - (insert "

      + (search-forward "

      ") + ;; FIXME Fragile! + ;; The Emacs and Elisp manual have some text at the + ;; start of the detailed menu that is not part of the menu. + ;; Other manuals do not. + (if (looking-at "Here are some other nodes") + (search-forward "

      ")) + (goto-char (match-beginning 0)) + (skip-chars-backward "\n ") + (setq open-td nil) + (insert "

      \n\n
      ")) + ((looking-at "") + (replace-match "" t t)) + ((looking-at "

      ") + (replace-match "" t t) + (when open-td + (insert " ") + (setq open-td nil)) + (insert "

      "))) - ((looking-at "[ \t]*[ \t]*$") - (replace-match - (if open-td - " \n
      ") - (if (re-search-forward "

      [ \t\n]*
        " nil t) - (replace-match "
      " - "") t t) - (setq done t)) - (t - (if (eobp) - (error "Parse error in %s" - (file-name-nondirectory buffer-file-name))) - (unless open-td - (setq done t)))) - (forward-line 1)))) + (if (re-search-forward "

      [ \t\n]*
        " nil t) + (replace-match " "))) + ((looking-at "[ \t]*
      [ \t]*$") + (replace-match + (if open-td + " \n" + "") t t) + (setq done t)) + (t + (if (eobp) + (error "Parse error in %s" + (file-name-nondirectory buffer-file-name))) + (unless open-td + (setq done t)))) + (forward-line 1))))) -;; Stuff to check new defcustoms got :version tags. +;; Stuff to check new `defcustom's got :version tags. ;; Adapted from check-declare.el. (defun cusver-find-files (root &optional old) - "Find .el files beneath directory ROOT that contain defcustoms. -If optional OLD is non-nil, also include defvars." + "Find .el files beneath directory ROOT that contain `defcustom's. +If optional OLD is non-nil, also include `defvar's." (process-lines find-program root "-name" "*.el" "-exec" grep-program @@ -510,14 +627,14 @@ If optional OLD is non-nil, also include defvars." (defvar cusver-new-version (format "%s.%s" emacs-major-version (1+ emacs-minor-version)) - "Version number that new defcustoms should have.") + "Version number that new `defcustom's should have.") (defun cusver-scan (file &optional old) "Scan FILE for `defcustom' calls. Return a list with elements of the form (VAR . VER), This means that FILE contains a defcustom for variable VAR, with a :version tag having value VER (may be nil). -If optional argument OLD is non-nil, also scan for defvars." +If optional argument OLD is non-nil, also scan for `defvar's." (let ((m (format "Scanning %s..." file)) (re (format "^[ \t]*\\((def%s\\)[ \t\n]" (if old "\\(custom\\|var\\)" "\\(custom\\|group\\)"))) @@ -526,13 +643,19 @@ If optional argument OLD is non-nil, also scan for defvars." (with-temp-buffer (insert-file-contents file) ;; FIXME we could theoretically be inside a string. - (while (re-search-forward re nil t) + (while (re-search-forward re nil :noerror) (goto-char (match-beginning 1)) (if (and (setq form (ignore-errors (read (current-buffer)))) (setq var (car-safe (cdr-safe form))) ;; Exclude macros, eg (defcustom ,varname ...). (symbolp var)) (progn + ;; FIXME It should be cus-test-apropos that does this. + (and (not old) + (equal "custom" (match-string 2)) + (not (memq :type form)) + (display-warning 'custom + (format "Missing type in: `%s'" form))) (setq ver (car (cdr-safe (memq :version form)))) (if (equal "group" (match-string 2)) ;; Group :version could be old. @@ -568,7 +691,7 @@ If optional argument OLD is non-nil, also scan for defvars." (define-button-type 'cusver-xref 'action #'cusver-goto-xref) (defun cusver-goto-xref (button) - "Jump to a lisp file for the BUTTON at point." + "Jump to a Lisp file for the BUTTON at point." (let ((file (button-get button 'file)) (var (button-get button 'var))) (if (not (file-readable-p file)) @@ -584,34 +707,36 @@ If optional argument OLD is non-nil, also scan for defvars." ;; TODO Check cus-start if something moved from C to Lisp. ;; TODO Handle renamed things with aliases to the old names. (defun cusver-check (newdir olddir version) - "Check that defcustoms have :version tags where needed. -NEWDIR is the current lisp/ directory, OLDDIR is that from the previous -release. A defcustom that is only in NEWDIR should have a :version -tag. We exclude cases where a defvar exists in OLDDIR, since -just converting a defvar to a defcustom does not require a :version bump. + "Check that `defcustom's have :version tags where needed. +NEWDIR is the current lisp/ directory, OLDDIR is that from the +previous release, VERSION is the new version number. A +`defcustom' that is only in NEWDIR should have a :version tag. +We exclude cases where a `defvar' exists in OLDDIR, since just +converting a `defvar' to a `defcustom' does not require +a :version bump. Note that a :version tag should also be added if the value of a defcustom changes (in a non-trivial way). This function does not check for that." - (interactive (list (read-directory-name "New Lisp directory: ") - (read-directory-name "Old Lisp directory: ") + (interactive (list (read-directory-name "New Lisp directory: " nil nil t) + (read-directory-name "Old Lisp directory: " nil nil t) (number-to-string (read-number "New version number: " (string-to-number cusver-new-version))))) (or (file-directory-p (setq newdir (expand-file-name newdir))) - (error "Directory `%s' not found" newdir)) + (user-error "Directory `%s' not found" newdir)) (or (file-directory-p (setq olddir (expand-file-name olddir))) - (error "Directory `%s' not found" olddir)) + (user-error "Directory `%s' not found" olddir)) (setq cusver-new-version version) - (let* ((newfiles (progn (message "Finding new files with defcustoms...") + (let* ((newfiles (progn (message "Finding new files with `defcustom's...") (cusver-find-files newdir))) - (oldfiles (progn (message "Finding old files with defcustoms...") + (oldfiles (progn (message "Finding old files with `defcustom's...") (cusver-find-files olddir t))) - (newcus (progn (message "Reading new defcustoms...") + (newcus (progn (message "Reading new `defcustom's...") (mapcar (lambda (file) (cons file (cusver-scan file))) newfiles))) oldcus result thisfile file) - (message "Reading old defcustoms...") + (message "Reading old `defcustom's...") (dolist (file oldfiles) (setq oldcus (append oldcus (cusver-scan file t)))) (setq oldcus (append oldcus (cusver-scan-cus-start @@ -636,7 +761,7 @@ changes (in a non-trivial way). This function does not check for that." (message "No missing :version tags") (pop-to-buffer "*cusver*") (erase-buffer) - (insert "These defcustoms might be missing :version tags:\n\n") + (insert "These `defcustom's might be missing :version tags:\n\n") (dolist (elem result) (let* ((str (file-relative-name (car elem) newdir)) (strlen (length str)))