| 1 | ;;; admin.el --- utilities for Emacs administration |
| 2 | |
| 3 | ;; Copyright (C) 2001-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; This file is part of GNU Emacs. |
| 6 | |
| 7 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 8 | ;; it under the terms of the GNU General Public License as published by |
| 9 | ;; the Free Software Foundation, either version 3 of the License, or |
| 10 | ;; (at your option) any later version. |
| 11 | |
| 12 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;; GNU General Public License for more details. |
| 16 | |
| 17 | ;; You should have received a copy of the GNU General Public License |
| 18 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 19 | |
| 20 | ;;; Commentary: |
| 21 | |
| 22 | ;; add-release-logs Add ``Version X released'' change log entries. |
| 23 | ;; set-version Change Emacs version number in source tree. |
| 24 | ;; set-copyright Change emacs short copyright string (eg as |
| 25 | ;; printed by --version) in source tree. |
| 26 | |
| 27 | ;;; Code: |
| 28 | |
| 29 | (defun add-release-logs (root version) |
| 30 | "Add \"Version VERSION released.\" change log entries in ROOT. |
| 31 | Root must be the root of an Emacs source tree." |
| 32 | (interactive "DEmacs root directory: \nNVersion number: ") |
| 33 | (setq root (expand-file-name root)) |
| 34 | (unless (file-exists-p (expand-file-name "src/emacs.c" root)) |
| 35 | (error "%s doesn't seem to be the root of an Emacs source tree" root)) |
| 36 | (require 'add-log) |
| 37 | (let* ((logs (process-lines "find" root "-name" "ChangeLog")) |
| 38 | (entry (format "%s %s <%s>\n\n\t* Version %s released.\n\n" |
| 39 | (funcall add-log-time-format) |
| 40 | (or add-log-full-name (user-full-name)) |
| 41 | (or add-log-mailing-address user-mail-address) |
| 42 | version))) |
| 43 | (dolist (log logs) |
| 44 | (unless (string-match "/gnus/" log) |
| 45 | (find-file log) |
| 46 | (goto-char (point-min)) |
| 47 | (insert entry))))) |
| 48 | |
| 49 | (defun set-version-in-file (root file version rx) |
| 50 | (find-file (expand-file-name file root)) |
| 51 | (goto-char (point-min)) |
| 52 | (unless (re-search-forward rx nil t) |
| 53 | (error "Version not found in %s" file)) |
| 54 | (replace-match (format "%s" version) nil nil nil 1)) |
| 55 | |
| 56 | (defun set-version (root version) |
| 57 | "Set Emacs version to VERSION in relevant files under ROOT. |
| 58 | Root must be the root of an Emacs source tree." |
| 59 | (interactive "DEmacs root directory: \nsVersion number: ") |
| 60 | (unless (file-exists-p (expand-file-name "src/emacs.c" root)) |
| 61 | (error "%s doesn't seem to be the root of an Emacs source tree" root)) |
| 62 | (set-version-in-file root "README" version |
| 63 | (rx (and "version" (1+ space) |
| 64 | (submatch (1+ (in "0-9.")))))) |
| 65 | (set-version-in-file root "configure.ac" version |
| 66 | (rx (and "AC_INIT" (1+ (not (in ?,))) |
| 67 | ?, (0+ space) |
| 68 | (submatch (1+ (in "0-9.")))))) |
| 69 | (set-version-in-file root "doc/emacs/emacsver.texi" version |
| 70 | (rx (and "EMACSVER" (1+ space) |
| 71 | (submatch (1+ (in "0-9.")))))) |
| 72 | (set-version-in-file root "doc/man/emacs.1" version |
| 73 | (rx (and ".TH EMACS" (1+ not-newline) |
| 74 | "GNU Emacs" (1+ space) |
| 75 | (submatch (1+ (in "0-9.")))))) |
| 76 | (set-version-in-file root "nt/config.nt" version |
| 77 | (rx (and bol "#" (0+ blank) "define" (1+ blank) |
| 78 | "VERSION" (1+ blank) "\"" |
| 79 | (submatch (1+ (in "0-9.")))))) |
| 80 | (set-version-in-file root "msdos/sed2v2.inp" version |
| 81 | (rx (and bol "/^#undef " (1+ not-newline) |
| 82 | "define VERSION" (1+ space) "\"" |
| 83 | (submatch (1+ (in "0-9.")))))) |
| 84 | (set-version-in-file root "nt/makefile.w32-in" version |
| 85 | (rx (and "VERSION" (0+ space) "=" (0+ space) |
| 86 | (submatch (1+ (in "0-9.")))))) |
| 87 | ;; nt/emacs.rc also contains the version number, but in an awkward |
| 88 | ;; format. It must contain four components, separated by commas, and |
| 89 | ;; in two places those commas are followed by space, in two other |
| 90 | ;; places they are not. |
| 91 | (let* ((version-components (append (split-string version "\\.") |
| 92 | '("0" "0"))) |
| 93 | (comma-version |
| 94 | (concat (car version-components) "," |
| 95 | (cadr version-components) "," |
| 96 | (cadr (cdr version-components)) "," |
| 97 | (cadr (cdr (cdr version-components))))) |
| 98 | (comma-space-version |
| 99 | (concat (car version-components) ", " |
| 100 | (cadr version-components) ", " |
| 101 | (cadr (cdr version-components)) ", " |
| 102 | (cadr (cdr (cdr version-components)))))) |
| 103 | (set-version-in-file root "nt/emacs.rc" comma-version |
| 104 | (rx (and "FILEVERSION" (1+ space) |
| 105 | (submatch (1+ (in "0-9,")))))) |
| 106 | (set-version-in-file root "nt/emacs.rc" comma-version |
| 107 | (rx (and "PRODUCTVERSION" (1+ space) |
| 108 | (submatch (1+ (in "0-9,")))))) |
| 109 | (set-version-in-file root "nt/emacs.rc" comma-space-version |
| 110 | (rx (and "\"FileVersion\"" (0+ space) ?, (0+ space) |
| 111 | ?\" (submatch (1+ (in "0-9, "))) "\\0\""))) |
| 112 | (set-version-in-file root "nt/emacs.rc" comma-space-version |
| 113 | (rx (and "\"ProductVersion\"" (0+ space) ?, |
| 114 | (0+ space) ?\" (submatch (1+ (in "0-9, "))) |
| 115 | "\\0\""))) |
| 116 | ;; Likewise for emacsclient.rc |
| 117 | (set-version-in-file root "nt/emacsclient.rc" comma-version |
| 118 | (rx (and "FILEVERSION" (1+ space) |
| 119 | (submatch (1+ (in "0-9,")))))) |
| 120 | (set-version-in-file root "nt/emacsclient.rc" comma-version |
| 121 | (rx (and "PRODUCTVERSION" (1+ space) |
| 122 | (submatch (1+ (in "0-9,")))))) |
| 123 | (set-version-in-file root "nt/emacsclient.rc" comma-space-version |
| 124 | (rx (and "\"FileVersion\"" (0+ space) ?, (0+ space) |
| 125 | ?\" (submatch (1+ (in "0-9, "))) "\\0\""))) |
| 126 | (set-version-in-file root "nt/emacsclient.rc" comma-space-version |
| 127 | (rx (and "\"ProductVersion\"" (0+ space) ?, |
| 128 | (0+ space) ?\" (submatch (1+ (in "0-9, "))) |
| 129 | "\\0\"")))) |
| 130 | ;; nextstep. |
| 131 | (set-version-in-file |
| 132 | root "nextstep/Cocoa/Emacs.base/Contents/Info.plist" |
| 133 | version (rx (and "CFBundleGetInfoString" (1+ anything) "Emacs" (1+ space) |
| 134 | (submatch (1+ (in "0-9.")))))) |
| 135 | (set-version-in-file |
| 136 | root "nextstep/Cocoa/Emacs.base/Contents/Info.plist" |
| 137 | version (rx (and "CFBundleShortVersionString" (1+ not-newline) ?\n |
| 138 | (0+ not-newline) "<string>" (0+ space) |
| 139 | (submatch (1+ (in "0-9.")))))) |
| 140 | (set-version-in-file |
| 141 | root "nextstep/Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" |
| 142 | version (rx (and "CFBundleShortVersionString" (0+ space) ?= (0+ space) |
| 143 | ?\" (0+ space) "Version" (1+ space) |
| 144 | (submatch (1+ (in "0-9.")))))) |
| 145 | (set-version-in-file |
| 146 | root "nextstep/Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" |
| 147 | version (rx (and "CFBundleGetInfoString" (0+ space) ?= (0+ space) |
| 148 | ?\" (0+ space) "Emacs version" (1+ space) |
| 149 | (submatch (1+ (in "0-9.")))))) |
| 150 | (set-version-in-file |
| 151 | root "nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist" |
| 152 | version (rx (and "ApplicationRelease" (0+ space) ?= (0+ space) |
| 153 | ?\" (0+ space) (submatch (1+ (in "0-9.")))))) |
| 154 | (set-version-in-file |
| 155 | root "nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist" |
| 156 | version (rx (and "FullVersionID" (0+ space) ?= (0+ space) |
| 157 | ?\" (0+ space) "Emacs" (1+ space) |
| 158 | (submatch (1+ (in "0-9.")))))) |
| 159 | (set-version-in-file |
| 160 | root "nextstep/GNUstep/Emacs.base/Resources/Emacs.desktop" |
| 161 | version (rx (and "Version=" (submatch (1+ (in "0-9."))))))) |
| 162 | |
| 163 | ;; Note this makes some assumptions about form of short copyright. |
| 164 | (defun set-copyright (root copyright) |
| 165 | "Set Emacs short copyright to COPYRIGHT in relevant files under ROOT. |
| 166 | Root must be the root of an Emacs source tree." |
| 167 | (interactive (list |
| 168 | (read-directory-name "Emacs root directory: " nil nil t) |
| 169 | (read-string |
| 170 | "Short copyright string: " |
| 171 | (format "Copyright (C) %s Free Software Foundation, Inc." |
| 172 | (format-time-string "%Y"))))) |
| 173 | (unless (file-exists-p (expand-file-name "src/emacs.c" root)) |
| 174 | (error "%s doesn't seem to be the root of an Emacs source tree" root)) |
| 175 | (set-version-in-file root "src/emacs.c" copyright |
| 176 | (rx (and "emacs_copyright" (0+ (not (in ?\"))) |
| 177 | ?\" (submatch (1+ (not (in ?\")))) ?\"))) |
| 178 | (set-version-in-file root "lib-src/ebrowse.c" copyright |
| 179 | (rx (and "emacs_copyright" (0+ (not (in ?\"))) |
| 180 | ?\" (submatch (1+ (not (in ?\")))) ?\"))) |
| 181 | (set-version-in-file root "lib-src/etags.c" copyright |
| 182 | (rx (and "emacs_copyright" (0+ (not (in ?\"))) |
| 183 | ?\" (submatch (1+ (not (in ?\")))) ?\"))) |
| 184 | (set-version-in-file root "lib-src/rcs2log" copyright |
| 185 | (rx (and "Copyright" (0+ space) ?= (0+ space) |
| 186 | ?\' (submatch (1+ nonl))))) |
| 187 | ;; This one is a nuisance, as it needs to be split over two lines. |
| 188 | (string-match "\\(.*[0-9]\\{4\\} *\\)\\(.*\\)" copyright) |
| 189 | ;; nextstep. |
| 190 | (set-version-in-file |
| 191 | root "nextstep/Cocoa/Emacs.base/Contents/Info.plist" |
| 192 | copyright (rx (and "CFBundleGetInfoString" (1+ anything) "Emacs" (1+ space) |
| 193 | (1+ (in "0-9.")) (1+ space) |
| 194 | (submatch (1+ (not (in ?\<))))))) |
| 195 | (set-version-in-file |
| 196 | root "nextstep/Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" |
| 197 | copyright (rx (and "NSHumanReadableCopyright" (0+ space) ?\= (0+ space) |
| 198 | ?\" (submatch (1+ (not (in ?\"))))))) |
| 199 | (set-version-in-file |
| 200 | root "nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist" |
| 201 | copyright (rx (and "Copyright" (0+ space) ?\= (0+ space) |
| 202 | ?\" (submatch (1+ (not (in ?\"))))))) |
| 203 | (when (string-match "\\([0-9]\\{4\\}\\)" copyright) |
| 204 | (setq copyright (match-string 1 copyright)) |
| 205 | (dolist (file (directory-files (expand-file-name "etc/refcards" root) |
| 206 | t "\\.tex\\'")) |
| 207 | (unless (string-match "gnus-refcard\\.tex" file) |
| 208 | (set-version-in-file |
| 209 | root file copyright |
| 210 | (concat (if (string-match "ru-refcard\\.tex" file) |
| 211 | "\\\\newcommand{\\\\cyear}\\[0\\]{" |
| 212 | "\\\\def\\\\year{") |
| 213 | "\\([0-9]\\{4\\}\\)}.+%.+copyright year")))))) |
| 214 | |
| 215 | ;;; Various bits of magic for generating the web manuals |
| 216 | |
| 217 | (defun make-manuals (root) |
| 218 | "Generate the web manuals for the Emacs webpage." |
| 219 | (interactive "DEmacs root directory: ") |
| 220 | (let* ((dest (expand-file-name "manual" root)) |
| 221 | (html-node-dir (expand-file-name "html_node" dest)) |
| 222 | (html-mono-dir (expand-file-name "html_mono" dest)) |
| 223 | (txt-dir (expand-file-name "text" dest)) |
| 224 | (dvi-dir (expand-file-name "dvi" dest)) |
| 225 | (ps-dir (expand-file-name "ps" dest))) |
| 226 | (when (file-directory-p dest) |
| 227 | (if (y-or-n-p (format "Directory %s exists, delete it first?" dest)) |
| 228 | (delete-directory dest t) |
| 229 | (error "Aborted"))) |
| 230 | (make-directory dest) |
| 231 | (make-directory html-node-dir) |
| 232 | (make-directory html-mono-dir) |
| 233 | (make-directory txt-dir) |
| 234 | (make-directory dvi-dir) |
| 235 | (make-directory ps-dir) |
| 236 | ;; Emacs manual |
| 237 | (let ((texi (expand-file-name "doc/emacs/emacs.texi" root))) |
| 238 | (manual-html-node texi (expand-file-name "emacs" html-node-dir)) |
| 239 | (manual-html-mono texi (expand-file-name "emacs.html" html-mono-dir)) |
| 240 | (manual-txt texi (expand-file-name "emacs.txt" txt-dir)) |
| 241 | (manual-pdf texi (expand-file-name "emacs.pdf" dest)) |
| 242 | (manual-dvi texi (expand-file-name "emacs.dvi" dvi-dir) |
| 243 | (expand-file-name "emacs.ps" ps-dir))) |
| 244 | ;; Lisp manual |
| 245 | (let ((texi (expand-file-name "doc/lispref/elisp.texi" root))) |
| 246 | (manual-html-node texi (expand-file-name "elisp" html-node-dir)) |
| 247 | (manual-html-mono texi (expand-file-name "elisp.html" html-mono-dir)) |
| 248 | (manual-txt texi (expand-file-name "elisp.txt" txt-dir)) |
| 249 | (manual-pdf texi (expand-file-name "elisp.pdf" dest)) |
| 250 | (manual-dvi texi (expand-file-name "elisp.dvi" dvi-dir) |
| 251 | (expand-file-name "elisp.ps" ps-dir))) |
| 252 | ;; Misc manuals |
| 253 | (let ((manuals '("ada-mode" "auth" "autotype" "calc" "cc-mode" |
| 254 | "cl" "dbus" "dired-x" "ebrowse" "ede" "ediff" |
| 255 | "edt" "eieio" "emacs-mime" "epa" "erc" "ert" |
| 256 | "eshell" "eudc" "faq" "flymake" "forms" |
| 257 | "gnus" "emacs-gnutls" "idlwave" "info" |
| 258 | "mairix-el" "message" "mh-e" "newsticker" |
| 259 | "nxml-mode" "org" "pcl-cvs" "pgg" "rcirc" |
| 260 | "remember" "reftex" "sasl" "sc" "semantic" |
| 261 | "ses" "sieve" "smtpmail" "speedbar" "tramp" |
| 262 | "url" "vip" "viper" "widget" "woman"))) |
| 263 | (dolist (manual manuals) |
| 264 | (manual-misc-html manual root html-node-dir html-mono-dir))) |
| 265 | (message "Manuals created in %s" dest))) |
| 266 | |
| 267 | (defconst manual-doctype-string |
| 268 | "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" |
| 269 | \"http://www.w3.org/TR/html4/loose.dtd\">\n\n") |
| 270 | |
| 271 | (defconst manual-meta-string |
| 272 | "<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\"> |
| 273 | <link rev=\"made\" href=\"mailto:webmasters@gnu.org\"> |
| 274 | <link rel=\"icon\" type=\"image/png\" href=\"/graphics/gnu-head-mini.png\"> |
| 275 | <meta name=\"ICBM\" content=\"42.256233,-71.006581\"> |
| 276 | <meta name=\"DC.title\" content=\"gnu.org\">\n\n") |
| 277 | |
| 278 | (defconst manual-style-string "<style type=\"text/css\"> |
| 279 | @import url('/style.css');\n</style>\n") |
| 280 | |
| 281 | (defun manual-misc-html (name root html-node-dir html-mono-dir) |
| 282 | (let ((texi (expand-file-name (format "doc/misc/%s.texi" name) root))) |
| 283 | (manual-html-node texi (expand-file-name name html-node-dir)) |
| 284 | (manual-html-mono texi (expand-file-name (concat name ".html") |
| 285 | html-mono-dir)))) |
| 286 | |
| 287 | (defun manual-html-mono (texi-file dest) |
| 288 | "Run Makeinfo on TEXI-FILE, emitting mono HTML output to DEST. |
| 289 | This function also edits the HTML files so that they validate as |
| 290 | HTML 4.01 Transitional, and pulls in the gnu.org stylesheet using |
| 291 | the @import directive." |
| 292 | (call-process "makeinfo" nil nil nil |
| 293 | "--html" "--no-split" texi-file "-o" dest) |
| 294 | (with-temp-buffer |
| 295 | (insert-file-contents dest) |
| 296 | (setq buffer-file-name dest) |
| 297 | (manual-html-fix-headers) |
| 298 | (manual-html-fix-index-1) |
| 299 | (manual-html-fix-index-2 t) |
| 300 | (manual-html-fix-node-div) |
| 301 | (goto-char (point-max)) |
| 302 | (re-search-backward "</body>[\n \t]*</html>") |
| 303 | (insert "</div>\n\n") |
| 304 | (save-buffer))) |
| 305 | |
| 306 | (defun manual-html-node (texi-file dir) |
| 307 | "Run Makeinfo on TEXI-FILE, emitting per-node HTML output to DIR. |
| 308 | This function also edits the HTML files so that they validate as |
| 309 | HTML 4.01 Transitional, and pulls in the gnu.org stylesheet using |
| 310 | the @import directive." |
| 311 | (unless (file-exists-p texi-file) |
| 312 | (error "Manual file %s not found" texi-file)) |
| 313 | (call-process "makeinfo" nil nil nil |
| 314 | "--html" texi-file "-o" dir) |
| 315 | ;; Loop through the node files, fixing them up. |
| 316 | (dolist (f (directory-files dir nil "\\.html\\'")) |
| 317 | (let (opoint) |
| 318 | (with-temp-buffer |
| 319 | (insert-file-contents (expand-file-name f dir)) |
| 320 | (setq buffer-file-name (expand-file-name f dir)) |
| 321 | (if (looking-at "<meta http-equiv") |
| 322 | ;; Ignore those HTML files that are just redirects. |
| 323 | (set-buffer-modified-p nil) |
| 324 | (manual-html-fix-headers) |
| 325 | (if (equal f "index.html") |
| 326 | (let (copyright-text) |
| 327 | (manual-html-fix-index-1) |
| 328 | ;; Move copyright notice to the end. |
| 329 | (when (re-search-forward "[ \t]*<p>Copyright ©" nil t) |
| 330 | (setq opoint (match-beginning 0)) |
| 331 | (re-search-forward "</blockquote>") |
| 332 | (setq copyright-text (buffer-substring opoint (point))) |
| 333 | (delete-region opoint (point))) |
| 334 | (manual-html-fix-index-2) |
| 335 | (if copyright-text |
| 336 | (insert copyright-text)) |
| 337 | (insert "\n</div>\n")) |
| 338 | ;; For normal nodes, give the header div a blue bg. |
| 339 | (manual-html-fix-node-div)) |
| 340 | (save-buffer)))))) |
| 341 | |
| 342 | (defun manual-txt (texi-file dest) |
| 343 | "Run Makeinfo on TEXI-FILE, emitting plaintext output to DEST." |
| 344 | (call-process "makeinfo" nil nil nil |
| 345 | "--plaintext" "--no-split" texi-file "-o" dest) |
| 346 | (shell-command (concat "gzip -c " dest " > " (concat dest ".gz")))) |
| 347 | |
| 348 | (defun manual-pdf (texi-file dest) |
| 349 | "Run texi2pdf on TEXI-FILE, emitting plaintext output to DEST." |
| 350 | (call-process "texi2pdf" nil nil nil texi-file "-o" dest)) |
| 351 | |
| 352 | (defun manual-dvi (texi-file dest ps-dest) |
| 353 | "Run texi2dvi on TEXI-FILE, emitting dvi output to DEST. |
| 354 | Also generate PostScript output in PS-DEST." |
| 355 | (call-process "texi2dvi" nil nil nil texi-file "-o" dest) |
| 356 | (call-process "dvips" nil nil nil dest "-o" ps-dest) |
| 357 | (call-process "gzip" nil nil nil dest) |
| 358 | (call-process "gzip" nil nil nil ps-dest)) |
| 359 | |
| 360 | (defun manual-html-fix-headers () |
| 361 | "Fix up HTML headers for the Emacs manual in the current buffer." |
| 362 | (let (opoint) |
| 363 | (insert manual-doctype-string) |
| 364 | (search-forward "<head>\n") |
| 365 | (insert manual-meta-string) |
| 366 | (search-forward "<meta") |
| 367 | (setq opoint (match-beginning 0)) |
| 368 | (re-search-forward "<!--") |
| 369 | (goto-char (match-beginning 0)) |
| 370 | (delete-region opoint (point)) |
| 371 | (insert manual-style-string) |
| 372 | (search-forward "<meta http-equiv=\"Content-Style") |
| 373 | (setq opoint (match-beginning 0)) |
| 374 | (search-forward "</head>") |
| 375 | (delete-region opoint (match-beginning 0)))) |
| 376 | |
| 377 | (defun manual-html-fix-node-div () |
| 378 | "Fix up HTML \"node\" divs in the current buffer." |
| 379 | (let (opoint div-end) |
| 380 | (while (search-forward "<div class=\"node\">" nil t) |
| 381 | (replace-match |
| 382 | "<div class=\"node\" style=\"background-color:#DDDDFF\">" |
| 383 | t t) |
| 384 | (setq opoint (point)) |
| 385 | (re-search-forward "</div>") |
| 386 | (setq div-end (match-beginning 0)) |
| 387 | (goto-char opoint) |
| 388 | (if (search-forward "<hr>" div-end 'move) |
| 389 | (replace-match "" t t))))) |
| 390 | |
| 391 | (defun manual-html-fix-index-1 () |
| 392 | (let (opoint) |
| 393 | (re-search-forward "<body>\n") |
| 394 | (setq opoint (match-end 0)) |
| 395 | (search-forward "<h2 class=\"") |
| 396 | (goto-char (match-beginning 0)) |
| 397 | (delete-region opoint (point)) |
| 398 | (insert "<div id=\"content\" class=\"inner\">\n\n"))) |
| 399 | |
| 400 | (defun manual-html-fix-index-2 (&optional table-workaround) |
| 401 | "Replace the index list in the current buffer with a HTML table." |
| 402 | (let (done open-td tag desc) |
| 403 | ;; Convert the list that Makeinfo made into a table. |
| 404 | (or (search-forward "<ul class=\"menu\">" nil t) |
| 405 | (search-forward "<ul>")) |
| 406 | (replace-match "<table style=\"float:left\" width=\"100%\">") |
| 407 | (forward-line 1) |
| 408 | (while (not done) |
| 409 | (cond |
| 410 | ((or (looking-at "<li>\\(<a.+</a>\\):[ \t]+\\(.*\\)$") |
| 411 | (looking-at "<li>\\(<a.+</a>\\)$")) |
| 412 | (setq tag (match-string 1)) |
| 413 | (setq desc (match-string 2)) |
| 414 | (replace-match "" t t) |
| 415 | (when open-td |
| 416 | (save-excursion |
| 417 | (forward-char -1) |
| 418 | (skip-chars-backward " ") |
| 419 | (delete-region (point) (line-end-position)) |
| 420 | (insert "</td>\n </tr>"))) |
| 421 | (insert " <tr>\n ") |
| 422 | (if table-workaround |
| 423 | ;; This works around a Firefox bug in the mono file. |
| 424 | (insert "<td bgcolor=\"white\">") |
| 425 | (insert "<td>")) |
| 426 | (insert tag "</td>\n <td>" (or desc "")) |
| 427 | (setq open-td t)) |
| 428 | ((eq (char-after) ?\n) |
| 429 | (delete-char 1) |
| 430 | ;; Negate the following `forward-line'. |
| 431 | (forward-line -1)) |
| 432 | ((looking-at "<!-- ") |
| 433 | (search-forward "-->")) |
| 434 | ((looking-at "<p>[- ]*The Detailed Node Listing[- \n]*") |
| 435 | (replace-match " </td></tr></table>\n |
| 436 | <h3>Detailed Node Listing</h3>\n\n" t t) |
| 437 | (search-forward "<p>") |
| 438 | (search-forward "<p>" nil t) |
| 439 | (goto-char (match-beginning 0)) |
| 440 | (skip-chars-backward "\n ") |
| 441 | (setq open-td nil) |
| 442 | (insert "</p>\n\n<table style=\"float:left\" width=\"100%\">")) |
| 443 | ((looking-at "</li></ul>") |
| 444 | (replace-match "" t t)) |
| 445 | ((looking-at "<p>") |
| 446 | (replace-match "" t t) |
| 447 | (when open-td |
| 448 | (insert " </td></tr>") |
| 449 | (setq open-td nil)) |
| 450 | (insert " <tr> |
| 451 | <th colspan=\"2\" align=\"left\" style=\"text-align:left\">") |
| 452 | (if (re-search-forward "</p>[ \t\n]*<ul class=\"menu\">" nil t) |
| 453 | (replace-match " </th></tr>"))) |
| 454 | ((looking-at "[ \t]*</ul>[ \t]*$") |
| 455 | (replace-match |
| 456 | (if open-td |
| 457 | " </td></tr>\n</table>" |
| 458 | "</table>") t t) |
| 459 | (setq done t)) |
| 460 | (t |
| 461 | (if (eobp) |
| 462 | (error "Parse error in %s" f)) |
| 463 | (unless open-td |
| 464 | (setq done t)))) |
| 465 | (forward-line 1)))) |
| 466 | |
| 467 | \f |
| 468 | ;; Stuff to check new defcustoms got :version tags. |
| 469 | ;; Adapted from check-declare.el. |
| 470 | |
| 471 | (defun cusver-find-files (root &optional old) |
| 472 | "Find .el files beneath directory ROOT that contain defcustoms. |
| 473 | If optional OLD is non-nil, also include defvars." |
| 474 | (process-lines find-program root |
| 475 | "-name" "*.el" |
| 476 | "-exec" grep-program |
| 477 | "-l" "-E" (format "^[ \\t]*\\(def%s" |
| 478 | (if old "(custom|var)" |
| 479 | "custom" |
| 480 | )) |
| 481 | "{}" "+")) |
| 482 | |
| 483 | ;; TODO if a defgroup with a version tag, apply to all customs in that |
| 484 | ;; group (eg for new files). |
| 485 | (defun cusver-scan (file &optional old) |
| 486 | "Scan FILE for `defcustom' calls. |
| 487 | Return a list with elements of the form (VAR . VER), |
| 488 | This means that FILE contains a defcustom for variable VAR, with |
| 489 | a :version tag having value VER (may be nil). |
| 490 | If optional argument OLD is non-nil, also scan for defvars." |
| 491 | (let ((m (format "Scanning %s..." file)) |
| 492 | (re (format "^[ \t]*\\((def%s\\)[ \t\n]" |
| 493 | (if old "\\(?:custom\\|var\\)" "custom"))) |
| 494 | alist var ver) |
| 495 | (message "%s" m) |
| 496 | (with-temp-buffer |
| 497 | (insert-file-contents file) |
| 498 | ;; FIXME we could theoretically be inside a string. |
| 499 | (while (re-search-forward re nil t) |
| 500 | (goto-char (match-beginning 1)) |
| 501 | (if (and (setq form (ignore-errors (read (current-buffer)))) |
| 502 | (setq var (car-safe (cdr-safe form))) |
| 503 | ;; Exclude macros, eg (defcustom ,varname ...). |
| 504 | (symbolp var)) |
| 505 | (setq ver (car (cdr-safe (memq :version form))) |
| 506 | alist (cons (cons var ver) alist)) |
| 507 | (if form (message "Malformed defcustom: `%s'" form))))) |
| 508 | (message "%sdone" m) |
| 509 | alist)) |
| 510 | |
| 511 | (define-button-type 'cusver-xref 'action #'cusver-goto-xref) |
| 512 | |
| 513 | (defun cusver-goto-xref (button) |
| 514 | "Jump to a lisp file for the BUTTON at point." |
| 515 | (let ((file (button-get button 'file)) |
| 516 | (var (button-get button 'var))) |
| 517 | (if (not (file-readable-p file)) |
| 518 | (message "Cannot read `%s'" file) |
| 519 | (with-current-buffer (find-file-noselect file) |
| 520 | (goto-char (point-min)) |
| 521 | (or (re-search-forward (format "^[ \t]*(defcustom[ \t]*%s" var) nil t) |
| 522 | (message "Unable to locate defcustom")) |
| 523 | (pop-to-buffer (current-buffer)))))) |
| 524 | |
| 525 | ;; You should probably at least do a grep over the old directory |
| 526 | ;; to check the results of this look sensible. Eg cus-start if |
| 527 | ;; something moved from C to Lisp. |
| 528 | ;; TODO handle renamed things with aliases to the old names. |
| 529 | ;; What to do about new files? Does everything in there need a :version, |
| 530 | ;; or eg just the defgroup? |
| 531 | (defun cusver-check (newdir olddir) |
| 532 | "Check that defcustoms have :version tags where needed. |
| 533 | NEWDIR is the current lisp/ directory, OLDDIR is that from the previous |
| 534 | release. A defcustom that is only in NEWDIR should have a :version |
| 535 | tag. We exclude cases where a defvar exists in OLDDIR, since |
| 536 | just converting a defvar to a defcustom does not require a :version bump. |
| 537 | |
| 538 | Note that a :version tag should also be added if the value of a defcustom |
| 539 | changes (in a non-trivial way). This function does not check for that." |
| 540 | (interactive "DNew Lisp directory: \nDOld Lisp directory: ") |
| 541 | (or (file-directory-p (setq newdir (expand-file-name newdir))) |
| 542 | (error "Directory `%s' not found" newdir)) |
| 543 | (or (file-directory-p (setq olddir (expand-file-name olddir))) |
| 544 | (error "Directory `%s' not found" olddir)) |
| 545 | (let* ((newfiles (progn (message "Finding new files with defcustoms...") |
| 546 | (cusver-find-files newdir))) |
| 547 | (oldfiles (progn (message "Finding old files with defcustoms...") |
| 548 | (cusver-find-files olddir t))) |
| 549 | (newcus (progn (message "Reading new defcustoms...") |
| 550 | (mapcar |
| 551 | (lambda (file) |
| 552 | (cons file (cusver-scan file))) newfiles))) |
| 553 | oldcus result thisfile) |
| 554 | (message "Reading old defcustoms...") |
| 555 | (dolist (file oldfiles) |
| 556 | (setq oldcus (append oldcus (cusver-scan file t)))) |
| 557 | ;; newcus has elements (FILE (VAR VER) ... ). |
| 558 | ;; oldcus just (VAR . VER). |
| 559 | (message "Checking for version tags...") |
| 560 | (dolist (new newcus) |
| 561 | (setq file (car new) |
| 562 | thisfile |
| 563 | (let (missing var) |
| 564 | (dolist (cons (cdr new)) |
| 565 | (or (cdr cons) |
| 566 | (assq (setq var (car cons)) oldcus) |
| 567 | (push var missing))) |
| 568 | (if missing |
| 569 | (cons file missing)))) |
| 570 | (if thisfile |
| 571 | (setq result (cons thisfile result)))) |
| 572 | (message "Checking for version tags... done") |
| 573 | (if (not result) |
| 574 | (message "No missing :version tags") |
| 575 | (pop-to-buffer "*cusver*") |
| 576 | (erase-buffer) |
| 577 | (insert "These defcustoms might be missing :version tags:\n\n") |
| 578 | (dolist (elem result) |
| 579 | (let* ((str (file-relative-name (car elem) newdir)) |
| 580 | (strlen (length str))) |
| 581 | (dolist (var (cdr elem)) |
| 582 | (insert (format "%s: %s\n" str var)) |
| 583 | (make-text-button (+ (line-beginning-position 0) strlen 2) |
| 584 | (line-end-position 0) |
| 585 | 'file (car elem) |
| 586 | 'var var |
| 587 | 'help-echo "Mouse-2: visit this definition" |
| 588 | :type 'cusver-xref))))))) |
| 589 | |
| 590 | (provide 'admin) |
| 591 | |
| 592 | ;;; admin.el ends here |