[Add a few new site-lisp file clinton@unknownlamer.org**20090917201022 Ignore-this: 3b477c0c7aac513adf0fd36698d715cc ] { addfile ./site-lisp/apt-utils.el hunk ./site-lisp/apt-utils.el 1 +;;; apt-utils.el --- Emacs interface to APT (Debian package management) + +;;; Copyright (C) 2002, 2003, 2004, 2005 Matthew P. Hodges + +;; Author: Matthew P. Hodges +;; $Id: apt-utils.el,v 1.207 2006/09/03 12:45:42 mphodges-guest Exp $ + +;; apt-utils.el is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; apt-utils.el is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;;; Commentary: +;; +;; Package to interface Emacs with APT. Start things off using e.g.: +;; M-x apt-utils-show-package RET emacs21 RET +;; +;; Other packages (dependencies, conflicts etc.) can be navigated +;; using apt-utils-{next,previous}-package, +;; apt-utils-choose-package-link or apt-utils-follow-link. Return to +;; the previous package with apt-utils-view-previous-package. +;; ChangeLog and README files for the current package can easily be +;; accessed with, for example, apt-utils-view-changelog. +;; +;; For normal (i.e., not virtual) packages, the information can be +;; toggled between `package' and `showpkg' displays using +;; apt-utils-toggle-package-info; the latter is useful for the +;; "Reverse Depends". +;; +;; View the key bindings with describe-mode (bound to ? by default). + +;;; Code: + +(defconst apt-utils-version "2.8.0" + "Version number of this package.") + +(require 'browse-url) +(require 'jka-compr) + +(cond + ((fboundp 'puthash) + (defalias 'apt-utils-puthash 'puthash)) + ((and (require 'cl) + (fboundp 'cl-puthash)) + (defalias 'apt-utils-puthash 'cl-puthash)) + (t + (error "No puthash function known"))) + +;; Customizable variables + +(defgroup apt-utils nil + "Emacs interface to APT (Debian package management)." + :group 'tools + :link '(url-link "http://mph-emacs-pkgs.alioth.debian.org/AptUtilsEl.html")) + +(defcustom apt-utils-fill-packages t + "*Fill APT package names if t." + :group 'apt-utils + :type 'boolean) + +(defcustom apt-utils-show-link-info t + "*Show APT package descriptions when cycling through links if t." + :group 'apt-utils + :type 'boolean) + +(defcustom apt-utils-show-all-versions nil + "*Show APT descriptions for multiple package versions if t." + :group 'apt-utils + :type 'boolean) + +(defcustom apt-utils-automatic-update 'ask + "*Controls automatic rebuilding of APT package lists. + +If t always rebuilt when `apt-utils-timestamped-file' is newer +than the timestamp stored in `apt-utils-package-list-built'. If +equal to the symbol ask, ask the user about the update. If nil, +never update automatically." + :group 'apt-utils + :type '(choice (const :tag "Always update automatically" t) + (const :tag "Ask user about update" ask) + (const :tag "Never update automatically" nil))) + +(defcustom apt-utils-grep-dctrl-args '("-e") + "*List of arguments to pass to `apt-utils-grep-dctrl-program'." + :group 'apt-utils + :type '(repeat string)) + +(defcustom apt-utils-kill-buffer-confirmation-function 'yes-or-no-p + "Function called before killing any buffers. +The function is called with one argument, which is a prompt. +Suitable non-nil values include `yes-or-no-p', `y-or-n-p' and +`ignore'." + :group 'apt-utils + :type '(choice (const :tag "Kill buffers only after yes or no query" yes-or-no-p) + (const :tag "Kill buffers only after y or n query" y-or-n-p) + (const :tag "Never kill buffers" ignore) + (const :tag "Kill buffers without confirmation" nil))) + +(defcustom apt-utils-search-split-regexp "\\s-*&&\\s-*" + "Regular expression used to split multiple search terms. +See `apt-utils-search' and `apt-utils-search-names-only'." + :group 'apt-utils + :type 'regexp) + +(defcustom apt-utils-web-browse-debian-changelog-url + "http://packages.debian.org/changelogs/pool/main/%d/%s/%s_%v/changelog" + "Template URL for Debian ChangeLog files. +See `apt-utils-web-format-url'." + :group 'apt-utils + :type 'string) + +(defcustom apt-utils-web-browse-bug-reports-url + "http://bugs.debian.org/%p" + "Template URL for Debian bug reports. +See `apt-utils-web-format-url'." + :group 'apt-utils + :type 'string) + +(defcustom apt-utils-web-browse-copyright-url + "http://packages.debian.org/changelogs/pool/main/%d/%s/%s_%v/%p.copyright" + "Template URL for Debian copyright files. +See `apt-utils-web-format-url'." + :group 'apt-utils + :type 'string) + +(defcustom apt-utils-web-browse-versions-url + "http://packages.debian.org/%p" + "Template URL for Debian version information. +See `apt-utils-web-format-url'." + :group 'apt-utils + :type 'string) + +(defcustom apt-utils-show-package-hooks nil + "Hooks to be run after presenting package information." + :group 'apt-utils + :type 'hook) + +(defcustom apt-utils-use-current-window nil + "If non-nil always display APT utils buffers in the current window. +In this case `switch-to-buffer' is used to select the APT utils +buffer. If nil, `display-buffer' is used, and the precise +behaviour depends on the value of `pop-up-windows'." + :group 'apt-utils + :type 'boolean) + +(defcustom apt-utils-dpkg-program "/usr/bin/dpkg" + "Location of the dpkg program. +This can be set to dlocate, which has the advantage of better +performance, but uses cached data that may be out of date." + :group 'apt-utils + :type '(choice (const :tag "dpkg" "/usr/bin/dpkg") + (const : tag "dlocate" "/usr/bin/dlocate") + (file :must-match t))) + +(defcustom apt-utils-display-installed-status t + "If non-nil display the installed status of the current package." + :group 'apt-utils + :type 'boolean) + +;; Faces + +(defface apt-utils-normal-package-face + '((((class color) (background light)) + (:foreground "blue")) + (((class color) (background dark)) + (:foreground "yellow"))) + "Face used for APT normal package hyperlinks." + :group 'apt-utils) + +(defface apt-utils-virtual-package-face + '((((class color) (background light)) + (:foreground "green4")) + (((class color) (background dark)) + (:foreground "green"))) + "Face used for APT virtual package hyperlinks." + :group 'apt-utils) + +(defface apt-utils-field-keyword-face + '((((class color) (background light)) + (:foreground "purple" :bold t)) + (((class color) (background dark)) + (:foreground "purple" :bold t))) + "Face used for APT field keywords." + :group 'apt-utils) + +(defface apt-utils-field-contents-face + '((((class color) (background light)) + (:foreground "orchid")) + (((class color) (background dark)) + (:foreground "orange"))) + "Face used for APT field contents." + :group 'apt-utils) + +(defface apt-utils-description-face + '((((class color)) + (:foreground "cadet blue"))) + "Face used for APT package description." + :group 'apt-utils) + +(defface apt-utils-version-face + '((((class color)) + (:italic t))) + "Face used for APT package versions." + :group 'apt-utils) + +(defface apt-utils-broken-face + '((((class color)) + (:foreground "red"))) + "Face used for unknown APT package." + :group 'apt-utils) + +(defface apt-utils-file-face + '((((class color)) + (:foreground "brown"))) + "Face used for files." + :group 'apt-utils) + +(defface apt-utils-installed-status-face + '((((class color)) + (:italic t))) + "Face used for installed status." + :group 'apt-utils) + +;; Other variables + +(defvar apt-utils-apt-cache-program "/usr/bin/apt-cache" + "Location of the apt-cache program.") + +(defvar apt-utils-grep-dctrl-program "/usr/bin/grep-dctrl" + "Location of the grep-dctrl program.") + +(defvar apt-utils-grep-dctrl-file-directory "/var/lib/apt/lists" + "Directory used by `apt-utils-search-grep-dctrl'. +See also `apt-utils-grep-dctrl-file-list'.") + +(defvar apt-utils-grep-dctrl-file-list nil + "List of files searched by `apt-utils-search-grep-dctrl'. +If no list is specified, this is computed on demand from files in +`apt-utils-grep-dctrl-file-directory'.") + +(defvar apt-utils-package-list nil + "Hash table containing APT packages types.") + +(defvar apt-utils-package-list-built nil + "If non-nil, a timestamp for the APT package list data.") + +(defvar apt-utils-package-history nil + "History of packages for each `apt-utils-mode' buffer.") +(make-variable-buffer-local 'apt-utils-package-history) + +(defvar apt-utils-current-links nil + "Package links associated with the `apt-utils-mode' buffer.") +(make-variable-buffer-local 'apt-utils-current-links) + +(defvar apt-utils-buffer-positions nil + "Cache of positions associated with package history. +These are stored in a hash table. See also +`apt-utils-package-history'") +(make-variable-buffer-local 'apt-utils-buffer-positions) + +(defvar apt-utils-dired-buffer nil + "Keep track of dired buffer.") + +(defvar apt-utils-automatic-update-asked nil + "Non-nil if user already asked about updating package lists.") + +(defvar apt-utils-timestamped-file "/var/cache/apt/pkgcache.bin" + "File to check timestamp of (see `apt-utils-automatic-update').") + +;; XEmacs support + +(defconst apt-utils-xemacs-p + (or (featurep 'xemacs) + (string-match "XEmacs\\|Lucid" (emacs-version))) + "True if we are using apt-utils under XEmacs.") + +;; Other version-dependent configuration + +(defalias 'apt-utils-line-end-position + (cond + ((fboundp 'line-end-position) 'line-end-position) + ((fboundp 'point-at-eol) 'point-at-eol))) + +(defalias 'apt-utils-line-beginning-position + (cond + ((fboundp 'line-beginning-position) 'line-beginning-position) + ((fboundp 'point-at-bol) 'point-at-bol))) + +(defconst apt-utils-completing-read-hashtable-p + ;; I think this is a valid way to check this feature... + (condition-case nil + (or (all-completions "" (make-hash-table)) t) + (error nil)) + "Non-nil if `completing-read' supports hash table as input.") + +(defconst apt-utils-face-property + (if (with-temp-buffer + ;; We have to rename to something without a leading space, + ;; otherwise font-lock-mode won't get activated. + (rename-buffer "*test-font-lock*") + (font-lock-mode 1) + (and (boundp 'char-property-alias-alist) + (member 'font-lock-face + (assoc 'face char-property-alias-alist)))) + 'font-lock-face + 'face) + "Use font-lock-face if `add-text-properties' supports it. +Otherwise, just use face.") + +(cond + ;; Emacs 21 + ((fboundp 'replace-regexp-in-string) + (defalias 'apt-utils-replace-regexp-in-string 'replace-regexp-in-string)) + ;; Emacs 20 + ((and (require 'dired) + (fboundp 'dired-replace-in-string)) + (defalias 'apt-utils-replace-regexp-in-string 'dired-replace-in-string)) + ;; XEmacs + ((fboundp 'replace-in-string) + (defun apt-utils-replace-regexp-in-string (regexp rep string) + (replace-in-string string regexp rep))) + ;; Bail out + (t + (error "No replace in string function found"))) + +;; Commands and functions + +;;;###autoload +(defun apt-utils-show-package (&optional new-session) + "Show information for a Debian package. +A selection of known packages is presented. See `apt-utils-mode' +for more detailed help. If NEW-SESSION is non-nil, generate a +new `apt-utils-mode' buffer." + (interactive "P") + (apt-utils-check-package-lists) + (let ((package (apt-utils-choose-package))) + (when (> (length package) 0) + (apt-utils-show-package-1 package t new-session)))) + +(defun apt-utils-show-package-1 (package-spec &optional interactive new-session) + "Present Debian package information in a dedicated buffer. + +PACKAGE-SPEC can be either a string (the name of the package) or +a list, where the car of the list is the name of the package, and +the cdr is the package type. + +If INTERACTIVE is non-nil, then we have been called +interactively (or from a keyboard macro) via +`apt-utils-show-package'. Hence, reset the history of visited +packages. + +If NEW-SESSION is non-nil, generate a new `apt-utils-mode' +buffer." + (apt-utils-check-package-lists) + (let (package type) + (cond ((and package-spec (listp package-spec)) + (setq package (car package-spec)) + (setq type (cdr package-spec))) + ((stringp package-spec) + (setq package package-spec + type (apt-utils-package-type package)))) + ;; Set up the buffer + (cond + (new-session + (set-buffer (generate-new-buffer "*APT package info*")) + (apt-utils-mode) + (apt-utils-update-mode-name)) + ((eq major-mode 'apt-utils-mode) + ;; do nothing + ) + (t + (set-buffer (get-buffer-create "*APT package info*")) + (apt-utils-mode))) + ;; If called interactively, initialize apt-utils-package-history + (when (or interactive new-session) + (setq apt-utils-package-history (cons (cons package type) nil)) + (if (hash-table-p apt-utils-buffer-positions) + (clrhash apt-utils-buffer-positions) + (setq apt-utils-buffer-positions (make-hash-table :test 'equal)))) + (let ((inhibit-read-only t)) + (erase-buffer) + (cond + ((equal type 'normal) + (call-process apt-utils-apt-cache-program nil '(t nil) nil "show" package) + ;; Remove old versions if not wanted + (unless apt-utils-show-all-versions + (goto-char (point-min)) + (re-search-forward "^$") + (unless (eobp) + (delete-region (point) (point-max)))) + (apt-utils-add-package-links)) + ;; Virtual package or normal package w/ showpkg + ((memq type '(virtual normal-showpkg)) + (call-process apt-utils-apt-cache-program nil '(t nil) nil "showpkg" package) + (apt-utils-add-showpkg-links package)) + ;; Normal search + ((equal type 'search) + (insert (format "Debian package search for %s\n\n" package)) + (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil + "search" "--" + (split-string package apt-utils-search-split-regexp)) + (apt-utils-add-search-links 'search)) + ;; Search for names only + ((equal type 'search-names-only) + (insert (format "Debian package search (names only) for %s\n\n" package)) + (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil + "search" "--names-only" "--" + (split-string package apt-utils-search-split-regexp)) + (apt-utils-add-search-links 'search-names-only)) + ;; Search for file names + ((equal type 'search-file-names) + (insert (format "Debian package search (file names) for %s\n\n" package)) + (apply 'call-process apt-utils-dpkg-program nil t nil + "-S" (list package)) + (apt-utils-add-search-links 'search-file-names)) + ;; grep-dctrl search + ((equal type 'search-grep-dctrl) + (insert (format "grep-dctrl search for %s\n\n" + (concat (format "\"%s\" " (car package)) + (mapconcat 'identity (cdr package) " ")))) + (apply 'call-process apt-utils-grep-dctrl-program nil t nil package) + (apt-utils-add-package-links))) + (if apt-utils-use-current-window + (switch-to-buffer (current-buffer)) + (select-window (display-buffer (current-buffer)))) + ;; Point only needs setting for new sessions or when choosing + ;; new packages with apt-utils-follow-link or + ;; apt-utils-choose-package-link. + (goto-char (point-min)) + (run-hooks 'apt-utils-show-package-hooks))) + (set-buffer-modified-p nil) + (setq buffer-read-only t)) + +(defun apt-utils-list-package-files () + "List the files associated with the current package. +The list appears in a `dired-mode' buffer. Only works for +installed packages; uses `apt-utils-dpkg-program'." + (interactive) + (let ((package (caar apt-utils-package-history)) + (type (cdar apt-utils-package-history)) + files) + (setq files (apt-utils-get-package-files package)) + ;; Some meta packages contain only directories, so + ;; apt-utils-get-package-files returns '("/."); however, we don't + ;; want to list /. + (when (equal files '("/.")) + (setq files nil)) + (cond + ((memq type '(normal normal-showpkg)) + (if files + (progn + ;; Some versions of Emacs won't update dired for the same + ;; directory name if it already exists + (if (buffer-live-p apt-utils-dired-buffer) + (kill-buffer apt-utils-dired-buffer)) + (setq apt-utils-dired-buffer (dired-noselect files)) + (display-buffer apt-utils-dired-buffer)) + (message "Package does not contain any files/is not installed."))) + (t + (message "No files associated for type: %s." type))))) + +(defalias 'apt-utils-view-package-files 'apt-utils-list-package-files) + +(defun apt-utils-get-package-files (package &optional filter installed) + "Return a list of files belonging to package PACKAGE. +With optional argument FILTER, return files matching this regular +expression. + +With non-nil INSTALLED, return t if package is installed, +otherwise nil." + (let (files) + (catch 'installed + (with-temp-buffer + (call-process apt-utils-dpkg-program nil t nil "-L" package) + ;; Check for files + (cond + ((or (search-backward "does not contain any files" nil t) + (search-backward "not installed" nil t) + ;; dlocate returns nothing for uninstalled packages + (or (zerop (buffer-size)))) + (when installed + (throw 'installed nil))) + (installed + (throw 'installed t)) + (t + (setq files (split-string (buffer-string) "\n")) + ;; Keep regular files or top directory (for dired) + (setq files + (delq nil + (mapcar (lambda (elt) + (if (and (or (file-regular-p elt) + (string-equal "/." elt)) + (string-match (or filter ".") elt)) + elt + nil)) + files)))))) + files))) + +(defun apt-utils-current-package-installed-p () + "Return non-nil if the current-package is installed." + (apt-utils-get-package-files (caar apt-utils-package-history) nil t)) + +;;;###autoload +(defun apt-utils-search () + "Search Debian packages for regular expression. +To search for multiple patterns use a string like \"foo && bar\". +The regular expression used to split the +terms (`apt-utils-search-split-regexp') is customisable." + (interactive) + (apt-utils-search-internal 'search + "Search packages for regexp: ")) + +(defun apt-utils-search-names-only () + "Search Debian package names for regular expression. +To search for multiple patterns use a string like \"foo && bar\". +The regular expression used to split the +terms (`apt-utils-search-split-regexp') is customisable." + (interactive) + (apt-utils-search-internal 'search-names-only + "Search package names for regexp: ")) + +(defun apt-utils-search-file-names () + "Search Debian file names for string." + (interactive) + (apt-utils-search-internal 'search-file-names + "Search file names for string: ")) + +(defun apt-utils-search-internal (type prompt) + "Search Debian packages for regular expression or string. +The type of search is specified by TYPE, the prompt for the +search is specified by PROMPT." + (apt-utils-check-package-lists) + (let ((regexp (read-from-minibuffer prompt))) + ;; Set up the buffer + (cond + ((eq major-mode 'apt-utils-mode) + ;; do nothing + ) + (t + (set-buffer (get-buffer-create "*APT package info*")) + (apt-utils-mode))) + (let ((inhibit-read-only t) + result) + (erase-buffer) + ;; Can't search for string starting with "-" because the "--" + ;; option isn't understood by dpkg or dlocate + (when (and (eq type 'search-file-names) + (string-match "^-" regexp)) + (setq regexp (apt-utils-replace-regexp-in-string "^-+" "" regexp))) + (insert (format "Debian package search%s for %s\n\n" + (cond ((eq type 'search-names-only) " (names only)") + ((eq type 'search-file-names) " (file names)") + (t "")) + regexp)) + (setq result + (cond + ((eq type 'search) + (setq apt-utils-package-history (cons (cons regexp 'search) nil)) + (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil + "search" "--" + (split-string regexp apt-utils-search-split-regexp))) + ((eq type 'search-names-only) + (setq apt-utils-package-history (cons (cons regexp 'search-names-only) nil)) + (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil + "search" "--names-only" "--" + (split-string regexp apt-utils-search-split-regexp))) + + ((eq type 'search-file-names) + (setq apt-utils-package-history (cons (cons regexp 'search-file-names) nil)) + (apply 'call-process apt-utils-dpkg-program nil t nil + "-S" (list regexp))))) + (if (hash-table-p apt-utils-buffer-positions) + (clrhash apt-utils-buffer-positions) + (setq apt-utils-buffer-positions (make-hash-table :test 'equal))) + (if (eq result 0) + (apt-utils-add-search-links type) + (if (hash-table-p apt-utils-current-links) + (clrhash apt-utils-current-links))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (display-buffer (current-buffer))))) + +(defun apt-utils-search-grep-dctrl () + "Search Debian packages for regular expression using grep-dctrl." + (interactive) + (apt-utils-check-package-lists) + (let (args + (fields (apt-utils-read-fields "Search package fields: ")) + (show (apt-utils-read-fields "Show package fields: ")) + (regexp (read-from-minibuffer "Search regexp: "))) + ;; Check args + (cond + ((equal (length fields) 0) + (error "No fields selected for search")) + ((equal (length show) 0) + (error "No fields selected for show")) + ((equal (length regexp) 0) + (error "No regexp selected"))) + (setq fields (concat "-F" fields)) + (setq show (concat "-s" show)) + (cond + ((eq major-mode 'apt-utils-mode) + ;; do nothing + ) + (t + (set-buffer (get-buffer-create "*APT package info*")) + (apt-utils-mode))) + (let ((inhibit-read-only t) + result) + (erase-buffer) + ;; Construct argument list (need to keep this) + (setq args (append (list regexp fields show) apt-utils-grep-dctrl-args + (or apt-utils-grep-dctrl-file-list + (directory-files apt-utils-grep-dctrl-file-directory + t "_Packages")))) + (insert (format "grep-dctrl search for %s\n\n" + (mapconcat + (lambda (elt) + (if (string-equal regexp elt) + (format "\"%s\"" regexp) + elt)) + args " "))) + (setq result + (apply 'call-process + apt-utils-grep-dctrl-program nil t nil args)) + (setq apt-utils-package-history (cons (cons args 'search-grep-dctrl) nil)) + (if (hash-table-p apt-utils-buffer-positions) + (clrhash apt-utils-buffer-positions) + (setq apt-utils-buffer-positions (make-hash-table :test 'equal))) + (if (eq result 0) + (apt-utils-add-package-links) + (if (hash-table-p apt-utils-current-links) + (clrhash apt-utils-current-links))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (display-buffer (current-buffer))))) + +(defun apt-utils-read-fields (prompt) + "Read fields for `apt-utils-search-grep-dctrl'. +Use PROMPT for `completing-read'." + (let ((chosen "foo") + (completion-ignore-case t) + ;; Why can't I use '(...) for the list? + (keywords (list "Architecture" "Bugs" "Conffiles" "Conflicts" + "Depends" "Description" "Enhances" "Essential" + "Filename" "Installed-Size" "MD5sum" "Maintainer" + "Origin" "Package" "Pre-Depends" "Priority" + "Provides" "Recommends" "Replaces" "Section" + "Size" "Source" "Suggests" "Tag" "Task" "Version" + "url")) + fields) + (while (> (length chosen) 0) + (setq chosen + (completing-read prompt + (mapcar (lambda (elt) + (list elt elt)) + keywords) + nil + t)) + (setq keywords (delete chosen keywords)) + (if (stringp fields) + (progn + (when (> (length chosen) 0) + (setq fields (concat fields "," chosen)))) + (setq fields chosen))) + fields)) + +(defun apt-utils-toggle-package-info () + "Toggle between package and showpkg info for normal packages." + (interactive) + (unless (equal major-mode 'apt-utils-mode) + (error "Not in APT utils buffer")) + (let ((package (caar apt-utils-package-history)) + (type (cdar apt-utils-package-history)) + posns) + (cond + ((equal type 'normal) + (setq posns (apt-utils-update-buffer-positions 'toggle)) + (setq apt-utils-package-history + (cons (cons package 'normal-showpkg) + (cdr apt-utils-package-history))) + (apt-utils-show-package-1 (car apt-utils-package-history) nil) + (goto-char (car posns)) + (set-window-start (selected-window) (cadr posns))) + ((equal type 'normal-showpkg) + (setq posns (apt-utils-update-buffer-positions 'toggle)) + (setq apt-utils-package-history + (cons (cons package 'normal) + (cdr apt-utils-package-history))) + (apt-utils-show-package-1 (car apt-utils-package-history) nil) + (goto-char (car posns)) + (set-window-start (selected-window) (cadr posns))) + ((equal type 'virtual) + (message "Cannot toggle info for virtual packages.")) + ((memq type '(search search-names-only + search-file-names + search-grep-dctrl)) + (message "Cannot toggle info for searches."))))) + +(defun apt-utils-normal-package-p () + "Return non-nil if the current package is a normal package. +That is, not a normal-showpkg, search or a virtual package." + (eq (cdar apt-utils-package-history) 'normal)) + +(defun apt-utils-toggle-package-p () + "Return non-nil if we can toggle between package and showpkg. +See also `apt-utils-toggle-package-info'." + (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + +(defun apt-utils-check-package-lists () + "Determine whether package lists need rebuilding." + (apt-utils-update-mode-name) + (cond + ((null apt-utils-package-list-built) + (apt-utils-build-package-list)) + ((and (apt-utils-packages-needs-update) + ;; Only act for non-nil apt-utils-automatic-update + apt-utils-automatic-update + (cond + ((eq apt-utils-automatic-update t)) + ((eq apt-utils-automatic-update 'ask) + (unless apt-utils-automatic-update-asked + (setq apt-utils-automatic-update-asked t) + (yes-or-no-p + "APT package lists may be out of date. Update them? "))))) + (apt-utils-build-package-list t)))) + +;; Find ChangeLog files + +(defun apt-utils-view-changelog () + "Find ChangeLog for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-changelog-file package))) + (if file + (apt-utils-view-file file) + (message "No ChangeLog file found for %s." package)))))) + +(defun apt-utils-changelog-file (&optional package) + "Find ChangeLog file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("CHANGELOG" "ChangeLog" "Changelog" "changelog") + '("" ".gz")))) + file)) + +;; Find Debian ChangeLog files + +(defun apt-utils-view-debian-changelog () + "Find Debian ChangeLog for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-debian-changelog-file package))) + (if file + (apt-utils-view-file file) + (message "No Debian ChangeLog file found for %s." package)))))) + +(defun apt-utils-debian-changelog-file (&optional package) + "Find Debian ChangeLog file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("changelog.Debian") + '(".gz")))) + file)) + +;; Find NEWS files + +(defun apt-utils-view-news () + "Find NEWS for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-news-file package))) + (if file + (apt-utils-view-file file) + (message "No NEWS file found for %s." package)))))) + +(defun apt-utils-news-file (&optional package) + "Find NEWS file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("NEWS") + '("" ".gz")))) + file)) + +;; Find Debian NEWS files + +(defun apt-utils-view-debian-news () + "Find Debian NEWS for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-debian-news-file package))) + (if file + (apt-utils-view-file file) + (message "No Debian NEWS file found for %s." package)))))) + +(defun apt-utils-debian-news-file (&optional package) + "Find Debian NEWS file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("NEWS.Debian") + '(".gz")))) + file)) + +;; Find README files + +(defun apt-utils-view-readme () + "Find README for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-readme-file package))) + (if file + (apt-utils-view-file file) + (message "No README file found for %s." package)))))) + +(defun apt-utils-readme-file (&optional package) + "Find README file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("README" "readme") + '("" ".gz")))) + file)) + +;; Find Debian README files + +(defun apt-utils-view-debian-readme () + "Find Debian README for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-debian-readme-file package))) + (if file + (apt-utils-view-file file) + (message "No Debian README file found for %s." package)))))) + +(defun apt-utils-debian-readme-file (&optional package) + "Find Debian README file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/" package) + '("README.Debian" "README.debian") + '("" ".gz")))) + file)) + +;; Find copyright files + +(defun apt-utils-view-copyright () + "Find copyright file for the current package." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let* ((package (caar apt-utils-package-history)) + (file (apt-utils-copyright-file package))) + (if file + (apt-utils-view-file file) + (message "No copyright file found for %s." package)))))) + +(defun apt-utils-copyright-file (&optional package) + "Find copyright file for PACKAGE or the current package." + (unless package (setq package (caar apt-utils-package-history))) + (let ((file + (apt-utils-find-readable-file + (format "/usr/share/doc/%s/copyright" package) + '("") + '("")))) + file)) + +(defun apt-utils-view-man-page () + "View man page for the current package. +If there is more than one man page associated with the package, +offer a choice." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let ((package (caar apt-utils-package-history)) + (regexp + "^.*/man/\\([a-zA-Z_/.]+\\)?man[0-9]/\\(.*\\)\\.\\([0-9a-z]+\\)\\.gz") + choice chosen files table) + (setq files (apt-utils-get-package-files package + "/man/.*\\.gz$")) + (cond + ((null files) + (message "No man pages found for %s." package)) + ((not (cdr files)) + (setq chosen (car files))) + (t + (setq table (mapcar + (lambda (file) + (setq choice + (with-temp-buffer + (insert file) + (when (re-search-backward regexp nil t) + (replace-match "\\2 (\\1\\3)" nil nil)) + (buffer-string))) + (cons choice file)) + files)) + (setq chosen + (cdr (assoc + (let ((completion-ignore-case t)) + (completing-read "Choose man page: " table nil t)) + table))))) + (when chosen + (if (fboundp 'woman-find-file) + (woman-find-file chosen) + (manual-entry chosen))))))) + +(defun apt-utils-view-emacs-startup-file () + "View Emacs startup file for the current package. +If there is more than one file associated with the package, offer +a choice." + (interactive) + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (let ((package (caar apt-utils-package-history)) + chosen files table) + (setq files + (or (apt-utils-get-package-files package + "^/etc/emacs/site-start.d/.*") + (and (boundp 'debian-emacs-flavor) + (apt-utils-get-package-files + package + (format "^/etc/%s/site-start.d/.*" + (symbol-name debian-emacs-flavor)))))) + (cond + ((null files) + (message "No Emacs startup files found for %s." package)) + ((not (cdr files)) + (setq chosen (car files))) + (t + (setq table (mapcar + (lambda (file) + (cons file file)) + files)) + (setq chosen + (cdr (assoc + (let ((completion-ignore-case t)) + (completing-read "Choose Emacs startup file: " table nil t)) + table))))) + (when chosen + (apt-utils-view-file chosen)))))) + +(defun apt-utils-view-version () + "View installed version information for current package." + (interactive) + (let ((package (caar apt-utils-package-history)) + (type (cdar apt-utils-package-history))) + (if (memq type '(normal normal-showpkg)) + (let ((info (apt-utils-get-installed-info package))) + (if info + (message (apply #'format + "%s: version %s (Desired = %s; Status = %s; Error = %s)" + package info)) + (message "Not installed; not known to dkpg"))) + (message "Can show version info only for normal packages")))) + +(defun apt-utils-get-installed-info (package) + "Return list of installation information for package PACKAGE." + (let ((desired-list '((?u "Unknown") + (?i "Install") + (?r "Remove") + (?p "Purge") + (?h "Hold"))) + (status-list '((?n "Not installed") + (?i "Installed") + (?c "Config files") + (?u "Unpackage") + (?f "Failed config") + (?h "Half installed"))) + (err-list '((? "None") + (?h "Hold") + (?r "Reinstall required") + (?x "Hold + reinstall required"))) + desired status err status-bad err-bad) + (unless (eq package 'broken) + (with-temp-buffer + (let ((process-environment (append '("COLUMNS=200") (copy-alist process-environment)))) + (call-process apt-utils-dpkg-program nil t nil "-l" package)) + (when (re-search-backward + (format "^\\([a-z ][a-z ][a-z ]\\)\\s-+%s\\s-+\\(\\S-+\\)" + (regexp-quote package)) nil t) + (progn + (setq desired (aref (match-string 1) 0) + status (aref (match-string 1) 1) + err (aref (match-string 1) 2) + status-bad (not (eq status (downcase status))) + err-bad (not (eq err (downcase err)))) + ;; Return list of information + (list (match-string 2) ; version + (cadr (assoc desired desired-list)) + (concat (cadr (assoc (downcase status) status-list)) + (and status-bad " [bad]")) + (concat (cadr (assoc (downcase err) err-list)) + (and err-bad " [bad]"))))))))) + +(defun apt-utils-insert-installed-info (package) + "Insert installed information for package PACKAGE at point." + (let ((posn (point))) + (insert (format " (%s)" (or (nth 2 (apt-utils-get-installed-info package)) + "Not installed; not known to dpkg"))) + (add-text-properties (1+ posn) + (point) + '(face apt-utils-installed-status-face)))) + +;; File-related utility functions + +(defun apt-utils-find-readable-file (dir prefixes suffixes) + "Find a readable file composed of directory prefix and suffix. +Directory is DIR, prefix is one of PREFIXES and suffix is one of +SUFFIXES." + (catch 'found + (mapcar (lambda (prefix) + (mapcar (lambda (suffix) + (when (file-readable-p (concat dir prefix suffix)) + (throw 'found (concat dir prefix suffix)))) + suffixes)) + prefixes) + nil)) ; Return nil, if no file found + +(defun apt-utils-view-file (file) + "View file FILE in function `view-mode'." + (cond ((string-match "\\.gz$" file) + (if (fboundp 'with-auto-compression-mode) + (with-auto-compression-mode + (view-file file)) + (auto-compression-mode 1) + (view-file file))) + (t + (view-file file)))) + +;; Follow hyperlinks + +(defun apt-utils-follow-link (new-session) + "Follow hyperlink at point. +With non-nil NEW-SESSION, follow link in a new buffer." + (interactive "P") + (unless (equal major-mode 'apt-utils-mode) + (error "Not in APT utils buffer")) + (let ((package + (cadr + (member 'apt-package (text-properties-at (point)))))) + (apt-utils-follow-link-internal package new-session))) + +(defun apt-utils-mouse-follow-link (event) + "Follow hyperlink at mouse click. +Argument EVENT is a mouse event." + (interactive "e") + (let (package) + (save-selected-window + (mouse-set-point event) + (setq package (apt-utils-package-at-point)) + (apt-utils-follow-link-internal package nil)))) + +(defun apt-utils-package-at-point () + "Return name of package at point, if any." + (cadr + (member 'apt-package (text-properties-at + (point))))) + +(defun apt-utils-follow-link-internal (package new-session) + "Follow hyperlink for PACKAGE. +With non-nil NEW-SESSION, follow link in a new buffer." + (cond + ((equal package 'broken) + (message "Package name is broken somehow.")) + (package + (unless new-session + (apt-utils-update-buffer-positions 'forward)) + (apt-utils-show-package-1 package nil new-session) + (unless new-session + (setq apt-utils-package-history + (cons (cons package (apt-utils-package-type package)) + apt-utils-package-history)))) + (t + (message "No known package at point.")))) + +;; Go to previous package in list + +(defun apt-utils-view-previous-package () + "Go back to previous package displayed." + (interactive) + (unless (equal major-mode 'apt-utils-mode) + (error "Not in APT utils buffer")) + (if (cdr apt-utils-package-history) + (progn + (let ((posns (apt-utils-update-buffer-positions 'backward))) + (apt-utils-show-package-1 (cadr apt-utils-package-history) nil) + (goto-char (car posns)) + (set-window-start (selected-window) (cadr posns))) + (setq apt-utils-package-history (cdr apt-utils-package-history))) + (message "No further package history."))) + +(defun apt-utils-previous-package-p () + "Return non-nil if there is a previous entry in the package history. +See also `apt-utils-package-history'." + (cdr apt-utils-package-history)) + +;; Adapted from widget-move + +(defun apt-utils-next-package (&optional arg) + "Move point to the ARG next package. +ARG may be negative to move backward." + (interactive "p") + (unless (equal major-mode 'apt-utils-mode) + (error "Not in APT utils buffer")) + (cond + ;; No links + ((or (null apt-utils-current-links) + (= (hash-table-count apt-utils-current-links) 0)) + (message "No package links.")) + ;; One link + ((and (= (hash-table-count apt-utils-current-links) 1) + (not (eq (cdar apt-utils-package-history) 'search-file-names))) + (goto-char (point-min)) + (goto-char (next-single-property-change (point) + 'apt-package))) + (t + (let ((old (apt-utils-package-at))) + ;; Forward. + (while (> arg 0) + (cond ((eobp) + (goto-char (point-min))) + (t + (goto-char (or (next-single-property-change + (point) 'apt-package) + (point-max))))) + (let ((new (apt-utils-package-at))) + (when new + (unless (eq new old) + (setq arg (1- arg)) + (setq old new))))) + ;; Backward. + (while (< arg 0) + (cond ((bobp) + (goto-char (point-max))) + (t + (goto-char (or (previous-single-property-change + (point) 'apt-package) + (point-min))))) + (let ((new (apt-utils-package-at))) + (when new + (unless (eq new old) + (setq arg (1+ arg)))))) + ;; Go to beginning of field. + (let ((new (apt-utils-package-at))) + (while (eq (apt-utils-package-at) new) + (backward-char))) + (forward-char)))) + ;; Echo some info + (when apt-utils-show-link-info + (apt-utils-package-at-message))) + +(defun apt-utils-previous-package (&optional arg) + "Move point to the ARG previous package. +ARG may be negative to move forward." + (interactive "p") + (apt-utils-next-package (- arg))) + +;; Choose a package from the known links + +(defun apt-utils-choose-package-link (new-session) + "Choose a Debian package from a list of links. +With non-nil NEW-SESSION, follow link in a new buffer." + (interactive "P") + (apt-utils-choose-package-link-internal new-session)) + +(defun apt-utils-choose-package-link-internal (new-session) + "Choose a Debian package from a list of links. +With non-nil NEW-SESSION, follow link in a new buffer." + (cond + ((not (equal major-mode 'apt-utils-mode)) + (error "Not in APT utils buffer")) + ((= (hash-table-count apt-utils-current-links) 0) + (message "No package links.")) + (t + (let ((package + (completing-read "Choose related Debian package: " + (cond + (apt-utils-completing-read-hashtable-p + apt-utils-current-links) + (t + (apt-utils-build-completion-table + apt-utils-current-links))) + nil t))) + (when (> (length package) 0) + (unless new-session + (apt-utils-update-buffer-positions 'forward)) + (apt-utils-show-package-1 package nil new-session) + (unless new-session + (setq apt-utils-package-history + (cons (cons package (apt-utils-package-type package)) + apt-utils-package-history)))))))) + +(defun apt-utils-build-package-list (&optional force) + "Build list of Debian packages known to APT. +With optional argument FORCE, rebuild the packages lists even if +they are defined. When package lists are not up-to-date, this is +indicated in `mode-name'." + (when (or force (null apt-utils-package-list-built)) + (unwind-protect + (progn + (setq apt-utils-package-list-built nil + apt-utils-automatic-update-asked nil) + (message "Building Debian package lists...") + ;; Hash table listing package types + (if (hash-table-p apt-utils-package-list) + (clrhash apt-utils-package-list) + (setq apt-utils-package-list (make-hash-table :test 'equal))) + ;; All packages except virtual ones + (with-temp-buffer + ;; Virtual and normal packages + (call-process apt-utils-apt-cache-program nil '(t nil) nil "pkgnames") + (mapcar (lambda (elt) + (apt-utils-puthash elt 'virtual apt-utils-package-list)) + (split-string (buffer-string))) + ;; Normal packages + (erase-buffer) + (call-process apt-utils-apt-cache-program nil '(t nil) nil "pkgnames" + "-o" "APT::Cache::AllNames=0") + (mapcar (lambda (elt) + (apt-utils-puthash elt 'normal apt-utils-package-list)) + (split-string (buffer-string)))) + (message "Building Debian package lists...done.") + (setq apt-utils-package-list-built (current-time)) + (apt-utils-update-mode-name)) + (unless apt-utils-package-list-built + (message "Building Debian package lists...interrupted.") + (apt-utils-update-mode-name) + (if (hash-table-p apt-utils-package-list) + (clrhash apt-utils-package-list)))))) + +(defun apt-utils-rebuild-package-lists () + "Rebuild the APT package lists." + (interactive) + (apt-utils-build-package-list t)) + +(defun apt-utils-choose-package () + "Choose a Debian package name." + (let ((package + (and (eq major-mode 'apt-utils-mode) + (cadr (member 'apt-package + (text-properties-at (point))))))) + (when (not (stringp package)) + (setq package nil)) + (completing-read "Choose Debian package: " + (cond + (apt-utils-completing-read-hashtable-p + apt-utils-package-list) + (t + (apt-utils-build-completion-table + apt-utils-package-list))) + nil t package))) + +(defun apt-utils-build-completion-table (hash) + "Build completion table for packages using keys of hashtable HASH." + (with-temp-buffer + (maphash (lambda (key value) + (insert key "\n")) + hash) + (mapcar (lambda (elt) + (list elt)) + (split-string (buffer-string))))) + +;; Add hyperlinks + +(defun apt-utils-add-package-links () + "Add hyperlinks to related Debian packages." + (let ((keywords '("Conflicts" "Depends" "Enhances" "Package" + "Pre-Depends" "Provides" "Recommends" "Replaces" + "Suggests")) + match) + (if (hash-table-p apt-utils-current-links) + (clrhash apt-utils-current-links) + (setq apt-utils-current-links (make-hash-table :test 'equal))) + (goto-char (point-min)) + (while (re-search-forward "^\\([^ \n:]+\\):\\( \\|$\\)" + (point-max) t) + (setq match (match-string 1)) + (add-text-properties (if (looking-at "$") + (point) ;; Conffiles (also see below) + (1- (point))) + (save-excursion + (beginning-of-line) + (point)) + `(,apt-utils-face-property apt-utils-field-keyword-face)) + (cond + ((member match keywords) + ;; Remove newline characters in field + (let ((end (apt-field-end-position))) + (subst-char-in-region (point) end ?\n ?\ ) + (canonically-space-region (point) end)) + ;; Find packages + (let ((packages (apt-utils-current-field-packages)) + (inhibit-read-only t) + face + length length-no-version + package) + (while packages + (setq package (car packages)) + (setq length (length package)) + ;; Remove version info (in parenthesis), and whitespace + (setq package (apt-utils-replace-regexp-in-string + "\\((.*)\\|\\s-+\\)" "" package)) + (setq length-no-version (length package)) + ;; Package type + (cond + ((equal (apt-utils-package-type package t) 'normal) + (setq face 'apt-utils-normal-package-face)) + ((equal (apt-utils-package-type package t) 'virtual) + (setq face 'apt-utils-virtual-package-face)) + (t + (setq face 'apt-utils-broken-face) + (setq package 'broken))) + ;; Store package links + (apt-utils-current-links-add-package package) + ;; Add text properties + (add-text-properties (point) (+ (point) length-no-version) + `(,apt-utils-face-property ,face + mouse-face highlight + apt-package ,package)) + ;; Version? + (when (> length length-no-version) + (add-text-properties (+ (point) length-no-version 1) + (+ (point) length) + `(,apt-utils-face-property apt-utils-version-face))) + ;; Fill package names + (when (and apt-utils-fill-packages + (> (current-column) (+ 2 (length match))) + (> (+ (current-column) length) fill-column)) + (when (equal (char-before) ?\ ) + (delete-char -1)) ; trailing whitespace + (insert "\n" (make-string (+ 2 (length match)) ? ))) + (forward-char length) + (when (and (equal match "Package") + apt-utils-display-installed-status) + (apt-utils-insert-installed-info package)) + (skip-chars-forward ", |\n") + (setq packages (cdr packages))))) + ((equal match "Description") + (add-text-properties (point) + (save-excursion + (or + (re-search-forward "^[^ ]" (point-max) t) + (point-max))) + `(,apt-utils-face-property apt-utils-description-face))) + ;; Conffiles doesn't have trailing space + ((looking-at "$") + nil) + (t + (add-text-properties (1- (point)) + (save-excursion + (end-of-line) + (point)) + `(,apt-utils-face-property apt-utils-field-contents-face))))))) + +(defun apt-utils-add-showpkg-links (package) + "Add hyperlinks to related Debian packages for PACKAGE." + (let ((keywords '("Reverse Depends" "Reverse Provides")) + (inhibit-read-only t) + start end regexp face link) + (if (hash-table-p apt-utils-current-links) + (clrhash apt-utils-current-links) + (setq apt-utils-current-links (make-hash-table :test 'equal))) + (while keywords + (setq regexp (concat "^" (car keywords) ": ")) + (goto-char (point-min)) + (when (re-search-forward regexp (point-max) t) + (add-text-properties (match-beginning 0) (1- (match-end 0)) + `(,apt-utils-face-property + apt-utils-field-keyword-face)) + ;; Limits of search + (setq start (1+ (point))) + (setq end (or (re-search-forward "[a-z]:" (point-max) t) + (point-max))) + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (not (eobp)) + (when (or (looking-at "^\\s-+\\(.*\\),") + (looking-at "^\\(.*\\) ")) + (setq link (match-string 1)) + (cond + ((equal (apt-utils-package-type link t) 'normal) + (setq face 'apt-utils-normal-package-face)) + ((equal (apt-utils-package-type link t) 'virtual) + (setq face 'apt-utils-virtual-package-face)) + (t + (setq face 'apt-utils-broken-face) + (setq link 'broken))) + ;; Store package links + (apt-utils-current-links-add-package link) + (add-text-properties (match-beginning 1) (match-end 1) + `(,apt-utils-face-property ,face + mouse-face highlight + apt-package ,link))) + (forward-line)))) + (setq keywords (cdr keywords)))) + (when (and apt-utils-display-installed-status + (eq (apt-utils-package-type package t) 'normal)) + (goto-char (point-min)) + (re-search-forward "Package: .*$") + (apt-utils-insert-installed-info package))) + +(defun apt-utils-add-search-links (type) + "Add hyperlinks to related Debian packages. +The type of search is specified by TYPE." + (let ((inhibit-read-only t) + local-keymap + face link regexp) + (when (eq type 'search-file-names) + (setq local-keymap (make-sparse-keymap)) + (define-key local-keymap (kbd "RET") + (lambda () + (interactive) + (view-file (or (get-text-property (point) 'apt-package-file) + (get-text-property (1- (point)) 'apt-package-file)))))) + (if (hash-table-p apt-utils-current-links) + (clrhash apt-utils-current-links) + (setq apt-utils-current-links (make-hash-table :test 'equal))) + (goto-char (point-min)) + (forward-line 2) ; Move past header + (cond + ((eq type 'search-file-names) + ;; Reformat diversion information + (save-excursion + (while (re-search-forward "diversion by \\(.*\\) \\(from\\|to\\): \\(.*\\)" nil t) + (replace-match "\\1: \\3 (diversion \\2)" nil nil))) + (setq regexp "\\([^:,]+\\)[,:]")) + (t + (setq regexp"^\\([^ ]+\\) - "))) + (while (re-search-forward regexp (point-max) t) + (setq link (match-string 1)) + (cond + ((equal (apt-utils-package-type link t) 'normal) + (setq face 'apt-utils-normal-package-face)) + ((equal (apt-utils-package-type link t) 'virtual) + (setq face 'apt-utils-virtual-package-face)) + (t + (setq face 'apt-utils-broken-face) + (setq link 'broken))) + ;; Store package links + (apt-utils-current-links-add-package link) + (add-text-properties (match-beginning 1) (match-end 1) + `(,apt-utils-face-property ,face + mouse-face highlight + apt-package ,link)) + ;; Multiple fields separated by commas + (when (eq type 'search-file-names) + (if (eq (char-before) ?\:) + (progn + (when local-keymap + (let ((start (1+ (point))) + (end (save-excursion + (goto-char (apt-utils-line-end-position)) + (re-search-backward " (diversion \\(from\\|to\\))" + (apt-utils-line-beginning-position) + t) + (point)))) + (add-text-properties start end + `(face apt-utils-file-face + keymap ,local-keymap + ;; Pretend we're a package + ;; so that we can move + ;; here with + ;; apt-utils-next-package + apt-package dummy + apt-package-file + ,(buffer-substring-no-properties start end) + )))) + (goto-char (1+ (apt-utils-line-end-position)))) + (skip-chars-forward ", ")))))) + +(defun apt-utils-package-type (package &optional no-error) + "Return what type of package PACKAGE is. +With optional argument NO-ERROR, don't flag an error for unknown +packages." + (or (gethash package apt-utils-package-list) + (cond + (no-error + nil) + (t + (error + (substitute-command-keys + "Package name is broken: rebuild package lists using \\[apt-utils-rebuild-package-lists] may help") + package))))) + +(defun apt-utils-package-at () + "Get package at point." + (get-text-property (point) 'apt-package)) + +(defun apt-utils-package-at-message () + "Emit message describing package at point." + (let ((package (apt-utils-package-at))) + (cond + ((eq package 'dummy) + ;; Do nothing as this isn't really a package + ) + ((equal package 'broken) + (message "Package name is broken somehow.")) + (package + (with-temp-buffer + (call-process apt-utils-apt-cache-program nil t nil "show" package) + (if (re-search-backward "^Description: \\(.*\\)$" (point-min) t) + (message "%s: %s." package (match-string 1)) + (message "%s: virtual package (no description)." + package))))))) + +(defun apt-utils-quit (&optional kill-buffer) + "Quit this `apt-utils-mode' buffer. +With prefix argument KILL-BUFFER, kill the `apt-utils-mode' +buffer." + (interactive "P") + (unless (equal major-mode 'apt-utils-mode) + (error "Not in APT utils buffer")) + (let ((buffer (current-buffer))) + (if (fboundp 'quit-window) + (quit-window) + (bury-buffer)) + (when kill-buffer + (kill-buffer buffer))) + (run-hooks 'apt-utils-quit-hooks)) + +(defun apt-utils-cleanup () + "Clean up lists used by `apt-utils-mode'. +Specifically, nullify `apt-utils-package-list'. Only do this if +there are no buffers left in `apt-utils-mode'." + (unless (memq 'apt-utils-mode + (mapcar (lambda (b) + (with-current-buffer b + major-mode)) + (delete (current-buffer) (buffer-list)))) + (clrhash apt-utils-package-list) + (setq apt-utils-package-list-built nil))) + +(defun apt-utils-describe-package () + "Describe package at point." + (interactive) + (apt-utils-package-at-message)) + +(defun apt-utils-kill-other-window-buffers () + "Kill buffers in other windows and the windows themselves. +See `apt-utils-kill-buffer-confirmation-function' for +customisation options." + (interactive) + (cond + ((not (eq major-mode 'apt-utils-mode)) + (error "Not in APT utils buffer")) + ((not (cdr (window-list))) + (message "No other windows to kill")) + (t + (when (or (null apt-utils-kill-buffer-confirmation-function) + (funcall apt-utils-kill-buffer-confirmation-function + "Kill buffers in other windows? ")) + (let ((buffer-list + (delq (current-buffer) + (mapcar #'window-buffer (window-list))))) + (mapc (lambda (b) + (when (buffer-live-p b) + (kill-buffer b))) + buffer-list)) + (delete-other-windows)) + (message nil)))) + +;; Track positions + +(defun apt-utils-update-buffer-positions (type) + "Update `apt-utils-buffer-positions'. +TYPE can be forward, backward, or toggle." + (let (posns) + (cond + ((eq type 'forward) + ;; Make the key unique; we could visit the same package more + ;; than once + (apt-utils-puthash (format "%s/%s/%d" + (caar apt-utils-package-history) + (cdar apt-utils-package-history) + (length apt-utils-package-history)) + (list (point) (window-start (selected-window))) + apt-utils-buffer-positions)) + ((eq type 'backward) + ;; Remove old values + (remhash (format "%s/normal/%d" + (caar apt-utils-package-history) + (length apt-utils-package-history)) + apt-utils-buffer-positions) + (remhash (format "%s/normal-showpkg/%d" + (caar apt-utils-package-history) + (length apt-utils-package-history)) + apt-utils-buffer-positions) + (remhash (format "%s/virtual/%d" + (caar apt-utils-package-history) + (length apt-utils-package-history)) + apt-utils-buffer-positions) + ;; Get position for previous package + (setq posns + (gethash (format "%s/%s/%d" + (car (cadr apt-utils-package-history)) + (cdr (cadr apt-utils-package-history)) + (1- (length apt-utils-package-history))) + apt-utils-buffer-positions))) + ((eq type 'toggle) + ;; new/old package types + (let ((package (caar apt-utils-package-history)) + (type (cdar apt-utils-package-history)) + new old) + (if (equal type 'normal) + (setq old 'normal + new 'normal-showpkg) + (setq old 'normal-showpkg + new 'normal)) + ;; Set position for old entry + (apt-utils-puthash (format "%s/%s/%d" + package + old + (length apt-utils-package-history)) + (list (point) (window-start (selected-window))) + apt-utils-buffer-positions) + ;; Get position for new entry + (setq posns + (gethash (format "%s/%s/%d" + package + new + (length apt-utils-package-history)) + apt-utils-buffer-positions + (list 1 1))) ; default value + ))) + posns)) + +(defun apt-utils-current-field-packages () + "Return a list of the packages on the current line." + (let ((keywords '("Conflicts" "Depends" "Enhances" "Package" + "Pre-Depends" "Provides" "Recommends" "Replaces" + "Suggests")) + eol match packages posn string) + (save-excursion + (end-of-line) + (setq eol (point)) + (beginning-of-line) + (cond + ((eobp) + (message "Not on package field line.") + nil) + ((and (re-search-forward "^\\([^ \n:]+\\): " eol t) + (setq match (match-string 1)) + (member match keywords)) + (setq posn (point)) + (goto-char (apt-field-end-position)) + (setq string (buffer-substring-no-properties posn (point))) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n *" nil t) + (replace-match " ")) + (setq packages + ;; Packages split by commas, or alternatives by vertical + ;; bars; for Enhances, multiple lines my be spanned + (split-string (buffer-substring (point-min) (point-max)) + " ?[,|] ?"))) + packages) + (t + (message "Not on package field line.") + nil))))) + +(defun apt-field-end-position () + "Move to end of current field." + (save-excursion + (re-search-forward "\\(^[^: ]+:\\|^$\\)") + (beginning-of-line) + (backward-char) + (point))) + +;; Borrowed from gnus/lisp/time-date.el + +(defun apt-utils-time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun apt-utils-web-browse-debian-changelog () + "Browse web version of Debian ChangeLog file for the current package." + (interactive) + (apt-utils-web-browse-url + apt-utils-web-browse-debian-changelog-url)) + +(defun apt-utils-web-browse-bug-reports () + "Browse Debian bug reports for the current package." + (interactive) + (apt-utils-web-browse-url + apt-utils-web-browse-bug-reports-url)) + +(defun apt-utils-web-browse-copyright () + "Browse web version of Debian copyright file for the current package." + (interactive) + (apt-utils-web-browse-url + apt-utils-web-browse-copyright-url)) + +(defun apt-utils-web-browse-versions () + "Browse web version information for the current package." + (interactive) + (apt-utils-web-browse-url + apt-utils-web-browse-versions-url)) + +(defun apt-utils-web-browse-url (url) + "Browse Debian-related URL. +The URL can contain tokens that need formatting (see +`apt-utils-web-format-url')." + (cond + ((not (equal major-mode 'apt-utils-mode)) + (message "Not in APT utils buffer.")) + ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg))) + (message "Not a normal package.")) + (t + (browse-url (apt-utils-web-format-url url))))) + +(defun apt-utils-web-format-url (url) + "Format and return Debian URL. +The tokens that can be replaced are: + %d: pool directory + %s: source package name + %p: package name + %v: package version." + (let ((buffer (current-buffer)) + (package (caar apt-utils-package-history)) + (type (cdar apt-utils-package-history)) + char source-package version) + (save-excursion ; for normal package type + (with-temp-buffer + (cond + ((eq type 'normal) + (set-buffer buffer)) + ((eq type 'normal-showpkg) + (call-process apt-utils-apt-cache-program nil '(t nil) nil "show" package))) + (goto-char (point-min)) + (if (re-search-forward "^Source: \\(.*\\)$" (point-max) t) + (setq source-package (match-string 1)) + (setq source-package package)) + (goto-char (point-min)) + (re-search-forward "^Version: \\([0-9]:\\)?\\(.*\\)$" (point-max)) + (setq version (match-string 2)))) + ;; Format the URL + (while (string-match "%\\(.\\)" url) + (setq char (string-to-char (match-string 1 url))) + (setq url (apt-utils-replace-regexp-in-string + (match-string 0 url) + (cond + ((eq char ?d) + (substring source-package 0 + (if (string-match "^lib[a-z]" + source-package) + 4 1))) + ((eq char ?s) source-package) + ((eq char ?p) package) + ((eq char ?v) version) + (t + (error "Unrecognized token (%%%c) in URL: %s" char url))) + url)))) + url) + +(defun apt-utils-packages-needs-update () + "Return t if `apt-utils' package lists needs updating." + (or (not apt-utils-package-list-built) + (apt-utils-time-less-p apt-utils-package-list-built + (nth 5 (file-attributes apt-utils-timestamped-file))))) + +(defun apt-utils-update-mode-name () + "Update `mode-name' for all buffers in `apt-utils-mode'." + (let* ((need-update (apt-utils-packages-needs-update)) + (update-string + (and need-update + (substitute-command-keys + ": update using \\\\[apt-utils-rebuild-package-lists]"))) + (name (concat "APT utils" update-string))) + (mapc (lambda (b) + (with-current-buffer b + (when (eq major-mode 'apt-utils-mode) + (setq mode-name name)))) + (buffer-list)))) + +(defun apt-utils-current-links-add-package (package) + "Add PACKAGE to `apt-utils-current-links' hashtable." + (unless (eq package 'broken) + (apt-utils-puthash package nil apt-utils-current-links))) + +;; Mode settings + +(defvar apt-utils-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "#") 'apt-utils-rebuild-package-lists) + (define-key map (kbd "1") 'delete-other-windows) + (define-key map (kbd "<") 'apt-utils-view-previous-package) + (define-key map (kbd ">") 'apt-utils-choose-package-link) + (define-key map (kbd "?") 'describe-mode) + (define-key map (kbd "DEL") 'scroll-down) + (define-key map (kbd "M-TAB") 'apt-utils-previous-package) + (define-key map (kbd "RET") 'apt-utils-follow-link) + (define-key map (kbd "S s") 'apt-utils-search) + (define-key map (kbd "S f") 'apt-utils-search-file-names) + (define-key map (kbd "S g") 'apt-utils-search-grep-dctrl) + (define-key map (kbd "S n") 'apt-utils-search-names-only) + (define-key map (kbd "SPC") 'scroll-up) + (define-key map (kbd "TAB") 'apt-utils-next-package) + (define-key map (kbd "b C") 'apt-utils-web-browse-debian-changelog) + (define-key map (kbd "b b") 'apt-utils-web-browse-bug-reports) + (define-key map (kbd "b l") 'apt-utils-web-browse-copyright) + (define-key map (kbd "b v") 'apt-utils-web-browse-versions) + (define-key map (kbd "d") 'apt-utils-describe-package) + (when (fboundp 'window-list) + (define-key map (kbd "k") 'apt-utils-kill-other-window-buffers)) + (define-key map (kbd "l") 'apt-utils-list-package-files) + (define-key map (kbd "o") 'other-window) + (define-key map (kbd "q") 'apt-utils-quit) + (define-key map (kbd "s") 'apt-utils-show-package) + (define-key map (kbd "t") 'apt-utils-toggle-package-info) + (define-key map (kbd "v C") 'apt-utils-view-debian-changelog) + (define-key map (kbd "v R") 'apt-utils-view-debian-readme) + (define-key map (kbd "v N") 'apt-utils-view-debian-news) + (define-key map (kbd "v c") 'apt-utils-view-changelog) + (define-key map (kbd "v e") 'apt-utils-view-emacs-startup-file) + (define-key map (kbd "v f") 'apt-utils-view-package-files) + (define-key map (kbd "v l") 'apt-utils-view-copyright) + (define-key map (kbd "v m") 'apt-utils-view-man-page) + (define-key map (kbd "v n") 'apt-utils-view-news) + (define-key map (kbd "v r") 'apt-utils-view-readme) + (define-key map (kbd "v v") 'apt-utils-view-version) + (define-key map [(shift iso-lefttab)] 'apt-utils-previous-package) + (define-key map [(shift tab)] 'apt-utils-previous-package) + (define-key map + (if apt-utils-xemacs-p '(button2) (kbd "")) + 'apt-utils-mouse-follow-link) + map) + "Keymap for apt-utils mode.") + +;; Menus + +(defvar apt-utils-menu nil + "Menu to use for `apt-utils-mode'.") + +(when (fboundp 'easy-menu-define) + + (easy-menu-define apt-utils-menu apt-utils-mode-map "Apt Utils Menu" + `("Apt Utils" + ["Show Package" apt-utils-show-package t] + ["Toggle Package Info" apt-utils-toggle-package-info + (apt-utils-toggle-package-p)] + ["View Previous Package" apt-utils-view-previous-package + (apt-utils-previous-package-p)] + ["Choose Package Link" apt-utils-choose-package-link + (> (hash-table-count apt-utils-current-links) 0)] + ["Next Package Link" apt-utils-next-package + (> (hash-table-count apt-utils-current-links) 0)] + ["Previous Package Link" apt-utils-previous-package + (> (hash-table-count apt-utils-current-links) 0)] + ["Follow Link at Point" apt-utils-follow-link + (apt-utils-package-at-point)] + ["Rebuild Package Lists" apt-utils-rebuild-package-lists t] + "---" + ("Search" + ["Package Descriptions" apt-utils-search t] + ["Package Names" apt-utils-search-names-only t] + ["Installed Files" apt-utils-search-file-names t] + ["Grep-Dctrl" apt-utils-search-grep-dctrl t]) + ("View Files" + ,@(list (if apt-utils-xemacs-p + :included + :active) + '(apt-utils-current-package-installed-p)) + ["ChangeLog" apt-utils-view-changelog + (apt-utils-changelog-file)] + ["Debian ChangeLog" apt-utils-view-debian-changelog + (apt-utils-debian-changelog-file)] + ["README" apt-utils-view-readme + (apt-utils-readme-file)] + ["Debian README" apt-utils-view-debian-readme + (apt-utils-debian-readme-file)] + ["NEWS" apt-utils-view-news + (apt-utils-news-file)] + ["Debian NEWS" apt-utils-view-debian-news + (apt-utils-debian-news-file)] + ["Copyright" apt-utils-view-copyright + (apt-utils-copyright-file)] + "---" + ["Man Page" apt-utils-view-man-page + (apt-utils-current-package-installed-p)] + "---" + ["All Package Files (dired)" apt-utils-view-package-files + (apt-utils-current-package-installed-p)]) + ("Browse URL" + ,@(list (if apt-utils-xemacs-p + :included + :active) + '(apt-utils-toggle-package-p)) + ["Debian ChangeLog" apt-utils-web-browse-debian-changelog t] + ["Bug Reports" apt-utils-web-browse-bug-reports t] + ["Copyright" apt-utils-web-browse-copyright t] + ["Package Versions" apt-utils-web-browse-versions t]) + "---" + ["Help" describe-mode t] + ["Quit" apt-utils-quit t]))) + +(defun apt-utils-mode () + "Major mode to interface Emacs with APT (Debian package management). + +Start things off with, for example: + + M-x apt-utils-show-package RET emacs21 RET + +Other packages (dependencies, conflicts etc.) can be navigated +using: + + \\[apt-utils-toggle-package-info] toggle package and showpkg information + \\[apt-utils-view-previous-package] show the previous package from history + \\[apt-utils-choose-package-link] choose next package from current links + \\[apt-utils-next-package] move to next package link + \\[apt-utils-previous-package] move to previous package link + \\[apt-utils-follow-link] show package for the link at point + \\[apt-utils-list-package-files] list package files (in a `dired' buffer) + +Confirmation will be requested before updating the list of known +packages. The update can be started at any time with +\\[apt-utils-rebuild-package-lists]. + +Package searches can be performed using: + + \\[apt-utils-search] search for regular expression in package names and descriptions + \\[apt-utils-search-names-only] search for regular expression in package names + \\[apt-utils-search-file-names] search for string in filenames + \\[apt-utils-search-grep-dctrl] search for regular expression in selected package fields + (using the grep-dctrl program) + +Files associated with installed packages can be accessed using: + + \\[apt-utils-view-changelog] view ChangeLog file + \\[apt-utils-view-debian-changelog] view Debian ChangeLog file + \\[apt-utils-view-readme] view README file + \\[apt-utils-view-debian-readme] view Debian ChangeLog file + \\[apt-utils-view-news] view NEWS file + \\[apt-utils-view-debian-news] view Debian NEWS file + \\[apt-utils-view-copyright] view copyright (licence) file + \\[apt-utils-view-man-page] view man page + +Web locations can be visited using: + + \\[apt-utils-web-browse-debian-changelog] browse Debian ChangeLog URL + \\[apt-utils-web-browse-bug-reports] browse bug report URL + \\[apt-utils-web-browse-copyright] browse copyright (licence) URL + \\[apt-utils-web-browse-versions] browse package versions URL + +A history of navigated packages is maintained when package links +are followed using `apt-utils-choose-package-link' or +`apt-utils-follow-link'. This history is reset when +`apt-utils-show-package' or any of the search commands is used. + +Key definitions: +\\{apt-utils-mode-map}" + (kill-all-local-variables) + (use-local-map apt-utils-mode-map) + (setq major-mode 'apt-utils-mode) + (setq mode-name "APT utils") + (setq buffer-undo-list t) + (setq truncate-lines t) + ;; XEmacs + (when (and (fboundp 'easy-menu-add) + apt-utils-menu) + (easy-menu-add apt-utils-menu)) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'apt-utils-cleanup nil t) + (run-hooks 'apt-utils-mode-hook)) + +;; Debugging + +(defun apt-utils-trace-all () + "Trace all `apt-utils' functions. For debugging." + (require 'trace) + (let ((buffer (get-buffer-create "*APT Utils Trace*"))) + (buffer-disable-undo buffer) + (all-completions "apt-utils" obarray + (lambda (sym) + (and (fboundp sym) + (not (memq (car-safe (symbol-function sym)) + '(autoload macro))) + (trace-function-background sym buffer)))))) + +(provide 'apt-utils) + +;;; apt-utils.el ends here addfile ./site-lisp/dpans2texi.el hunk ./site-lisp/dpans2texi.el 1 +;;; dpans2texi.el --- Convert the ANSI Common Lisp draft to Texinfo + +;; Copyright (C) 2004,2005 Jesper Harder + +;; Author: Jesper Harder +;; Created: 1 Mar 2004 +;; Version: 1.02 +;; Location: +;; Keywords: Lisp, documentation + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be +;; useful, but WITHOUT ANY WARRANTY; without even the implied +;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. See the GNU General Public License for more details. +;; + +;;; Commentary: +;; +;; This program converts the TeX sources for the draft proposed ANSI +;; Common Lisp standard to Texinfo. The TeX sources are available +;; from ftp://parcftp.xerox.com/pub/cl/dpANS3 and +;; ftp://parcftp.xerox.com/pub/cl/dpANS3R +;; +;; It's by no means a general TeX to Texinfo converter -- the +;; conversion is only doable because most of the draft is written with +;; a set of mostly semantic macros. In the cases where the draft +;; reverts to basic TeX, we mostly bail out, see `dp-special-cases'. +;; +;; The simpler TeX macros are implemented as Texinfo macros in +;; `dp.texi' (`dpi.texi' and `dph.texi' contain macros that should be +;; done differently for Info and HTML). +;; +;; `makeinfo' isn't multibyte clean, so we have to map multibyte chars +;; to unused 8bit chars, and post-process the Info files with `dp-tr'. +;; This isn't necessary for HTML. +;; +;; To use `C-h C-i' (`info-lookup-symbol') to look up the symbol at +;; point in the manual, add the following to your .emacs: +;; +;; (require 'info-look) +;; +;; (info-lookup-add-help +;; :mode 'lisp-mode +;; :regexp "[^][()'\" \t\n]+" +;; :ignore-case t +;; :doc-spec '(("(ansicl)Symbol Index" nil nil nil))) + +;; +;;; Code: + +(require 'rx) +(require 'cl) + +(defvar dp-preamble + "\\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename ansicl +@settitle ANSI Common Lisp +@paragraphindent 0 +@exampleindent 0 +@documentencoding utf-8 +@defindex sy +@c %**end of header +@dircategory Programming +@direntry +* ANSI Common Lisp: (ansicl). Draft ANSI Common Lisp standard (dpANS3R). +@end direntry +@include dp.texi +@node Top +@top ANSI Common Lisp + +This is a Texinfo version@footnote{The converter is available +from @uref{http://purl.org/harder/dpans.html}} of the draft +ANSI Common Lisp standard. Some font information has been lost +in the conversion, and errors may have been introduced. Report +discrepancies with the hardcopy version to +@email{harder@@phys.au.dk, Jesper Harder}. + +@menu +") + +(defvar dp-postamble + "@node Index +@unnumbered Index +@printindex cp +@node Symbol Index +@unnumbered Symbol Index +@printindex sy +@node List of Figures +@unnumbered List of Figures +@listoffloats Figure +@ifnotinfo +@node Table of Contents +@unnumbered +@contents +@end ifnotinfo +@bye") + +(defvar dp-list-type nil) +(defvar dp-current-label nil) +(defvar dp-nodes nil) +(defvar dp-dictionary-p nil) +(defvar dp-chapter-list nil) +(defvar dp-current-chapter nil) +(defvar dp-current-chapter-no) +(defvar dp-current-section-name) +(defvar dp-fig-no 0) +(defvar dp-section-no 0) +(defvar dp-subsection-no 0) +(defvar dp-subsubsection-no 0) +(defvar dp-subsubsubsection-no 0) +(defvar dp-subsubsubsubsection-no 0) +(defvar dp-current-chapter-marker (make-marker)) +(defvar dp-current-section-marker) +(defvar dp-work-buffer) + +(defvar dp-syntax-table + (let ((table (copy-syntax-table))) + (modify-syntax-entry ?\[ "." table) + (modify-syntax-entry ?\] "." table) + (modify-syntax-entry ?\( "." table) + (modify-syntax-entry ?\) "." table) + (modify-syntax-entry ?\" "." table) + table)) + +(defsubst dp-pm () + "Go to point-min." + (goto-char (point-min))) + +(defun dp-defconvert (function &rest tags) + "Declare FUNCTION as a converter for TAGS." + (mapc (lambda (x) (put x 'convert function)) tags)) + +(defun dp-parse-macros (file) + "Parse Texinfo macros in FILE." + (let (name arg args) + (with-temp-buffer + (insert-file-contents file) + (insert-file-contents "dpi.texi") + (dp-pm) + (while (re-search-forward "^@r*macro \\([^{]+\\) +{\\([^}]*\\)}" nil t) + (setq name (match-string 1) + arg (match-string 2)) + (setq args (length (split-string arg))) + (put (intern name) 'convert + (intern (format "dp-arg%s" args))))))) + +(defun dp-trim-whitespace (str) + "Remove leading and trailing whitespace characters from STR." + (when (string-match "\\`\\s-+" str) + (setq str (substring str (match-end 0)))) + (when (string-match "\\s-+\\'" str) + (setq str (substring str 0 (match-beginning 0)))) + str) + +(defun dp-remove-whitespace (str) + "Remove multiple whitespace from STR." + (replace-regexp-in-string (rx (or "\n" (+ " "))) " " str t t)) + +(defun dp-freshline () + (unless (bolp) + (insert "\n"))) + +(defun dp-strip-comments () + "Strip TeX comments." + (dp-pm) + (while (search-forward "%" nil t) + (if (= (point) (1+ (point-at-bol))) + ;; remove entire line if % starts the line + (dp-delete-line) + (delete-region (1- (point)) (point-at-eol)))) + (dp-pm) + (while (re-search-forward "\n\n\n+" nil t) + (replace-match "\n\n"))) + +(defun dp-non-code () + "Strip comments and leading whitespace in non-code sections." + (let (bpoint) + (dp-pm) + (while (not (eobp)) + (setq bpoint (point)) + (save-restriction + (re-search-forward "^\\\\code" nil 'move-to-lmit) + (narrow-to-region bpoint (point)) + (save-excursion + (dp-strip-comments) + (dp-pm) + ;; strip leading whitespace + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "")) + (dp-hack-$))) + (search-forward "\\endcode" nil 'move-to-limit)))) + +(defun dp-hack-~ () + "Convert ~ to @tie{} in non-code sections." + (let (bpoint) + (dp-pm) + (while (not (eobp)) + (setq bpoint (point)) + (save-restriction + (re-search-forward "^@lisp" nil 'move-to-lmit) + (narrow-to-region bpoint (point)) + (dp-pm) + (while (search-forward "~" nil t) + (replace-match "@tie{}"))) + (search-forward "@end lisp" nil 'move-to-limit)))) + +(defun dp-delete-line (&optional n) + (delete-region (point-at-bol) + (progn (forward-line (or n 1)) (point)))) + +(defun dp-strip-newline (str &optional inplace) + "Replace newlines with space in STR. +If INPLACE is non-nil, do it destructively" + (subst-char-in-string ?\n ?\ str inplace)) + +(defun dp-quote-comma (str) + "Quote commas in STR." + (replace-regexp-in-string "," "\\," str nil t)) + +(defun dp-arg3 (command) + (replace-match (concat "@" command) t t nil) + (save-excursion + (insert + (dp-strip-newline + (concat + "{" (dp-quote-comma (dp-get-arg-delete)) ", " + (dp-quote-comma (dp-get-arg-delete)) ", " + (dp-quote-comma (dp-get-arg-delete)) "}") + t)))) + +(defun dp-arg2 (command) + (replace-match (concat "@" command) t t nil) + (save-excursion + (insert + (dp-strip-newline + (concat + "{" (dp-quote-comma (dp-get-arg-delete)) ", " + (dp-quote-comma (dp-get-arg-delete)) "}") + t)))) + +(dp-defconvert 'dp-arg1 'i 'b 'loopref) +(defun dp-arg1 (command) + "Convert 1 arg commands." + (let ((p (make-marker))) + (replace-match (concat "@" command) t t nil) + (save-excursion + (search-backward "@") + (when (char-equal (preceding-char) ?{) + (forward-char -1) + (when (char-equal (preceding-char) ?\ ) + (set-marker p (scan-sexps (point) 1)) + (delete-char 1) + (goto-char p) + (delete-backward-char 1)))))) + + +(defun dp-f (command) + "Convert f commands." + (replace-match "") + (save-excursion + (let ((arg (replace-regexp-in-string + "~" "@tild{}" (dp-get-arg-delete)))) + (insert (concat "@f{" arg "}"))))) + +(dp-defconvert 'dp-arg0 'dots) +(defun dp-arg0 (command) + (replace-match (concat "@" command "{}") t t nil)) + + + +(dp-defconvert 'dp-delete-command + 'issue 'endissue 'bye 'endsubsubsubsubsection) + +(defun dp-delete-command (command) + (dp-delete-line)) + +(dp-defconvert 'dp-delete-command-1 'Vskip) +(defun dp-delete-command-1 (command) + (delete-region (point-at-bol) (point-at-eol))) + +(put 'code 'convert 'dp-translate) +(put 'code 'trans "@lisp") +(put 'endcode 'convert 'dp-translate) +(put 'endcode 'trans "@end lisp\n") + +(put 'noindent 'convert 'dp-translate) +(put 'noindent 'trans "@noindent\n") + +(put 't 'convert 'dp-translate) +(put 't 'trans "@code{t}") + +(defun dp-translate (command) + (replace-match (get (intern command) 'trans) t t nil)) + +(defun dp-strip-curly (str) + (let (p) + (with-current-buffer dp-work-buffer + (erase-buffer) + (insert str) + (dp-pm) + (skip-chars-forward " \n") + (delete-region (point-min) (point)) + (when (looking-at "{") + (setq p (scan-sexps (point) 1)) + (delete-char 1) + (goto-char p) + (delete-backward-char 1)) + (buffer-string)))) + +(defun dp-get-arg () + (dp-strip-curly (buffer-substring (point) (scan-sexps (point) 1)))) + +(defun dp-get-arg-delete () + (dp-strip-curly (delete-and-extract-region (point) + (scan-sexps (point) 1)))) + +;;; {\bf foo} \bar{\bf foo} + +(defun dp-brace-command (command) + (let (newbrace) + (replace-match "") + (when (char-equal (following-char) ?\ ) + (delete-char 1)) + (assert (char-equal (char-before) ?{)) + (search-backward "{") + (save-excursion + (backward-char) + (setq newbrace (looking-at "\\w"))) + (if newbrace + (progn + (save-excursion + (forward-sexp) + (insert "}")) + (forward-char) + (insert "@" command "{")) + (insert "@" command)))) + +;;; tables + +(defvar dp-current-fig-label nil) +(dp-defconvert 'dp-DefineFigure 'DefineFigure) +(defun dp-DefineFigure (command) + (replace-match "") + (setq dp-current-fig-label (dp-get-arg-delete))) + +(defun dp-get-rows (n) + (let ((str (dp-get-arg-delete)) + (continue t) + row rows p) + (with-current-buffer dp-work-buffer + (erase-buffer) + (insert str) + (dp-pm) + (while continue + (save-restriction + (narrow-to-region (point) (progn (search-forward "\\cr") + (point))) + (dp-pm) + (while (progn (setq p (point)) (search-forward "&" nil t)) + (push (dp-trim-whitespace + (buffer-substring p (1- (point)))) row)) + (setq p (point)) + (search-forward "\\cr") + (push (dp-trim-whitespace + (buffer-substring p (- (point) 3))) row) + (dotimes (i (- n (length row))) + (push "" row)) + (push (nreverse row) rows) + (setq row nil)) + (setq continue (save-excursion (search-forward "&" nil t))))) + (nreverse rows))) + +(defun dp-transpose (list) + (apply 'mapcar* (cons 'list list))) + +(defun dp-max-elems (list) + (let ((max "") max-list) + (dolist (row (dp-transpose list)) + (dolist (element row) + (when (> (length element) (length max)) + (setq max element))) + (push max max-list) + (setq max "")) + (nreverse max-list))) + +(put 'tablefigtwo 'num 2) +(put 'displaytwo 'num 2) +(put 'showtwo 'num 2) +(put 'tablefigthree 'num 3) +(put 'displaythree 'num 3) +(put 'showthree 'num 3) +(put 'tablefigfour 'num 4) +(put 'displayfour 'num 4) +(put 'displayfive 'num 5) +(put 'showfive 'num 5) +(put 'tablefigsix 'num 6) + +(dp-defconvert 'dp-table + 'tablefigtwo 'displaytwo 'showtwo + 'tablefigthree 'displaythree 'showthree + 'tablefigfour 'displayfour + 'displayfive 'showfive 'tablefigsix) + +(defvar dp-table-alist + '(("CharSyntaxTypesInStdSyntax" . (9 26 6 22)) + ("fig2.10" . (29 9 6 11 10)) + ("fig4.9" . (7 7 52)) + ("fig5.5" . (45 28)) + ("fig5.6" . (45 28)) + ("fig24.1" . (35 29)) + )) + +(defun dp-table (command) + (replace-match "") + (let ((n (get (intern command) 'num)) + (caption (dp-get-arg-delete)) + rows heads) + (when (string-match "tablefig" command) + (dotimes (i n) + (push (dp-get-arg-delete) heads)) + (setq heads (nreverse heads))) + (setq rows (dp-get-rows n)) + (when (null dp-current-fig-label) + (setq dp-current-fig-label + (format "fig%s.%d" dp-current-chapter-no (1+ dp-fig-no)))) + (incf dp-fig-no) + (save-excursion + (insert "\n@float Figure," dp-current-fig-label) + (insert "\n@cartouche\n") + (insert "@multitable") + (if (assoc dp-current-fig-label dp-table-alist) + (insert (mapconcat + (lambda (n) + (concat "{" (make-string n ?x) "}")) + (cdr (assoc dp-current-fig-label dp-table-alist)) "")) + (dolist (elem (dp-max-elems (if heads (cons heads rows) rows))) + (insert (format "{%s}" + (with-temp-buffer + (set-syntax-table dp-syntax-table) + (insert (dp-strip-newline elem t)) + (dp-pm) + (dp-convert) + (dp-pm) + (dp-hack-curly) + (buffer-string)))))) + (insert "\n") + (when heads + (insert "@headitem " (mapconcat 'identity heads " @tab "))) + (dolist (row rows) + (insert "\n@item " (mapconcat 'identity row " @tab "))) + (insert "\n@end multitable\n") + (insert "@end cartouche\n") + (insert "@caption{" caption "}\n") + (insert "@end float\n"))) + (setq dp-current-fig-label nil)) + +(dp-defconvert 'dp-quadrant 'dpquadrant) +(defun dp-quadrant (command) + (incf dp-fig-no) + (replace-match "@quadrant{}")) + +(dp-defconvert 'dp-tabletwo 'tabletwo) +(defun dp-tabletwo (command) + "Table in the Glossary." + (let (head rows) + (replace-match "") + (insert "\n@multitable @columnfractions 0.25 0.7\n") + (insert "\n@headitem " (dp-get-arg-delete) "@tab " (dp-get-arg-delete) "\n") + (save-excursion + (while (re-search-forward "\\entry{\\([^}]*\\)}{\\([^}]*\\)}" nil t) + (push (list (match-string 1) (match-string 2)) rows))) + (setq rows (nreverse rows)) + (dp-get-arg-delete) + (save-excursion + (dolist (row rows) + (insert "\n@item " (mapconcat 'identity row " @tab "))) + (insert "\n@end multitable\n")))) + +(dp-defconvert 'dp-simplecaption 'simplecaption) +(defun dp-simplecaption (command) + (replace-match "") + (let ((arg (dp-get-arg-delete))) + (save-excursion + (search-backward "@lisp") + (insert + (format "@float Figure,fig%s.%d\n" dp-current-chapter-no + (incf dp-fig-no)))) + (insert "@caption{" arg "}\n@end float\n"))) + +;;; Dictionary entries + +(defvar dp-com-duplicates + '("lambda" "function" "nil" "not" "t" "eql" + "and" "or" "values" "error" "abort" "continue" + "muffle-warning" "store-value" "use-value" + "mod" "complex" "rational" "float" + "cons" "atom" "list" "null" "member" "initialize-instance" + "vector" "bit" "string" "pathname" "shared-initialize" + "logical-pathname" "character" "-" "+" "*" "/" "1-" "time") + + "Duplicate node names aren't allowed in Texinfo. +We must prepend the type to these nodes.") + +(defvar dp-anchors nil) + +(dp-defconvert 'dp-begincom 'begincom) +(defun dp-begincom (command) + "Beginning of a dictionary entry." + (let (node-name dname type beg names) + (setq beg (point-at-bol)) + (setq dname (dp-remove-whitespace (dp-get-arg))) + (search-forward "\\ftype") + (setq type (dp-get-arg)) + (delete-region beg (scan-sexps (point) 1)) + (setq node-name + (subst-char-in-string + ?, ?\; + (replace-regexp-in-string "[()]" "" dname) t)) + (when (> (length node-name) 72) + (setq node-name (concat (substring node-name 0 71) "+"))) + (unless dp-dictionary-p + (setq dp-dictionary-p t) + (push 'Dictionary dp-nodes)) + (when (member node-name dp-com-duplicates) + (setq node-name (concat node-name " (" type ")"))) + (push node-name dp-nodes) + (insert "@node " node-name "\n") + (insert "@heading " dname " (" type ")\n") + (setq names (split-string dname ", *")) + (dolist (name names) + (insert "@syindex " name "\n") + (insert "@cindex " name "\n")) + (when (> (length names) 1) + (dolist (name names) + (insert "@anchor{" name "}\n") + (push name dp-anchors))))) + +(dp-defconvert 'dp-endcom 'endcom) +(defun dp-endcom (command) + (setq dp-current-label nil) + (dp-delete-line)) + +(dp-defconvert 'dp-label 'label) +(defun dp-label (command) + (let (label) + (skip-chars-forward " ") + (setq label (buffer-substring + (point) (search-forward ":"))) + (if (looking-at "\\\\None.") + (progn + (dp-delete-line) + (delete-region (point-at-bol) + (progn + (skip-chars-forward " \n\t") + (point)))) + (dp-delete-line) + (setq dp-current-label label) + (insert "@subsubheading " label "\n")))) + +;; Sections, chapters + +(defvar dp-chapter-name-alist nil) + +(defvar dp-section-names nil) +(defun dp-get-section-names () + (setq dp-section-names nil) + (setq dp-chapter-name-alist nil) + (let (label name) + (with-temp-buffer + (insert-file-contents "setup-sections.tex") + (dp-pm) + (while (re-search-forward "\\\\def\\\\\\([^{]+\\)" nil t) + (setq label (match-string 1)) + (setq name (subst-char-in-string ?: ?. (replace-regexp-in-string "[{}]" "" (dp-get-arg)) t)) + (push (cons label name) dp-section-names) + (when (<= (length (split-string name "\\.")) 3) + (string-match "(\\([^)]+\\))" name) + (push (cons label (match-string 1 name)) dp-chapter-name-alist))) + (erase-buffer) + (insert-file-contents "setup-figures.tex") + (dp-pm) + (while (re-search-forward "\\\\def\\\\\\([^{]+\\)" nil t) + (setq label (match-string 1)) + (setq name (subst-char-in-string + ?~ ?\ (replace-regexp-in-string "--" "." (dp-get-arg)) t)) + (push (cons label name) dp-section-names))))) + +(dp-defconvert 'dp-beginchapter 'beginchapter) +(defun dp-beginchapter (command) + (setq dp-current-chapter-no (dp-get-arg-delete)) + (let ((name (dp-get-arg-delete)) + (ref-name (dp-get-arg-delete))) + (dp-delete-line) + (insert "@node " name "\n") + (if (string= dp-current-chapter-no "A") + (insert "@appendix " name "\n") + (insert "@chapter " name "\n")) + (setq dp-current-chapter name) + (setq dp-current-chapter-marker (point)) + (push name dp-chapter-list) + (message "Converting %s" name))) + +(dp-defconvert 'dp-endchapter 'endchapter) +(defun dp-endchapter (command) + (save-excursion + (dp-delete-line) + (goto-char dp-current-chapter-marker) + (when dp-nodes + (insert "@menu\n") + (setq dp-nodes (nreverse dp-nodes)) + (dolist (node dp-nodes) + (if (symbolp node) + (insert (format "\n%s\n\n" node)) + (insert "* " node "::\n"))) + (insert "@end menu\n")) + (setq dp-current-chapter nil + dp-current-chapter-marker nil + dp-nodes nil + dp-dictionary-p nil + dp-fig-no 0 + dp-section-no 0))) + +(dp-defconvert 'dp-beginsection 'beginSection) +(defun dp-beginsection (command) + (let ((name (subst-char-in-string ?, ?\; (dp-get-arg) t))) + (setq dp-current-section-name name) + (push name dp-nodes) + (dp-delete-line) + (insert "@node " name "\n" + "@section " name "\n") + (incf dp-section-no) + (setq dp-current-section-marker (point)))) + +(defvar dp-subsections-list nil) + +(dp-defconvert 'dp-endsection 'endSection) +(defun dp-endsection (command) + (dp-delete-line) + (setq dp-subsection-no 0) + (setq dp-subsubsection-no 0) + (setq dp-subsubsubsection-no 0) + (save-excursion + (goto-char dp-current-section-marker) + (when dp-subsections-list + (when (search-forward "@node" nil t) + (goto-char (point-at-bol)) + (insert "@menu\n") + (setq dp-subsections-list (nreverse dp-subsections-list)) + (dolist (node dp-subsections-list) + (insert "* " node "::\n")) + (insert "@end menu\n")))) + (setq dp-subsections-list nil)) + +(dp-defconvert 'dp-beginsubsection + 'beginsubsection + 'beginSubsection + 'beginsubSection) + +(defun dp-beginsubsection (command) + (let ((name (dp-get-arg))) + (setq name + (with-temp-buffer + (set-syntax-table dp-syntax-table) + (insert name) + (goto-char (point-min)) + (dp-convert) + (buffer-string))) + (setq dp-current-section-name name) + (dp-delete-line) + (insert "@node " name "\n") + (push name dp-subsections-list) + (insert "@subsection " name "\n") + (incf dp-subsection-no))) + +(dp-defconvert 'dp-endsubsection + 'endSubsection 'endsubsection 'endSubsection + 'endsubSection) + +(defun dp-endsubsection (command) + (dp-delete-line) + (setq dp-subsubsection-no 0 + dp-subsubsubsection-no 0)) + +(dp-defconvert 'dp-beginsubsubsection 'beginsubsubsection) +(defun dp-beginsubsubsection (command) + (let ((name (dp-get-arg))) + (setq name + (with-temp-buffer + (set-syntax-table dp-syntax-table) + (insert name) + (goto-char (point-min)) + (dp-convert) + (buffer-string))) + (dp-delete-line) + (insert "@subsubsection " name "\n") + (incf dp-subsubsection-no))) + +(dp-defconvert 'dp-endsubsubsection 'endsubsubsection) +(defun dp-endsubsubsection (command) + (dp-delete-line) + (setq dp-subsubsubsection-no 0)) + +(dp-defconvert 'dp-beginsubsubsubsection'beginsubsubsubsection) +(defun dp-beginsubsubsubsection (command) + (replace-match "") + (let ((name (dp-get-arg-delete))) + (setq dp-current-section-name name) + (insert + (format "@unnumberedsubsubsec %s.%d.%d.%d.%d %s\n" + dp-current-chapter-no + dp-section-no dp-subsection-no + dp-subsubsection-no + (incf dp-subsubsubsection-no) name)))) + +(dp-defconvert 'dp-endsubsubsubsection 'endsubsubsubsection) +(defun dp-endsubsubsubsection (command) + (dp-delete-line) + (setq dp-subsubsubsubsection-no 0)) + +(dp-defconvert 'dp-beginsubsubsubsubsection 'beginsubsubsubsubsection) +(defun dp-beginsubsubsubsubsection (command) + (replace-match "") + (let ((name (dp-get-arg-delete))) + (setq dp-current-section-name name) + (insert + (format "@unnumberedsubsubsec %s.%d.%d.%d.%d.%d %s\n" + dp-current-chapter-no + dp-section-no dp-subsection-no + dp-subsubsection-no + dp-subsubsubsection-no + (incf dp-subsubsubsubsection-no) name)))) + +(dp-defconvert 'dp-definesection 'DefineSection) +(defun dp-definesection (command) + (replace-match "") + (let ((name (dp-get-arg-delete))) + (unless (string= name dp-current-section-name) + (insert "@anchor{" name "}") + (push name dp-anchors)))) + +(dp-defconvert 'dp-vskip 'vskip) +(defun dp-vskip (command) + (replace-match "") + (delete-region (point) (search-forward "pt"))) + +;; multi + +(dp-defconvert 'dp-defun-multi-with-values 'DefunMultiWithValues) +(defun dp-defun-multi-with-values (command) + (replace-match "") + (let ((arg1 (dp-quote-comma (dp-get-arg-delete))) + (arg2 (dp-quote-comma (dp-get-arg-delete))) + (arg3 (dp-get-arg-delete)) + entries) + (with-temp-buffer + (insert arg3) + (dp-pm) + (while (search-forward "\\entry" nil t) + (push (dp-get-arg) entries))) + (setq entries (nreverse entries)) + (save-excursion + (dolist (entry entries) + (insert "@DefunWithValues{" entry ", " arg1 ", " arg2 "}\n"))))) + +(dp-defconvert 'dp-defun-multi-accessor-with-values 'DefunMultiAccessorWithValues) +(defun dp-defun-multi-accessor-with-values (command) + (replace-match "") + (let ((arg1 (dp-get-arg-delete)) + (arg2 (dp-get-arg-delete)) + (arg3 (dp-get-arg-delete)) + (arg4 (dp-get-arg-delete)) + entries) + (with-temp-buffer + (insert arg4) + (dp-pm) + (while (re-search-forward (rx (or "\\entry" "\\blankline")) nil t) + (when (string= (match-string 0) "\\entry") + (push (dp-get-arg) entries)))) + (setq entries (nreverse entries)) + (save-excursion + (dolist (entry entries) + (insert entry " " arg1 " @EV{} " arg2 " | (setf (" arg1 " " arg2 ") " arg3 ")@*\n")) + (insert "@*\n")))) + +(dp-defconvert 'dp-defsetf-multi 'DefsetfMulti) +(defun dp-defsetf-multi (command) + (replace-match "") + (let ((arg1 (dp-get-arg-delete)) + (arg2 (dp-get-arg-delete)) + (arg3 (dp-get-arg-delete)) + entries) + (with-temp-buffer + (insert arg3) + (dp-pm) + (while (search-forward "\\entry" nil t) + (push (dp-get-arg) entries)) + (setq entries (nreverse entries)) + (save-excursion + (dolist (entry entries) + (insert "@defsetf{" entry ", " arg1 ", " arg2 "}@*\n")) + (insert "@*\n"))))) + +(dp-defconvert 'dp-docmethods 'DocMethods) +(defun dp-docmethods (command) + (replace-match "") + (let ((arg1 (dp-get-arg-delete)) + (arg2 (dp-get-arg-delete)) + entries) + (with-temp-buffer + (insert arg2) + (dp-pm) + (while (search-forward "\\Meth" nil t) + (push (list (dp-get-arg) (dp-get-arg)) entries))) + (save-excursion + (insert arg1 "\n\n") + (dolist (entry entries) + (insert "documentation (@var{x} @code{" (car entry) + "}) (@var{doc-type} @f{(eql '" (cadr entry) + ")}) " (cadr entry) "\n\n" )) + (dolist (entry entries) + (insert "(setf documentation) @var{new-value} (@var{x} @code{" + (car entry) "}) (@var{doc-type} @f{(eql '" + (cadr entry) ")}) " (cadr entry) "\n\n"))))) + +(dp-defconvert 'dp-Defmeth 'Defmeth) +(defun dp-Defmeth (command) + (replace-match "")) + +;;; Glossary + +(dp-defconvert 'dp-indextab 'indextab) +(defun dp-indextab (command) + (let ((arg (dp-get-arg))) + (push arg dp-nodes) + (dp-delete-line) + (insert "\n@end table\n" + "@node " arg "\n" + "@unnumberedsec " arg "\n" + "@table @asis\n"))) + +(dp-defconvert 'dp-firstindextab 'firstindextab) +(defun dp-firstindextab (command) + (let ((arg (dp-get-arg))) + (push arg dp-nodes) + (dp-delete-line) + (insert "@node " arg "\n" + "@unnumberedsec " arg "\n" + "@table @asis\n"))) + +(dp-defconvert 'dp-gentry 'gentry) +(defun dp-gentry (command) + (replace-match "") + (let ((arg (dp-get-arg-delete))) + (insert "@item @b{" arg "} @anchor{glos-" arg "}\n") + (push (concat "glos-" arg) dp-anchors))) + +;;; Lists + +(dp-defconvert 'dp-beginlist 'beginlist) +(defun dp-beginlist (command) + (let (arg) + (save-excursion + (re-search-forward (rx (or "\\itemitem" "\\item"))) + (setq arg (dp-get-arg)) + (cond ((string= arg "1.") + (push 'enumerate dp-list-type) + (setq arg "1")) + ((string= arg "a.") + (push 'enumerate dp-list-type) + (setq arg "a")) + ((string= arg "--") + (push 'itemize dp-list-type)) + ((string= arg "\\bull") + (push 'itemize dp-list-type) + (setq arg "@bullet{}")) + (t + (push 'table dp-list-type)))) + (dp-delete-line) + (ecase (car dp-list-type) + (enumerate (insert "\n@enumerate " arg "\n")) + (itemize (insert "\n@itemize " arg "\n")) + (table (insert "\n@table @asis\n"))))) + +(dp-defconvert 'dp-endlist 'endlist) +(defun dp-endlist (command) + (dp-delete-line) + (when (save-excursion ;; i.e. `looking-back' + (re-search-backward "\\(?:\n\n\\)\\=" nil t)) + (delete-char -1)) + (ecase (pop dp-list-type) + (enumerate (insert "@end enumerate\n\n")) + (itemize (insert "@end itemize\n\n")) + (table (insert "@end table\n\n")))) + +(dp-defconvert 'dp-item 'itemitem 'item) +(defun dp-item (command) + (let (arg) + (ecase (car dp-list-type) + ((enumerate itemize) + (delete-region (point-at-bol) (scan-sexps (point) 1)) + (insert "@item")) + (table + (replace-match "@item" nil t) + (setq arg (dp-strip-newline (dp-get-arg-delete))) + (save-excursion + (insert " " "@id{" arg "}\n")))))) + +;;; Cross references + +(defvar dp-funref-name-alist + '(("bit" . "bit") + ("list" . "list") + ("member" . "member") + ("rational" ."rational") + ("use-value" . "use-value") + ("store-value" . "store-value") + ("continue" . "continue") + ("abort" . "abort") + ("muffle-warning" ."muffle-warning") + ("values" . "values (Accessor)") + ("shared-initialize" . "shared-initialize (Standard Generic Function)") + ("initialize-instance" . "initialize-instance (Standard Generic Function)"))) + +(dp-defconvert 'dp-varref + 'varref 'seevar 'Seevar + 'specref 'seespec 'Seespec + 'macref 'seemac 'Seemac + 'typeref 'seetype 'Seetype + 'conref 'declref + 'funref 'seefun 'Seefun + 'seefuns 'Seefuns 'function + 'misc 'seemisc 'Seemisc + 'packref + 'seeterm 'Seeterm 'SeetermAlso 'seetermAlso) + +(defun dp-varref (command) + (replace-match "") + (setq command (intern command)) + (let* ((arg (dp-get-arg-delete)) + (link arg)) + (when (member arg dp-com-duplicates) + (setq + link + (ecase command + ((seefun Seefun seefuns Seefuns function funref) + (if (assoc arg dp-funref-name-alist) + (cdr (assoc arg dp-funref-name-alist)) + (concat arg " (Function)"))) + ((specref seespec Seespec) + (concat arg " (Special Operator)")) + ((seemac Seemac macref) + (concat arg " (Macro)")) + ((seetype Seetype typeref) + (concat arg " (System Class)")) + (conref + (concat arg " (Constant Variable)")) + (declref + (concat arg " (Type Specifier)")) + ((misc seemisc Seemisc) + (concat arg " (Symbol)")) + ((Seeterm seeterm SeetermAlso seetermAlso) + arg) + ))) + (if (memq command '(seeterm Seeterm SeetermAlso seetermAlso)) + (setq link (concat "@ref{glos-" arg ", " arg "}")) + (setq link (concat "@ref{" link "}"))) + (ecase command + (seefun (insert "see the @term{function} " link)) + (Seefun (insert "See the @term{function} " link)) + (seefuns (insert "see the @term{functions} " link)) + (Seefuns (insert "See the @term{functions} " link)) + (seevar (insert "see the @term{variable} " link)) + (Seevar (insert "See the @term{variable} " link)) + (seespec (insert "see the @term{special operator} " link)) + (Seespec (insert "See the @term{special operator} " link)) + (seemac (insert "see the @term{macro} " link)) + (Seemac (insert "See the @term{macro} " link)) + (seetype (insert "see the @term{type} " link)) + (Seetype (insert "See the @term{type} " link)) + (seemisc (insert "see " link)) + (Seemisc (insert "See " link)) + (Seeterm (insert "See " link)) + (seeterm (insert "see " link)) + (SeetermAlso (insert "See also " link)) + (seetermAlso (insert "see also " link)) + ((varref specref macref typeref conref declref funref function) + (if (string= dp-current-label "See Also:") + (insert link) + (insert "@code{" arg "}"))) + (misc + (if (string= dp-current-label "See Also:") + (insert link) + (insert "@t{" arg "}"))) + (packref + (setq arg (upcase arg)) + (if (string= dp-current-label "See Also:") + (insert "@ref{" arg "}") + (insert "@code{" arg "}"))) + ))) + +(dp-defconvert 'dp-seeref + 'seechapter 'Seechapter + 'seefigure 'Seefigure + 'seesection 'Seesection + 'secref 'chapref + 'figref 'Figref) + +(defun dp-seeref (command) + (let (arg text) + (save-match-data + (re-search-forward "\\\\\\(\\w+\\)") + (setq arg (match-string 1)) + (replace-match "")) + (setq text (cdr (assoc arg dp-section-names))) + (assert text) + (when (assoc arg dp-chapter-name-alist) + (setq arg (cdr (assoc arg dp-chapter-name-alist)))) + (ecase (intern command) + ((seechapter seefigure seesection) + (replace-match (concat "see @ref{" arg ", " text "}") t t nil)) + ((Seechapter Seefigure Seesection) + (replace-match (concat "See @ref{" arg ", " text "}") t t nil)) + ((figref Figref chapref secref) + (replace-match (concat "@ref{" arg ", " text "}") t t nil))) + (when (looking-at "}") + (save-excursion + (goto-char + (prog1 + (scan-sexps (1+ (point)) -1) + (replace-match ""))) + (delete-char 1))))) + +(dp-defconvert 'dp-thepackage 'thepackage 'Thepackage) +(defun dp-thepackage (command) + (replace-match "") + (let ((arg (dp-get-arg-delete))) + (if (eq (aref command 0) ?T) + (insert "T") + (insert "t")) + (insert "he @code{" (upcase arg) "} @term{package}"))) + +;;; Index entries + +(dp-defconvert 'dp-idx + 'idxref 'idxterm 'idxtext 'idxexample + 'idxpackref 'idxcode 'idxkwd 'idxkeyref) + +(defun dp-idx (command) + (replace-match "") + (let ((arg (dp-get-arg-delete))) + (dp-freshline) + (insert + "@cindex " + (case (intern command) + (idxkeyref (concat "&" arg)) + (idxpackref (upcase arg)) + (idxkwd (concat ":" arg)) + (t arg))) + (unless (eolp) + (skip-chars-forward " ") + (insert "\n")))) + +(dp-defconvert 'dp-newtermidx 'newtermidx) +(defun dp-newtermidx (command) + (replace-match "") + (let ((arg1 (dp-get-arg-delete)) + (arg2 (dp-get-arg-delete))) + (dp-freshline) + (insert "@cindex " arg2 "\n") + (insert "@dfn{" arg1 "}"))) + +;;; $ + +(defun dp-hack-$ () + "Convert math environments." + (dp-pm) + (while (search-forward "$$" nil t) + (replace-match "\n@quotation\n\\\\mat{") + (search-forward "$$") + (replace-match "}\n@end quotation\n")) + (dp-pm) + (while (re-search-forward + (rx (and (+ "$") (group (* (not (in "$")))) (+ "$"))) nil t) + (replace-match "\\\\mat{\\1}" t))) + +;;; Subscripts + +(defvar dp-sub-alist + '((?0 . "@sub0{}") + (?1 . "@sub1{}") + (?2 . "@sub2{}") + (?3 . "@sub3{}") + (?4 . "@sub4{}") + (?5 . "@sub5{}") + (?6 . "@sub6{}") + (?7 . "@sub7{}") + (?8 . "@sub8{}") + (?9 . "@sub9{}"))) + +(dp-defconvert 'dp-sub 'sub) +(defun dp-sub (command) + (let (arg) + (replace-match "") + (delete-region (point) (progn (skip-chars-forward " \n") (point))) + (if (char-equal (following-char) ?{) + (setq arg (dp-get-arg-delete)) + (setq arg + (delete-and-extract-region + (point) + (progn + (skip-chars-forward "a-zA-Z0-9 ") + (point))))) + (setq arg (dp-trim-whitespace arg)) + (if (string-match "^[0-9]+$" arg) + (insert (mapconcat (lambda (char) + (cdr (assoc char dp-sub-alist))) + arg "")) + (if (= (length arg) 1) + (insert "@subs1{" arg "}") + (save-excursion + (insert "@subs{" arg "}")))))) + +(dp-defconvert 'dp-meaning 'meaning) +(defun dp-meaning (command) + (replace-match "") + (let ((arg (dp-get-arg-delete))) + (if (string-match "^[0-9]+$" arg) + (insert (mapconcat (lambda (char) + (cdr (assoc char dp-sub-alist))) + arg "")) + (insert "[" arg "]")))) + +;;; Credits + +(defun dp-hack-credits () + "Do the Credits chapter." + (save-excursion + (goto-char (point-min)) + (search-forward "\\goodbreak" nil nil 2) + (delete-region (point-min) (point)) + (push "Credits" dp-chapter-list) + (insert "@node Credits\n" + "@unnumbered Credits\n" + "@editors\n") + (dp-hack-credits-1 3 3 "Edit and Review History:" "0.15 0.15 0.7") + (dp-hack-credits-1 2 3 "Ad Hoc Group Chairs:" "0.5 0.5") + (dp-hack-credits-1 2 4 "Major Administrative Contributions:" "0.5 0.5") + (dp-hack-credits-1 3 3 "Major Technical Contributions:" "0.33 0.33 0.33") + (dp-hack-credits-1 2 3 "Participating Companies and Organizations:" "0.5 0.5") + (dp-hack-credits-1 3 3 "Individual Participants:" "0.33 0.33 0.33"))) + +(defun dp-hack-credits-1 (columns delete heading fractions) + (search-forward "$$") + (dp-delete-line delete) + (insert "@subheading " heading "\n") + (insert "@multitable @columnfractions " fractions "\n") + (save-restriction + (narrow-to-region (point) (search-forward "$$")) + (goto-char (point-min)) + (insert "{") + (goto-char (point-max)) + (insert "}") + (goto-char (point-min)) + (dolist (row (dp-get-rows columns)) + (insert "\n@item " (mapconcat 'identity row " @tab ")))) + (re-search-forward "\\$\\$}") + (replace-match "\n@end multitable")) + +;;; + +(defun dp-insert () + "Handle include directives." + (let (file) + (dp-pm) + (while (re-search-forward "^[^%]*\\\\\\input \\([^ \t%\n]+\\)" nil t) + (setq file (concat (match-string 1) ".tex")) + (dp-delete-line) + (unless (string= file "setup.tex") + (save-restriction + (narrow-to-region (point) (point)) + (insert-file-contents-literally file)))) + (dp-pm) + (while (search-forward "\\includeDictionary" nil t) + (setq file (concat (dp-get-arg-delete) ".tex")) + (dp-delete-line) + (save-restriction + (narrow-to-region (point) (point)) + (insert-file-contents-literally file))))) + +(defun dp-hack-curly () + "This is just a band-aid for not parsing TeX curlies well enough. +Yuck." + (let (multi (p (make-marker))) + (while (search-forward "{" nil t) + (save-excursion + (forward-char -1) + (skip-chars-backward "a-zA-Z0-9") + (if (looking-at "multitable") + (setq multi t) + (unless (char-equal (preceding-char) ?@) + (search-forward "{") + (forward-char -1) + (set-marker p (scan-sexps (point) 1)) + (delete-char 1) + (goto-char p) + (delete-backward-char 1)))) + (when multi + (forward-line) + (setq multi nil))))) + +(defun dp-quote-special () + "Deal with character that special in either Tex or Texinfo." + (let ((alist + '(("@" . "@@") ("\\ " . "@spc{}") + ("\\," . "") ("\\\\" . "@bsl{}") + ("\\_" . "_") ("\\&" . "@ampers{}") + ("\\#" . "#") ("\\$" . "@dollar{}") + ("\\%" . "@percent{}") ("\\{" . "@lcurly{}") + ("\\}" . "@rcurly{}") ("\\/" . "") + ("$-$" . "-") ("$+$" . "+") + ("\\\n" . "\n") ("\t" . "")))) + (dolist (elem alist) + (dp-pm) + (while (search-forward (car elem) nil t) + (replace-match (cdr elem) t t nil))))) + +;;; Annoying cases + +(defun dp-substitute (table) + (dolist (row table) + (dp-pm) + (while (re-search-forward (concat "\\(\\\\" (car row) "\\)\\W") nil t) + (replace-match (cdr row) t t nil 1)))) + +(defvar dp-charsyntaxtypes-table + '(("w" . "@term{whitespace}@sub2{}") + ("n" . "@term{non-terminating} @term{macro char}") + ("t" . "@term{terminating} @term{macro char}") + ("c" . "@term{constituent}") + ("C" . "@term{constituent}*") + ("SE" . "@term{single escape}") + ("ME" . "@term{multiple escape}"))) + +(defvar dp-sharpsign-table + '(("u" . "undefined") + ("s" . "signals error") + ("ia" . "infix argument"))) + +(defvar dp-constituent-table + '(("a" . "@term{alphabetic}@sub2{}") + ("ad" . "alphadigit") + ("i" . "@term{invalid}") + ("pm" . "@term{package marker}"))) + +(defun dp-search-delete (str n) + "Search for STR from bob and delete N lines." + (dp-pm) + (when (search-forward str nil t) + (dp-delete-line n) t)) + +(defun dp-special-cases () + "Handle special cases. +This would probably be better done with a diff. Oh, well." + (dp-pm) + (search-forward "$$ \\ff{arctanh} z = {{\\ff{log} (1+z) - \\ff{log} (1-z)}\\over{2}}. $$ ") + (dp-delete-line) + (insert "$$ \\ff{arctanh} z = (\\ff{log} (1+z) - \\ff{log} (1-z))/2. $$ ") + (dp-pm) + (search-forward "$$ \\ff{arctan} z = {{\\ff{log} (1+iz) - \\ff{log} (1-iz)}\\over{2i}} $$") + (dp-delete-line) + (insert "$$ \\ff{arctan} z = (\\ff{log} (1+iz) - \\ff{log} (1-iz))/2i $$") + (dp-pm) + (while (re-search-forward "}\\( *-- *\\)[^-]" nil t) + (replace-match "---" t t nil 1)) + (dp-pm) + (while (search-forward "\\\"u" nil t) + (replace-match "\\uumlaut{}" t t)) + (dp-pm) + (while (dp-search-delete "\\noalign{\\vskip " 1)) + (dp-pm) + (search-forward "Defun floatp") + (replace-match "DefunWithValues floatp") + (dp-pm) + (search-forward "Defun find-restart") + (replace-match "DefunWithValues find-restart") + (dp-pm) + (search-forward "constructor-function-name" nil t) ;; dict-structures + (forward-line -2) + (dp-delete-line 8) + (insert + "\\code + (constructor-function-name + slot-keyword1 form-1 + slot-keyword2 form-2 + ...) +\\endcode") + (dp-pm) + (while (search-forward "\\item{{" nil t) + (forward-char -2) + (save-excursion + (forward-sexp) + (delete-char -1)) + (delete-char 1)) + (dp-pm) + (search-forward "{\\def\\Qfont" nil t) + (dp-delete-line 16) + (insert "\\dpquadrant\n") + ;; dict-numbers + (dp-search-delete "\\def\\realtypespec" 20) + ;; dict-numbers + (dp-search-delete "\\def\\Result{" 3) + (dp-pm) ;; dict-numbers + (search-forward "\\def\\zz" nil t) + (forward-line -1) + (dp-delete-line 6) + (search-forward "}\n}" nil t) + (dp-delete-line) + (dp-search-delete "\\def\\alfa" 1) + ;; dict-conses + (dp-search-delete "\\def\\SatisfyTest" 3) + (dp-pm) ;; dict-arrays + (search-forward "\\tabskip 2\\dimen" nil t) + (forward-line -2) + (dp-delete-line 7) + (insert "\\tablefigtwo{Bit-wise Logical Operations on Bit Arrays} +{Function}{Operation}{") + (search-forward "\\caption{Bit-wise") + (dp-delete-line 3) + (insert "}") + (dp-pm) + (search-forward "\\beginsubsubsubsection{Open and Closed Streams}" nil t) + (forward-line) + (dp-delete-line) + ;; concept-files + (dp-search-delete "\\DefineSection{Truenames}" 1) + ;; dict-streams + (dp-search-delete "\\def\\ExplainRecursiveP" 3) + ; concept-format + (dp-search-delete "\\def\\Partial" 1) + ;; dict-printer + (dp-search-delete "\\def\\writekeys" 35) + (dp-pm) + (while (search-forward "#\\b" nil t) ;; bug in dict-printer.tex + (replace-match "#@backslash{}b" t t nil)) + ;; concept-systems + (dp-search-delete "\\DefineSection{Features" 1) + (dp-pm) ;; concept-systems + (search-forward "#+spice" nil t) + (save-restriction + (narrow-to-region (point) (progn (forward-line 28) (point))) + (dp-pm) + (while (search-forward "\\span" nil t) + (replace-match "&")) + (dp-pm)) + ;; dict-environment + (dp-search-delete "\\def\\DocMethods" 6) + ;; concetp-environment + (dp-search-delete "\\DefineSection{Time" 1) + (dp-pm) + ;; dict-objects + (dp-search-delete "$$\\vbox{\\halign{\\strut" 8) + (insert "@initargs{}\n") + (dp-search-delete "\\def\\GFauxOptionsAndMethDesc" 12) ;; dict-objects + (dp-pm) + (while (search-forward "\\!" nil t) + (replace-match "")) + (dp-pm) ;; dict-objects + (search-forward "A \\macref{with-accessors} expression" nil t) + (forward-line 2) + (dp-delete-line 19) + (insert "\\withaccessors\n") + (search-forward "A \\macref{with-slots} expression" nil t) + (forward-line 2) + (dp-delete-line 31) + (insert "\\withslots\n") + (search-forward "\\begincom{defclass" nil t) + (forward-line 11) + (dp-delete-line 24) + (insert "\\defclass\n") + (dp-pm) + (search-forward "\\begincom{defmethod" nil t) + (forward-line 16) + (dp-delete-line 26) + (insert "\\defmethod\n") + (dp-pm) ;; concept-loop + (search-forward "\\kern-7pt" nil t) + (replace-match "") + (dp-search-delete "\\def\\subOne" 2) ;; dict-flow + (dp-pm) ;; concept-bvl + (search-forward "{\\def\\TVar{\\curly" nil t) + (forward-line -1) + (dp-delete-line 9) + (insert "\\macrolambdalist\n") + (search-forward "\\Vskip 1pc!") + (forward-line -1) + (dp-delete-line 2) + (dp-pm) + (while (search-forward "\\vfill" nil t) + (dp-delete-line)) + (dp-pm) + (search-forward "\\beginSection{Introduction}" nil t) + (replace-match "\\beginSection{Introduction to Types and Classes}" t t) + ;; concept-compile + (dp-pm) + (search-forward "\\offinterlineskip" nil t) + (forward-line -3) + (dp-delete-line 9) + (insert "\\tablefigsix{EVAL-WHEN processing}{\\b{CT}}{\\b{LT}}{\\b{E}}{\\b{Mode}}{\\b{Action}}{\\b{New Mode}}{") + (search-forward "\\endfig") + (forward-line) + (dp-delete-line -3) + (insert "}") + (dp-search-delete "\\def\\sim#1#2#3" 1) + (dp-pm) + (search-forward "{\\def\\TVar{\\curly" nil t) + (forward-line -1) + (dp-delete-line 9) + (insert "\\dmacrolambdalist\n") + (search-forward "\\Vskip") + (forward-line -1) + (dp-delete-line 2) + (dp-pm) + (search-forward "\\DefineFigure{CharSyntaxTypesInStdSyntax}" nil t) + (forward-line 1) + (dp-delete-line 8) + (save-restriction + (narrow-to-region + (point) + (progn + (re-search-forward "^}}") + (delete-char -1) + (point))) + (dp-pm) + (dp-substitute dp-charsyntaxtypes-table)) + (dp-pm) + (search-forward "{\\def\\u{undefined}" nil t) + (dp-delete-line 3) + (save-restriction + (narrow-to-region + (point) + (progn + (re-search-forward "^}}") + (delete-char -1) + (point))) + (dp-pm) + (dp-substitute dp-sharpsign-table)) + (dp-pm) + (search-forward "\\DefineFigure{ConstituentTraitsOfStdChars}" nil t) + (forward-line 1) + (dp-delete-line 13) + (insert "\\displayfour{Constituent Traits of Standard Characters and Semi-Standard Characters}{\n") + (insert "\\b{constituent}&\\b{traits}&\\b{constituent}&\\b{traits}\\cr\n") + (insert "\\b{characters}&&\\b{characters}\\cr\n") + (save-restriction + (narrow-to-region (point) + (progn + (search-forward "\\endfig") + (forward-line -2) + (dp-delete-line 3) + (insert "}") + (point))) + (dp-pm) + (dp-substitute dp-constituent-table)) + (dp-pm) + (search-forward "\\DefineFigure{SyntaxForNumericTokens}" nil t) + (forward-line 1) + (dp-delete-line 6) + (insert "\\showthree{Syntax for Numeric Tokens}{") + (search-forward "\\param{sign}---") + (goto-char (point-at-bol)) + (insert "}\n") + (search-forward "\\endfig") + (forward-line -2) + (dp-delete-line 3) + (dp-pm) + (search-forward "\$\\vert\\;\$" nil t) + (replace-match "|") + (dp-pm) + (search-forward "\\beginSection{Glossary}" nil t) + (dp-delete-line 1) + (insert "\\beginSection{Glossary Notation}\n") + (search-forward "\\def\\gentry" nil t) + (dp-delete-line 20) + (search-forward "\\firstindextab") + (forward-line -2) + (dp-delete-line 1) + (search-forward "\\seeterm\\term") + (replace-match "\\seeterm" t t) + (search-forward "\\endlist") + (dp-delete-line 2) + (insert "@end table\n") + (dp-pm) + (search-forward "\\begincom{deftype}" nil t) + (save-restriction + (narrow-to-region (point) (search-forward "\\endcom")) + (dp-pm) + (while (re-search-forward "\\$\\\\sub{\\(.\\)}\\$" nil t) + (replace-match "_\\1"))) + (dp-pm) + (search-forward "\\DefineSection{DeterminingtheEffectiveMethod" nil t) + (save-restriction + (narrow-to-region (point) (search-forward "\\endlist")) + (dp-pm) + (while (re-search-forward "\\(\\\\itemitem{..}\\){\\([^}]+\\)}" nil t) + (replace-match "\\1 \\2"))) + (dp-pm) + (search-forward "unbound-slot-object" nil t) + (replace-match "unbound-slot-instance") + (dp-pm) + (search-forward "\\chapref\\ReaderConcepts" nil t) + (replace-match "\\secref\\ReaderConcepts" t t) + (dp-pm) + (search-forward "{\\tt ~*}" nil t) + (replace-match "@tt{ @tild{}*}") + (dp-pm) + (search-forward "\\misc{t} (\\term{constant variable})") + (replace-match "\\conref{t}" t t) + (dp-pm) + (search-forward "\\misc{nil} (\\term{constant variable})") + (replace-match "\\conref{nil}" t t)) + +(defun dp-remove-anchors () + "Remove unused anchors." + (let (refs anchors) + (dp-pm) + (search-forward "@anchor{1-}") + (replace-match "@anchor{1- (Function)}") + ;; this anchor is referenced in dp.texi + (push "SatisfyingTheTwoArgTest" refs) + (dp-pm) + (while (re-search-forward "@ref{\\([^},]+\\)" nil t) + (push (match-string 1) refs)) + (setq anchors (set-difference dp-anchors refs :test 'string=)) + (dolist (anchor anchors) + (dp-pm) + (when (search-forward (concat "@anchor{" anchor "}") nil t) + (replace-match "") + (when (eolp) + (delete-char 1)))))) + +(defun dp-auxbnf (command) + (replace-match (concat "@" command) t t nil) + (save-excursion + (insert + (dp-remove-whitespace + (dp-strip-newline + (concat + "{" (dp-quote-comma (dp-get-arg-delete)) ", " + (dp-quote-comma (dp-get-arg-delete)) "}") + t))))) + +(defun dp-setup () + (setq dp-chapter-list nil + dp-chapter-name-alist nil + dp-dictionary-p nil + dp-anchors nil + dp-nodes nil + dp-current-fig-label nil + dp-section-no 0 + dp-section-names nil + dp-current-label nil + dp-subsection-no 0 + dp-subsections-list nil) + (dp-defconvert 'dp-brace-command + 'rest 'opt 'keyword 'tt 'bf 'prmseven) + (dp-defconvert 'dp-f 'f) + (dp-defconvert 'dp-auxbnf 'auxbnf)) + +(defvar dp-tr-alist + '(("Õ" . "≡") ("Ö" . "▷") ("Ø" . "₀") ("Ù" . "₉") ("Ú" . "₈") ("Û" . "₇") + ("Ü" . "₆") + ("Ý" . "₅") + ("Þ" . "₄") ("ß" . "₃") ("à" . "₂") ("á" . "₁") ("â" . "≠") ("ã" . "≤") + ("ä" . "ː") ("å" . "ō") ("æ" . "ē") ("ç" . "ā") ("è" . "ə") ("é" . "ˌ") + ("ê" . "ˈ") ("ë" . "·") ("ì" . "α") ("í" . "ε") ("î" . "π") ("ï" . "∂") + ("ð" . "↓") ("ñ" . "〉") ("ò" . "〈") ("ó" . "≤") ("õ" . "⋃") ("ö" . "≥") + ("÷" . "∈") ("ø" . "〛") ("ù" . "〚") ("ú" . "⁺") ("û" . "↓") ("ô" . "↩") + ("ý" . "→") ("þ" . "’") ("ÿ" . "‘"))) + +(defun dp-tr () + "Map 8bit values in Info files to multibyte chars." + (interactive) + (let ((re (concat "[" (mapconcat (lambda (x) (car x)) dp-tr-alist "") + "]")) + case-fold-search) + (dolist (file (directory-files default-directory nil "ansicl-?[0-9]*$")) + (with-temp-buffer + (let ((coding-system-for-read 'latin-1)) + (insert-file-contents file)) + (dp-pm) + (while (re-search-forward re nil t) + (replace-match (cdr (assoc (match-string 0) + dp-tr-alist)) t t)) + (let ((coding-system-for-write 'utf-8)) + (write-region (point-min) (point-max) file)))))) + +(defun dp-convert () + "Main translation loop." + (let (command) + (while (re-search-forward "\\\\\\(\\w+\\)" nil 'move-to-limit) + (setq command (match-string 1)) + (funcall (get (intern command) 'convert) command)))) + +(defun dp-tex2texi () + "Convert TeX sources to Texinfo and save in the file 'temp.texi'." + (interactive) + (setq dp-work-buffer (get-buffer-create " *dp-work*")) + (with-current-buffer dp-work-buffer + (set-syntax-table dp-syntax-table)) + (with-temp-buffer + (with-syntax-table dp-syntax-table + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents "chap-0-edit-history.tex") + (dp-strip-comments) + (dotimes (i 26) + (goto-char (point-max)) + (insert-file-contents (format "chap-%d.tex" (1+ i)))) + (goto-char (point-max)) + (insert-file-contents "chap-a.tex") + ;; conversion + (dp-parse-macros "dp.texi") + (dp-setup) + (dp-get-section-names) + (dp-insert) + (dp-quote-special) + (dp-special-cases) + (dp-hack-credits) + (dp-non-code) + (dp-pm) + (dp-convert) + ;; post-process + (dp-pm) + (dp-hack-curly) + (dp-hack-~) + (dp-remove-anchors) + (dp-pm) + (insert dp-preamble) + (push "Index" dp-chapter-list) + (push "Symbol Index" dp-chapter-list) + (push "List of Figures" dp-chapter-list) + (setq dp-chapter-list (nreverse dp-chapter-list)) + (dolist (node dp-chapter-list) + (insert "* " node "::\n")) + (insert "@ifnotinfo\n" + "* Table of Contents::\n" + "@end ifnotinfo\n" + "@end menu\n") + (goto-char (point-max)) + (insert dp-postamble) + (setq dp-chapter-list nil)) + (write-region (point-min) (point-max) "temp.texi"))) + +;;; Local Variables: *** +;;; mode:emacs-lisp *** +;;; coding:utf-8 *** +;;; End: *** +;;; dpans2texi.el ends here }